[VBS32]Access2016+64bit でAccess97形式MDBファイルにテーブルをコピーする

VBScript 2

テーブル、配列に登録されたクエリまではコピーできるバージョンができました
まだクエリを全部拾うところまではいきません。
F:\の
TESTTYPE97.mdbにTEST.accdbの
TEST2016テーブルをコピーする
スクリプトの場所はC:\hoge\testvbs2.vbs

C\hoge\AC16To97.VBS

'%SystemRoot%\SysWow64\cscript.exe //Nologo "C:\hoget\AC16ToAc97.vbs"
'#If VBA7 Then
'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
'#Else
'Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
'#End If
'**********************
'** ファイル設定定数 **
'**********************
Const DN97 = "E:\TEST97.mdb" 'Access97形式MDBファイル(フルパス)。既存のファイルは削除するので注意
Const DN16 = "E:\TEST16.accdb" 'Source Accdb File コピー元となるaccdbファイル(フルパス)
Dim Br : Br = Split("QS0,QS1,QS2",",") 'コピーするクエリの名前、ユニオンクエリは後にする。
Const oldFile = "E:\test97.mdb" '変換元ファイル(フルパス) 通常はDN97と同じ
Const NewFile = "E:\test20_2005.mdb" '変換先Access2003形式mdbファイル
'**************
'**定数宣言部**
'**************
'///Database Language
Const DB_LANG_JAPANESE = ";LANGID=0x0411;CP=932;COUNTRY=0" 'For Access95 Later
Const DB_Lang_Global = ";LANGID=0x0409;CP=1252;COUNTRY=0" '英語、ドイツ語、フランス語、ポルトガル語、イタリア語、および現代スペイン語 For Access 2.0 earlier

Const DB_Lang_Arabic = ";LANGID=0x0401;CP=1256;COUNTRY=0" 'アラビア語
Const DB_Lang_ChineseSimplified = ";LANGID=0x0804;CP=936;COUNTRY=0" '簡体字中国語
Const DB_Lang_ChineseTraditional = ";LANGID=0x0404;CP=950;COUNTRY=0" '繁体字中国語
Const DB_Lang_Cyrillic = ";LANGID=0x0419;CP=1251;COUNTRY=0" 'ロシア語
Const DB_Lang_Czech = ";LANGID=0x0405;CP=1250;COUNTRY=0" 'チェコ語
Const DB_Lang_Dutch = ";LANGID=0x0413;CP=1252;COUNTRY=0" 'オランダ語
Const DB_Lang_Greek = ";LANGID=0x0408;CP=1253;COUNTRY=0" 'ギリシャ語
Const DB_Lang_Hebrew = ";LANGID=0x040D;CP=1255;COUNTRY=0" 'ヘブライ語
Const DB_Lang_Hungarian = ";LANGID=0x040E;CP=1250;COUNTRY=0" 'ハンガリー語
Const DB_Lang_Icelandic = ";LANGID=0x040F;CP=1252;COUNTRY=0" ' アイスランド語
Const DB_Lang_Korean = ";LANGID=0x0412;CP=949;COUNTRY=0" '韓国語
Const DB_Lang_Nordic = ";LANGID=0x041D;CP=1252;COUNTRY=0" '北欧諸国語
Const DB_Lang_NorwDan = ";LANGID=0x0406;CP=1252;COUNTRY=0" 'ノルウェー語およびデンマーク語
Const DB_Lang_Polish = ";LANGID=0x0415;CP=1250;COUNTRY=0" 'ポーランド語
Const DB_Lang_Slovenian = ";LANGID=0x0424;CP=1250;COUNTRY=0" 'スロベニア語
Const DB_Lang_Spanish = ";LANGID=0x040A;CP=1252;COUNTRY=0" 'スペイン語
Const DB_Lang_SwedFin = ";LANGID=0x041D;CP=1252;COUNTRY=0" 'スウェーデン語およびフィンランド語
Const DB_Lang_Thai = ";LANGID=0x041E;CP=874;COUNTRY=0" 'タイ語
Const DB_Lang_Turkish = ";LANGID=0x041F;CP=1254;COUNTRY=0" 'トルコ語

'///Jet DBVersion [DataTypeEnum(DAO)](https://msdn.microsoft.com/ja-jp/library/office/ff821447.aspx)
Const cnsDbVersion30_AC95_AC97_Jet30_Jet35 = 32
Const cnsDbVersion20_AC20_Jet20 = 16
Const cnsDBVersion11 = 8 'Jet Engine Versiont1.1 Access 1.1 Available Japnese
Const cnsDBVersion10 = 1 'Access1.0
Const cnsDBDEcript = 4
Const cnsDBEncrypt  = 2
Const cnsDBVersion = 120 'Not for Dao.3.6


