AccessIO

common.vbs

Option Explicit

' AcCloseSave
Const acSavePrompt = 0
Const acSaveYes = 1
Const acSaveNo = 2

' AcObjectType
Const acDefault = -1
Const acTable = 0
Const acQuery = 1
Const acForm = 2
Const acReport = 3
Const acMacro = 4
Const acModule = 5
Const acServerView = 7
Const acDiagram = 8
Const acStoredProcedure = 9
Const acFunction = 10
Const acDatabaseProperties = 11
Const acTableDataMacro = 12

' AcView
Const acViewNormal = 0
Const acViewDesign = 1
Const acViewPreview = 2
Const acViewPivotTable = 3
Const acViewPivotChart = 4
Const acViewReport = 5
Const acViewLayout = 6

' Format
Const TristateUseDefault = -2
Const TristateTrue = -1
Const TristateFalse = 0
Dim EncodingUnicode
Dim EncodingAscii
EncodingUnicode = TristateTrue
EncodingAscii = TristateFalse

' IoMode
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

' TableDefAttributeEnum
Const dbSystemObject = -2147483646
Const dbHiddenObject = 1
Const dbAttachExclusive = 65536
Const dbAttachSavePWD = 131072
Const dbAttachedODBC = 536870912
Const dbAttachedTable = 1073741824

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Sub CompactAndRepair(fileName)
    Dim app
    Dim tempFileName
    
    Set app = CreateObject("Access.Application")
    tempFileName = fileName & ".temp"
    app.CompactRepair fileName, tempFileName
    app.Quit
    fso.DeleteFile fileName
    fso.MoveFile tempFileName, fileName
End Sub

Function Encode(fileName, sourceEncoding, targetEncoding, overwrite)
    Dim tempFileName
    Dim source
    Dim target
    
    tempFileName = fileName & ".temp"
    Set source = fso.OpenTextFile(fileName, ForReading, False, sourceEncoding)
    Set target = fso.CreateTextFile(tempFileName, False, targetEncoding)
    target.Write source.ReadAll()
    source.Close
    target.Close
    If overwrite Then
        fso.DeleteFile fileName
        fso.MoveFile tempFileName, fileName
        Encode = fileName
    Else
        Encode = tempFileName
    End If
End Function

Sub EnsureTrailingNewline(fileName, encoding)
    Dim tempFileName
    Dim source
    Dim target
    
    tempFileName = fileName & ".temp"
    Set source = fso.OpenTextFile(fileName, ForReading, False, encoding)
    Set target = fso.CreateTextFile(tempFileName, False, encoding)
    Do Until source.AtEndOfStream
        target.WriteLine source.ReadLine()
    Loop
    source.Close
    target.Close
    fso.DeleteFile fileName
    fso.MoveFile tempFileName, fileName
End Sub

Function GetFolderName(objType)
    Select Case objType
        Case acTable
            GetFolderName = "Tables"
        Case acQuery
            GetFolderName = "Queries"
        Case acForm
            GetFolderName = "Forms"
        Case acReport
            GetFolderName = "Reports"
        Case acMacro
            GetFolderName = "Macros"
        Case acModule
            GetFolderName = "Modules"
        Case Else
            GetFolderName = "Other"
            Err.Raise 5
    End Select
End Function

export.vbs

Option Explicit

Dim rxIgnoredLine
Dim rxIgnoredTopLevelLine
Dim rxIgnoredBlock
Dim rxBlockEnd

If StrComp(Right(WScript.ScriptName, 4), ".wsf", vbTextCompare) <> 0 Then
    WScript.Echo "Do not invoke this file directly."
    WScript.Echo "Use the corresponding Windows script file (.wsf) instead."
    WScript.Quit
End If
Dim validArgs
validArgs = True
Dim argSanitize
Dim argDatabase
Select Case WScript.Arguments.Count()
    Case 1
        argSanitize = True
        argDatabase = WScript.Arguments(0)
    Case 2
        If StrComp(WScript.Arguments(0), "/nosanitize", vbTextCompare) = 0 Then
            argSanitize = False
            argDatabase = WScript.Arguments(1)
        Else
            validArgs = False
        End If
    Case Else
        validArgs = False
End Select
If Not validArgs Then
    WScript.Echo "Usage: cscript " & WScript.ScriptName & " [/nosanitize] DATABASE"
    WScript.Echo
    WScript.Echo "Exports objects from an Access database as text."
    WScript.Echo "This includes linked tables, queries, forms, reports, macros, modules, and references."
    WScript.Echo "Creates a stub database by removing these objects."
    WScript.Echo "Sanitizes exported text to remove volatile properties."
    WScript.Echo
    WScript.Echo "  /nosanitize  Do not sanitize exported text"
    WScript.Quit
End If

