Access VBA 的眉眉角角Day28: 連結外部ODBC資料表

2017 iT 邦幫忙鐵人賽

DAY 28

自我挑戰組

Access VBA的眉眉角角系列第 28 篇

2017鐵人賽

Andy Chiu

2016-12-29 01:40:55

7374 瀏覽

分享至

昨日介紹了使用連結外部Access檔案資料表的程式，今日再來介紹ODBC的部份，如果使用Access的操作界面，我們可以由滑鼠右鍵的彈出選單中，使用「連結資料表」功能來進行連結：

之後的操作，則跟之前介紹的匯入功能相同，只是這部份改為連結，但是該如何使用VBA來連結ODBC外部資料庫的資料表？這部份，筆者有撰寫VBA程式與資料表進行管理，如果程式越來越複雜，建議以此方式來管理，而且如果程式需要發布到不同電腦操作，透過此程式來「重新連結」外部資料表，會更有效率。

另外，筆者有發現，如果於其他電腦開啟已於其他電腦設好連結ODBC資料表的Access MDB資料檔，有些時候，是無法連結的，所以還必須移除連結，再重新連結，才有辦法正常連上，這部份，透過此次介紹的程式，將可順利的協助user無聲無息的重連外部資料庫，達到正常使用的效果。

由於筆者的環境主要為AS/400與SQL Server，因此連結資料表的VBA程式均以這兩種Server開發，如果有需要連結到其他的資料庫程式，可以再上網找相關資訊進行修改。

以下兩個程式用於連線到SQL Server與AS/400：

Function AttachDSNLessTableSQLServer(stLocalTableName As String, _
                                     stRemoteTableName As String, _
                                     stServer As String, _
                                     stDatabase As String, _
                                     Optional stUsername As String, _
                                     Optional stPassword As String, _
                                     Optional strKey As String, _
                                     Optional strDescription As String = "")
'參考來源：https://support.microsoft.com/zh-hk/kb/892490
' 不使用DSN方式來建立連結資料表功能
'    stLocalTableName  本地資料表名稱
'    stRemoteTableName 伺服器資料表名稱
'    stServer          伺服器名稱或IP
'    stDatabase        資料庫名稱
'    stUsername        使用者名稱
'    stPassword        使用者密碼
'    strKey            索引套用欄位
'    strDescription    資料表描述
    
    On Error GoTo AttachDSNLessTableSQLServer_Err
    Dim td As TableDef
    Dim stConnect As String
    
    CurrentDb.TableDefs.Delete stLocalTableName
      
    If Len(stUsername) = 0 Then
        '//Use trusted authentication if stUsername is not supplied.
        stConnect = "ODBC;DRIVER=SQL Server;SERVER=" & stServer & ";DATABASE=" & stDatabase & ";Trusted_Connection=Yes"
    Else
        '//WARNING: This will save the username and the password with the linked table information.
        stConnect = "ODBC;DRIVER=SQL Server;SERVER={" & stServer & "};DATABASE=" & stDatabase & ";UID=" & stUsername & ";PWD=" & stPassword
    End If
    Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, stConnect)
    CurrentDb.TableDefs.Append td
    
    '建立索引
    If Len(strKey) > 0 Then
        DoCmd.RunSQL "CREATE UNIQUE INDEX UniqueIndex ON [" & stLocalTableName & "] (" & strKey & ")"
    End If

    '建立描述
    If strDescription <> "" Then
        Set prp = CurrentDb.TableDefs(stLocalTableName).CreateProperty("Description", dbText, strDescription)
        CurrentDb.TableDefs(stLocalTableName).Properties.Append prp
    
    End If

    AttachDSNLessTableSQLServer = True
    Exit Function

AttachDSNLessTableSQLServer_Err:
    
    If err.Number = 3265 Then
        '刪除連結資料表時，資料表不存在
        Resume Next
    Else
        AttachDSNLessTableSQLServer = False
        MsgBox "AttachDSNLessTableSQLServer encountered an unexpected error: " & err.Description
    End If
    
End Function