'////SystemReQuest SQL Strings
'[Access 2013 テーブル・クエリ等すべてのオブジェクトを取得する方法 ](http://nasunoblog.blogspot.com/2013/10/access-2013.html)
Const sLinkTableConnectioninfo = " FROM MsysObjects WHERE Type = 4;" 'SELECT Name, Connect, ForeignName
Const sAllTableName = " FROM MsysObjects WHERE Type = 1 AND Flags = 0;" 'SELECT Name
Const sALLReportName = " FROM MsysObjects WHERE Type = -32764 AND Flags = 0;" 'Select Name
Const sALLQueryName = " FROM MsysObjects WHERE Type = 5 AND Flags = 0;" 'Select Name
Const sALLFormName = " FROM MsysObjects WHERE Type = -32768 AND Flags = 0;" 'Select Name
Const sALLMacroName = " FROM MsysObjects WHERE Type = -32764 AND Flags = 0;" 'Select Name
Const sALLModuleName = " FROM MsysObjects WHERE Type = -32761 AND Flags = 0;" 'Select Name

'///接続文字列
Const Pro12 = "Provider=Microsoft.Ace.Oledb.12.0;Data Source="
Const Pro16 = "Provider=Microsoft.Ace.Oledb.16.0;Data Source="
Const Jet40 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Const JETCreateLink = "JET OLEDB:Create Link"
Const JETLinkSource = "JET OLEDB:Link Source"
Const JETRmtTblName = "JET OLEDB:Remote Table Name"

'///[RecordsetTypeEnum 列挙 (DAO)](https://msdn.microsoft.com/ja-jp/library/office/ff195231.aspx)
Const DB_Open_Dynamic = 16 'ダイナセット タイプの Recordset を開きます。
Const DB_Open_Dynaset = 2 'ダイナセット タイプの Recordset を開きます。
Const DB_Open_ForwardOnly = 8 '前方スクロール タイプの Recordset を開きます。
Const DB_Open_Snapshot = 4 'スナップショット タイプの Recordset を開きます。
Const DB_Open_Table = 1 'テーブル タイプの Recordset を開きます。

'///[TableDefAttributeEnum 列挙 (DAO)](https://msdn.microsoft.com/ja-jp/library/office/ff194433.aspx)
Const dbAttachedODBC = 536870912 'リンクされた ODBC データベース テーブル。
Const dbAttachedTable = 1073741824 'リンクされた非 ODBC データベース テーブル。
Const dbAttachExclusive = 65536 'リンクされた Microsoft Access データベース エンジン テーブルを排他的に開きます。
Const dbAttachSavePWD = 131072 'リンクされたリモート テーブルのユーザー ID とパスワードを保存します。
Const dbHiddenObject = 1 '隠しテーブル (一時的な用途用)。
Const dbSystemObject = -2147483646 'システム テーブル。

'///RecordsetOptionEnum 列挙 (DAO)
Const dbAppendOnly = 8 'ユーザーが新しいレコードをダイナセットに追加するのを許可しますが、既存のレコードを読み取ることは許可しません。
Const dbConsistent = 32 'ダイナセット内の他のレコードに影響を与えないフィールドにのみ更新を適用します (ダイナセット タイプとスナップショット タイプのみ)。
Const dbDenyRead = 2 '他のユーザーが Recordset のレコードを読み取れないようにします (テーブル タイプのみ)。
Const dbDenyWrite = 1 '他のユーザーが Recordset のレコードを変更できないようにします。
Const dbExecDirect = 2048 'SQLPrepare ODBC 関数を最初に呼び出さずに、クエリを実行します。
Const dbFailOnError = 128 'エラーが発生した場合、更新をロールバックします。
Const dbForwardOnly = 256 '前方スクロールのみのスナップショット タイプ Recordset を作成します (スナップショット タイプのみ)。44
Const dbInconsistent = 16 '他のレコードに影響が及ぶ場合でも、すべてのダイナセット フィールドに更新を適用します (ダイナセット タイプとスナップショット タイプのみ)。
Const dbReadOnly = 4 'Recordset を読み取り専用として開きます。
Const dbRunAsync = 1024 'クエリを非同期で実行します。
Const dbSeeChanges = 512 '編集中のデータを別のユーザーが変更している場合、実行時エラーを生成します (ダイナセット タイプのみ)。
Const dbSQLPassThrough = 64 'ODBC データベースに SQL ステートメントを送信します (スナップショット タイプのみ)。


'///LockType
Const dbOptimistic = 3 'レコード ID に基づく共有的同時ロック。カーソルは古いレコードと新しいレコードのレコード ID を比較し、そのレコードへのアクセスが最後に行われてから変更が加えられたかどうか判断します。
Const dbOptimisticBatch =5 '共有的バッチ更新を可能にします (ODBCDirect ワークスペースのみ)。
Const dbOptimisticValue = 1 'レコード値に基づく共有的同時ロック。カーソルは古いレコードと新しいレコードのデータ値を比較し、そのレコードへのアクセスが最後に行われてから変更が加えられたかどうか判断します (ODBCDirect ワークスペースのみ)。
Const dbPessimistic = 2 '排他的同時ロック。カーソルは、レコードが更新可能であることを保証するために必要な最低限のロックを使用します。
'MEMO:Microsoft Access 2013 では、ODBCDirect ワークスペースはサポートされていません。Microsoft Access データベース エンジンを使用しないで外部データ ソースにアクセスする場合は、ADO を使用してください。