InitRegExps
Dim fileName
fileName = CreateStub(argDatabase)
Export fileName
CompactAndRepair fileName

Sub InitRegExps
    Dim ignoredLines
    Dim ignoredTopLevelLines
    Dim ignoredBlocks
    
    ' During sanitization, ignore lines like the following:
    '     Property =...
    '         ...
    '     dbType "Property" =...
    '         ...
    ' Match against the property names listed below
    ignoredLines = Array( _
        "AllowPivot(Chart|Table)View", _
        "BaseInfo", _
        "Checksum", _
        "NoSaveCTIWhenDisabled", _
        "PublishOption", _
        "PublishToWeb" _
    )
    ' Match against the top-level property names listed below
    ' I.e., only match if they are properties of the root object (form, report, etc.)
    ' Note that these properties are not sanitized for queries
    ignoredTopLevelLines = Array( _
        "Bottom", _
        "Left", _
        "Right", _
        "Top" _
    )
    Set rxIgnoredLine = New RegExp
    Set rxIgnoredTopLevelLine = New RegExp
    rxIgnoredLine.Pattern = "^\s*(?:db\w+\s+)?""?(?:" & Join(ignoredLines, "|") & ")""?\s*="
    rxIgnoredTopLevelLine.Pattern = "^    (?:db\w+\s+)?""?(?:" & Join(ignoredTopLevelLines, "|") & ")""?\s*="
    
    ' During sanitization, ignore blocks like the following:
    '     Property = Begin
    '         ...
    '     End
    '     dbType "Property" = Begin
    '         ...
    '     End
    ' Match against the property names listed below
    ignoredBlocks = Array( _
        "DOL", _
        "GUID", _
        "NameMap", _
        "PrtDev(?:Names|Mode)[W]?" _
    )
    Set rxIgnoredBlock = New RegExp
    rxIgnoredBlock.Pattern = "^\s*(?:db\w+\s+)?""?(?:" & Join(ignoredBlocks, "|") & ")""?\s*=\s*Begin\b"
    Set rxBlockEnd = New RegExp
    rxBlockEnd.Pattern = "^\s*End\b"
End Sub

Function CreateStub(fileName)
    Dim path
    Dim baseName
    Dim extension
    Dim stubFileName
    
    fileName = fso.GetAbsolutePathName(fileName)
    path = fso.GetParentFolderName(fileName) & "\"
    baseName = fso.GetBaseName(fileName)
    extension = "." & fso.GetExtensionName(fileName)
    stubFileName = path & baseName & ".stub" & extension
    fso.CopyFile fileName, stubFileName
    CreateStub = stubFileName
End Function

Sub Export(fileName)
    Dim path
    Dim app
    Dim db
    Dim proj
    Dim objs
    Dim obj
    Dim i
    
    path = fso.GetParentFolderName(fileName) & "\Source\"
    If fso.FolderExists(path) Then
        fso.DeleteFolder Left(path, Len(path) - 1)
    End If
    WScript.Sleep 3000
    fso.CreateFolder path
    Set app = CreateObject("Access.Application")
    app.OpenCurrentDatabase fileName
    Set db = app.CurrentDb()
    Set proj = app.CurrentProject
    Set objs = CreateObject("Scripting.Dictionary")
    For i = 0 To db.TableDefs.Count - 1
        Set obj = db.TableDefs(i)
        If IsExportable(obj) Then
            SaveAsText app, objs, acTable, obj, path
        End If
    Next
    For i = 0 To db.QueryDefs.Count - 1
        Set obj = db.QueryDefs(i)
        SaveAsText app, objs, acQuery, obj, path
    Next
    For Each obj In proj.AllForms
        SaveAsText app, objs, acForm, obj, path
    Next
    For Each obj In proj.AllReports
        SaveAsText app, objs, acReport, obj, path
    Next
    For Each obj In proj.AllMacros
        SaveAsText app, objs, acMacro, obj, path
    Next
    For Each obj In proj.AllModules
        SaveAsText app, objs, acModule, obj, path
    Next
    SaveReferences app, path
    On Error Resume Next
    For Each obj In objs
        app.DoCmd.DeleteObject objs(obj), Mid(obj, 2)
    Next
    On Error Goto 0
    app.Quit
End Sub

Function IsExportable(tableDef)
    IsExportable = True
    If (tableDef.Attributes And dbSystemObject) <> 0 Then
        IsExportable = False
    ElseIf (tableDef.Attributes And dbAttachedODBC) = 0 And (tableDef.Attributes And dbAttachedTable) = 0 Then
        IsExportable = False
    End If
End Function

