Putting It All Together
I expanded on the original decompose.vbs script. The code below is the culmination of more than 50 individual changes and tweaks over 10+ years.
My Microsoft Access version control journey began with this StackOverflow answer. Over the years, I expanded on the original decompose.vbs script. I wrote about the various enhancements I added in a series of separate blog posts. Please refer to the individual posts for more information about why I've included each additional feature in the amended decompose.vbs script below.
- Export database properties to text files
- Export local "design-time" table data to CSVs
- Export external references to text files
- Export linked table locations and table structures to text files
- Exporting queries for version control
The code below is the culmination of more than 50 individual changes and tweaks to the original script over a more than ten-year period. The script is relatively stable now. I have only made a single change to it over the past four years.
Believe it or not, this script is still not the totality of my Microsoft Access version control process. I have a separate AutoHotKey script that strips out unneeded lines in the exported text files, converts their encoding to a more diff-friendly format, and auto-reverts any files that are identical save for changes in capitalization.
The code may also include references to items that are unique to my workflow. For example, there is a procedure in there to RemoveRelinkerLinkedTables. The Relinker is a form that I include in most of my projects for managing automatic relinking of tables among multiple data environments (production vs. development vs. testing) and/or multiple clients.
Sample Code
Decompose.vbs
' Usage:
' CScript decompose.vbs <input file> <path> <stubname>
' Converts all modules, classes, forms and macros from an Access Project file (.MDB) <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")
const ForWriting = 2
dim sMDBFilename
If (WScript.Arguments.Count = 0) then
MsgBox "Please pass name of .mdb file to decompose", vbExclamation, "Error"
Wscript.Quit()
End if
sMDBFilename = fso.GetAbsolutePathName(WScript.Arguments(0))
Dim sExportpath
If (WScript.Arguments.Count = 1) then
sExportpath = ""
else
sExportpath = WScript.Arguments(1)
End If
Dim KeepOpenDict
If WScript.Arguments.Named.Exists("accobj") Or _
WScript.Arguments.Named.Exists("includetables") Or _
WScript.Arguments.Named.Exists("cleanstub") Then
exportModulesTxt sMDBFilename, sExportpath
End If
If (Err <> 0) and (Err.Description <> NULL) Then
MsgBox Err.Description, vbExclamation, "Error"
Err.Clear
End If
Function exportModulesTxt(sMDBFilename, sExportpath)
Dim myComponent
Dim sModuleType
Dim sTempname
Dim sOutstring
dim myType, myName, myPath
myType = fso.GetExtensionName(sMDBFilename)
myName = fso.GetBaseName(sMDBFilename)
myPath = fso.GetParentFolderName(sMDBFilename)
If (sExportpath = "") then
sExportpath = myPath & "\Source\"
End If
Dim sStubMDBFilename
If (WScript.Arguments.Count < 3) then
sStubMDBFilename = sExportpath & myName & "_stub." & myType
Else
sStubMDBFileName = WScript.Arguments(2)
End If
WScript.Echo "copy stub to " & sStubMDBFilename & "..."
On Error Resume Next
fso.CreateFolder(sExportpath)
On Error Goto 0
fso.CopyFile sMDBFilename, sStubMDBFilename
WScript.Echo "starting Access..."
Dim oApplication
Set oApplication = CreateObject("Access.Application")
WScript.Echo "opening " & sStubMDBFilename & " ..."
oApplication.OpenCurrentDatabase sStubMDBFilename
Dim db
Set db = oApplication.CurrentDB
oApplication.Visible = false
KeepOpen db
If WScript.Arguments.Named.Exists("accobj") Then
dim dctDelete
Set dctDelete = CreateObject("Scripting.Dictionary")
WScript.Echo "exporting..."
Dim myObj
On Error Resume Next
WScript.Echo oApplication.CurrentProject.AllForms.Count
For Each myObj In oApplication.CurrentProject.AllForms
WScript.Echo "Forms: " & myObj.name
Dim IsTempFrm
IsTempFrm = False
IsTempFrm = (db.Containers("Forms").Documents(myObj.Name).Properties("Description") = "temp form created by clsSQL")
Err.Clear
If Not IsTempFrm Then oApplication.SaveAsText acForm, myObj.Name, sExportpath & "\" & myObj.Name & ".form"
If Err Then
LogError sExportPath, "Form: " & myObj.Name
Err.Clear
Else
oApplication.DoCmd.Close acForm, myObj.Name
dctDelete.Add "FO" & myObj.Name, acForm
End If
Next
WScript.Echo db.QueryDefs.Count
Dim f
For Each myObj in db.QueryDefs
If Not Left(myObj.Name,4) = "~sq_" Then
WScript.Echo "Queries: " & myObj.Name
Dim IsTempQry
IsTempQry = False
IsTempQry = (db.QueryDefs(myObj.Name).Properties("Description") = "temp query created by clsSQL") Or _
(db.QueryDefs(myObj.Name).Properties("Description") = "temp query created by clsExcel")
Err.Clear
If Not IsTempQry Then
'save SQL to text file
set f = fso.CreateTextFile(sExportpath & "\" & myObj.Name & ".sql", True)
Dim sqlTxt
If Len(myObj.Connect)>0 Then
sqlTxt = myObj.SQL
Else
sqlTxt = AddLineBreaks(myObj.SQL)
End If
f.WriteLine(sqlTxt)
f.Close
'save query object
oApplication.SaveAsText acQuery, myObj.Name, sExportpath & "\" & myObj.Name & ".qry"
End If
If Err Then
LogError sExportPath, "Query: " & myObj.Name
Err.Clear
Else
oApplication.DoCmd.Close acQuery, myObj.Name
dctDelete.Add "QU" & myObj.Name, acQuery
End If
End If
Next
set f = Nothing
For Each myObj In oApplication.CurrentProject.AllModules
WScript.Echo "Modules: " & myObj.Name
oApplication.SaveAsText acModule, myObj.Name, sExportpath & "\" & myObj.Name & ".bas"
dctDelete.Add "MO" & myObj.Name, acModule
Next
For Each myObj In oApplication.CurrentProject.AllMacros
WScript.Echo "Macros: " & myObj.Name
oApplication.SaveAsText acMacro, myObj.Name, sExportpath & "\" & myObj.Name & ".mac"
dctDelete.Add "MA" & myObj.Name, acMacro
Next
For Each myObj In oApplication.CurrentProject.AllReports
Err.Clear
WScript.Echo "Reports: " & myObj.Name
oApplication.SaveAsText acReport, myObj.Name, sExportpath & "\" & myObj.Name & ".report"
If Err Then
LogError sExportPath, "Report: " & myObj.Name
Err.Clear
Else
dctDelete.Add "RE" & myObj.Name, acReport
End If
Next
For Each myObj in oApplication.VBE.ActiveVBProject.VBComponents
If myObj.Type = 3 Then ' UserForm
WScript.Echo "User forms: " & myObj.Name
myObj.Export sExportPath & "\" & myObj.Name & ".userform"
End If
Next
ExportCSVs db, sExportPath, oApplication
ExportRefs sExportPath, oApplication
ExportProps db, sExportPath
End If
If WScript.Arguments.Named.Exists("includetables") Then
ExportTables db, sExportPath, oApplication
ExportRelations db, sExportPath
ExportIcons sExportPath, oApplication
End If
If WScript.Arguments.Named.Exists("cleanstub") Then
WScript.Echo "deleting..."
dim sObjectname
On Error Resume Next
For Each sObjectname In dctDelete
WScript.Echo " " & Mid(sObjectname, 3)
oApplication.DoCmd.DeleteObject dctDelete(sObjectname), Mid(sObjectname, 3)
If Err Then
LogError sExportPath, "Error deleting: " & Mid(sObjectname, 3)
Err.Clear
End If
Next
WScript.Echo "clearing temporary tables..."
ClearTempTables db
RemoveRelinkerLinkedTables db, sExportPath
On Error Goto 0
End If
Dim rsKeepOpen
For Each rsKeepOpen In KeepOpenDict.Items
rsKeepOpen.Close
Next
oApplication.CloseCurrentDatabase
oApplication.Quit
End Function
Public Sub ClearTempTables(db)
Dim td, recs
For Each td In db.TableDefs
'Get local, non-system tables...
If Not Left(td.Name, 4) = "MSys" And td.Connect = "" Then
'...excluding these ones...
If td.Name <> "YrMos" Then
'...with lots of records
recs = db.OpenRecordset("SELECT Count(*) AS Num FROM [" & td.Name & "]")("Num")
If recs > 500 Then
WScript.Echo " " & td.Name & " " & recs
'And clear them out
db.Execute "DELETE * FROM [" & td.Name & "]"
End If
End If
End If
Next
End Sub
Public Sub RemoveRelinkerLinkedTables(db, sExportPath)
On Error Resume Next
Dim rsLocs, rsTbls
Set rsLocs = db.OpenRecordset("SELECT LocID FROM eLocations")
Set rsTbls = db.OpenRecordset("SELECT LocalTblName FROM eSyncTables")
If Err Then
'MsgBox Err.Number & ": " & Err.Description
'LogError sExportPath, "rsLocs/rsTbls"
Exit Sub
End If
Dim TblName
Do Until rsTbls.EOF
TblName = rsTbls.Fields("LocalTblName").Value
db.TableDefs.Delete TblName
If Err Then
'LogError sExportPath, TblName
Err.Clear
End If
Do Until rsLocs.EOF
TblName = "_" & rsLocs.Fields("LocID").Value & "_" & rsTbls.Fields("LocalTblName").Value
db.TableDefs.Delete TblName
rsLocs.MoveNext
If Err Then
'LogError sExportPath, TblName
Err.Clear
End If
Loop
rsLocs.MoveFirst
rsTbls.MoveNext
Loop
End Sub
Public Sub ExportTables(db, ExportPath, oApp)
Dim td, objFSO, f, prop, fld, ix, x, TableList
'On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set TableList = objFSO.OpenTextFile(ExportPath & "\_TableList.table", 8, True)
For Each td In db.TableDefs
Err.Clear
'Exclude system tables and hidden tables (i.e., Relinker tables)
Dim acTable
acTable = 0
If Not Left(td.Name, 4) = "MSys" And Not oApp.GetHiddenAttribute(acTable, td.Name) Then
On Error Resume Next
WScript.Echo "Tables: " & td.Name & " (" & td.Fields.Count & " fields, " & td.Indexes.Count & " indexes)"
If Err Then
'LogError ExportPath, "Error exporting table: " & td.Name
Err.Clear
End If
On Error Goto 0
If UCase(td.Name) = "AUX" Then
Set f = objFSO.OpenTextFile(ExportPath & "\" & td.Name & "_.table", 8, True)
Else
Set f = objFSO.OpenTextFile(ExportPath & "\" & td.Name & ".table", 8, True)
End If
'Write connect strings to a separate file to minimize the number of modified text files when switching db's
TableList.WriteLine td.Name & " Connect: " & td.Connect
f.WriteLine "Table Properties"
f.WriteLine "----------------"
On Error Resume Next
f.WriteLine " Description: " & td.Properties("Description").Value
On Error Goto 0
f.WriteLine " Attributes: " & td.Attributes
f.WriteLine " SourceTableName: " & td.SourceTableName
f.WriteLine ""
f.WriteLine "Fields"
f.WriteLine "------"
For Each fld In td.Fields
f.WriteLine fld.Name & " [" & DbTypeToString(fld.Type) & "] (" & fld.Size & ")"
On Error Resume Next
f.WriteLine " Description: " & fld.Properties("Description").Value
On Error Goto 0
f.WriteLine " Attributes: " & fld.Attributes
f.WriteLine " Ordinal Position: " & fld.OrdinalPosition
f.WriteLine " Default Value: " & fld.DefaultValue
f.WriteLine " Required: " & fld.Required
f.WriteLine " AllowZeroLength: " & fld.AllowZeroLength
Next
f.WriteLine ""
f.WriteLine "Indexes"
f.WriteLine "-------"
On Error Resume Next
For Each ix In td.Indexes
f.WriteLine ix.Name
For Each fld In ix.Fields
f.WriteLine " " & fld.Name & " {Attributes: " & fld.Attributes & "}"
Next
For Each prop In ix.Properties
If prop.Name <> "DistinctCount" Then
f.WriteLine " " & prop.Name & ": " & prop.Value
End If
Next
f.WriteLine ""
Next
On Error Goto 0
f.Close
Set f = Nothing
End If
If Err Then
LogError ExportPath, "Error exporting: " & td.Name
Err.Clear
End If
Next
Set objFSO = Nothing
End Sub
Public Sub ExportRelations(db, ExportPath)
Dim objFSO, f, fld
Dim rel, tbl, ftbl
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set f = objFSO.OpenTextFile(ExportPath & "\_RelationList.table", 8, True)
For Each rel In db.Relations
WScript.Echo "Relations: " & rel.Name
f.WriteLine rel.Name
f.WriteLine "-------------------"
tbl = rel.Table
ftbl = rel.ForeignTable
For Each fld In rel.Fields
f.WriteLine tbl & "." & fld.Name & " --> " & ftbl & "." & fld.ForeignName
Next 'fld
f.WriteLine "---== Attributes ==---"
if (rel.Attributes And 1) > 0 then f.WriteLine "dbRelationUnique: The relationship is one-to-one."
if (rel.Attributes And 2) > 0 then f.WriteLine "dbRelationDontEnforce: The relationship isn't enforced (no referential integrity)."
if (rel.Attributes And 4) > 0 then f.WriteLine "dbRelationInherited: The relationship exists in a non-current database that contains the two linked tables."
if (rel.Attributes And 256) > 0 then f.WriteLine "dbRelationUpdateCascade: Updates will cascade."
if (rel.Attributes And 4096) > 0 then f.WriteLine "dbRelationDeleteCascade: Deletions will cascade."
if (rel.Attributes And 16777216) > 0 then f.WriteLine "dbRelationLeft: Microsoft Access only. In Design view, display a LEFT JOIN as the default join type."
if (rel.Attributes And 33554432) > 0 then f.WriteLine "dbRelationRight: Microsoft Access only. In Design view, display a RIGHT JOIN as the default join type."
f.WriteLine ""
Next 'rel
f.Close
Set f = Nothing
Set objFSO = Nothing
End Sub
Public Sub ExportCSVs(db, ExportPath, oApp)
Const acExportDelim = 2
Dim Tbls, TblName, QDef, QDefName
On Error Resume Next
QDefName = "___TempCsvExportQDef___"
Tbls = Split(db.Properties("hg_csv"), ",")
If Err = 0 Then
For Each TblName In Tbls
WScript.Echo "CSV: " & Trim(TblName)
Dim ColumnNames
ColumnNames = ColNames(db, Trim(TblName), True)
Set QDef = db.CreateQueryDef(QDefName, "SELECT * FROM " & Trim(TblName) & " ORDER BY " & ColumnNames)
oApp.DoCmd.TransferText acExportDelim, , QDef.Name, ExportPath & "\" & Trim(TblName) & ".csv", True
db.QueryDefs.Delete QDef.Name
Set QDef = Nothing
If Err <> 0 Then
WScript.Echo " error " & Err & ": " & Err.Description & " {" & ColumnNames & "}"
Err.Clear
End If
Next
Else
Err.Clear
End If
For Each TblName In Array("MSysIMEXSpecs", "MSysIMEXColumns")
WScript.Echo "CSV: " & Trim(TblName)
Set QDef = db.CreateQueryDef(QDefName, "SELECT * FROM " & Trim(TblName) & " ORDER BY " & ColNames(db, Trim(TblName), True))
oApp.DoCmd.TransferText acExportDelim, , QDef.Name, ExportPath & "\" & Trim(TblName) & ".csv", True
db.QueryDefs.Delete QDef.Name
Set QDef = Nothing
Next
End Sub
Public Function ColNames(db, TblName, SortableOnly)
Dim i, td
On Error Resume Next
Set td = db.TableDefs(TblName)
If td Is Nothing Then Set td = db.QueryDefs(TblName)
ColNames = td.Fields(0).Name
For i = 1 To td.Fields.Count - 1
Dim isSortable
Select Case td.Fields(i).Type
Case 11, 12: isSortable = False ' Memo, OLE, and Hyperlink fields are not sortable
Case Else: isSortable = True
End Select
If isSortable Or Not SortableOnly Then
ColNames = ColNames & ", " & td.Fields(i).Name
End If
Next
End Function
Public Function AddLineBreaks(Txt) 'As String
Dim s
s = Txt
s = Replace(s, " INNER JOIN ", vbCrLf & " INNER JOIN ")
s = Replace(s, " LEFT JOIN ", vbCrLf & " LEFT JOIN ")
s = Replace(s, " ON ", vbCrLf & " ON ")
s = Replace(s, " AND ", vbCrLf & " AND ")
s = Replace(s, " OR ", vbCrLf & " OR ")
s = Replace(s, ", ", "," & vbCrLf & " ")
AddLineBreaks = s
End Function
Public Sub ExportRefs(ExportPath, oApp)
Dim ref, Refs, objFSO, i
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Refs = objFSO.CreateTextFile(ExportPath & "\References.txt", True)
'Refs.WriteLine oApp.VBE.ActiveVBProject.References.Count & " references found"
Refs.WriteLine Join(Array("Name", "Major", "Minor", "Type", "Builtin", "Broken", "GUID", "Description"), vbTab)
On Error Resume Next
For Each ref In oApp.VBE.ActiveVBProject.References
i = i + 1
'Refs.WriteLine "Reference " & i
Refs.WriteLine Join(Array(ref.Name, ref.Major, ref.Minor, ref.Type, ref.Builtin, ref.IsBroken, ref.GUID, ref.Description), vbTab)
If err.number <> 0 then
Refs.WriteLine err.Description
err.Clear
End If
Next
Refs.Close
Set Refs=Nothing
End Sub
Public Sub ExportProps(db, ExportPath)
Dim i, Props, objFSO, Prop
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Props = objFSO.CreateTextFile(ExportPath & "\DbProperties.txt", True)
Props.WriteLine Join(Array("Index", "Name ", "Value"), vbTab)
On Error Resume Next
For i = 0 To db.Properties.Count - 1
Set Prop = db.Properties(i)
Props.WriteLine Join(Array(i, Left(Prop.Name & " ", 31), Prop.Value), vbTab)
Next
On Error Goto 0
Props.Close
Set Props=Nothing
End Sub
Public Sub ExportIcons(ExportPath, oApp)
On Error Resume Next
oApp.Run "ExportIcons", ExportPath & "eIcons"
End Sub
Public Sub LogError(sExportPath, sNote)
Dim objFso, objFile, filLog, PATH
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile = objFso.OpenTextFile(sExportPath & "_Errors.Log", 8, True)
objFile.WriteLine Date() & " {" & sNote & "} " & Err.Number & ": " & Err.Description
objFile.Close
Set objFso = Nothing
Set objFile = Nothing
End Sub
Private Function DbTypeToString(DbType)
Select Case DbType
Case 16: DbTypeToString = "Big Int"
Case 9: DbTypeToString = "Binary"
Case 1: DbTypeToString = "Boolean"
Case 2: DbTypeToString = "Byte"
Case 18: DbTypeToString = "Char"
Case 5: DbTypeToString = "Currency"
Case 8: DbTypeToString = "Date"
Case 20: DbTypeToString = "Decimal"
Case 7: DbTypeToString = "Double"
Case 21: DbTypeToString = "Float"
Case 15: DbTypeToString = "GUID"
Case 3: DbTypeToString = "Integer"
Case 4: DbTypeToString = "Long"
Case 11: DbTypeToString = "Long Binary"
Case 12: DbTypeToString = "Memo"
Case 19: DbTypeToString = "Numeric"
Case 6: DbTypeToString = "Single"
Case 10: DbTypeToString = "Text"
Case 22: DbTypeToString = "Time"
Case 23: DbTypeToString = "TimeStamp"
Case 17: DbTypeToString = "VarBinary"
End Select
End Function
Private Function KeepOpen(db) 'As Collection
Const dbOpenDynaset = 2, dbOpenForwardOnly = 8
Dim dbNames, rsKeepOpen, rsDBList, DbName
Set KeepOpenDict = CreateObject("Scripting.Dictionary")
Set rsDBList = db.OpenRecordset("SELECT DISTINCT Database FROM MSysObjects WHERE Database Like '*.*db'", dbOpenForwardOnly)
With rsDBList
Do Until .EOF
DbName = .Fields("Database").Value
if fso.FileExists(DbName) Then
dbNames = dbNames & DbName & "|"
Set rsKeepOpen = db.OpenRecordset("SELECT TOP 1 Database FROM MSysObjects", dbOpenDynaset)
KeepOpenDict.Add DbName, rsKeepOpen
End If
.MoveNext
Loop
End With
'MsgBox dbNames
End Function