'///Access Object
Const acDataAccessPage = 6
Const acDefault = -1
Const acDiagram = 8
Const acForm = 2
Const acFunction = 10
Const acMacro = 4
Const acModule = 5
Const acQuery = 1
Const acReport = 3
Const acServerView = 7
Const acStoredProcedure = 9
Const acTable = 0

'Field Type Enum
Const dbGUID= 15 'dbGUID
Const dbBoolean= 1 'dbBoolean
Const dbByte= 2 'dbByte
Const dbInteger= 3 'dbInteger
Const dbLong= 4 'dbLong
Const dbCurrency= 5 'dbCurrency
Const dbSingle= 6 'dbsingle
Const dbDouble= 7 'dbDouble
Const dbDate= 8 'dbDate
Const dbBinary= 9 'dbBinary
Const dbText= 10 'dbText
Const dbMemo= 12 'dbMemo
Const dbVarBinary= 17 'dbVarBinaryMicrosoft Access 2013 では、ODBCDirect ワークスペースはサポートされていません。Microsoft Access データベース エンジンを使用しないで外部データ ソースにアクセスする場合は、ADO を使用してください。
Const dbChar= 18 'dbChar
Const dbNumeric= 19 'dbNumeric
Const dbDecimal= 20 'dbDecimal ODBCDirect ワークスペースは、Microsoft Access 2013 ではサポートされていません。Microsoft Office Access データベース エンジンを使用しないで外部データ ソースにアクセスする場合は、ADO を使用してください。
Const dbFloat= 21 'dbFloat Microsoft Access 2013 では、ODBCDirect ワークスペースはサポートされていません。Microsoft Access データベース エンジンを使用しないで外部データ ソースにアクセスする場合は、ADO を使用してください。
Const dbTime= 22 'dbTime
Const dbTimeStamp= 23 'dbTimeStamp Microsoft Access 2013 では、ODBCDirect ワークスペースはサポートされていません。

'///[CursorLocationEnum(ADO)](https://msdn.microsoft.com/ja-jp/library/cc389782.aspx)
Const ad_UseClient = 3 'ローカル カーソル ライブラリより提供されたクライアント側カーソルを使います。ローカル カーソル サービスにはドライバによって提供されるカーソルよりも多くのカーソル機能があるので、この設定を利用すればより高度な機能を提供できます。以前のバージョンとの互換性を保つために、同じ意味を持つ adUseClientBatch もサポートしています。
Const as_UseNone = 1 'カーソル サービスを使いません。(この定数は現行バージョン用ではなく、以前のバージョンとの互換性を保つために装備されています。)
Const ad_UseServer = 2 '既定値です。データ プロバイダ カーソルまたはドライバによって供給されるカーソルを使用します。これらのカーソルは、多くの場合柔軟性が高く、ほかのユーザーが行うデータ ソースへの変更を検出できます。ただし、「Microsoft Cursor Service for OLE DB」にはサーバー側カーソルではシミュレートできない機能 (独立した Recordset オブジェクトなど) があり、そのような機能はこの設定では利用できません。

'///[PositionEnum(ADO)](https://msdn.microsoft.com/ja-jp/library/cc389855.aspx)
Const ad_PostBOF = -2 'カレント レコードのポインタが BOF にあることを表します (BOF プロパティが True です)。
Const ad_PosEOF = -3 'カレント レコードのポインタが EOF にあることを表します (EOF プロパティが True です)。
Const ad_PostUnknown = -1 'Recordset が空である、現在の位置が不明、あるいはプロバイダが AbsolutePage プロパティまたは AbsolutePosition プロパティをサポートしていません。