Sub SaveAsText(app, objs, objType, obj, path)
    Dim folderName
    Dim subpath
    Dim fileName
    Dim f
    
    objs.Add objType & obj.Name, objType
    If Left(obj.Name, 1) = "~" Then
        Exit Sub
    End If
    folderName = GetFolderName(objType)
    WScript.Echo folderName & "\" & obj.Name
    subpath = path & folderName & "\"
    If Not fso.FolderExists(subpath) Then
        fso.CreateFolder subpath
    End If
    If objType = acTable Then
        fileName = subpath & obj.Name & ".txt"
        Set f = fso.CreateTextFile(fileName)
        With obj
            f.WriteLine .Attributes And Not dbAttachedODBC And Not dbAttachedTable
            f.WriteLine .SourceTableName
            f.WriteLine .Connect
        End With
        f.Close
    Else
        fileName = subpath & obj.Name & ".bas"
        app.SaveAsText objType, obj.Name, fileName
        If objType = acModule Then
            EnsureTrailingNewline fileName, EncodingAscii
        Else
            Encode fileName, EncodingUnicode, EncodingAscii, True
            If argSanitize Then
                Sanitize fileName, objType
            End If
            If objType = acReport Then
                SavePrinter app, obj.Name, subpath
            End If
        End If
    End If
    app.DoCmd.Close objType, obj.Name, acSaveNo
End Sub

Sub SavePrinter(app, reportName, path)
    Dim printer
    Dim subpath
    Dim fileName
    Dim f
    
    app.DoCmd.OpenReport reportName, acViewDesign
    Set printer = app.Reports(reportName).Printer
    subpath = path & "Printer\"
    If Not fso.FolderExists(subpath) Then
        fso.CreateFolder subpath
    End If
    fileName = subpath & reportName & ".txt"
    Set f = fso.CreateTextFile(fileName)
    With printer
        f.WriteLine .DataOnly
        f.WriteLine .PaperSize
        f.WriteLine .Orientation
        f.WriteLine .DefaultSize
        f.WriteLine .ItemSizeWidth
        f.WriteLine .ItemSizeHeight
        f.WriteLine .TopMargin
        f.WriteLine .RightMargin
        f.WriteLine .BottomMargin
        f.WriteLine .LeftMargin
        f.WriteLine .ItemLayout
        f.WriteLine .ItemsAcross
        f.WriteLine .ColumnSpacing
        f.WriteLine .RowSpacing
    End With
    f.Close
End Sub

Sub Sanitize(fileName, objType)
    Dim tempFileName
    Dim source
    Dim target
    Dim line
    Dim needLine
    Dim codeBehind
    Dim indentLevel
    
    tempFileName = fileName & ".temp"
    Set source = fso.OpenTextFile(fileName, ForReading)
    Set target = fso.CreateTextFile(tempFileName)
    needLine = True
    codeBehind = False
    Do Until source.AtEndOfStream
        If needLine Then
            line = source.ReadLine()
        End If
        needLine = True
        If Not codeBehind And (rxIgnoredLine.Test(line) Or (objType <> acQuery And rxIgnoredTopLevelLine.Test(line))) Then
            indentLevel = GetIndentLevel(line)
            Do Until source.AtEndOfStream
                line = source.ReadLine()
                If GetIndentLevel(line) <= indentLevel Then
                    Exit Do
                End If
            Loop
            needLine = False
        ElseIf Not codeBehind And rxIgnoredBlock.Test(line) Then
            Do Until source.AtEndOfStream
                line = source.ReadLine()
                If rxBlockEnd.Test(line) Then
                    Exit Do
                End If
            Loop
        Else
            If line = "CodeBehindForm" Then
                codeBehind = True
            End If
            If codeBehind Or Len(Trim(line)) > 0 Then
                target.WriteLine line
            End If
        End If
    Loop
    source.Close
    target.Close
    fso.DeleteFile fileName
    fso.MoveFile tempFileName, fileName
End Sub

Function GetIndentLevel(line)
    GetIndentLevel = Len(line) - Len(LTrim(line))
End Function

Sub SaveReferences(app, path)
    Dim f
    Dim ref
    
    Set f = fso.CreateTextFile(path & "References.csv")
    For Each ref in app.References
        If Not ref.BuiltIn Then
            f.Write ref.GUID & ","
            f.Write ref.Major & ","
            f.Write ref.Minor & ","
            f.Write """" & Replace(ref.Name, """", """""") & """"
            f.WriteLine
            app.References.Remove ref
        End If
    Next
    f.Close
End Sub

export.wsf

<job id="export">
    <script language="VBScript" src="common.vbs" />
    <script language="VBScript" src="export.vbs" />
</job>

import.vbs

Option Explicit

If StrComp(Right(WScript.ScriptName, 4), ".wsf", vbTextCompare) <> 0 Then
    WScript.Echo "Do not invoke this file directly."
    WScript.Echo "Use the corresponding Windows script file (.wsf) instead."
    WScript.Quit