Function AttachDSNLessTableAS400(stLocalTableName As String, _
                                 stRemoteTableName As String, _
                                 stServer As String, _
                                 stDatabase As String, _
                                 Optional stUsername As String, _
                                 Optional stPassword As String, _
                                 Optional strKey As String, _
                                 Optional bnDescription As Boolean = False)
'參考來源：https://support.microsoft.com/zh-hk/kb/892490
' 不使用DSN方式來建立連結資料表功能
'    stLocalTableName  本地資料表名稱
'    stRemoteTableName 伺服器資料表名稱
'    stServer          伺服器名稱或IP
'    stDatabase        資料庫名稱
'    stUsername        使用者名稱
'    stPassword        使用者密碼
'    strKey            索引套用欄位
'    bnDescription     是否寫入描述

    On Error GoTo AttachDSNLessTableAS400_Err
    Dim td As TableDef
    Dim stConnect As String
    
    CurrentDb.TableDefs.Delete stLocalTableName
    
    stConnect = "ODBC;Driver=iSeries Access ODBC Driver;System=" & stServer & ";UID=" & stUsername & ";PWD=" & stPassword & ";MGDSN=0;"
    Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stDatabase & "." & stRemoteTableName, stConnect)
    CurrentDb.TableDefs.Append td
    
    '建立描述
    If bnDescription = True Then
        '取得Table描述並且寫入Description屬性
        strSQL = "SELECT * FROM AS400LIBFILEFFDH WHERE Library='" & stDatabase & "'  AND File='" & stRemoteTableName & "'"
        Set M = CurrentDb.OpenRecordset(strSQL)
        If M.EOF = False Then
            strDescription = Trim(M("Description")) 'Mid(m("Description"), 1, 10)
            If strDescription <> "" Then
                'CurrentDb.TableDefs(stLocalTableName).Properties("Description") = strDescription
                Set prp = CurrentDb.TableDefs(stLocalTableName).CreateProperty("Description", dbText, strDescription)
                CurrentDb.TableDefs(stLocalTableName).Properties.Append prp
            End If
        End If
        '取得Field描述並寫入Description屬性
        strSQL = "SELECT * FROM AS400LIBFILEFFDB WHERE Library = '" & stDatabase & "' AND File='" & stRemoteTableName & "' "
        Set M = CurrentDb.OpenRecordset(strSQL)
        If M.EOF = False Then
            Do
                strField = M("Field")
                strDescription = Trim(M("FieldText"))
                If strDescription <> "" Then
                    Set prp = CurrentDb.TableDefs(stLocalTableName).fields(strField).CreateProperty("Description", dbText, strDescription)
                    CurrentDb.TableDefs(stLocalTableName).fields(strField).Properties.Append prp
                End If
                M.MoveNext
            Loop Until M.EOF
        End If
    End If
    
    '建立索引
    If Len(strKey) > 0 Then
        DoCmd.RunSQL "CREATE UNIQUE INDEX UniqueIndex ON [" & stLocalTableName & "] (" & strKey & ")"
    End If

    AttachDSNLessTableAS400 = True
    Exit Function

AttachDSNLessTableAS400_Err:
    If err.Number = 3265 Then
        '刪除連結資料表時，資料表不存在
        Resume Next
    ElseIf err.Number = 3125 Then
        '名稱異常，很奇怪，有些電腦會這樣
        '測試V5R4英文版後再安裝中文版會這樣
        MsgBox "3125錯誤！資料表：" & stLocalTableName & "，建議完整重新安裝IBM iSeries Access for Windows!"
        Resume Next
    Else
        AttachDSNLessTableAS400 = False
        MsgBox "AttachDSNLessTableAS400 encountered an unexpected error: " & err.Number & " " & err.Description
    End If
    
End Function

AttachDSNLessTableSQLServer與AttachDSNLessTableAS400的來源均由微軟提供的範本改良而來，依照伺服器不同而有不同的設定，AttachDSNLessTableSQLServer的描述部份，直接使用ConnectTables內的DESCRIPTION欄位資訊，而AttachDSNLessTableAS400則另外由AS400LIBFILEFFDH與AS400LIBFILEFFDB兩個資料表來取得資料表描述與欄位描述，然後建立連結後，再寫入到連結的資料表描述與欄位描述中。