'///[DataTypeEnum(ADO)](https://msdn.microsoft.com/ja-jp/library/cc389790.aspx)
Const ad_Array = &H2000 '( Const ad_OX には適用せず。) 0x2000 常に別のデータ型定数と組み合わされ、そのデータ型の配列を示すフラグ値です。
Const ad_BigInt = 20 '8 バイトの符号付き整数を示します (DBTYPE_I8)。
Const ad_Binary = 128 'バイナリ値を示します (DBTYPE_BYTES)。
Const ad_Boolean = 11 'ブール値を示します (DBTYPE_BYTES)。
Const ad_BSTR = 8 'Null で終了する Unicode 文字列を示します (DBTYPE_BSTR)。
Const ad_Chapter = 136 '子行セットの行を識別する 4 バイト チャプタ値を示します (DBTYPE_HCHAPTER)。
Const ad_Char = 129 '文字列値を示します (DBTYPE_STR)。
Const ad_Currency = 6 '通貨値を示します (DBTYPE_CY)。通貨型は小数点以下 4 桁の固定小数点の数値です。スケールが 10,000 の、8 バイトの符号付き整数で格納します。
Const ad_Date = 7 '日付値を示します (DBTYPE_DATE)。日付型は倍精度浮動小数点数型 (Double) で格納され、整数部分は 1899 年 12 月 30 日からの日数を、分数部分は日数の分数を表します。
Const ad_DBDate = 133 '日付値 (yyyymmdd) を示します (DBTYPE_DBDATE)。
Const ad_DBTime = 134 '時刻値 (hhmmss) を示します (DBTYPE_DBTIME)。
Const ad_DBTimeStamp = 135 '日付/時刻スタンプ (yyyymmddhhmmss および 10 億分の 1 桁までの分数) を示します (DBTYPE_DBTIMESTAMP)。
Const ad_Decimal = 14 '固定精度およびスケールの正確な数値を示します (DBTYPE_DECIMAL)。
Const ad_Double = 5 '倍精度浮動小数点値を示します (DBTYPE_R8)。
Const ad_Empty = 0 '値を指定しません (DBTYPE_EMPTY)。
Const ad_Error = 10 '32 ビット エラー コードを示します (DBTYPE_ERROR)。
Const ad_FileTime = 64 '1601 年 1 月 1 日からの時間を示す 64 ビット値を 100 ナノ秒単位で示します (DBTYPE_FILETIME)。
Const ad_GUID = 72 '固有のグローバル識別子 (GUID) を示します (DBTYPE_GUID)。
Const ad_IDispatch = 9 'COM オブジェクトの IDispatch インターフェイスへのポインタを示します (DBTYPE_IDISPATCH)。
'注意 このデータ型は、現在は Const ad_O ではサポートされていません。使用すると予期しない結果になることがあります。
Const ad_Integer = 3 '4 バイトの符号付き整数を示します (DBTYPE_I4)。
Const ad_IUnknown = 13 'COM オブジェクトの IUnknown インターフェイスへのポインタを示します (DBTYPE_IUNKNOWN)。
'注意 このデータ型は、現在は Const ad_O ではサポートしていません。使用すると予期しない結果になることがあります。
Const ad_LongVarBinary = 205 '長バイナリ値を示します (Parameter オブジェクトのみ)。
Const ad_LongVarChar = 201 '長文字列の値を示します (Parameter オブジェクトのみ)。
Const ad_LongVarWChar = 203 'Null で終了する Unicode 文字列値を示します (Parameter オブジェクトのみ)。
Const ad_Numeric = 131 '固定精度およびスケールの正確な数値を示します (DBTYPE_NUMERIC)。
Const ad_PropVariant = 138 'オートメーション PROPVARIANT を示します (DBTYPE_PROP_VARIANT)。
Const ad_Single = 4 '単精度浮動小数点値を示します (DBTYPE_R4)。
Const ad_SmallInt = 2 '2 バイトの符号付き整数を示します (DBTYPE_I2)。
Const ad_TinyInt = 16 '1 バイトの符号付き整数を示します (DBTYPE_I1)。
Const ad_UnsignedBigInt = 21 '8 バイトの符号なし整数を示します (DBTYPE_I8)。
Const ad_UnsignedInt = 19 '4 バイトの符号なし整数を示します (DBTYPE_I4)。
Const ad_UnsignedSmallInt = 18 '2 バイトの符号なし整数を示します (DBTYPE_I2)。
Const ad_UnsignedTinyInt = 17 '1 バイトの符号なし整数を示します (DBTYPE_I1)。
Const ad_UserDefined = 132 'ユーザー定義の変数を示します (DBTYPE_UDT)。
Const ad_VarBinary = 204 'バイナリ値を示します (Parameter オブジェクトのみ)。
Const ad_VarChar = 200 '文字列値を示します (Parameter オブジェクトのみ)。
Const ad_Variant = 12 'オートメーション バリアント型 (Variant) を示します (DBTYPE_VARIANT)。
'注意 このデータ型は、現在は Const ad_O ではサポートされていません。使用すると予期しない結果になることがあります。
Const ad_VarNumeric = 139 '数値を示します (Parameter オブジェクトのみ)。
Const ad_VarWChar = 202 'Null で終了する Unicode 文字列を示します (Parameter オブジェクトのみ)。
Const ad_WChar = 130 'Null で終了する Unicode 文字列を示します (DBTYPE_WSTR)。
'******************
'** 実行ファイル **
'******************
Main
Sub Main()
Dim accessApp : set accessApp = createObject("Access.Application")
Dim db,DBE 'Set db = CreateObject("DAO.DBEngine.36").OpenDatabase(DN97)
Dim DBA ,Tb9, i, i1
Dim V,Buf
Dim RS
Dim RST
Dim ADC : Set ADC = CreateObject("ADOX.Catalog")':ADC.Create(Pro12 & """ & DN16 & """)
Dim ADX : Set ADX = CreateObject("ADOX.Table")
Dim bl:bl=False
Dim Ar()
Dim CNT
Dim Q,Qtg,CntLine,Qr(),Qs,TDF
WScript.Sleep 1000
' MDB を削除します。
With CreateObject("Scripting.FileSystemObject")
'変換元ファイルがなければ終了する
If .FileExists(DN16) = False Then Wscript.Echo DN16 & "NOT FOUND.Script Stop." :Wscript.Quit()
'変換先ファイルがあれば削除する
If .FileExists(DN97) Then .DeleteFile DN97, True
End With
' MDBファイルの作成
Set dbe = CreateObject("DAO.DBEngine.36")
Set db = dbe.CreateDatabase(DN97, DB_LANG_JAPANESE, cnsDbVersion30_AC95_AC97_Jet30_Jet35)

