·Access快速平台QQ群号:277422564    ·Access快速开发平台下载地址及教程    ·欢迎添加微信交流账号:Accessoft7    ·如何快速搜索本站文章|示例|资料!    
您的位置: 首页 > 技术文章 > ADP及SQL SERVER


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



Option Compare Database
Option Explicit
Global Const ServerAddressMTO = ""
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

    On Error Resume Next
        Set rst = Nothing
        Set qdf = Nothing
        Set dbCurrent = Nothing
    Exit Function
    InitConnect = False
    MsgBox Err.Description & " (" & Err.Number & ") encountered", _
        vbOKOnly + vbCritical, "InitConnect"
    Resume ExitProcedure

End Function


比如红尘如烟的SQL Server及Access链接表刷新向导,


access传递查询访问Sql Server数据方法简介


根据表名和SQL Server服务IP地址,在ACCESS中创建SQL SERVER链接表

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
' Modifications suggested by
' George Hepworth, MVP
' 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
' 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
' 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
  Set tdfCurrent = Nothing
  Set dbCurrent = Nothing
  Exit Sub
' 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

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

最新评论 查看更多评论(0)


密 码:
内 容:





关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助