私は通常、開発のために DSN を介して Access 2010 の SQL Server 2008 テーブルをリンクし、VBA コードを介して DSN レスにします (以下を参照)。
誰でもデータベースにアクセスできるようにするため、WindowsではなくSQlサーバー認証で接続することにしました。問題は、リンクしてパスワードを保存し、コードを実行して DSN レスにすると、SQL Server 認証のユーザー ID とパスワードが保存されないことです。私は本当に困惑しています。
私はから変更しようとしています:
ODBC;DSN=Organisations_sql8;UID=xx;PWD=x;APP=Microsoft Office 2010;DATABASE=Organisations
デバッグでチェックされているようにこれに：
ODBC;DRIVER={SQL Server Native Client 10.0};DATABASE=Organisations;SERVER=ra_sql8;UID=xx;PWD=x;
しかし、これは保存されているものです：
DRIVER=SQL Server Native Client 10.0;SERVER=ra_sql8;APP=Microsoft Office 2010;DATABASE=Organisations;
何か案は？:)
どうもありがとう
Type TableDetails
TableName As String
SourceTableName As String
Attributes As Long
IndexSQL As String
Description As Variant
End Type
Private Sub SubmitFix()
Call FixConnections("ra_sql8", "Organisations", "UserID", "Password")
End Sub
Sub FixConnections( _
ServerName As String, _
DatabaseName As String, _
Optional UID As String, _
Optional PWD As String _
)
' This code was originally written by
' Doug Steele, MVP AccessMVPHelp@gmail.com
' Modifications suggested by
' George Hepworth, MVP ghepworth@gpcdata.com
'
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description: This subroutine looks for any TableDef objects in the
' database which have a connection string, and changes the
' Connect property of those TableDef objects to use a
' DSN-less connection.
' It then looks for any QueryDef objects in the database
' which have a connection string, and changes the Connect
' property of those pass-through queries to use the same
' DSN-less connection.
' This specific routine connects to the specified SQL Server
' database on a specified server.
' If a user ID and password are provided, it assumes
' SQL Server Security is being used.
' If no user ID and password are provided, it assumes
' trusted connection (Windows Security).
'
' Inputs: ServerName: Name of the SQL Server server (string)
' DatabaseName: Name of the database on that server (string)
' UID: User ID if using SQL Server Security (string)
' PWD: Password if using SQL Server Security (string)
'
On Error GoTo Err_FixConnections
Dim dbCurrent As DAO.Database
Dim prpCurrent As DAO.Property
Dim tdfCurrent As DAO.TableDef
Dim qdfCurrent As DAO.QueryDef
Dim intLoop As Integer
Dim intToChange As Integer
Dim strConnectionString As String
Dim strDescription As String
Dim strQdfConnect As String
Dim typNewTables() As TableDetails
' Start by checking whether using Trusted Connection or SQL Server Security
If (Len(UID) > 0 And Len(PWD) = 0) Or (Len(UID) = 0 And Len(PWD) > 0) Then
MsgBox "Must supply both User ID and Password to use SQL Server Security.", _
vbCritical + vbOKOnly, "Security Information Incorrect."
Exit Sub
Else
If Len(UID) > 0 And Len(PWD) > 0 Then
' Use SQL Server Security
strConnectionString = "ODBC;DRIVER={sql server};" & _
"DATABASE=" & DatabaseName & ";" & _
"SERVER=" & ServerName & ";" & _
"UID=" & UID & ";" & _
"PWD=" & PWD & ";"
Else
' Use Trusted Connection
strConnectionString = "ODBC;DRIVER={sql server};" & _
"DATABASE=" & DatabaseName & ";" & _
"SERVER=" & ServerName & ";" & _
"Trusted_Connection=YES;"
End If
End If
intToChange = 0
Set dbCurrent = DBEngine.Workspaces(0).Databases(0)
' Build a list of all of the connected TableDefs and
' the tables to which they're connected.
For Each tdfCurrent In dbCurrent.TableDefs
If Len(tdfCurrent.Connect) > 0 Then
If UCase$(Left$(tdfCurrent.Connect, 5)) = "ODBC;" Then
ReDim Preserve typNewTables(0 To intToChange)
Debug.Print "------------------------------"
typNewTables(intToChange).Attributes = tdfCurrent.Attributes
Debug.Print tdfCurrent.Attributes
typNewTables(intToChange).TableName = tdfCurrent.Name
Debug.Print tdfCurrent.Name
Debug.Print tdfCurrent.Connect
typNewTables(intToChange).SourceTableName = tdfCurrent.SourceTableName
Debug.Print tdfCurrent.SourceTableName
typNewTables(intToChange).IndexSQL = GenerateIndexSQL(tdfCurrent.Name)
typNewTables(intToChange).Description = Null
typNewTables(intToChange).Description = tdfCurrent.Properties("Description")
intToChange = intToChange + 1
End If
End If
Next
' Loop through all of the linked tables we found
Debug.Print "===================================="
For intLoop = 0 To (intToChange - 1)
' Delete the existing TableDef object
dbCurrent.TableDefs.Delete typNewTables(intLoop).TableName
Debug.Print "------------------------------"
' Create a new TableDef object, using the DSN-less connection
Set tdfCurrent = dbCurrent.CreateTableDef(typNewTables(intLoop).TableName)
tdfCurrent.Connect = strConnectionString
Debug.Print tdfCurrent.Name
Debug.Print tdfCurrent.Connect
' Unfortunately, I'm current unable to test this code,
' but I've been told trying this line of code is failing for most people...
' If it doesn't work for you, just leave it out.
'tdfCurrent.Attributes = typNewTables(intLoop).Attributes
tdfCurrent.SourceTableName = typNewTables(intLoop).SourceTableName
dbCurrent.TableDefs.Append tdfCurrent
' Where it existed, add the Description property to the new table.
If IsNull(typNewTables(intLoop).Description) = False Then
strDescription = CStr(typNewTables(intLoop).Description)
Set prpCurrent = tdfCurrent.CreateProperty("Description", dbText, strDescription)
tdfCurrent.Properties.Append prpCurrent
End If
' Where it existed, create the __UniqueIndex index on the new table.
If Len(typNewTables(intLoop).IndexSQL) > 0 Then
dbCurrent.Execute typNewTables(intLoop).IndexSQL, dbFailOnError
End If
Next
' Loop through all the QueryDef objects looked for pass-through queries to change.
' Note that, unlike TableDef objects, you do not have to delete and re-add the
' QueryDef objects: it's sufficient simply to change the Connect property.
' The reason for the changes to the error trapping are because of the scenario
' described in Addendum 6 below.
For Each qdfCurrent In dbCurrent.QueryDefs
On Error Resume Next
strQdfConnect = qdfCurrent.Connect
On Error GoTo Err_FixConnections
If Len(strQdfConnect) > 0 Then
If UCase$(Left$(qdfCurrent.Connect, 5)) = "ODBC;" Then
qdfCurrent.Connect = strConnectionString
End If
End If
strQdfConnect = vbNullString
Next qdfCurrent
End_FixConnections:
Set tdfCurrent = Nothing
Set dbCurrent = Nothing
Exit Sub
Err_FixConnections:
' Specific error trapping added for Error 3291
' (Syntax error in CREATE INDEX statement.), since that's what many
' people were encountering with the old code.
' Also added error trapping for Error 3270 (Property Not Found.)
' to handle tables which don't have a description.
Select Case err.Number
Case 3270
Resume Next
Case 3291
MsgBox "Problem creating the Index using" & vbCrLf & _
typNewTables(intLoop).IndexSQL, _
vbOKOnly + vbCritical, "Fix Connections"
Resume End_FixConnections
Case 18456
MsgBox "Wrong User ID or Password.", _
vbOKOnly + vbCritical, "Fix Connections"
Resume End_FixConnections
Case Else
MsgBox err.Description & " (" & err.Number & ") encountered", _
vbOKOnly + vbCritical, "Fix Connections"
Resume End_FixConnections
End Select
End Sub
Function GenerateIndexSQL(TableName As String) As String
' This code was originally written by
' Doug Steele, MVP AccessMVPHelp@gmail.com
' Modifications suggested by
' George Hepworth, MVP ghepworth@gpcdata.com
'
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Description: Linked Tables should have an index __uniqueindex.
' This function looks for that index in a given
' table and creates an SQL statement which can
' recreate that index.
' (There appears to be no other way to do this!)
' If no such index exists, the function returns an
' empty string ("").
'
' Inputs: TableDefObject: Reference to a Table (TableDef object)
'
' Returns: An SQL string (or an empty string)
'
On Error GoTo Err_GenerateIndexSQL
Dim dbCurr As DAO.Database
Dim idxCurr As DAO.Index
Dim fldCurr As DAO.Field
Dim strSQL As String
Dim tdfCurr As DAO.TableDef
Set dbCurr = CurrentDb()
Set tdfCurr = dbCurr.TableDefs(TableName)
If tdfCurr.Indexes.Count > 0 Then
' Ensure that there's actually an index named
' "__UnigueIndex" in the table
On Error Resume Next
Set idxCurr = tdfCurr.Indexes("__uniqueindex")
If err.Number = 0 Then
On Error GoTo Err_GenerateIndexSQL
' Loop through all of the fields in the index,
' adding them to the SQL statement
If idxCurr.Fields.Count > 0 Then
strSQL = "CREATE INDEX __UniqueIndex ON [" & TableName & "] ("
For Each fldCurr In idxCurr.Fields
strSQL = strSQL & "[" & fldCurr.Name & "], "
Next
' Remove the trailing comma and space
strSQL = Left$(strSQL, Len(strSQL) - 2) & ")"
End If
End If
End If
End_GenerateIndexSQL:
Set fldCurr = Nothing
Set tdfCurr = Nothing
Set dbCurr = Nothing
GenerateIndexSQL = strSQL
Exit Function
Err_GenerateIndexSQL:
' Error number 3265 is "Not found in this collection
' (in other words, either the tablename is invalid, or
' it doesn't have an index named __uniqueindex)
If err.Number <> 3265 Then
MsgBox err.Description & " (" & err.Number & ") encountered", _
vbOKOnly + vbCritical, "Generate Index SQL"
End If
Resume End_GenerateIndexSQL
End Function