'Access 2007 Later Accdb
accessApp.OpenCurrentDataBase(DN16) 'Failed Set DBA = accessApp.OpenCurrentDataBase(DN16)

Set DBA = accessApp.CurrentDB:WScript.Echo "Line:" & 102
accessApp.visible = true
accessApp.UserControl = true

For Each V in DBA.TableDefs
     buf = BUF & ":" & V.name: CntLine = 224
Next
'Make Table Name(Ex SystemTable) List Array
i=0
For Each V in DBA.TableDefs
     If ((V.Attributes And dbSystemObject) Or _
     (V.Attributes And dbHiddenObject)) = 0 Then
     If BlCheck(V.name)= True Then Redim Preserve ar(i): Ar(i)=V.Name :Wscript.Echo "Line111: " & V.name & "is in at Ar(" & i & ")"
     i=i+1
     Redim Preserve ar(i)
     End if
Next
Cntline =CNTLine+16
For i= Lbound(ar) to Ubound(ar)
Wscript.Echo "Array Value: " & i & " : " & Ar(i) & " Line:" & CNTLine
WScript.Sleep 100
Next
Wscript.Sleep 100:WScript.Echo "Arrayed"
Wscript.Echo DBA.Name
Wscript.Echo buf:buf = ""
WScript.Sleep 100
For each V in DBA.TableDefs
buf = BUF & ":" & V.name
Next
Wscript.Echo buf

CntLine = CntLine + 21 '6行下を指定
For i = LBound(ar) to UBound(ar)
On error resume next
Set V = DBA.TableDefs(ar(i))
on error goto 0
If Err.Number = 0 Then
Wscript.Echo "Line:" & CntLine & " " & V.name
If BlCheck(V.Name) = True Then
Set TDF = DBA.TableDefs(V.Name)
Set RS = DBA.OpenRecordSet(V.Name,1,4):Wscript.Echo "Line" & CntLine + 3 & " :" & V.name :Wscript.Sleep 500
If Rs.RecordCount > 0 Then
on error resume next
DB.Execute "DROP TABLE " & V.Name & " ":WScript.Sleep 100
If Err.Number<> 0 then Err.clear
db.Execute "CREATE TABLE " & V.Name & " " :WScript.Sleep 100
DB.TableDefs.Refresh
Set tb9= db.TableDefs(V.Name):Wscript.Echo "Line:" & Cntline + 10 & ":" & V.name
With tb9
for i1= 0 to TDF.Fields.Count-1
.Fields.Append .CreateField(TDF.Fields(i1).Name ,Tdf.Fields(i1).Type):Wscript.Echo "Line:" & CntLine +13 & " :" & V.name
.Fields(i1).AllowZeroLength = True:Wscript.Echo "Line" & CntLine +14 & " :" & V.name & ":" & .Fields(i1).name' TDF.Fields(i1).AllowZeroLength '情報が未確認のために空白になっているフィールドと、当てはまらないので空白になっているフィールドを区別できるようにするには、"Required/値要求" プロパティに [No/いいえ] を設定し、"AllowZeroLength/空文字列の許可" プロパティに [Yes/はい] を設定します。
.Fields(i1).Required = False :Wscript.Echo "Line" & Cntline +15 & " :" & V.name & ":" & .Fields(i1).name
.Fields(i1).CollatingOrder = TDF.Fields(i1).CollatingOrder
.Fields(i1).DataUpdatable = TDF.Fields(i1).DataUpdatable
.Fields(i1).OrdinalPosition = TDF.Fields(i1).OrdinalPosition:WScript.Echo CntLine+18
.Fields(i1).Size = TDF.Fields(i1).Size
.Fields(i1).DefaulValue= TDF.Fields(i1).DefaultValue
.Fields(i1).Attributes = TDF.Fields(i1).Attributes:WScript.Echo TDF.Fields(i1).Attributes
.Fields.Refresh:WScript.Sleep 100
Next
End With
On Error Goto 0
If err.number<>0 then Wscript.Echo Err.Number & ":" & Err.Description :Err.Clear
On error resume Next
db.Tabledefs.refresh:Wscript.Echo "Line:" & CntLine + 28 & " :" & V.name & "Refresh"
On Error Goto 0
If err.number<>0 then Wscript.Echo Err.Number & ":" & Err.Description :Err.Clear
WScript.Sleep 1000
On Error Resume Next
Set RST = DB.OpenRecordSet(V.Name,1):Wscript.Echo "Line:" & CntLine + 33 & " :" & V.name & ":" & "RecordSet"
On Error Goto 0
IF Err.Number = 0 Then
CNT=0:Wscript.Echo "Line:" & CntLine + 36 & " :" & V.name & ":" & "Adding..." 'Rs.MoveFirst
Do While RS.EOF = False
On Error Resume Next
Rst.Addnew
for i1= 0 to rs.fields.count-1
'if IsNull(Rs.Fields(i1).value) = False Then
Rst.Fields(i1).value=Rs.Fields(i1).value
'Else
'Rst.Fields(i1).value=vbNull
'End IF
Next
Rst.Update
CNT = CNT + 1
IF CNT mod 1000 = 0 then WScript.ECHO "Line306:" & CNT
Rs.MoveNext
If Err.Number <> 0 and Err.Number <> 3163 then WScript.Echo Err.Number & Err.Description & " " & V.Name & ":" & "CNT:=" & CNT: Err.Clear

