カテゴリー名： ［ADOによるデータベースの中身の把握］
' Accessデータベースのフィールド情報の取得
Option Explicit
Sub Macro1()
Dim DbName As String, DbPath As String, ConnStr As String
Dim FSO As Object, TypeCst As Object, TypeSql As Object
Dim CN As ADODB.Connection, CAT As ADOX.Catalog
Dim Tbl As Variant, FldName As Variant, Col As Object
Dim TypeStr As String, IdxHash As Object, Ary As Object, i As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
DbName = InputBox("Accessファイルの名前： ", _
"Accessフィールド情報取得", "TestDB.mdb")
If DbName = "" Then Exit Sub
CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path
DbPath = FSO.GetAbsolutePathName(DbName)
If FSO.FileExists(DbPath) = False Then
MsgBox "ファイルがみつかりません: " & DbPath
Exit Sub
End If
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DbPath & ";"
Set CN = New ADODB.Connection
CN.Open ConnStr
Set CAT = New ADOX.Catalog
CAT.ActiveConnection = CN
Set TypeCst = TypeCstHash() ' データ型：番号と定数名の関連付け
Set TypeSql = TypeSqlHash() ' データ型：番号とSQL表記の関連付け
Set Ary = CreateObject("System.Collections.ArrayList")
For Each Tbl In CAT.Tables ' テーブルを一つずつたどる
If (Tbl.Type = "TABLE") Or (Tbl.Type = "VIEW") Then
FldName = GetFieldName(CN, Tbl.Name) ' フィールド名一覧を取得
Ary.Add Array(Tbl.Name, Tbl.Type)
Set IdxHash = IndexHash(Tbl)
For i = 0 To UBound(FldName) ' フィールドを一つずつ
Set Col = Tbl.Columns(FldName(i))
TypeStr = FieldSqlStr(Col, TypeSql)
If IdxHash.Exists(Col.Name) Then
TypeStr = TypeStr & " " & IdxHash(Col.Name)
End If
Ary.Add Array("", Col.Name, TypeCst(Col.Type), TypeStr)
Next
Ary.Add Array("")
End If
Next
CN.Close
ActiveSheet.UsedRange.Clear
For i = 0 To (Ary.Count-1)
Range(Cells(i+1, 1), Cells(i+1, UBound(Ary(i))+1)).Value = Ary(i)
Next
For i = 1 To ActiveSheet.UsedRange.Columns.Count
ActiveSheet.UsedRange.Columns(i).AutoFit
Next
End Sub
' ----------------
Function GetFieldName(CN, ByVal TblName) ' フィールド名の取得
Dim RS As ADODB.Recordset, FldName() As Variant
Dim FldCount As Integer, i As Integer
TblName = "[" & TblName & "]"
Set RS = New ADODB.Recordset
RS.Open TblName,CN,0,1,2
FldCount = RS.Fields.Count
ReDim FldName(FldCount-1)
For i = 0 To (FldCount-1)
FldName(i) = RS.Fields(i).Name
Next
RS.Close
Set RS = Nothing
GetFieldName = FldName
End Function
' ----------------
Function FieldSqlStr(Col, TypeSql) ' フィールド情報をSQL表記に
Dim TypeStr As String, Val As Variant
If Col.Properties("Autoincrement").Value = True Then
TypeStr = "counter(" & Col.Properties("Seed").Value & _
"," & Col.Properties("Increment").Value & ")"
Else
TypeStr = TypeSql(Col.Type)
End If
If (Col.DefinedSize > 0) And (Col.Type <> adBoolean) Then _
TypeStr = TypeStr & "(" & Col.DefinedSize & ")"
If Col.Type = adNumeric Then _
TypeStr = TypeStr & "(" & Col.Precision & ", " & _
Col.NumericScale & ")"
Val = Col.Properties("Default").Value
If Val <> "" Then
If InStr(Val, " ") Then Val = "[" & Val & "]"
TypeStr = TypeStr & " DEFAULT " & val
End If
Val = Col.Properties("NULLable").Value
If Val = False Then
TypeStr = TypeStr & " NOT NULL"
End If
FieldSqlStr = TypeStr
End Function
' ----------------
Function IndexHash(Tbl) ' インデックス情報の取得
Dim IdxHash As Object, Idx As Variant, Str As String, Col As Variant
Set IdxHash = CreateObject("Scripting.Dictionary")
For Each Idx In Tbl.Indexes
Str = ""
If Idx.PrimaryKey Then Str = "primary key"
If (Str = "") And Idx.Unique Then Str = "unique"
If Str <> "" Then
For Each Col In Idx.Columns
If IdxHash.Exists(Col.Name) = False Then _
IdxHash.Add Col.Name, Str
Next
End If
Next
Set IndexHash = IdxHash
End Function
' ----------------
' データベースのデータ型：番号と定数名の関連付け
Function TypeCstHash()
Dim TypeCst As Object
Set TypeCst = CreateObject("Scripting.Dictionary")
TypeCst.Add 2, "adSmallInt"
TypeCst.Add 3, "adInteger"
TypeCst.Add 4, "adSingle"
TypeCst.Add 5, "adDouble"
TypeCst.Add 6, "adCurrency"
TypeCst.Add 7, "adDate"
TypeCst.Add 8, "adBSTR"
TypeCst.Add 9, "adIDispatch"
TypeCst.Add 10, "adError"
TypeCst.Add 11, "adBoolean"
TypeCst.Add 12, "adVariant"
TypeCst.Add 13, "adIUnknown"
TypeCst.Add 14, "adDecimal"
TypeCst.Add 16, "adTinyInt"
TypeCst.Add 17, "adUnsignedTinyInt"
TypeCst.Add 18, "adUnsignedSmallInt"
TypeCst.Add 19, "adUnsignedInt"
TypeCst.Add 20, "adBigInt"
TypeCst.Add 21, "adUnsignedBigInt"
TypeCst.Add 64, "adFileTime"
TypeCst.Add 72, "adGUID"
TypeCst.Add 128, "adBinary"
TypeCst.Add 129, "adChar"
TypeCst.Add 130, "adWChar"
TypeCst.Add 131, "adNumeric"
TypeCst.Add 132, "adUserDefined"
TypeCst.Add 133, "adDBDate"
TypeCst.Add 134, "adDBTime"
TypeCst.Add 135, "adDBTimeStamp"
TypeCst.Add 136, "adChapter"
TypeCst.Add 138, "adPropVariant"
TypeCst.Add 139, "adVarNumeric"
TypeCst.Add 200, "adVarChar"
TypeCst.Add 201, "adLongVarChar"
TypeCst.Add 202, "adVarWChar"
TypeCst.Add 203, "adLongVarWChar"
TypeCst.Add 204, "adVarBinary"
TypeCst.Add 205, "adLongVarBinary"
Set TypeCstHash = TypeCst
End Function
' データベースのデータ型：番号とSQL表記の関連付け
Function TypeSqlHash()
Dim TypeSql As Object
Set TypeSql = CreateObject("Scripting.Dictionary")
TypeSql.Add 2, "SmallInt"
TypeSql.Add 3, "int"
TypeSql.Add 4, "real"
TypeSql.Add 5, "float"
TypeSql.Add 6, "money"
TypeSql.Add 7, "date"
TypeSql.Add 11, "YesNo"
TypeSql.Add 17, "TinyInt"
TypeSql.Add 72, "guid"
TypeSql.Add 130, "char"
TypeSql.Add 131, "decimal"
TypeSql.Add 202, "varchar"
TypeSql.Add 203, "longtext"
TypeSql.Add 204, "binary"
TypeSql.Add 205, "longbinary"
Set TypeSqlHash = TypeSql
End Function
' Accessデータベースのフィールド情報を取得
Option Explicit
Dim FSO, Fobj, DbName, DbPath, TypeCst, TypeSql
Dim ConnStr, CN, CAT, Tbl, FldName, Col, Ary, TypeStr, IdxHash, i
Include "constants_ad.vbs"
Set FSO = CreateObject("Scripting.FileSystemObject")
DbName = InputBox("Accessファイルの名前： ", _
"Accessフィールド情報取得", "TestDB.mdb")
If DbName = "" Then WScript.Quit
DbPath = FSO.GetAbsolutePathName(DbName)
If FSO.FileExists(DbPath) = False Then
MsgBox "ファイルがみつかりません: " & DbPath
WScript.Quit
End If
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DbPath & ";"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnStr
Set CAT = CreateObject("ADOX.Catalog")
CAT.ActiveConnection = CN
Set TypeCst = TypeCstHash() ' データ型：番号と定数名の関連付け
Set TypeSql = TypeSqlHash() ' データ型：番号とSQL表記の関連付け
Set Ary = CreateObject("System.Collections.ArrayList")
For Each Tbl In CAT.Tables ' テーブルを一つずつたどる
If (Tbl.Type = "TABLE") Or (Tbl.Type = "VIEW") Then
FldName = GetFieldName(CN, Tbl.Name) ' フィールド名一覧を取得
Ary.Add Array("＊" & Tbl.Name, Tbl.Type)
Set IdxHash = IndexHash(Tbl)
For i = 0 To UBound(FldName) ' フィールドを一つずつ
Set Col = Tbl.Columns(FldName(i))
TypeStr = FieldSqlStr(Col, TypeSql)
If IdxHash.Exists(Col.Name) Then
TypeStr = TypeStr & " " & IdxHash(Col.Name)
End If
Ary.Add Array("", Col.Name, TypeCst(Col.Type), TypeStr)
Next
Ary.Add Array("")
End If
Next
CN.Close
Set Fobj = FSO.OpenTextFile("FieldInfo.txt", 2, True)
For i = 0 To (Ary.Count-1)
Fobj.WriteLine Join(Ary(i), vbTab)
Next
Fobj.Close
' ----------------
Function GetFieldName(CN, ByVal TblName) ' フィールド名の取得
Dim RS, FldName(), FldCount, i
TblName = "[" & TblName & "]"
Set RS = CreateObject("ADODB.Recordset")
RS.Open TblName,CN,0,1,2
FldCount = RS.Fields.Count
ReDim FldName(FldCount-1)
For i = 0 To (FldCount-1)
FldName(i) = RS.Fields(i).Name
Next
RS.Close
Set RS = Nothing
GetFieldName = FldName
End Function
' ----------------
Function FieldSqlStr(Col, TypeSql) ' フィールド情報をSQL表記に
Dim TypeStr, Val
If Col.Properties("Autoincrement").Value = True Then
TypeStr = "counter(" & Col.Properties("Seed").Value & _
"," & Col.Properties("Increment").Value & ")"
Else
TypeStr = TypeSql(Col.Type)
End If
If (Col.DefinedSize > 0) And (Col.Type <> adBoolean) Then _
TypeStr = TypeStr & "(" & Col.DefinedSize & ")"
If Col.Type = adNumeric Then _
TypeStr = TypeStr & "(" & Col.Precision & ", " & _
Col.NumericScale & ")"
Val = Col.Properties("Default").Value
If Val <> "" Then
If InStr(Val, " ") Then Val = "[" & Val & "]"
TypeStr = TypeStr & " DEFAULT " & val
End If
Val = Col.Properties("NULLable").Value
If Val = False Then
TypeStr = TypeStr & " NOT NULL"
End If
FieldSqlStr = TypeStr
End Function
' ----------------
Function IndexHash(Tbl) ' インデックス情報の取得
Dim IdxHash, Idx, Str, Col
Set IdxHash = CreateObject("Scripting.Dictionary")
For Each Idx In Tbl.Indexes
Str = ""
If Idx.PrimaryKey Then Str = "primary key"
If (Str = "") And Idx.Unique Then Str = "unique"
If Str <> "" Then
For Each Col In Idx.Columns
If IdxHash.Exists(Col.Name) = False Then _
IdxHash.Add Col.Name, Str
Next
End If
Next
Set IndexHash = IdxHash
End Function
' ----------------
Sub Include(ByVal FileName)
Dim FSO, FileObj, MyStr
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FileObj = FSO.OpenTextFile(FSO.GetAbsolutePathName(FileName))
MyStr = FileObj.ReadAll()
FileObj.Close
Set FSO = Nothing
Set FileObj = Nothing
ExecuteGlobal MyStr
End Sub
// Accessデータベースのフィールド情報の取得
var fso, Fobj, dbName, dbPath, typeCst, typeSql;
var connStr, cn, cat, tbl, fldName, idxHash, col, Ary, i, j;
eval(ReadFile("constants_ad.js"));
fso = WScript.CreateObject("Scripting.FileSystemObject");
dbName = InputBox("Accessファイルの名前： ",
"Accessフィールド情報取得", "TestDB.mdb");
if (dbName == "") WScript.Quit();
dbPath = fso.GetAbsolutePathName(dbName);
if (fso.FileExists(dbPath) == false) {
var shellObj = WScript.CreateObject("WScript.Shell");
WScript.Echo("ファイルがみつかりません: " + dbPath);
while (shellObj.AppActivate("Windows Script Host") != true) {
WScript.Sleep(100);
}
WScript.Quit();
}
connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" + dbPath + ";";
cn = WScript.CreateObject("ADODB.Connection");
cn.Open(connStr);
cat = WScript.CreateObject("ADOX.Catalog");
cat.ActiveConnection = cn;
typeCst = TypeCstHash(); // データ型：番号と定数名の関連付け
typeSql = TypeSqlHash(); // データ型：番号とSQL表記の関連付け
Ary = [];
for (i=0; i<cat.Tables.Count; i++) { // テーブルを一つずつたどる
tbl = cat.Tables(i);
if (tbl.Type == "TABLE" || tbl.Type == "VIEW") {
Ary.push(["＊" + tbl.Name, tbl.Type]);
fldName = GetFieldName(cn, tbl.Name); // フィールド名一覧を取得
idxHash = IndexHash(tbl);
for (j=0; j<fldName.length; j++) { // フィールドを一つずつ
col = tbl.Columns(fldName[j]);
typeStr = FieldSqlStr(col, typeSql);
if (idxHash[col.Name] != null)
typeStr = typeStr + " " + idxHash[col.Name];
Ary.push(["", col.Name, typeCst[col.Type], typeStr]);
}
Ary.push([""]);
}
}
cn.Close();
Fobj = fso.OpenTextFile("FieldInfo.txt", 2, true);
for (i = 0; i < Ary.length; i++) {
Fobj.WriteLine(Ary[i].join("\t"));
}
Fobj.Close();
// ----------------
function GetFieldName(cn, tblName) { // フィールド名の取得
var rs, fldName, fldCount, i;
tblName = "[" + tblName + "]";
rs = WScript.CreateObject("ADODB.Recordset");
rs.Open(tblName,cn,0,1,2);
fldCount = rs.Fields.Count;
fldName = Array(fldCount);
for (i=0; i<fldCount; i++) {
fldName[i] = rs.Fields(i).Name
}
rs.Close();
return fldName
}
// ----------------
function FieldSqlStr(col, typeSql) { // フィールド情報をSQL表記に
var typeStr, val;
if (col.Properties("Autoincrement").Value == true)
typeStr = "counter(" + col.Properties("Seed").Value +
"," + col.Properties("Increment").Value + ")";
else
typeStr = typeSql[col.Type];
if (col.DefinedSize > 0 && col.Type != adBoolean)
typeStr = typeStr + "(" + col.DefinedSize + ")";
if (col.Type == adNumeric)
typeStr = typeStr + "(" + col.Precision + ", " +
col.NumericScale + ")";
val = col.Properties("Default").Value;
if (val != null) {
if (val.indexOf(" ") >= 0) val = "[" + val + "]";
typeStr = typeStr + " DEFAULT " + val;
}
val = col.Properties("NULLable").Value;
if (val == false)
typeStr = typeStr + " NOT NULL";
return typeStr;
}
// ----------------
function IndexHash(tbl) { // インデックス情報の取得
var idxHash, idx, str, col, i, j;
idxHash = {};
for (i=0; i<tbl.Indexes.Count; i++) {
idx = tbl.Indexes(i);
str = "";
if (idx.PrimaryKey) str = "primary key";
if (str == "" && idx.Unique) str = "unique";
if (str != "") {
for (j=0; j<idx.Columns.Count; j++) {
col = idx.Columns(j);
if (idxHash[col.Name] == null)
idxHash[col.Name] = str;
}
}
}
return idxHash;
}
// ----------------
function InputBox(prmpt, ttl, dflt) {
var sh = WScript.CreateObject("WScript.Shell");
var tmpFile = sh.Environment("Process").item("TEMP") + "\\MyTest.vbs";
var fso = WScript.CreateObject("Scripting.FileSystemObject");
var cmdStr = "Set FSO = CreateObject(\"Scripting.FileSystemObject\")\n" +
"dbName = InputBox(\"" + prmpt + "\", _\n" +
"\"" + ttl + "\", \"" + dflt + "\")\n" +
"FSO.GetStandardStream(1).Write dbName\n";
var Fobj = fso.OpenTextFile(tmpFile, 2, true);
Fobj.Write(cmdStr);
Fobj.Close();
execObj = sh.Exec("CScript.exe /Nologo " + tmpFile);
while (execObj.Status == 0) { // コマンド実行の終了を待つ
WScript.Sleep(100); // 0.1秒待機
}
var resStr = execObj.StdOut.ReadLine();
fso.DeleteFile(tmpFile);
return resStr;
}
// ----------------
function ReadFile(filename) {
var fso = WScript.CreateObject("Scripting.FileSystemObject");
var path = fso.GetAbsolutePathName(filename);
var MyStr = null;
if (fso.FileExists(path)) {
var fobj = fso.OpenTextFile(path, 1);
MyStr = fobj.ReadAll();
fobj.Close();
}
return MyStr;
}
〜 以上 〜