Access DB Pipeline Export

Option Compare Database
Option Explicit

'==============================================
' CONFIG
'==============================================
Private Const EXPORT_ROOT As String = "C:\VBAExport\"


'==============================================
' ENTRY POINT
'==============================================
Public Sub ExportDatabaseProject()
    CreateFolders

    ExportModules
    ExportTableDefs
    ExportQueryDefs
    ExportRelationships
    ExportReferences
    ExportMacros
    ExportForms
    ExportReports

    MsgBox "Export Complete!", vbInformation
End Sub


'==============================================
' FOLDER CREATION
'==============================================
Private Sub CreateFolders()
    Dim subFolders As Variant
    Dim f As Variant

    subFolders = Array( _
        "", _
        "Modules\", "Tables\", "Queries\", _
        "Relationships\", "References\", "Macros\", _
        "Forms\", "Reports\")

    For Each f In subFolders
        CreateFolder EXPORT_ROOT & f
    Next f
End Sub

Private Sub CreateFolder(path As String)
    If Dir(path, vbDirectory) = "" Then
        MkDir path
    End If
End Sub


'==============================================
' EXPORT MODULES (BAS / CLASS / FORM / REPORT)
'==============================================
Private Sub ExportModules()
    Dim comp As VBIDE.VBComponent
    Dim proj As VBIDE.VBProject

    Set proj = Application.VBE.ActiveVBProject

    For Each comp In proj.VBComponents
        Dim ext As String
        Select Case comp.Type
            Case vbext_ct_ClassModule: ext = ".cls"
            Case vbext_ct_MSForm: ext = ".frm"
            Case vbext_ct_StdModule: ext = ".bas"
            Case vbext_ct_Document: ext = ".cls"
        End Select

        comp.Export EXPORT_ROOT & "Modules\" & comp.Name & ext
    Next comp
End Sub


'==============================================
' EXPORT TABLE DEFINITIONS
'==============================================
Private Sub ExportTableDefs()
    Dim td As DAO.TableDef
    Dim fld As DAO.Field
    Dim idx As DAO.Index
    Dim f As Integer
    Dim out As String

    For Each td In CurrentDb.TableDefs
        If Left(td.Name, 4) = "MSys" Then GoTo SkipTable

        out = "Table: " & td.Name & vbCrLf & String(40, "=") & vbCrLf

        ' Fields
        out = out & "Fields:" & vbCrLf
        For Each fld In td.Fields
            out = out & "  " & fld.Name & " (" & fld.Type & ")"
            out = out & IfNullText(fld.Properties("Description"), "")
            out = out & vbCrLf
        Next fld

        ' Indexes
        out = out & vbCrLf & "Indexes:" & vbCrLf
        For Each idx In td.Indexes
            out = out & "  " & idx.Name & " (Unique=" & idx.Unique & "): "
            For f = 0 To idx.Fields.Count - 1
                out = out & idx.Fields(f).Name & ", "
            Next
            out = Left(out, Len(out) - 2) & vbCrLf
        Next idx

        SaveText EXPORT_ROOT & "Tables\" & td.Name & ".txt", out

SkipTable:
    Next td
End Sub


'==============================================
' EXPORT QUERYDEFS
'==============================================
Private Sub ExportQueryDefs()
    Dim qd As DAO.QueryDef
    Dim out As String

    For Each qd In CurrentDb.QueryDefs
        If Left(qd.Name, 1) = "~" Then GoTo SkipQuery

        out = "Query: " & qd.Name & vbCrLf & _
              String(40, "=") & vbCrLf & vbCrLf & _
              qd.SQL

        SaveText EXPORT_ROOT & "Queries\" & qd.Name & ".sql", out

SkipQuery:
    Next qd
End Sub


'==============================================
' EXPORT RELATIONSHIPS
'==============================================
Private Sub ExportRelationships()
    Dim rel As DAO.Relation
    Dim fld As DAO.Field
    Dim out As String

    For Each rel In CurrentDb.Relations
        out = "Relation: " & rel.Name & vbCrLf & _
              "From: " & rel.Table & vbCrLf & _
              "To:   " & rel.ForeignTable & vbCrLf & _
              "Attributes: " & rel.Attributes & vbCrLf & _
              "Fields:" & vbCrLf

        For Each fld In rel.Fields
            out = out & "  " & fld.Name & " -> " & fld.ForeignName & vbCrLf
        Next fld

        SaveText EXPORT_ROOT & "Relationships\" & rel.Name & ".txt", out
    Next rel
End Sub


'==============================================
' EXPORT REFERENCES
'==============================================
Private Sub ExportReferences()
    Dim ref As Reference
    Dim out As String

    out = "References" & vbCrLf & String(30, "=") & vbCrLf

    For Each ref In Application.References
        out = out & ref.Name & " | " & ref.FullPath & " | Version " & _
              ref.Major & "." & ref.Minor & vbCrLf
    Next ref

    SaveText EXPORT_ROOT & "References\References.txt", out
End Sub


'==============================================
' EXPORT MACROS
'==============================================
Private Sub ExportMacros()
    Dim obj As AccessObject

    For Each obj In CurrentProject.AllMacros
        Application.SaveAsText acMacro, obj.Name, _
                EXPORT_ROOT & "Macros\" & obj.Name & ".txt"
    Next obj
End Sub


'==============================================
' EXPORT FORMS (OPTIONAL HEAVY)
'==============================================
Private Sub ExportForms()
    Dim obj As AccessObject
    For Each obj In CurrentProject.AllForms
        Application.SaveAsText acForm, obj.Name, _
                EXPORT_ROOT & "Forms\" & obj.Name & ".txt"
    Next obj
End Sub


'==============================================
' EXPORT REPORTS (OPTIONAL HEAVY)
'==============================================
Private Sub ExportReports()
    Dim obj As AccessObject
    For Each obj In CurrentProject.AllReports
        Application.SaveAsText acReport, obj.Name, _
                EXPORT_ROOT & "Reports\" & obj.Name & ".txt"
    Next obj
End Sub


'==============================================
' UTILS
'==============================================
Private Sub SaveText(path As String, text As String)
    Dim f As Integer
    f = FreeFile
    Open path For Output As #f
    Print #f, text
    Close #f
End Sub

Private Function IfNullText(val, defaultText As String) As String
    If IsNull(val) Then
        IfNullText = ""
    Else
        IfNullText = " (" & val & ")"
    End If
End Function