End If
Dim validArgs
validArgs = True
Dim argStub
Select Case WScript.Arguments.Count()
    Case 1
        argStub = WScript.Arguments(0)
    Case Else
        validArgs = False
End Select
If Not validArgs Then
    WScript.Echo "Usage: cscript " & WScript.ScriptName & " STUB"
    WScript.Echo
    WScript.Echo "Imports previously exported objects into an Access database."
    WScript.Echo "See the companion export script for details."
    WScript.Quit
End If

Dim fileName
fileName = CreateDatabase(argStub)
Import fileName
CompactAndRepair fileName

Function CreateDatabase(stubFileName)
    Dim fileName
    
    stubFileName = fso.GetAbsolutePathName(stubFileName)
    fileName = Replace(stubFileName, ".stub", "")
    If fso.FileExists(fileName) Then
        fso.DeleteFile fileName, True
    End If
    fso.CopyFile stubFileName, fileName
    CreateDatabase = fileName
End Function

Sub Import(fileName)
    Dim path
    Dim app
    Dim db
    Dim objTypes
    Dim objType
    Dim subpath
    Dim file
    
    path = fso.GetParentFolderName(fileName) & "\Source\"
    If Not fso.FolderExists(path) Then
        Exit Sub
    End If
    Set app = CreateObject("Access.Application")
    app.OpenCurrentDatabase fileName
    Set db = app.CurrentDb()
    LoadReferences app, path
    objTypes = Array(acTable, acQuery, acForm, acReport, acMacro, acModule)
    For Each objType in objTypes
        subpath = path & GetFolderName(objType) & "\"
        If fso.FolderExists(subpath) Then
            For Each file In fso.GetFolder(subpath).Files
                LoadFromText app, db, objType, subpath, file.Path
            Next
        End If
    Next
    app.Quit
End Sub

Sub LoadReferences(app, path)
    Dim f
    Dim fields
    
    Set f = fso.OpenTextFile(path & "References.csv", ForReading)
    Do Until f.AtEndOfStream
        fields = Split(f.ReadLine(), ",", 4)
        app.References.AddFromGuid fields(0), fields(1), fields(2)
    Loop
    f.Close
End Sub

Sub LoadFromText(app, db, objType, path, fileName)
    Dim objName
    Dim table
    Dim f
    
    objName = fso.GetBaseName(fileName)
    WScript.Echo GetFolderName(objType) & "\" & objName
    If objType = acTable Then
        Set table = db.CreateTableDef(objName)
        Set f = fso.OpenTextFile(fileName, ForReading)
        With table
            .Attributes = CLng(f.ReadLine())
            .SourceTableName = f.ReadLine()
            .Connect = f.ReadLine()
        End With
        f.Close
        db.TableDefs.Append table
    Else
        app.LoadFromText objType, objName, fileName
        If objType = acReport Then
            LoadPrinter app, objName, path
        End If
    End If
End Sub

Sub LoadPrinter(app, reportName, path)
    Dim fileName
    Dim report
    Dim printer
    Dim f
    Dim itemSizeWidth
    Dim itemSizeHeight
    
    fileName = path & "Printer\" & reportName & ".txt"
    If Not fso.FileExists(fileName) Then
        Exit Sub
    End If
    app.DoCmd.OpenReport reportName, acViewDesign
    Set report = app.Reports(reportName)
    Set printer = report.Printer
    Set f = fso.OpenTextFile(fileName, ForReading)
    With printer
        .DataOnly = CBool(f.ReadLine())
        .PaperSize = CLng(f.ReadLine())
        .Orientation = CLng(f.ReadLine())
        .DefaultSize = CBool(f.ReadLine())
        itemSizeWidth = CLng(f.ReadLine())
        itemSizeHeight = CLng(f.ReadLine())
        If Not .DefaultSize Then
            .ItemSizeWidth = itemSizeWidth
            .ItemSizeHeight = itemSizeHeight
        End If
        .TopMargin = CLng(f.ReadLine())
        .RightMargin = CLng(f.ReadLine())
        .BottomMargin = CLng(f.ReadLine())
        .LeftMargin = CLng(f.ReadLine())
        .ItemLayout = CLng(f.ReadLine())
        .ItemsAcross = CLng(f.ReadLine())
        .ColumnSpacing = CLng(f.ReadLine())
        .RowSpacing = CLng(f.ReadLine())
    End With
    f.Close
    
    ' Update a report property
    ' Printer properties don't seem to get updated unless this happens
    ' So set an arbitrarily selected property to its current value
    report.Caption = report.Caption
    
    app.DoCmd.Close acReport, reportName, acSaveYes
End Sub

import.wsf

<job id="import">
    <script language="VBScript" src="common.vbs" />
    <script language="VBScript" src="import.vbs" />
</job>