[ACCESS→SQLServer]ACCESS内のリンクをVBAではりかえる(DNS-LESSver)。

【追記※DNS－LESS方式ﾊﾞｰｼﾞｮﾝ】--------------------------------------------

※DNS-LESS方式でリンクテーブルを張り替えると
SQLServerがintでも→ACCESSだと文字列扱いになるみたいです（ACCESS2003）。
(調査中)。
きちんとSQLServerと型を一致させるにはやはり
ローカルＰＣにきちんとODBC設定して行なった方がいいみたい…。

DNSﾊﾞｰｼﾞｮﾝはこちら
http://shumitestitblog.blogspot.jp/2012/04/accesssqlserveraccessvbadnsver.html

-------------------------------------------------------------------------

ACESSリンクテーブルのリンク先をSQLServerリンクに一斉に変更します。
SQLServerへのリンク方法はODBC設定等色々手順があると思いますが、
ローカルPCのODBC設定を行なうのがイヤだったので（DB更新時など）
ローカルPCのODBC設定がいらない方法として
DNS-LESS方式で接続する方式にしました。
（これはVBA通さないと出来ないみたい？）


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

    Dim strDSN As String: strDSN = "systest.aa"
    Dim strDB As String: strDB = "testDB"
    Dim strUser As String: strUser = "user"
    Dim strPass As String: strPass = "pwd"
    Dim TblName As String: TblName = ""
    Dim RemoteTblName As String: RemoteTblName = ""


    '確認(パスワード聞くとかするといいかも)---------------
    rtn = MsgBox("退避ＯＫ？", vbQuestion + vbYesNo, "確認")
    If rtn <> vbYes Then
        Exit Sub
    End If

    
    '実行--------------------------------------
    Dim db As DAO.Database, tb As DAO.TableDef
    Set db = CurrentDb


     For Each tb In db.TableDefs
               
            If tb.Connect <> "" Then 'リンクテーブルだけを処理
                               
                    TblName = tb.Name
                    If Left(tb.Connect, 4) = "Text" Then
                        Dim tmp As String
                        Dim tmp2
                        tmp = tb.SourceTableName
                        tmp2 = split(tmp, ".")
                        RemoteTblName = tmp2(0)
                    Else
                        RemoteTblName = tb.SourceTableName
                    End If
                 
                    '↓チェック=======
                    Dim stADOConnect As String
                    stADOConnect = "Driver={SQL Server};server=" & strDSN & _ 
                                           ";database=" & strDB & _ 
                                           ";uid=" & strUser & ";pwd=" & strPass & ";"
                    Dim ChkFLG As Boolean: ChkFLG = False
                    Dim adoCON As New ADODB.Connection
                    Dim adoRS As ADODB.Recordset
                    Dim mySQL As String
                    adoCON.Open stADOConnect
                    mySQL = "SELECT * FROM dbo.sysobjects " & _ 
                                 " WHERE xtype =N'U' ORDER BY name"
                    Set adoRS = adoCON.Execute(mySQL)
                    Do Until adoRS.EOF = True
                        If RemoteTblName = adoRS!Name Then
                            ChkFLG = True
                            Exit Do
                        End If
                        adoRS.MoveNext
                    Loop
                    adoRS.Close
                    Set adoRS = Nothing
                    adoCON.Close
                    Set adoCON = Nothing
                    '↑チェック=======
                 
                 
                    If ChkFLG = True Then
                        '実行！-----------------------
                        AttachDSNLessTable TblName, RemoteTblName, strDSN, strDB, strUser, strPass
                    Else
                        'MsgBox("×「" & TblName & "」元の「" & RemoteTblName & _ 
                                    "」テーブルはSQLServerに存在しません。")
                    End If                   
                   
            Else
                'MsgBox ("「" & tb.Name & "」はリンク元なしなのでスルーしました")
            End If
               
    Next tb
   
    RefreshDatabaseWindow



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


Function AttachDSNLessTable(stLocalTableName As String, stRemoteTableName As String, stServer As String, stDatabase As String, Optional stUsername As String, Optional stPassword As String)
    On Error GoTo AttachDSNLessTable_Err
    Dim td As TableDef
    Dim stConnect As String
   
   
    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
   
   
    '現テーブル削除
    For Each td In CurrentDb.TableDefs
        If td.Name = stLocalTableName Then
            CurrentDb.TableDefs.Delete stLocalTableName
        End If
    Next


    '新テーブル作成
    Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, stConnect)
    CurrentDb.TableDefs.Append td
    AttachDSNLessTable = True
       
    Exit Function


AttachDSNLessTable_Err:
   
    AttachDSNLessTable = False
    MsgBox "AttachDSNLessTable encountered an unexpected error: " & Err.Description


End Function

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



ACCESSからSQLServer 変換　移行　VBA  マクロ