Loop
Rs.Close
Rst.Close
End If
End IF 'If Rs.RecordCount > 0 Then
End If ' If BlCheck(V.Name) = True Then
End if 'If Err.nNumber = 0 Then
Next
i=0
'////////''''Query Add ''''//////
set Qs = DBA.QueryDefs
For each Q in Qs
With Q
If (.Type And &HF) = 0 Then
Redim Preserve Qr(i): Qr(i)=V.Name :Wscript.Echo "Line194: " & V.name & "is in at Qr(" & i & ")" :i=i+1
End If
End With
Next

AccessApp.CurrentDb.QueryDefs.refresh
For i= LBound(Br) to UBound(Br)
On Error Resume Next
Wscript.Echo "Accessapp.CurrentDb.QueryDefs(" & Br(i) & ").SQL" & Accessapp.Application.CurrentDb.QueryDefs(Br(i)).SQL
Wscript.Sleep 5000
db.CreateQuerydef Br(i), AccessApp.CurrentDb.QueryDefs(Br(i)).SQL
On error Goto 0
If Err.number <> 0 Then WScript.Echo Err.Number,Err.Description:Err.Clear: Else Wscript.Echo "Line 336:Query:Number" & i & " Name:" & Br(i) & "Success"
Next

'////!!!Finish!!!///!!!Finish!!!///
DBA.Close
db.Close
accessApp.Quit

Set Db=nothing
Call JetCompact
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''
Function BlCheck(QName)
IF Left(Qname,4)="MSys" Then BLCheck = False :Exit Function
BLCheck = True
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''
Sub JetCompact()
'%SystemRoot%\SysWow64\CScript.EXE "%USERPROFILE%\Documents\Myscript\JetCompact.vbs"
Dim JRO : Set JRO = CreateObject("JRO.JetEngine")
Dim strOldConnect : strOldConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & oldFile & ";"
Dim strNewConnect : strNewConnect ="Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & NewFile & ";Jet OLEDB:Engine Type =5;"
'Dim strNewConnect : strNewConnect ="Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & NewFile & ";"
With CreateObject("Scripting.FileSystemObject")
If .FileExists(oldFIle)=False then Wscript.Quit()
If .FileExists(NewFile)=True then Wscript.Quit()
End With
JRO.CompactDatabase strOldConnect, strNewConnec1t
Set JRO = Nothing
WScript.Echo "Success End"
End Sub

'https://social.msdn.microsoft.com/Forums/vstudio/en-US/7e1f5771-6c53-4779-9837-0105d54f4fe1/vbscript-and-daodbengibe120-fails?forum=accessdev

VBSCRIPT

F:\の
TESTTYPE97.mdbにTEST.accdbの
TEST2016テーブルをコピーする
スクリプトの場所はC:\hoge\testvbs.vbs

C\hoge\DbConnect9716.vbs

'%SystemRoot%\SysWow64\cscript.exe //Nologo "C:\hoge\testvbs.vbs"
'Setting
Const DN97 = "F:\TEST97.mdb" 'Access 97 MDB File
Const DN16 = "F:\Test.accdb" 'Access 2017 Later accdb File
ConstTN="2017" 'Table Name

'Field Type Enum
Const dbGUID= 15 'dbGUID
Const dbBoolean= 1 'dbBoolean
Const dbByte= 2 'dbByte
Const dbInteger= 3 'dbInteger
Const dbLong= 4 'dbLong
Const dbCurrency= 5 'dbCurrency
Const dbSingle= 6 'dbsingle
Const dbDouble= 7 'dbDouble
Const dbDate= 8 'dbDate
Const dbBinary= 9 'dbBinary
Const dbText= 10 'dbText
Const dbMemo= 12 'dbMemo
Const dbVarBinary= 17 'dbVarBinaryMicrosoft Access 2013 では、ODBCDirect ワークスペースはサポートされていません。Microsoft Access データベース エンジンを使用しないで外部データ ソースにアクセスする場合は、ADO を使用してください。
Const dbChar= 18 'dbChar
Const dbNumeric= 19 'dbNumeric
Const dbDecimal= 20 'dbDecimal ODBCDirect ワークスペースは、Microsoft Access 2013 ではサポートされていません。Microsoft Office Access データベース エンジンを使用しないで外部データ ソースにアクセスする場合は、ADO を使用してください。
Const dbFloat= 21 'dbFloat Microsoft Access 2013 では、ODBCDirect ワークスペースはサポートされていません。Microsoft Access データベース エンジンを使用しないで外部データ ソースにアクセスする場合は、ADO を使用してください。
Const dbTime= 22 'dbTime
Const dbTimeStamp= 23 'dbTimeStamp Microsoft Access 2013 では、ODBCDirect ワークスペースはサポートされていません。

