为确保Access具有缓存连接，为所有其他ODBC对象使用，
应该在应用程序的启动中调用，
类似ACCESSOFT快速开发平台的登录窗体中ODBC缓存连接
Option Compare Database
Option Explicit
Global Const ServerAddressMTO = "aux99xmbfs.database.windows.net"
Global Const DatabaseAddressMTO = "db_f4689298_1035_4588_b062_096bf56eed7e"
Global Const UIDMTO = "db_f4689298_1035_4588_b062_096bf56eed7e_ExternalWriter"
Global Const PWDMTO = "V/x^QC715w9gGcc"
Type TableDetails
TableName As String
SourceTableName As String
Attributes As Long
IndexSQL As String
Description As Variant
End Type
Public Function InitConnect( _
ServerAddress As String, _
DatabaseName As String, _
UserName As String, _
Password As String, _
FixConnectionsFlag As Boolean _
) As Boolean
' Description: Should be called in the application's startup
' to ensure that Access has a cached connection
' for all other ODBC objects' use.
On Error GoTo ErrHandler
Dim strConnection As String
Dim dbCurrent As DAO.Database
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
strConnection = "ODBC;DRIVER={SQL Server Native Client 11.0};" & _
"Encrypt=yes;Trusted_Connection=no;" & _
"Server=" & ServerAddress & ";" & _
"Database=" & DatabaseName & ";" & _
"UID=" & UserName & ";" & _
"PWD=" & Password & ";"
Set dbCurrent = CurrentDb
Set qdf = dbCurrent.CreateQueryDef("")
With qdf
.Connect = strConnection
.SQL = "Select @@OPTIONS;"
Set rst = .OpenRecordset(dbOpenSnapshot, dbSQLPassThrough)
End With
If FixConnectionsFlag Then
FixConnections ServerName:=ServerAddress, DatabaseName:=DatabaseName, UID:=UserName, PWD:=Password
End If
InitConnect = True
ExitProcedure:
On Error Resume Next
Set rst = Nothing
Set qdf = Nothing
Set dbCurrent = Nothing
Exit Function
ErrHandler:
InitConnect = False
MsgBox Err.Description & " (" & Err.Number & ") encountered", _
vbOKOnly + vbCritical, "InitConnect"
Resume ExitProcedure
Resume
End Function
access传递查询操作过程中，一般点选属性窗口ODBC栏目，点选DNS文件，
而采用DSN-less连接策略允许完全不使用DNS文件，
批量更解表与查询的ODBC连接字符串，Access云端运用与否，只与数据库驱动程序有关。
比如红尘如烟的SQL Server及Access链接表刷新向导，
http://www.accessoft.com/article-show.asp?id=10816
有些网友测试失败，这需要随ACCESS的版本不同更改数据库驱动程序
access传递查询访问Sql Server数据方法简介
http://www.accessoft.com/article-show.asp?id=4883
这种连接策略也不错
根据表名和SQL Server服务IP地址，在ACCESS中创建SQL SERVER链接表
http://www.accessoft.com/article-show.asp?id=16816
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
Debug.Print DatabaseName
strConnectionString = _
"ODBC;DRIVER={SQL Server Native Client 11.0};" & _
"Encrypt=yes;Trusted_Connection=no;" & _
"Server=" & ServerName & ";" & _
"Database=" & DatabaseName & ";" & _
"PWD=" & PWD & ";" & _
"UID=" & UID & ";"
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)
typNewTables(intToChange).Attributes = tdfCurrent.Attributes
typNewTables(intToChange).TableName = tdfCurrent.Name
typNewTables(intToChange).SourceTableName = 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
For intLoop = 0 To (intToChange - 1)
' Delete the existing TableDef object
dbCurrent.TableDefs.Delete typNewTables(intLoop).TableName
' Create a new TableDef object, using the DSN-less connection
Set tdfCurrent = dbCurrent.CreateTableDef(typNewTables(intLoop).TableName)
tdfCurrent.Connect = strConnectionString
' 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 = DAO.dbAttachSavePWD
'tdfCurrent.Attributes = DAO.dbAttachSavePWD
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
Resume
End Select
End Sub
