Option Compare Database
Option Explicit



'---------------------------------------------------------------------------------------
' Procedure : SaveDBAsText
' Author    : Patrick Wood - Gaining Access Technologies http://gainingaccess.net/
' Origin    : Inspired by Arvin Meyer's DocDatabase Sub
' Date      : 3/16/2012
' Purpose   : Saves and Documents the database as text files
' Comment   : Uses the undocumented [Application.SaveAsText] syntax
'           : To reload use the syntax [Application.LoadFromText]
' Example   : SaveDBAsText("C:\Users\MyUserName\Documents\Databases SaveAsText\")
' Requires  : FolderExists Function from http://allenbrowne.com/func-11.html
'---------------------------------------------------------------------------------------
'
Public Function SaveDBAsText(strPath As StringAs Boolean
On Error GoTo ErrHandle

    Dim accObject As AccessObject
    Dim strFolderPath As String
    Dim strTablesPath As String
    Dim strDate As String

    SaveDBAsText = False 'Default Value

    'Ensure Main Folder Exists
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strPath = strPath & Replace(CurrentProject.Name, ".", "-")
    strPath = strPath & "_" & Format(Now(), "yyyy-mm-dd-hh-nn") & "\"

    If Not FolderExists(strPath) Then
        MkDir strPath
    End If

    'SaveAsText does not work for tables - Use custom Function
    strTablesPath = strPath 'Do not Delete this - strPath is changed by PAWTablesDocument
    If Not PAWTablesDocument(strTablesPath) Then
        MsgBox "There was an error documenting the Tables.", vbCritical
    End If

    'Ensure Folder for Forms Exists
    strFolderPath = strPath & "Forms"
    If Not FolderExists(strFolderPath) Then
        MkDir strFolderPath
    End If

    For Each accObject In CurrentProject.AllForms
        Application.SaveAsText acForm, accObject.Name, strFolderPath & "\" & accObject.Name & ".txt"
    Next accObject

    'Ensure Folder for Reports Exists
    strFolderPath = strPath & "Reports"
    If Not FolderExists(strFolderPath) Then
        MkDir strFolderPath
    End If

    For Each accObject In CurrentProject.AllReports
        Application.SaveAsText acReport, accObject.Name, strFolderPath & "\" & accObject.Name & ".txt"
    Next accObject

    'Ensure Folder for Modules Exists
    strFolderPath = strPath & "Modules"
    If Not FolderExists(strFolderPath) Then
        MkDir strFolderPath
    End If

    For Each accObject In CurrentProject.AllModules
        Application.SaveAsText acModule, accObject.Name, strFolderPath & "\" & accObject.Name & ".txt"
    Next accObject

    'Ensure Folder for Queries Exists
    strFolderPath = strPath & "Queries"
    If Not FolderExists(strFolderPath) Then
        MkDir strFolderPath
    End If

    For Each accObject In CurrentData.AllQueries
        Application.SaveAsText acQuery, accObject.Name, strFolderPath & "\" & accObject.Name & ".txt"
    Next accObject

    'Ensure Folder for Macros Exists
    strFolderPath = strPath & "Macros"
    If Not FolderExists(strFolderPath) Then
        MkDir strFolderPath
    End If

    For Each accObject In CurrentProject.AllMacros
        Application.SaveAsText acMacro, accObject.Name, strFolderPath & "\" & accObject.Name & ".txt"
    Next accObject

    SaveDBAsText = True

ExitHere:
    On Error Resume Next
    Set accObject = Nothing
    Exit Function

ErrHandle:
    MsgBox "Error " & Err.Number & " " & Err.Description & vbCrLf _
    & "In Procedure SaveDBAsText in modPAWSaveAsText"
    Resume ExitHere
    Resume

End Function


'---------------------------------------------------------------------------------------
' Procedure : LoadFilesFromText
' Author    : Patrick Wood - Gaining Access Technologies http://gainingaccess.net/
' Date      : 4/30/2012
' Purpose   : Restores Database Objects from Text
'---------------------------------------------------------------------------------------
'
Function LoadFilesFromText(strFolder As StringOptional blnIncludeSubfolders As Boolean)

    Dim fso As Object               'Scripting.FileSystemObject
    Dim fsoSourceFolder As Object   'Scripting.Folder
    Dim fsoSubFolder As Object      'Scripting.Folder
    Dim fsoFile As Object           'Scripting.File
    Dim strFilePath As String
    Dim strObjName As String

    On Error GoTo ErrHandle

    LoadFilesFromText = False 'Default Value

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fsoSourceFolder = fso.GetFolder(strFolder)

    For Each fsoFile In fsoSourceFolder.Files
        strObjName = Replace(fsoFile.Name, ".txt", "")
        strFilePath = fsoFile.path
        Application.LoadFromText acQuery, strObjName, strFilePath
    Next fsoFile

    LoadFilesFromText = True

ExitHere:
    On Error Resume Next
    Set fsoFile = Nothing
    Set fsoSubFolder = Nothing
    Set fsoSourceFolder = Nothing
    Set fso = Nothing
    Exit Function

ErrHandle:
    MsgBox "Error " & Err.Number & " " & Err.Description & vbCrLf _
    & "In Procedure LoadFilesFromText of modPAWSaveAsText"
    Resume ExitHere

End Function



'---------------------------------------------------------------------------------------
' Procedure : PAWTablesDocument
' Author    : Patrick Wood - Gaining Access Technologies http://gainingaccess.net/
' Date      : 3/17/2012
' Purpose   : Document Tables and their Properties and Fields
' Arguments : strPath is the main path in which to place the Database info
' Example   : Call PAWTablesDocument("C:\Users\MyUserName\Documents\Databases SaveAsText\")
'           : Creates a Database Folder and a Tables SubFolder
' Requires  : FolderExists Function from http://allenbrowne.com/func-11.html
'---------------------------------------------------------------------------------------
'
Public Function PAWTablesDocument(strPath As StringAs Boolean
On Error GoTo ErrHandle

    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim fso As Object
    Dim fsoFile As Object
    Dim i As Long
    Dim j As Long
    Dim strFolderPath As String
    Dim strFilePath As String

    PAWTablesDocument = False 'Default Value

    Set db = CurrentDb
    db.Properties.Refresh

    'Create the folders neeeded
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

    If Not FolderExists(strPath) Then
        MkDir strPath
    End If

    strFolderPath = strPath & "Tables"
    If Not FolderExists(strFolderPath) Then
        MkDir strFolderPath
    End If

    Set fso = CreateObject("Scripting.FileSystemObject")

    For Each tdf In db.TableDefs
        'Skip System Tables
        If Left(tdf.Name, 4) <> "MSys" Then

            Set tdf = db.TableDefs(tdf.Name)

            strFilePath = strFolderPath & "\" & tdf.Name & ".txt"

            Set fsoFile = fso.CreateTextFile(strFilePath)

            fsoFile.WriteLine "Table: " & tdf.Name
            fsoFile.WriteLine " "
            fsoFile.WriteLine "Table Properties:"

            On Error Resume Next

            For j = 0 To tdf.Properties.Count - 1
                fsoFile.WriteLine tdf.Properties(j).Name & " = " _
                    & tdf.Properties(j).value & vbTab & vbTab _
                    & "Type: " & tdf.Properties(j).Type
            Next j

            fsoFile.WriteLine " "
            fsoFile.WriteLine "Field Properties:"

            For Each fld In tdf.Fields
                fsoFile.WriteLine " "
                fsoFile.WriteLine "Field Name: " & fld.Name

                For i = 0 To fld.Properties.Count - 1
                    fsoFile.WriteLine fld.Properties(i).Name & " = " _
                        & fld.Properties(i).value & vbTab & vbTab _
                        & "Type: " & fld.Properties(i).Type
                Next i
            Next fld

            fsoFile.Close
            Set fsoFile = Nothing
            On Error GoTo ErrHandle
        End If
    Next tdf

    PAWTablesDocument = True

ExitHere:
    On Error Resume Next
    Set fso = Nothing
    Set tdf = Nothing
    Set db = Nothing
    Exit Function

ErrHandle:
    MsgBox "Error " & Err.Number & " " & Err.Description & vbCrLf _
    & "In Procedure PAWTablesDocument of modPAWSaveAsText"
    Resume ExitHere
    Resume
End Function




Public Function PAWTablesFieldsList() As Boolean
On Error GoTo ErrHandle

    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field

    PAWTablesFieldsList = False 'Default Value

    Set db = CurrentDb
    db.Properties.Refresh

    For Each tdf In db.TableDefs
        'Skip System Tables
        If Left(tdf.Name, 4) <> "MSys" Then

            Set tdf = db.TableDefs(tdf.Name)

            Debug.Print "----------------------------------------"
            Debug.Print tdf.Name
            Debug.Print "----------------------------------------"

            For Each fld In tdf.Fields
'                Debug.Print "Field Name: " & fld.Name
                Debug.Print fld.Name
            Next fld

        End If
    Next tdf

    PAWTablesFieldsList = True

ExitHere:
    On Error Resume Next
    Set tdf = Nothing
    Set db = Nothing
    Exit Function

ErrHandle:
    MsgBox "Error " & Err.Number & " " & Err.Description & vbCrLf _
    & "In Procedure PAWTablesFieldsList of modPAWSaveAsText"
    Resume ExitHere

End Function



'---------------------------------------------------------------------------------------
' Procedure : FolderExists
' Author    : Allen Browne http://allenbrowne.com/func-11.html
' Purpose   : Returns True if a Directory Exists, False if it does not Exist
' Arguments : strPath is the full path of the folder
'---------------------------------------------------------------------------------------
'
Function FolderExists(strPath As StringAs Boolean
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function