MS-Accessでﾘﾝｸﾃｰﾌﾞﾙ作りまくるのが面倒だったので、ﾘﾝｸﾃｰﾌﾞﾙの名前とｲﾝﾃﾞｯｸｽ用のﾌｨｰﾙﾄﾞ名をXMLからｻﾞｸｻﾞｸ読んで自動処理するコード作成(VB）ヽ(´ー｀)ノMDB
所要時間4時間くらいで作ったので効率割るい部分だのﾊﾞｸﾞだのｴﾗｰ処理が甘いﾄｺがわんさかあるはずだけど、自分のメモのために晒してみたり。ちなみに、PostgreSQL使っていろいろやってる作業用に作ったわけで･･･
使い方モ忘れないように書いておくと･･･
なんとか.mdb 用の作業をする場合は なんとか.dsn というFILEDSNを Program Files/Common Files/ODBC/DataSource下に作っておく。
ﾘﾝｸﾃｰﾌﾞﾙ用の定義は なんとか.linkdef ファイルに：
Tables
Table name="tablename"
MakeIndex
Fields
Field name="fieldname"
/Fields
/MakeIndex
/Table
･･･
で作っておく等
# 当然無保証、無担保、無責任(´ー｀)コピペして使って大事なtable全部ぶっ飛ばしても
# 自他ともに自己責任で宜しくどうぞ（つか、実際table上書きしてぶっ壊してくれます ﾜﾗｲ）。
# もちろん質問は受け付けますけど、回答するかどうかは不明(´ー｀)気分次第
で、DBサーバのIPｱﾄﾞﾚｽが変わったりとかしたときにﾘﾝｸ貼りなおすのが至極面倒･･･ありますよね（あるよねー）そんなときに、いちいち手でﾁｸﾁｸとﾘﾝｸﾃｰﾌﾞﾙの定義弄りたくないわけですよ。前にﾘﾝｸしたときと新しくﾘﾝｸしなおしたときとおおかた違う設定でﾘﾝｸしてしまったりして、ｱﾌﾟﾘの動作が再現しないｶﾅｼﾐ(;´Д`)や同じようなﾃｰﾌﾞﾙをﾘﾝｸするMDBをたくさん抱えてたりしてウンザリ･･･とか（って、それは全部現在の困り事ではあったりする）。
Private Sub MakeLinkTable_Click()
Dim db As Database
Dim dbODBC As Database
Dim strConn As String
Static wsp As Workspace
Static con As Connection
Dim tdfAccess As TableDef
Dim strSQL As String, strXML As String
'
Dim xDoc As New MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xNodeList As MSXML2.IXMLDOMNodeList
Dim xTableNodeList As MSXML2.IXMLDOMNodeList
Dim strTableNames As String
With CommonDialog1
' .Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNHideReadOnly
' .Filter = "テキストファイル(*.txt)|*.txt"
' .ShowOpen
' TableDefsList .FileName
.FileName = "C:\なんとかかんとか\pg\default.mdb"
.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNHideReadOnly
.Filter = "mdbファイル(*.mdb)|*.mdb"
.ShowOpen
End With
On Error GoTo Err_Database
Set dbs = CurrentDb
' 既定のワークスペースへの参照を取得します。
Set wsp = DBEngine.Workspaces(0)
Set db = wsp.OpenDatabase(CommonDialog1.FileName)
strConn = CommonDialog1.FileName
strConn = Left(strConn, Len(strConn) - Len(".mdb"))
strXML = strConn & ".linkdef"
strConn = GetFilename(strConn)
strConn = "ODBC;FILEDSN=" & strConn & ".dsn;"
DoCmd.SetWarnings False
Set dbODBC = OpenDatabase("", False, False, strConn)
strTableNames = ""
For Each tdef In db.TableDefs
strTableNames = strTableNames & "[" & tdef.Name & "]"
Next
On Error GoTo Err_XML
Set xDoc = CreateObject("Microsoft.XMLDOM")
xDoc.Load strXML
xDoc.async = False
Set xNodeList = xDoc.selectNodes("Tables/Table")
Do
On Error GoTo Err_XML
Set xNode = xNodeList.nextNode()
If xNode Is Nothing Then
Exit Do
End If
strTableName = xNode.selectSingleNode("@name").Text
strIndexes = ""
Set xTableNodeList = xNode.selectNodes("MakeIndex/Fields/Field/@name")
Do
Set xNode = xTableNodeList.nextNode()
If xNode Is Nothing Then
Exit Do
End If
strIndexes = strIndexes & ",[" & xNode.Text & "]"
Loop While (1)
strIndexes = Right(strIndexes, Len(strIndexes) - 1)
On Error GoTo Err_Ignore
If InStr(strTableNames, "[" & strTableName & "]") > 0 Then
db.Execute "DROP TABLE [" & strTableName & "];", dbFailOnError
End If
Set tdfAccess = db.CreateTableDef(strTableName, dbAttachSavePWD)
tdfAccess.Connect = dbODBC.Connect
tdfAccess.SourceTableName = "public." & strTableName '
db.TableDefs.Append tdfAccess
If Len(strIndexes) > 0 Then
'run pseudo index queries here. If the table does not exist then this gets skipped.
strSQL = "CREATE UNIQUE INDEX [" & strTableName & "Idx] ON [" & strTableName & "] ( " & strIndexes & " ) with primary;"
db.Execute strSQL
End If
Err_Ignore:
On Error GoTo 0
Loop While (1)
Set xDoc = Nothing
'
dbODBC.Close
db.Close
Exit Sub
Err_Database:
MsgBox Error$
Exit Sub
Err_XML:
MsgBox Error$
End Sub
Posted by minemaz at 2005年07月05日 21:24