' Usage:
' WScript compose.vbs <file> <path>
' Converts all modules, classes, forms and macros in a directory created by "decompose.vbs"
' and composes then into an Access Project file (.adp). This overwrites any existing Modules with the
' same names without warning!!!
' Requires Microsoft Access.
Option Explicit
const acForm = 2
const acModule = 5
const acMacro = 4
const acReport = 3
Const acCmdCompileAndSaveAllModules = &H7E
' BEGIN CODE
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
dim sADPFilename
If (WScript.Arguments.Count = 0) then
MsgBox "Please enter the file name!", vbExclamation, "Error"
Wscript.Quit()
End if
sADPFilename = fso.GetAbsolutePathName(WScript.Arguments(0))
Dim sPath
If (WScript.Arguments.Count = 1) then
sPath = ""
else
sPath = WScript.Arguments(1)
End If
importModulesTxt sADPFilename, sPath
If (Err <> 0) and (Err.Description <> NULL) Then
MsgBox Err.Description, vbExclamation, "Error"
Err.Clear
End If
Function importModulesTxt(sADPFilename, sImportpath)
Dim myComponent
Dim sModuleType
Dim sTempname
Dim sOutstring
' Build file and pathnames
dim myType, myName, myPath, sStubADPFilename
myType = fso.GetExtensionName(sADPFilename)
myName = fso.GetBaseName(sADPFilename)
myPath = fso.GetParentFolderName(sADPFilename)
' if no path was given as argument, use a relative directory
If (sImportpath = "") then
sImportpath = myPath & "\Source\"
End If
sStubADPFilename = sImportpath & myName & "_stub." & myType
' check for existing file and ask to overwrite with the stub
if (fso.FileExists(sADPFilename)) Then
WScript.StdOut.Write sADPFilename & " exists. Overwrite? (y/n) "
dim sInput
sInput = WScript.StdIn.Read(1)
if (sInput <> "y") Then
WScript.Quit
end if
fso.CopyFile sADPFilename, sADPFilename & ".bak"
end if
fso.CopyFile sStubADPFilename, sADPFilename
' launch MSAccess
WScript.Echo "starting Access..."
Dim oApplication
Set oApplication = CreateObject("Access.Application")
WScript.Echo "opening " & sADPFilename & " ..."
If (Right(sStubADPFilename,4) = ".adp") Then
oApplication.OpenAccessProject sADPFilename
Else
oApplication.OpenCurrentDatabase sADPFilename
End If
oApplication.Visible = false
Dim folder
Set folder = fso.GetFolder(sImportpath)
' load each file from the import path into the stub
Dim myFile, objectname, objecttype
for each myFile in folder.Files
objecttype = fso.GetExtensionName(myFile.Name)
objectname = fso.GetBaseName(myFile.Name)
WScript.Echo " " & objectname & " (" & objecttype & ")"
if (objecttype = "form") then
oApplication.LoadFromText acForm, objectname, myFile.Path
elseif (objecttype = "bas") then
oApplication.LoadFromText acModule, objectname, myFile.Path
elseif (objecttype = "mac") then
oApplication.LoadFromText acMacro, objectname, myFile.Path
elseif (objecttype = "report") then
oApplication.LoadFromText acReport, objectname, myFile.Path
end if
next
oApplication.RunCommand acCmdCompileAndSaveAllModules
oApplication.Quit
End Function
Public Function getErr()
Dim strError
strError = vbCrLf & "----------------------------------------------------------------------------------------------------------------------------------------" & vbCrLf & _
"From " & Err.source & ":" & vbCrLf & _
" Description: " & Err.Description & vbCrLf & _
" Code: " & Err.Number & vbCrLf
getErr = strError
End Function
' Writes database componenets to a series of text files
' @author Arvin Meyer
' @date June 02, 1999
Function DocDatabase(oApp)
Dim dbs
Dim cnt
Dim doc
Dim i
Dim prefix
Dim dctDelete
Dim docName
Const acQuery = 1
Set dctDelete = CreateObject("Scripting.Dictionary")
Set dbs = oApp.CurrentDb() ' use CurrentDb() to refresh Collections
Set cnt = dbs.Containers("Forms")
prefix = oApp.CurrentProject.Path & "\"
For Each doc In cnt.Documents
oApp.SaveAsText acForm, doc.Name, prefix & doc.Name & ".frm"
dctDelete.Add "frm_" & doc.Name, acForm
Next
Set cnt = dbs.Containers("Reports")
For Each doc In cnt.Documents
oApp.SaveAsText acReport, doc.Name, prefix & doc.Name & ".rpt"
dctDelete.Add "rpt_" & doc.Name, acReport
Next
Set cnt = dbs.Containers("Scripts")
For Each doc In cnt.Documents
oApp.SaveAsText acMacro, doc.Name, prefix & doc.Name & ".vbs"
dctDelete.Add "vbs_" & doc.Name, acMacro
Next
Set cnt = dbs.Containers("Modules")
For Each doc In cnt.Documents
oApp.SaveAsText acModule, doc.Name, prefix & doc.Name & ".bas"
dctDelete.Add "bas_" & doc.Name, acModule
Next
For i = 0 To dbs.QueryDefs.Count - 1
oApp.SaveAsText acQuery, dbs.QueryDefs(i).Name, prefix & dbs.QueryDefs(i).Name & ".txt"
dctDelete.Add "qry_" & dbs.QueryDefs(i).Name, acQuery
Next
WScript.Echo "deleting " & dctDelete.Count & " objects."
For Each docName In dctDelete
WScript.Echo " " & Mid(docName, 5)
oApp.DoCmd.DeleteObject dctDelete(docName), Mid(docName, 5)
Next
Set doc = Nothing
Set cnt = Nothing
Set dbs = Nothing
Set dctDelete = Nothing
End Function
'(to extract for importing to source control)
cscript compose.vbs database.accdb
'(to rebuild from extracted files saved from an earlier date)
cscript decompose.vbs database.accdb C:\SControl\Source\
我试图通过在访问数据库中为 Query 添加一个导出选项来帮助他回答这个问题。(在 其他 SO 答案的充分帮助下)
Dim def
Set stream = fso.CreateTextFile(sExportpath & "\" & myName & ".queries.txt")
For Each def In oApplication.CurrentDb.QueryDefs
WScript.Echo " Exporting Queries to Text..."
stream.WriteLine("Name: " & def.Name)
stream.WriteLine(def.SQL)
stream.writeline "--------------------------"
stream.writeline " "
Next
stream.Close
' Usage:
' CScript decompose.vbs <input file> <path>
' Converts all modules, classes, forms and macros from an Access Project file (.adp) <input file> to
' text and saves the results in separate files to <path>. Requires Microsoft Access.
'
Option Explicit
const acForm = 2
const acModule = 5
const acMacro = 4
const acReport = 3
const acQuery = 1
' BEGIN CODE
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
dim sADPFilename
If (WScript.Arguments.Count = 0) then
MsgBox "Bitte den Dateinamen angeben!", vbExclamation, "Error"
Wscript.Quit()
End if
sADPFilename = fso.GetAbsolutePathName(WScript.Arguments(0))
Dim sExportpath
If (WScript.Arguments.Count = 1) then
sExportpath = ""
else
sExportpath = WScript.Arguments(1)
End If
exportModulesTxt sADPFilename, sExportpath
If (Err <> 0) and (Err.Description <> NULL) Then
MsgBox Err.Description, vbExclamation, "Error"
Err.Clear
End If
Function exportModulesTxt(sADPFilename, sExportpath)
Dim myComponent
Dim sModuleType
Dim sTempname
Dim sOutstring
dim myType, myName, myPath, sStubADPFilename
myType = fso.GetExtensionName(sADPFilename)
myName = fso.GetBaseName(sADPFilename)
myPath = fso.GetParentFolderName(sADPFilename)
If (sExportpath = "") then
sExportpath = myPath & "\Source\"
End If
sStubADPFilename = sExportpath & myName & "_stub." & myType
WScript.Echo "copy stub to " & sStubADPFilename & "..."
On Error Resume Next
fso.CreateFolder(sExportpath)
On Error Goto 0
fso.CopyFile sADPFilename, sStubADPFilename
WScript.Echo "starting Access..."
Dim oApplication
Set oApplication = CreateObject("Access.Application")
WScript.Echo "opening " & sStubADPFilename & " ..."
If (Right(sStubADPFilename,4) = ".adp") Then
oApplication.OpenAccessProject sStubADPFilename
Else
oApplication.OpenCurrentDatabase sStubADPFilename
End If
oApplication.Visible = false
dim dctDelete
Set dctDelete = CreateObject("Scripting.Dictionary")
WScript.Echo "exporting..."
Dim myObj
For Each myObj In oApplication.CurrentProject.AllForms
WScript.Echo " " & myObj.fullname
oApplication.SaveAsText acForm, myObj.fullname, sExportpath & "\" & myObj.fullname & ".form"
oApplication.DoCmd.Close acForm, myObj.fullname
dctDelete.Add "FO" & myObj.fullname, acForm
Next
For Each myObj In oApplication.CurrentProject.AllModules
WScript.Echo " " & myObj.fullname
oApplication.SaveAsText acModule, myObj.fullname, sExportpath & "\" & myObj.fullname & ".bas"
dctDelete.Add "MO" & myObj.fullname, acModule
Next
For Each myObj In oApplication.CurrentProject.AllMacros
WScript.Echo " " & myObj.fullname
oApplication.SaveAsText acMacro, myObj.fullname, sExportpath & "\" & myObj.fullname & ".mac"
dctDelete.Add "MA" & myObj.fullname, acMacro
Next
For Each myObj In oApplication.CurrentProject.AllReports
WScript.Echo " " & myObj.fullname
oApplication.SaveAsText acReport, myObj.fullname, sExportpath & "\" & myObj.fullname & ".report"
dctDelete.Add "RE" & myObj.fullname, acReport
Next
For Each myObj In oApplication.CurrentDb.QueryDefs
if not left(myObj.name,3) = "~sq" then 'exclude queries defined by the forms. Already included in the form itself
WScript.Echo " " & myObj.name
oApplication.SaveAsText acQuery, myObj.name, sExportpath & "\" & myObj.name & ".query"
oApplication.DoCmd.Close acQuery, myObj.name
dctDelete.Add "FO" & myObj.name, acQuery
end if
Next
WScript.Echo "deleting..."
dim sObjectname
For Each sObjectname In dctDelete
WScript.Echo " " & Mid(sObjectname, 3)
oApplication.DoCmd.DeleteObject dctDelete(sObjectname), Mid(sObjectname, 3)
Next
oApplication.CloseCurrentDatabase
oApplication.CompactRepair sStubADPFilename, sStubADPFilename & "_"
oApplication.Quit
fso.CopyFile sStubADPFilename & "_", sStubADPFilename
fso.DeleteFile sStubADPFilename & "_"
End Function
Public Function getErr()
Dim strError
strError = vbCrLf & "----------------------------------------------------------------------------------------------------------------------------------------" & vbCrLf & _
"From " & Err.source & ":" & vbCrLf & _
" Description: " & Err.Description & vbCrLf & _
" Code: " & Err.Number & vbCrLf
getErr = strError
End Function
Vbs:
' Usage:
' WScript compose.vbs <file> <path>
' Converts all modules, classes, forms and macros in a directory created by "decompose.vbs"
' and composes then into an Access Project file (.adp). This overwrites any existing Modules with the
' same names without warning!!!
' Requires Microsoft Access.
Option Explicit
const acForm = 2
const acModule = 5
const acMacro = 4
const acReport = 3
const acQuery = 1
Const acCmdCompileAndSaveAllModules = &H7E
' BEGIN CODE
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
dim sADPFilename
If (WScript.Arguments.Count = 0) then
MsgBox "Bitte den Dateinamen angeben!", vbExclamation, "Error"
Wscript.Quit()
End if
sADPFilename = fso.GetAbsolutePathName(WScript.Arguments(0))
Dim sPath
If (WScript.Arguments.Count = 1) then
sPath = ""
else
sPath = WScript.Arguments(1)
End If
importModulesTxt sADPFilename, sPath
If (Err <> 0) and (Err.Description <> NULL) Then
MsgBox Err.Description, vbExclamation, "Error"
Err.Clear
End If
Function importModulesTxt(sADPFilename, sImportpath)
Dim myComponent
Dim sModuleType
Dim sTempname
Dim sOutstring
' Build file and pathnames
dim myType, myName, myPath, sStubADPFilename
myType = fso.GetExtensionName(sADPFilename)
myName = fso.GetBaseName(sADPFilename)
myPath = fso.GetParentFolderName(sADPFilename)
' if no path was given as argument, use a relative directory
If (sImportpath = "") then
sImportpath = myPath & "\Source\"
End If
sStubADPFilename = sImportpath & myName & "_stub." & myType
' check for existing file and ask to overwrite with the stub
if (fso.FileExists(sADPFilename)) Then
WScript.StdOut.Write sADPFilename & " existiert bereits. Überschreiben? (j/n) "
dim sInput
sInput = WScript.StdIn.Read(1)
if (sInput <> "j") Then
WScript.Quit
end if
fso.CopyFile sADPFilename, sADPFilename & ".bak"
end if
fso.CopyFile sStubADPFilename, sADPFilename
' launch MSAccess
WScript.Echo "starting Access..."
Dim oApplication
Set oApplication = CreateObject("Access.Application")
WScript.Echo "opening " & sADPFilename & " ..."
If (Right(sStubADPFilename,4) = ".adp") Then
oApplication.OpenAccessProject sADPFilename
Else
oApplication.OpenCurrentDatabase sADPFilename
End If
oApplication.Visible = false
Dim folder
Set folder = fso.GetFolder(sImportpath)
' load each file from the import path into the stub
Dim myFile, objectname, objecttype
for each myFile in folder.Files
objecttype = fso.GetExtensionName(myFile.Name)
objectname = fso.GetBaseName(myFile.Name)
WScript.Echo " " & objectname & " (" & objecttype & ")"
if (objecttype = "form") then
oApplication.LoadFromText acForm, objectname, myFile.Path
elseif (objecttype = "bas") then
oApplication.LoadFromText acModule, objectname, myFile.Path
elseif (objecttype = "mac") then
oApplication.LoadFromText acMacro, objectname, myFile.Path
elseif (objecttype = "report") then
oApplication.LoadFromText acReport, objectname, myFile.Path
elseif (objecttype = "query") then
oApplication.LoadFromText acQuery, objectname, myFile.Path
end if
next
oApplication.RunCommand acCmdCompileAndSaveAllModules
oApplication.Quit
End Function
Public Function getErr()
Dim strError
strError = vbCrLf & "----------------------------------------------------------------------------------------------------------------------------------------" & vbCrLf & _
"From " & Err.source & ":" & vbCrLf & _
" Description: " & Err.Description & vbCrLf & _
" Code: " & Err.Number & vbCrLf
getErr = strError
End Function
我已经修改了 Oliver 的两个脚本,使它们除了导出/导入模块、类、表单和宏之外,还可以导出/导入 关系、表和查询。一切被保存到纯文本文件中,因此有 没有数据库文件被创建来与版本控制中的文本文件一起存储。
导出到文本文件(compose.vbs)
' Usage:
' cscript decompose.vbs <input file> <path>
' Converts all modules, classes, forms and macros from an Access Project file (.adp) <input file> to
' text and saves the results in separate files to <path>. Requires Microsoft Access.
Option Explicit
Const acForm = 2
Const acModule = 5
Const acMacro = 4
Const acReport = 3
Const acQuery = 1
Const acExportTable = 0
' BEGIN CODE
Dim fso, relDoc, ACCDBFilename, sExportpath
Set fso = CreateObject("Scripting.FileSystemObject")
Set relDoc = CreateObject("Microsoft.XMLDOM")
If (Wscript.Arguments.Count = 0) Then
MsgBox "Please provide the .accdb database file", vbExclamation, "Error"
Wscript.Quit()
End If
ACCDBFilename = fso.GetAbsolutePathName(Wscript.Arguments(0))
If (Wscript.Arguments.Count = 1) Then
sExportpath = ""
Else
sExportpath = Wscript.Arguments(1)
End If
exportModulesTxt ACCDBFilename, sExportpath
If (Err <> 0) And (Err.Description <> Null) Then
MsgBox Err.Description, vbExclamation, "Error"
Err.Clear
End If
Function exportModulesTxt(ACCDBFilename, sExportpath)
Dim myComponent, sModuleType, sTempname, sOutstring
Dim myType, myName, myPath, hasRelations
myType = fso.GetExtensionName(ACCDBFilename)
myName = fso.GetBaseName(ACCDBFilename)
myPath = fso.GetParentFolderName(ACCDBFilename)
'if no path was given as argument, use a relative directory
If (sExportpath = "") Then
sExportpath = myPath & "\Source"
End If
'On Error Resume Next
fso.DeleteFolder (sExportpath)
fso.CreateFolder (sExportpath)
On Error GoTo 0
Wscript.Echo "starting Access..."
Dim oApplication
Set oApplication = CreateObject("Access.Application")
Wscript.Echo "Opening " & ACCDBFilename & " ..."
If (Right(ACCDBFilename, 4) = ".adp") Then
oApplication.OpenAccessProject ACCDBFilename
Else
oApplication.OpenCurrentDatabase ACCDBFilename
End If
oApplication.Visible = False
Wscript.Echo "exporting..."
Dim myObj
For Each myObj In oApplication.CurrentProject.AllForms
Wscript.Echo "Exporting FORM " & myObj.FullName
oApplication.SaveAsText acForm, myObj.FullName, sExportpath & "\" & myObj.FullName & ".form.txt"
oApplication.DoCmd.Close acForm, myObj.FullName
Next
For Each myObj In oApplication.CurrentProject.AllModules
Wscript.Echo "Exporting MODULE " & myObj.FullName
oApplication.SaveAsText acModule, myObj.FullName, sExportpath & "\" & myObj.FullName & ".module.txt"
Next
For Each myObj In oApplication.CurrentProject.AllMacros
Wscript.Echo "Exporting MACRO " & myObj.FullName
oApplication.SaveAsText acMacro, myObj.FullName, sExportpath & "\" & myObj.FullName & ".macro.txt"
Next
For Each myObj In oApplication.CurrentProject.AllReports
Wscript.Echo "Exporting REPORT " & myObj.FullName
oApplication.SaveAsText acReport, myObj.FullName, sExportpath & "\" & myObj.FullName & ".report.txt"
Next
For Each myObj In oApplication.CurrentDb.QueryDefs
Wscript.Echo "Exporting QUERY " & myObj.Name
oApplication.SaveAsText acQuery, myObj.Name, sExportpath & "\" & myObj.Name & ".query.txt"
Next
For Each myObj In oApplication.CurrentDb.TableDefs
If Not Left(myObj.Name, 4) = "MSys" Then
Wscript.Echo "Exporting TABLE " & myObj.Name
oApplication.ExportXml acExportTable, myObj.Name, , sExportpath & "\" & myObj.Name & ".table.txt"
'put the file path as a second parameter if you want to export the table data as well, instead of ommiting it and passing it into a third parameter for structure only
End If
Next
hasRelations = False
relDoc.appendChild relDoc.createElement("Relations")
For Each myObj In oApplication.CurrentDb.Relations 'loop though all the relations
If Not Left(myObj.Name, 4) = "MSys" Then
Dim relName, relAttrib, relTable, relFoTable, fld
hasRelations = True
relDoc.ChildNodes(0).appendChild relDoc.createElement("Relation")
Set relName = relDoc.createElement("Name")
relName.Text = myObj.Name
relDoc.ChildNodes(0).LastChild.appendChild relName
Set relAttrib = relDoc.createElement("Attributes")
relAttrib.Text = myObj.Attributes
relDoc.ChildNodes(0).LastChild.appendChild relAttrib
Set relTable = relDoc.createElement("Table")
relTable.Text = myObj.Table
relDoc.ChildNodes(0).LastChild.appendChild relTable
Set relFoTable = relDoc.createElement("ForeignTable")
relFoTable.Text = myObj.ForeignTable
relDoc.ChildNodes(0).LastChild.appendChild relFoTable
Wscript.Echo "Exporting relation " & myObj.Name & " between tables " & myObj.Table & " -> " & myObj.ForeignTable
For Each fld In myObj.Fields 'in case the relationship works with more fields
Dim lf, ff
relDoc.ChildNodes(0).LastChild.appendChild relDoc.createElement("Field")
Set lf = relDoc.createElement("Name")
lf.Text = fld.Name
relDoc.ChildNodes(0).LastChild.LastChild.appendChild lf
Set ff = relDoc.createElement("ForeignName")
ff.Text = fld.ForeignName
relDoc.ChildNodes(0).LastChild.LastChild.appendChild ff
Wscript.Echo " Involving fields " & fld.Name & " -> " & fld.ForeignName
Next
End If
Next
If hasRelations Then
relDoc.InsertBefore relDoc.createProcessingInstruction("xml", "version='1.0'"), relDoc.ChildNodes(0)
relDoc.Save sExportpath & "\relations.rel.txt"
Wscript.Echo "Relations successfuly saved in file relations.rel.txt"
End If
oApplication.CloseCurrentDatabase
oApplication.Quit
End Function
可以通过调用 cscript decompose.vbs <path to file to decompose> <folder to store text files>来执行此脚本。如果省略第二个参数,它将在数据库所在的位置创建“ Source”文件夹。请注意,如果目标文件夹已经存在,它将被清除。
' Usage:
' cscript compose.vbs <file> <path>
' Reads all modules, classes, forms, macros, queries, tables and their relationships in a directory created by "decompose.vbs"
' and composes then into an Access Database file (.accdb).
' Requires Microsoft Access.
Option Explicit
Const acForm = 2
Const acModule = 5
Const acMacro = 4
Const acReport = 3
Const acQuery = 1
Const acStructureOnly = 0 'change 0 to 1 if you want import StructureAndData instead of StructureOnly
Const acCmdCompileAndSaveAllModules = &H7E
Dim fso, relDoc, ACCDBFilename, sPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set relDoc = CreateObject("Microsoft.XMLDOM")
If (Wscript.Arguments.Count = 0) Then
MsgBox "Please provide the .accdb database file", vbExclamation, "Error"
Wscript.Quit()
End If
ACCDBFilename = fso.GetAbsolutePathName(Wscript.Arguments(0))
If (Wscript.Arguments.Count = 1) Then
sPath = ""
Else
sPath = Wscript.Arguments(1)
End If
importModulesTxt ACCDBFilename, sPath
If (Err <> 0) And (Err.Description <> Null) Then
MsgBox Err.Description, vbExclamation, "Error"
Err.Clear
End If
Function importModulesTxt(ACCDBFilename, sImportpath)
Dim myComponent, sModuleType, sTempname, sOutstring
' Build file and pathnames
Dim myType, myName, myPath
myType = fso.GetExtensionName(ACCDBFilename)
myName = fso.GetBaseName(ACCDBFilename)
myPath = fso.GetParentFolderName(ACCDBFilename)
' if no path was given as argument, use a relative directory
If (sImportpath = "") Then
sImportpath = myPath & "\Source\"
End If
' check for existing file and ask to overwrite with the stub
If fso.FileExists(ACCDBFilename) Then
Wscript.StdOut.Write ACCDBFilename & " already exists. Overwrite? (y/n) "
Dim sInput
sInput = Wscript.StdIn.Read(1)
If (sInput <> "y") Then
Wscript.Quit
Else
If fso.FileExists(ACCDBFilename & ".bak") Then
fso.DeleteFile (ACCDBFilename & ".bak")
End If
fso.MoveFile ACCDBFilename, ACCDBFilename & ".bak"
End If
End If
Wscript.Echo "starting Access..."
Dim oApplication
Set oApplication = CreateObject("Access.Application")
Wscript.Echo "Opening " & ACCDBFilename
If (Right(ACCDBFilename, 4) = ".adp") Then
oApplication.CreateAccessProject ACCDBFilename
Else
oApplication.NewCurrentDatabase ACCDBFilename
End If
oApplication.Visible = False
Dim folder
Set folder = fso.GetFolder(sImportpath)
'load each file from the import path into the stub
Dim myFile, objectname, objecttype
For Each myFile In folder.Files
objectname = fso.GetBaseName(myFile.Name) 'get rid of .txt extension
objecttype = fso.GetExtensionName(objectname)
objectname = fso.GetBaseName(objectname)
Select Case objecttype
Case "form"
Wscript.Echo "Importing FORM from file " & myFile.Name
oApplication.LoadFromText acForm, objectname, myFile.Path
Case "module"
Wscript.Echo "Importing MODULE from file " & myFile.Name
oApplication.LoadFromText acModule, objectname, myFile.Path
Case "macro"
Wscript.Echo "Importing MACRO from file " & myFile.Name
oApplication.LoadFromText acMacro, objectname, myFile.Path
Case "report"
Wscript.Echo "Importing REPORT from file " & myFile.Name
oApplication.LoadFromText acReport, objectname, myFile.Path
Case "query"
Wscript.Echo "Importing QUERY from file " & myFile.Name
oApplication.LoadFromText acQuery, objectname, myFile.Path
Case "table"
Wscript.Echo "Importing TABLE from file " & myFile.Name
oApplication.ImportXml myFile.Path, acStructureOnly
Case "rel"
Wscript.Echo "Found RELATIONSHIPS file " & myFile.Name & " ... opening, it will be processed after everything else has been imported"
relDoc.Load (myFile.Path)
End Select
Next
If relDoc.readyState Then
Wscript.Echo "Preparing to build table dependencies..."
Dim xmlRel, xmlField, accessRel, relTable, relName, relFTable, relAttr, i
For Each xmlRel In relDoc.SelectNodes("/Relations/Relation") 'loop through every Relation node inside .xml file
relName = xmlRel.SelectSingleNode("Name").Text
relTable = xmlRel.SelectSingleNode("Table").Text
relFTable = xmlRel.SelectSingleNode("ForeignTable").Text
relAttr = xmlRel.SelectSingleNode("Attributes").Text
'remove any possible conflicting relations or indexes
On Error Resume Next
oApplication.CurrentDb.Relations.Delete (relName)
oApplication.CurrentDb.TableDefs(relTable).Indexes.Delete (relName)
oApplication.CurrentDb.TableDefs(relFTable).Indexes.Delete (relName)
On Error GoTo 0
Wscript.Echo "Creating relation " & relName & " between tables " & relTable & " -> " & relFTable
Set accessRel = oApplication.CurrentDb.CreateRelation(relName, relTable, relFTable, relAttr) 'create the relationship object
For Each xmlField In xmlRel.SelectNodes("Field") 'in case the relationship works with more fields
accessRel.Fields.Append accessRel.CreateField(xmlField.SelectSingleNode("Name").Text)
accessRel.Fields(xmlField.SelectSingleNode("Name").Text).ForeignName = xmlField.SelectSingleNode("ForeignName").Text
Wscript.Echo " Involving fields " & xmlField.SelectSingleNode("Name").Text & " -> " & xmlField.SelectSingleNode("ForeignName").Text
Next
oApplication.CurrentDb.Relations.Append accessRel 'append the newly created relationship to the database
Wscript.Echo " Relationship added"
Next
End If
oApplication.RunCommand acCmdCompileAndSaveAllModules
oApplication.Quit
End Function
可以通过调用 cscript compose.vbs <path to file which should be created> <folder with text files>来执行此脚本。如果省略了第二个参数,它将查看应该创建数据库的“ Source”文件夹。
' Converts all modules, classes, forms and macros from an Access file (.mdb) <input file> to
' text and saves the results in separate files to <path>. Requires Microsoft Access.
Option Explicit
Const acQuery = 1
Const acForm = 2
Const acModule = 5
Const acMacro = 4
Const acReport = 3
Const acCmdCompactDatabase = 4
Const TemporaryFolder = 2
Dim strMDBFileName : strMDBFileName = SelectDatabaseFile
Dim strExportPath : strExportPath = SelectExportFolder
CreateExportFolders(strExportPath)
Dim objProgressWindow
Dim strOverallProgress
CreateProgressWindow objProgressWindow
Dim strTempMDBFileName
CopyToTempDatabase strMDBFileName, strTempMDBFileName, strOverallProgress
Dim objAccess
Dim objDatabase
OpenAccessDatabase objAccess, objDatabase, strTempMDBFileName, strOverallProgress
ExportQueries objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress
ExportForms objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress
ExportReports objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress
ExportMacros objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress
ExportModules objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress
objAccess.CloseCurrentDatabase
objAccess.Quit
DeleteTempDatabase strTempMDBFileName, strOverallProgress
objProgressWindow.Quit
MsgBox "Successfully exported database."
Private Function SelectDatabaseFile()
MsgBox "Please select the Access database to export."
Dim objFileOpen : Set objFileOpen = CreateObject("SAFRCFileDlg.FileOpen")
If objFileOpen.OpenFileOpenDlg Then
SelectDatabaseFile = objFileOpen.FileName
Else
WScript.Quit()
End If
End Function
Private Function SelectExportFolder()
Dim objShell : Set objShell = CreateObject("Shell.Application")
SelectExportFolder = objShell.BrowseForFolder(0, "Select folder to export the database to:", 0, "").self.path & "\"
End Function
Private Sub CreateExportFolders(strExportPath)
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
MsgBox "Existing folders from a previous Access export under " & strExportPath & " will be deleted!"
If objFileSystem.FolderExists(strExportPath & "Queries\") Then
objFileSystem.DeleteFolder strExportPath & "Queries", true
End If
objFileSystem.CreateFolder(strExportPath & "Queries\")
If objFileSystem.FolderExists(strExportPath & "Forms\") Then
objFileSystem.DeleteFolder strExportPath & "Forms", true
End If
objFileSystem.CreateFolder(strExportPath & "Forms\")
If objFileSystem.FolderExists(strExportPath & "Reports\") Then
objFileSystem.DeleteFolder strExportPath & "Reports", true
End If
objFileSystem.CreateFolder(strExportPath & "Reports\")
If objFileSystem.FolderExists(strExportPath & "Macros\") Then
objFileSystem.DeleteFolder strExportPath & "Macros", true
End If
objFileSystem.CreateFolder(strExportPath & "Macros\")
If objFileSystem.FolderExists(strExportPath & "Modules\") Then
objFileSystem.DeleteFolder strExportPath & "Modules", true
End If
objFileSystem.CreateFolder(strExportPath & "Modules\")
End Sub
Private Sub CreateProgressWindow(objProgressWindow)
Set objProgressWindow = CreateObject ("InternetExplorer.Application")
objProgressWindow.Navigate "about:blank"
objProgressWindow.ToolBar = 0
objProgressWindow.StatusBar = 0
objProgressWindow.Width = 320
objProgressWindow.Height = 240
objProgressWindow.Visible = 1
objProgressWindow.Document.Title = "Access export in progress"
End Sub
Private Sub CopyToTempDatabase(strMDBFileName, strTempMDBFileName, strOverallProgress)
strOverallProgress = strOverallProgress & "Copying to temporary database...<br/>"
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strTempMDBFileName = objFileSystem.GetSpecialFolder(TemporaryFolder) & "\" & objFileSystem.GetBaseName(strMDBFileName) & "_temp.mdb"
objFileSystem.CopyFile strMDBFileName, strTempMDBFileName
End Sub
Private Sub OpenAccessDatabase(objAccess, objDatabase, strTempMDBFileName, strOverallProgress)
strOverallProgress = strOverallProgress & "Compacting temporary database...<br/>"
Set objAccess = CreateObject("Access.Application")
objAccess.Visible = false
CompactAccessDatabase objAccess, strTempMDBFileName
strOverallProgress = strOverallProgress & "Opening temporary database...<br/>"
objAccess.OpenCurrentDatabase strTempMDBFileName
Set objDatabase = objAccess.CurrentDb
End Sub
' Sometimes the Compact Database command errors out, and it's not serious if the database isn't compacted first.
Private Sub CompactAccessDatabase(objAccess, strTempMDBFileName)
On Error Resume Next
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objAccess.DbEngine.CompactDatabase strTempMDBFileName, strTempMDBFileName & "_"
objFileSystem.CopyFile strTempMDBFileName & "_", strTempMDBFileName
objFileSystem.DeleteFile strTempMDBFileName & "_"
End Sub
Private Sub ExportQueries(objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Exporting Queries (Step 1 of 5)...<br/>"
Dim counter
For counter = 0 To objDatabase.QueryDefs.Count - 1
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter + 1 & " of " & objDatabase.QueryDefs.Count
objAccess.SaveAsText acQuery, objDatabase.QueryDefs(counter).Name, strExportPath & "Queries\" & Clean(objDatabase.QueryDefs(counter).Name) & ".sql"
Next
End Sub
Private Sub ExportForms(objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Exporting Forms (Step 2 of 5)...<br/>"
Dim counter : counter = 1
Dim objContainer : Set objContainer = objDatabase.Containers("Forms")
Dim objDocument
For Each objDocument In objContainer.Documents
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter & " of " & objContainer.Documents.Count
counter = counter + 1
objAccess.SaveAsText acForm, objDocument.Name, strExportPath & "Forms\" & Clean(objDocument.Name) & ".form"
objAccess.DoCmd.Close acForm, objDocument.Name
Next
End Sub
Private Sub ExportReports(objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Exporting Reports (Step 3 of 5)...<br/>"
Dim counter : counter = 1
Dim objContainer : Set objContainer = objDatabase.Containers("Reports")
Dim objDocument
For Each objDocument In objContainer.Documents
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter & " of " & objContainer.Documents.Count
counter = counter + 1
objAccess.SaveAsText acReport, objDocument.Name, strExportPath & "Reports\" & Clean(objDocument.Name) & ".report"
Next
End Sub
Private Sub ExportMacros(objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Exporting Macros (Step 4 of 5)...<br/>"
Dim counter : counter = 1
Dim objContainer : Set objContainer = objDatabase.Containers("Scripts")
Dim objDocument
For Each objDocument In objContainer.Documents
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter & " of " & objContainer.Documents.Count
counter = counter + 1
objAccess.SaveAsText acMacro, objDocument.Name, strExportPath & "Macros\" & Clean(objDocument.Name) & ".macro"
Next
End Sub
Private Sub ExportModules(objAccess, objDatabase, objProgressWindow, strExportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Exporting Modules (Step 5 of 5)...<br/>"
Dim counter : counter = 1
Dim objContainer : Set objContainer = objDatabase.Containers("Modules")
Dim objDocument
For Each objDocument In objContainer.Documents
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter & " of " & objContainer.Documents.Count
counter = counter + 1
objAccess.SaveAsText acModule, objDocument.Name, strExportPath & "Modules\" & Clean(objDocument.Name) & ".module"
Next
End Sub
Private Sub DeleteTempDatabase(strTempMDBFileName, strOverallProgress)
On Error Resume Next
strOverallProgress = strOverallProgress & "Deleting temporary database...<br/>"
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objFileSystem.DeleteFile strTempMDBFileName, true
End Sub
' Windows doesn't like certain characters, so we have to filter those out of the name when exporting
Private Function Clean(strInput)
Dim objRegexp : Set objRegexp = New RegExp
objRegexp.IgnoreCase = True
objRegexp.Global = True
objRegexp.Pattern = "[\\/:*?""<>|]"
Dim strOutput
If objRegexp.Test(strInput) Then
strOutput = objRegexp.Replace(strInput, "")
MsgBox strInput & " is being exported as " & strOutput
Else
strOutput = strInput
End If
Clean = strOutput
End Function
' Imports all of the queries, forms, reports, macros, and modules from text
' files to an Access file (.mdb). Requires Microsoft Access.
Option Explicit
const acQuery = 1
const acForm = 2
const acModule = 5
const acMacro = 4
const acReport = 3
const acCmdCompileAndSaveAllModules = &H7E
Dim strMDBFilename : strMDBFilename = SelectDatabaseFile
CreateBackup strMDBFilename
Dim strImportPath : strImportPath = SelectImportFolder
Dim objAccess
Dim objDatabase
OpenAccessDatabase objAccess, objDatabase, strMDBFilename
Dim objProgressWindow
Dim strOverallProgress
CreateProgressWindow objProgressWindow
ImportQueries objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress
ImportForms objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress
ImportReports objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress
ImportMacros objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress
ImportModules objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress
objAccess.CloseCurrentDatabase
objAccess.Quit
objProgressWindow.Quit
MsgBox "Successfully imported objects into the database."
Private Function SelectDatabaseFile()
MsgBox "Please select the Access database to import the objects from. ALL EXISTING OBJECTS WITH THE SAME NAME WILL BE OVERWRITTEN!"
Dim objFileOpen : Set objFileOpen = CreateObject( "SAFRCFileDlg.FileOpen" )
If objFileOpen.OpenFileOpenDlg Then
SelectDatabaseFile = objFileOpen.FileName
Else
WScript.Quit()
End If
End Function
Private Function SelectImportFolder()
Dim objShell : Set objShell = WScript.CreateObject("Shell.Application")
SelectImportFolder = objShell.BrowseForFolder(0, "Select folder to import the database objects from:", 0, "").self.path & "\"
End Function
Private Sub CreateBackup(strMDBFilename)
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objFileSystem.CopyFile strMDBFilename, strMDBFilename & ".bak"
End Sub
Private Sub OpenAccessDatabase(objAccess, objDatabase, strMDBFileName)
Set objAccess = CreateObject("Access.Application")
objAccess.OpenCurrentDatabase strMDBFilename
objAccess.Visible = false
Set objDatabase = objAccess.CurrentDb
End Sub
Private Sub CreateProgressWindow(ByRef objProgressWindow)
Set objProgressWindow = CreateObject ("InternetExplorer.Application")
objProgressWindow.Navigate "about:blank"
objProgressWindow.ToolBar = 0
objProgressWindow.StatusBar = 0
objProgressWindow.Width = 320
objProgressWindow.Height = 240
objProgressWindow.Visible = 1
objProgressWindow.Document.Title = "Access import in progress"
End Sub
Private Sub ImportQueries(objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress)
strOverallProgress = "Importing Queries (Step 1 of 5)...<br/>"
Dim counter : counter = 0
Dim folder : Set folder = objFileSystem.GetFolder(strImportPath & "Queries\")
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim file
Dim strQueryName
For Each file in folder.Files
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter + 1 & " of " & folder.Files.Count
strQueryName = objFileSystem.GetBaseName(file.Name)
objAccess.LoadFromText acQuery, strQueryName, file.Path
counter = counter + 1
Next
End Sub
Private Sub ImportForms(objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Importing Forms (Step 2 of 5)...<br/>"
Dim counter : counter = 0
Dim folder : Set folder = objFileSystem.GetFolder(strImportPath & "Forms\")
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim file
Dim strFormName
For Each file in folder.Files
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter + 1 & " of " & folder.Files.Count
strFormName = objFileSystem.GetBaseName(file.Name)
objAccess.LoadFromText acForm, strFormName, file.Path
counter = counter + 1
Next
End Sub
Private Sub ImportReports(objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Importing Reports (Step 3 of 5)...<br/>"
Dim counter : counter = 0
Dim folder : Set folder = objFileSystem.GetFolder(strImportPath & "Reports\")
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim file
Dim strReportName
For Each file in folder.Files
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter + 1 & " of " & folder.Files.Count
strReportName = objFileSystem.GetBaseName(file.Name)
objAccess.LoadFromText acReport, strReportName, file.Path
counter = counter + 1
Next
End Sub
Private Sub ImportMacros(objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Importing Macros (Step 4 of 5)...<br/>"
Dim counter : counter = 0
Dim folder : Set folder = objFileSystem.GetFolder(strImportPath & "Macros\")
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim file
Dim strMacroName
For Each file in folder.Files
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter + 1 & " of " & folder.Files.Count
strMacroName = objFileSystem.GetBaseName(file.Name)
objAccess.LoadFromText acMacro, strMacroName, file.Path
counter = counter + 1
Next
End Sub
Private Sub ImportModules(objAccess, objDatabase, objProgressWindow, strImportPath, strOverallProgress)
strOverallProgress = strOverallProgress & "Importing Modules (Step 5 of 5)...<br/>"
Dim counter : counter = 0
Dim folder : Set folder = objFileSystem.GetFolder(strImportPath & "Modules\")
Dim objFileSystem : Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim file
Dim strModuleName
For Each file in folder.Files
objProgressWindow.Document.Body.InnerHTML = strOverallProgress & counter + 1 & " of " & folder.Files.Count
strModuleName = objFileSystem.GetBaseName(file.Name)
objAccess.LoadFromText acModule, strModuleName, file.Path
counter = counter + 1
Next
' We need to compile the database whenever any module code changes.
If Not objAccess.IsCompiled Then
objAccess.RunCommand acCmdCompileAndSaveAllModules
End If
End Sub