DSN-less连接策略

时　间:2018-06-10 16:12:05
作　者:萤火虫   ID：66752  城市：大理
摘　要:本节数据驱动程序是连接微软云数据库
正　文:

为确保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


Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店