另外以下子程式，使用WMI服務取得電腦的IP位址，後面程式會用到：

Function GetIPAddress()
    '參考來源：http://stackoverflow.com/questions/828496/how-to-retrieve-this-computers-ip-address
    Const strComputer As String = "."   ' Computer name. Dot means local computer
    Dim objWMIService, IPConfigSet, IPConfig, IPAddress, i
    Dim strIPAddress As String

    ' Connect to the WMI service
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

    ' Get all TCP/IP-enabled network adapters
    Set IPConfigSet = objWMIService.ExecQuery _
        ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")

    ' Get all IP addresses associated with these adapters
    For Each IPConfig In IPConfigSet
        IPAddress = IPConfig.IPAddress
        If Not IsNull(IPAddress) Then
            strIPAddress = strIPAddress & Join(IPAddress, ", ")
        End If
    Next

    GetIPAddress = strIPAddress
End Function

最後，這個程式就是用來連結資料表用的子程式，如果有其他程式要套用，也可以填寫參數，讓它只列出所需的資料，減少連結時間：

Sub ReConnectDB(Optional strSERVER_TYPE As String = "", _
                Optional strDB As String = "", _
                Optional strSERVER_TABLE As String = "", _
                Optional bnDescription As Boolean = True, _
                Optional bnConfigLocal As Boolean = True)
                
'連結資料表並且標注上註解
'strSERVER_TYPE  指定什麼類型的伺服器
'strDB           指定資料檔
'strSERVER_TABLE 指定資料表
'bnDescription   是否將資料表描述內容謄上
'bnConfigLocal   是否連結Local端的Config檔

Dim strIndex_Key As String
Dim bnDBRW As Boolean
Dim strServer As String
Dim strSQL As String
Dim strDescription As String

'依照參數建立WHERE語句
If strSERVER_TYPE <> "" Then strWHERE = "SERVER_TYPE='" & strSERVER_TYPE & "'"

If strDB <> "" Then strWHERE = strWHERE & " AND "
    If strWHERE <> "" Then
    strWHERE = strWHERE & "DB='" & strDB & "'"
End If
    
If strSERVER_TABLE <> "" Then strWHERE = strWHERE & " AND "
    If strWHERE <> "" Then
    strWHERE = strWHERE & "SERVER_TABLE='" & strSERVER_TABLE & "'"
End If

If strWHERE = "" Then
    strSQL = "SELECT * FROM ConnectTables"
Else
    strSQL = "SELECT * FROM ConnectTables WHERE " & strWHERE
End If

'開啟篩選後的ConnectTables資料表
Set M = CurrentDb.OpenRecordset(strSQL)
If M.EOF = True Then Exit Sub

'如果電腦在可讀寫資料庫電腦清單中，則建立連結時，建立索引資料
If InStr(Config("Database_RW_PC"), UCase(Trim(Environ("COMPUTERNAME")))) > 0 Then
    bnDBRW = True
Else
    bnDBRW = False
End If

M.MoveFirst

'本機電腦IP
strIP = left(GetIPAddress, 10)
'公司內部電腦IP區段
strInternalIPs = Config("InternalIPs")

Do
    '若bnDBRW = False，僅SQLServer設定為無索引，AS/400則設定為有索引
    '因為AS/400有無索引，都無法寫入資料庫！
    If IsNull(M("INDEX_KEY")) Or (bnDBRW = False And M("SERVER_TYPE") = "SQLServer") Then
        strIndex_Key = ""
        
    ElseIf IsNull(M("INDEX_KEY")) = False Then
        strIndex_Key = M("INDEX_KEY")
        
    End If
    
    
    '如果為內部網路且類型為SQL Server，則使用SERVER_NAME方式連線
    '若不是，則改由IP連線
    If InStr(strInternals, strIP) > 0 _
    And M("SERVER_TYPE") = "SQLServer" Then
        strServer = CStr(M("SERVER_NAME"))
    Else
        strServer = CStr(M("SERVER_IP"))
    End If
    
    If M("SERVER_TYPE") = "SQLServer" Then
        If bnDescription = True And IsNull(M("DESCRIPTION")) = False Then
            strDescription = CStr(M("DESCRIPTION"))
        Else
            strDescription = ""
        End If
        Call AttachDSNLessTableSQLServer(CStr(M("LOCAL_TABLE")), CStr(M("SERVER_TABLE")), strServer, CStr(M("DB")), CStr(M("USER")), CStr(M("PASSWORD")), strIndex_Key, strDescription)
        
    ElseIf M("SERVER_TYPE") = "AS400" Then
        Call AttachDSNLessTableAS400(CStr(M("LOCAL_TABLE")), CStr(M("SERVER_TABLE")), CStr(M("SERVER_IP")), CStr(M("DB")), CStr(M("USER")), CStr(M("PASSWORD")), strIndex_Key, bnDescription)
        
    End If
    
    M.MoveNext
Loop Until M.EOF = True

If bnConfigLocal = True Then
    Call CreateAndLink_ConfigLocal
End If

Call ConfigSave("COMPUTERNAME", Trim(Environ("COMPUTERNAME")))

End Sub

若還沒有ConnectTables資料表，請複製以下內容，並由建立查詢，貼上內容並執行，以便建立資料表：

CREATE TABLE ConnectTables
(
 [SERVER_IP] TEXT (15),
 [SERVER_NAME] TEXT (15),
 [SERVER_TYPE] TEXT (10),
 [DB]        TEXT (50),
 [SERVER_TABLE] TEXT (50),
 [DESCRIPTION] TEXT (50),
 [USER]      TEXT (15),
 [PASSWORD]  TEXT (50),
 [LOCAL_TABLE] TEXT (50),
 [INDEX_KEY] TEXT (50),
 [EXP_DATE_FIELD] TEXT (50),
 [EXP_DATE_FIELD_TYPE] TEXT (50),
 [EXP_DATE_RANGE] TEXT (50),
 [JOIN_STRING] TEXT (255)
)

EXP_DATE_FIELD匯出表時，指定日期使用的欄位名稱
EXP_DATE_FIELD_TYPE TEXT or DATE or NUMBER
EXP_DATE_RANGE 1 = 本月、2=包含上個月
JOIN_STRING如果資料表為Body類型，則要JOIN HEAD類型的TABLE來查表

若還沒有AS400LIBFILEFFDH資料表，請複製以下內容，並由建立查詢，貼上內容並執行，以便建立資料表：

CREATE TABLE AS400LIBFILEFFDH
(
 [Library]   TEXT (10),
 [File]      TEXT (10),
 [Description] TEXT (50)
)

若還沒有AS400LIBFILEFFDB資料表，請複製以下內容，並由建立查詢，貼上內容並執行，以便建立資料表：

CREATE TABLE AS400LIBFILEFFDB
(
 [Library]   TEXT (10),
 [File]      TEXT (10),
 [Field]     TEXT (15),
 [FieldText] TEXT (50)
)

這三個資料表建立完成後，即可使用ReConnectDB程式來連線資料庫，這個更新完畢後，會將PC NAME寫入CONFIG中，以便能得知已更新過。
使用此特性，我們可以於要發布的程式，於檔案開啟時，自動執行表單的Form_Load中，加入以下程式，來判斷是否已有重新建立聯結資料表:

    '如果本台電腦與此MDB紀錄的電腦名稱不同，且檔名有SQLServer字眼
    '則重新連線資料庫
    If Trim(Config("COMPUTERNAME")) <> Trim(Environ("COMPUTERNAME")) And InStr(CurrentProject.Name, "SQLServer") > 0 Then
        Call ReConnectDB(, , , False, True)
        
    '如果僅電腦名稱不同，但檔名無SQLServer字眼，僅重連AS/400連線
    '因為無SQLServer連結資料表
    ElseIf Trim(Config("COMPUTERNAME")) <> Trim(Environ("COMPUTERNAME")) Then
        Call ReConnectDB("AS400")
    End If

當user開啟此MDB檔時，就會自動檢查電腦名稱是否與Config中的相同，不同的話，就執行ReConnectDB來更新「連結資料表」，而筆者的狀況，還多了是否連結SQLServer的MDB，區分成兩種，因此判斷還多了檔名是否有此字串。

以上分享希望對各位有幫助。