Main

Sub Main()
Const Pro12 = "Provider=Microsoft.Ace.Oledb.12.0;Data Source="
Const Pro16 = "Provider=Microsoft.Ace.Oledb.16.0;Data Source="
Const Jet40 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="

''''For ADOX
Const JETCreateLink = "JET OLEDB:Create Link"
Const JETLinkSource = "JET OLEDB:Link Source"
Const JETRmtTblName = "JET OLEDB:Remote Table Name"



Dim accessApp : set accessApp = createObject("Access.Application") 'For accdb
Dim db: Set db = CreateObject("DAO.DBEngine.36").OpenDatabase(DN97) 'For Access97 mdb

Dim DBA ,Tb9, i, i1
Dim V,Buf
Dim RS
Dim RST
Dim ADC : Set ADC = CreateObject("ADOX.Catalog")':ADC.Create(Pro12 & "'" & DN16 & "'")
Dim ADX : Set ADX = CreateObject("ADOX.Table")
Dim bl:bl=False
Dim Ar()
Dim CNT
Dim Q,Qtg
WScript.Sleep 1000
accessApp.OpenCurrentDataBase(DN16)

Set DBA = accessApp.CurrentDB
accessApp.visible = true
accessApp.UserControl = true

'Black magic for recognizing all database tables
For Each V in DBA.TableDefs
buf = BUF & ":" & V.name
Next

i=0
'Try to exclude system table but not well now.
For Each V in DBA.TableDefs
'If BLCheck(V.Name) = True Then
Redim Preserve ar(i)
Ar(i)=V.Name
i=i+1
Redim Preserve ar(i)
End if
Next

For i= Lbound(ar) to Ubound(ar)
Wscript.Echo "Array Value: " & i & " : " & Ar(i)
Next
Wscript.Echo DBA.Name
Wscript.Echo buf:buf = ""
WScript.Sleep 1000
For each V in DBA.TableDefs
buf = BUF & ":" & V.name
Next
Wscript.Echo buf


'For i = 0 to Ubound(ar)
'Set V = DBA.TableDefs(Ar(i))
Set V = DBA.TableDefs(TN)
Wscript.Echo "Line:92" & V.name
'If BlCheck(V.Name) = True Then
Set TDF = DBA.TableDefs(V.Name)
Set RS = DBA.OpenRecordSet(V.Name,1,4):Wscript.Echo "Line95 :" & V.name
on error resume next
DB.Execute "DROP TABLE " & V.Name & " "
db.Execute "CREATE TABLE " & V.Name & " "
Set tb9= db.TableDefs(V.Name):Wscript.Echo "Line99 :" & V.name
With tb9
for i1= 0 to TDF.Fields.Count-1
.Fields.Append .CreateField(TDF.Fields(i1).Name ,Tdf.Fields(i1).Type):Wscript.Echo "Line73 :" & V.name
.Fields(i1).AllowZeroLength = True:Wscript.Echo "Line102 :" & V.name & ":" & .Fields(i1).name' TDF.Fields(i1).AllowZeroLength '情報が未確認のために空白になっているフィールドと、当てはまらないので空白になっているフィールドを区別できるようにするには、"Required/値要求" プロパティに [No/いいえ] を設定し、"AllowZeroLength/空文字列の許可" プロパティに [Yes/はい] を設定します。
.Fields(i1).Required = False'"TDF.Fields(i1).Required:Wscript.Echo "Line104 :" & V.name & ":" & .Fields(i1).name
.Fields(i1).CollatingOrder = TDF.Fields(i1).CollatingOrder
.Fields(i1).DataUpdatable = TDF.Fields(i1).DataUpdatable
.Fields(i1).OrdinalPosition = TDF.Fields(i1).OrdinalPosition:Wscirpt.Echo 107
.Fields(i1).Size = TDF.Fields(i1).Size
.Fields(i1).Attributes = TDF.Fields(i1).Attributes:Wscirpt.Echo TDF.Fields(i1).Attributes
Next
End With

On Error Goto 0
If err.number<>0 then Wscript.Echo Err.Number & ":" & Err.Description :Err.Clear
On error resume Next
db.Tabledefs.refresh:Wscript.Echo "Line116 :" & V.name & "Refresh"
On Error Goto 0
If err.number<>0 then Wscript.Echo Err.Number & ":" & Err.Description :Err.Clear
WScript.Sleep 1000
On Error Resume Next
Set RST = DB.OpenRecordSet(V.Name,1):Wscript.Echo "Line121 :" & V.name & ":" & "RecordSet"
On Error Goto 0
IF Err.Number = 0 Then
CNT=0:Wscript.Echo "Line94 :" & V.name & ":" & "Adding..." 'Rs.MoveFirst
  Do While RS.EOF = False
   On Error Resume Next
   Rst.Addnew
     'Double Check & Copy value
     for i1= 0 to rs.fields.count-1
     if IsNull(Rs.Fields(i1).value) = False Then
     Rst.Fields(i1).value=Rs.Fields(i1).value
     Else
     Rst.Fields(i1).value=vbNull
     End IF
     Next

     Rst.Update

     CNT = CNT + 1
     IF CNT mod 1000 = 0 then WScript.ECHO "Line137:" & CNT
     Rs.MoveNext
     If Err.Number<> 0 then Wscript.Echo Err.Number & Err.Description & "CNT:=" & CNT: Err.Clear
Loop

Rs.Close
Rst.Close
End If 'IF Err.Number = 0 Then
'End 'For If C:\hoge\testvbs.vbs
'Next

DBA.Close
db.Close
accessApp.Quit

Set Db=nothing
Set Dao12 = Nothing
Set Dao36 = Nothing
Set ADX = Nothin
Set ADC=Nothing
Call JetCompact
End Sub

Sub JetCompact()
Dim oldFile : oldFile = DN97
Const NewFile = "E:\test20_2005.mdb"
Dim JIRO : Set JIRO = CreateObject("JRO.JetEngine")
Dim strOldConnect : strOldConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & oldFile & ";"
Dim strNewConnect : strNewConnect ="Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & NewFile & ";Jet OLEDB:Engine Type =5;"
'Dim strNewConnect : strNewConnect ="Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & NewFile & ";"
With CreateObject("Scripting.FileSystemObject")
If .FileExists(oldFIle)=False then Wscript.Quit
If .FileExists(NewFile)=True then Wscript.Quit
End With
JIRO.CompactDatabase strOldConnect, strNewConnect
Set Jiro = Nothing
End Sub
'https://social.msdn.microsoft.com/Forums/vstudio/en-US/7e1f5771-6c53-4779-9837-0105d54f4fe1/vbscript-and-daodbengibe120-fails?forum=accessdev
Function VbLike(sTest, sPattern)
Dim objRE,sAdd1,sAdd_1,xAdd,UAdd,AAdd
Set objRE = CreateObject("VBScript.RegExp")
'escape character add
'spattern = Replace(sPattern, "\", "\\", 1, -1)
'spattern = Replace(sPattern, "*", "\*", 1, -1) 'wildcard escape
'spattern = Replace(sPattern, "?", "\?", 1, -1) 'wildcard escape
'sPattern = Replace(sPattern, ".", "\.", 1, -1) 'wildcard escape
spattern = Replace(spattern, "+", "\+", 1, -1)
spattern = Replace(spattern, "|", "\|", 1, -1)
spattern = Replace(spattern, ")", "\)", 1, -1)
spattern = Replace(spattern, "(", "\(", 1, -1)
spattern = Replace(spattern, "[", "\[", 1, -1)
spattern = Replace(spattern, "]", "\]", 1, -1)
spattern = Replace(spattern, Chr(13), "\r", 1, -1)
spattern = Replace(spattern, Chr(10), "\n", 1, -1)
spattern = Replace(spattern, vbTab, "\t", 1, -1)
spattern = Replace(spattern, " ", "\s", 1, -1)
spattern = Replace(spattern, "　", "\s", 1, -1)
'Add character
sAdd1="\w" '[a-zA-Z_0-9]
sAdd_1="\W" '[^a-zA-Z_0-9]
xAdd = "\50" '( 50 is 8 digit ASCII
uAdd = "\u00A3" '( 00A3 is 16 digit UNICODE
AAdd="[A-z]"
objRE.Pattern = "^.*" & spattern & ".*$"
If objRE.test(sTest) = True Then
VbLike = True
Else
VbLike = False
End If
Set objRE = Nothing
End Function
Function blCheck(TBLName)
Dim Bl

Bl=True
If Vblike(Left(TBLName,4),"Msys") = "Msys" Then blCheck = False :Exit Function
If Left(TBLName,4) = "~TMP" Then blCheck = False :Exit Function
If TBLName = "MsysAccessStorage" Then blCheck = False :Exit Function
If TBLName = "MsysAccessXML" Then blCheck = False :Exit Function
If TBLName = "MsysACEsRefresh" Then blCheck = False :Exit Function
If TBLName = "MsysResources" Then blCheck = False :Exit Function
If TBLName = "MsysResources" Then blCheck = False :Exit Function
If TBLName = "MsysACEs" Then blCheck = False :Exit Function
blCheck = True :Exit Function
END Function

Point

Vbscriptで動かす。
現時点ではテーブル一つずつコピーしか動かせない。
まとめてやりたいが、システムテーブルが混入し、これをコピーすると変換後のテーブルが開けなくなる。
どうも97側のシステムテーブルを書き換えてしまうなどの影響があるようだ。
なのでシステムテーブルを排除する必要がある。
Function BLCchek, VBLIKEをつかってみたがうまくいかないようだ。

Accessが64ビットでも32BitVBSで起動できるため、AccdbはAccessで開くことになる。
ADOXも実はうごく。これでプロパティを抜き出せればと思ったが、接続文字列がよくわからないので動くことだけ示している。