From Evernote: |
[ACCESS→SQLServer]ACCESS内のリンクをVBAではりかえる(DNSver)。 |
【追記※DNS方式ﾊﾞｰｼﾞｮﾝ】--------------------------------------------
この方法はDNS方式ﾊﾞｰｼﾞｮﾝです。
ローカルＰＣにきちんとODBC設定して行なって使用します。
DNS-LESSﾊﾞｰｼﾞｮﾝはこちら
'--------------------------------------------------------
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
'実行！-----------------------
AttachDSNTable TblName, RemoteTblName, strDSN, strDB, strUser, strPass
Else
'MsgBox("×「" & TblName & "」元の「" & RemoteTblName & _
"」テーブルはSQLServerに存在しません。")
End If
Else
'MsgBox ("「" & tb.Name & "」はリンク元なしなのでスルーしました")
End If
Next tb
RefreshDatabaseWindow
'--------------------------------------------------------
Function AttachDSNTable(stLocalTableName As String, stRemoteTableName As String, stServer As String, stDatabase As String, Optional stUsername As String, Optional stPassword As String)
On Error GoTo AttachDSNTable_Err
Dim td As TableDef
Dim stConnect As String
'ここにＯＤＢＣ名
'現テーブル削除
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
AttachDSNTable_Err:
AttachDSNTable = False
MsgBox "AttachDSNTable encountered an unexpected error: " & Err.Description
End Function
'--------------------------------------------------------
ACCESSからSQLServer 変換 移行 VBA マクロ
0 件のコメント:
コメントを投稿