Friday, September 23, 2016

Document Access Database (*.mdb)

Public Sub DocumentDatabase()
    Dim path As String
    path = Application.CurrentProject.path & "\" + Replace(Application.CurrentProject.Name, ".mdb", "") + "\"
   
    On Error Resume Next
    Kill path & "Forms\*.*"
    Kill path & "Reports\*.*"
    Kill path & "Macros\*.*"
    Kill path & "Modules\*.*"
    Kill path & "Queries\*.*"
   
    On Error GoTo Err_DocDatabase
    Dim dbs As Database
    Dim cnt As Container
    Dim doc As Document
    Dim i As Integer
   
    Set dbs = CurrentDb() ' use CurrentDb() to refresh Collections
   
    Set cnt = dbs.Containers("Forms")
    For Each doc In cnt.Documents
        Application.SaveAsText acForm, doc.Name, path & "Forms\" & doc.Name & ".frm"
    Next doc
   
    Set cnt = dbs.Containers("Reports")
    For Each doc In cnt.Documents
        Application.SaveAsText acReport, doc.Name, path & "Reports\" & doc.Name & ".rpt"
    Next doc
   
    Set cnt = dbs.Containers("Scripts")
    For Each doc In cnt.Documents
        Application.SaveAsText acMacro, doc.Name, path & "Macros\" & doc.Name & ".vbs"
    Next doc
   
    Set cnt = dbs.Containers("Modules")
    For Each doc In cnt.Documents
        Application.SaveAsText acModule, doc.Name, path & "Modules\" & doc.Name & ".bas"
    Next doc
   
    'Dim obj As Object
    'For Each obj In Application.CurrentData.AllTables
        'Application.ExportXML acExportQuery, obj.Name, , path & "Tables\" & obj.Name & ".xsd"
    'Next
   
    For i = 0 To dbs.QueryDefs.Count - 1
        Application.SaveAsText acQuery, dbs.QueryDefs(i).Name, path & "Queries\" & dbs.QueryDefs(i).Name & ".sql"
    Next i
   
    'For i = 0 To dbs.TableDefs.Count - 1
    '    Application.ExportXML acExportTable, dbs.TableDefs(i).Name, , path & "Tables\" & dbs.TableDefs(i).Name & ".xsd"
    'Next i
   
    Set doc = Nothing
    Set cnt = Nothing
    Set dbs = Nothing
   
    MsgBox "Done"
Exit_DocDatabase:
    Exit Sub
   
Err_DocDatabase:
    Select Case Err

    Case Else
        MsgBox Err.Description
        Resume Exit_DocDatabase
    End Select
End Sub

No comments: