閉じる

外部ACCESS　と　リンクする　２／３　共通モジュール




Public Function ODBC_LINK_FUNC() As Integer

'--------------------------------------------------

'  LINK接続

'--------------------------------------------------

On Error GoTo Err_ODBC_LINK_FUNC

    'リンクテーブルエリア

     Dim wDMtb(100) As String

     Dim wDMtb_KBN(100) As String

     Dim wDMtb_limit As Long

     Dim wTBL As String

     Dim wDM_i As Long

     Dim wi As Long

    

    'ODBC接続定義

     Dim wDSN As String

     Dim wDBQ As String

     Dim wPWD As String

     Dim wUSER As String

     Dim wODBC As String

     Dim wAccess_Pass As String

     Dim wAccess_PWD As String

     Dim wORCLtb As String

    

    ODBC_LINK_FUNC = 0



    '警告メッセージをOFF

    DoCmd.SetWarnings False

    

   'DB定義

    Dim cn      As ADODB.Connection

    Dim rs0     As ADODB.Recordset

    Dim rs1     As ADODB.Recordset

   

   'ADO　カレントに接続

    Set cn = CurrentProject.Connection

   '--------------------------------------------------

   '１．リンクテーブルの取り込みと初期処理（削除）

    Set rs0 = New ADODB.Recordset

    rs0.Open "ODBC_LINK_TB", cn, adOpenKeyset, adLockOptimistic

    

    wDMtb_limit = 100

    wDM_i = 0

    Do Until rs0.EOF

       If wDM_i > wDMtb_limit Then

            MsgBox "読み込みテーブルがあふれました。処理を中止します。"

            rs0.Close: Set rs0 = Nothing

            cn.Close:  Set cn = Nothing

            ODBC_LINK_FUNC = 1

            Exit Function

        End If



        wDMtb(wDM_i) = rs0!linkTB_NM

        wDMtb_KBN(wDM_i) = rs0!linkTB_KBN

        wDM_i = wDM_i + 1

        rs0.MoveNext

    Loop

    rs0.Close: Set rs0 = Nothing

   'ADO　カレント切断

    cn.Close:  Set cn = Nothing

   

   

    'リンクテーブルを削除する

    For wi = 0 To (wDM_i - 1)

        'リンクテーブル名設定

        wTBL = wDMtb(wi)

        'リンクテーブルの削除

        DoCmd.DeleteObject acTable, wTBL

    Next

   

   '--------------------------------------------------

   '２．テーブルをリンクする

    'ODBC接続用値設定

    wDSN = ";DSN=" & ""

    wDBQ = ";DBQ=" & ""

    wPWD = ";PWD=" & ""

    wUSER = "" & "."

    wODBC = "ODBC" & wDSN & wDBQ & wPWD

    

    'ACCESS接続用値設定

    Dim myPASS As String

    myPASS = CurrentProject.Path

    wAccess_Pass = myPASS & "\db\techDD.mdb"

    wAccess_PWD = "techDD"

    

   '--------------------------------------------------

   '２．テーブルをリンクする　パスワード付ACCESSとリンクする。

    'テーブルをリンクする。

    Dim dbs As DAO.Database

    Dim tdf As DAO.TableDef

    Set dbs = Application.CurrentDb

    For wi = 0 To (wDM_i - 1)

    

        'リンクテーブル名設定

        wTBL = wDMtb(wi)

        'MsgBox "debug: " & wTBL

        If wDMtb_KBN(wi) = "ACCESS" Then

        

            Set tdf = dbs.CreateTableDef(wTBL)

           'Let tdf.Connect = "MS Access;DATABASE=C:\ac_data\db1.mdb;PWD=hogehoge;"

            Let tdf.Connect = "MS Access;DATABASE=" & wAccess_Pass & ";PWD=" & wAccess_PWD & ";"

            Let tdf.SourceTableName = wTBL

            dbs.TableDefs.Append tdf

            Set tdf = Nothing

       

        End If

    

    Next

    dbs.Close

    Set dbs = Nothing

   

   '--------------------------------------------------

   '２．テーブルをリンクする ODBC用

    'テーブルをリンクする。

    For wi = 0 To (wDM_i - 1)

    

        'リンクテーブル名設定

        wTBL = wDMtb(wi)

   

        '●テーブルのリンク

        '●wODBC = "ODBC;DSN=DEMO20021205;DBQ=DEMOACS;PWD=acsuser"

        '●wOdbc=接続文字列,acTable,orclのテーブル名

        

        If wDMtb_KBN(wi) <> "ACCESS" Then

            wORCLtb = wUSER & wTBL

            DoCmd.TransferDatabase acLink, "ODBC データベース", _

            wODBC, acTable, wORCLtb, wTBL

        End If

    

    Next

    

Exit_ODBC_LINK_FUNC:

    Exit Function



Err_ODBC_LINK_FUNC:

    'Err.Number = 7874 ：削除するテーブルが見つからなかった。

    'Resume　Next　：エラー発生の次の行から実行せよ

    If Err And Err.Number = 7874 Then

        Resume Next

    End If

    

    ODBC_LINK_FUNC = 9

    MsgBox Err.Number & " : " & Err.Description

    Resume Exit_ODBC_LINK_FUNC

    

    

End Function