[AccessD] Add-In Express 2009 for MS Office and .NET

Section 2 - Export

Max

Private Sub sExportAllObjects()
    On Error GoTo errhandler
    Dim dbs As DAO.Database, qdf As DAO.QueryDef
    Dim obj As Object, prjObj As Object
    Dim lngLoop As Integer
    Dim sql As String
    Dim strTemp As String
    Dim bProcess As Boolean, bLocalTables As Boolean, bLinkedTables As
Boolean
    Set dbs = CurrentDb
    Set prjObj = Application.CurrentProject
    ' we are going to export EVERYTHING in this demo
    'Select Case lngObjectType
    'Case acForm
    For Each obj In prjObj.AllForms
        strObj = obj.Name: strObjPath = strDir & conPathForms & strObj &
".txt"
        Call fExport(acForm, "")
    Next obj
    'Case acMacro
    For Each obj In prjObj.AllMacros
        strObj = obj.Name: strObjPath = strDir & conPathMacros & strObj &
".txt"
        Call fExport(acMacro, "")
    Next obj
    'Case acModule
    For Each obj In prjObj.AllModules
        strObj = obj.Name: strObjPath = strDir & conPathModules & strObj &
".txt"
        Call fExport(acModule, "")
    Next obj
    'Case acDataAccessPage
    For Each obj In prjObj.AllDataAccessPages
        strObj = obj.Name: strObjPath = strDir & conPathPages & strObj &
".txt"
        Call fExport(acDataAccessPage, "")
    Next obj
    'Case acReport
    For Each obj In prjObj.AllReports
        strObj = obj.Name: strObjPath = strDir & conPathReports & strObj &
".txt"
        Call fExport(acReport, "")
    Next obj
    'Case acQuery
    For lngLoop = 0 To dbs.QueryDefs.Count - 1
        Set qdf = dbs.QueryDefs(lngLoop)
        If Not Left(qdf.Name, 1) = "~" And Not Left(qdf.Name, 4) = "Msys"
Then
            strObj = qdf.Name: strObjPath = strDir & conPathQueries & strObj
& ".txt"
            Call fExport(acQuery, "")
        End If
    Next lngLoop
    'Case acTable
    For lngLoop = 0 To dbs.TableDefs.Count - 1
        bProcess = False
        Set obj = dbs.TableDefs(lngLoop)
        If Not InStr(obj.Name, "ExportError") > 0 Then
            If Not Left(obj.Name, 1) = "~" And Not Left(obj.Name, 4) =
"Msys" Then
                strObj = obj.Name
                If InStr(obj.Connect, ";") > 0 Then
                    bLinkedTables = True
                    If bLinkedTables Then
                        strObjPath = strDir & conPathTables & "Linked\" &
strObj
                        bProcess = True
                    End If
                Else
                    bLocalTables = True
                    If bLocalTables Then
                        strObjPath = strDir & conPathTables & "Local\" &
strObj
                        bProcess = True
                    End If
                End If
                If bProcess = True Then
                    Call fExport(acTable, "XLS")
                End If
            End If
        End If
    Next lngLoop
    'End Select
exithere:
    Set dbs = Nothing: Set qdf = Nothing: Set obj = Nothing: Set prjObj =
Nothing
    Exit Sub
errhandler:
    MsgBox "Unhandled Error in sExportAllObjects(): " & Err.Number & vbCrLf
& Err.Description
    Resume Next
End Sub

Private Function fExport(lngObjectType As Long, strTableType As String) As
Boolean
    On Error GoTo errhandler
    Dim dbs As DAO.Database, qdf As DAO.QueryDef
    Dim sql As String, strIn As String, lngLoop As Long
    Set dbs = CurrentDb
    fExport = True  ' default to ok
    Select Case lngObjectType
    Case 0  'acTable
        If Right(strObjPath, 4) = ".txt" Then strObjPath = Left(strObjPath,
Len(strObjPath) - 4) ' drop the .txt bit
        If strTableType = "XLS" Then
            If Not InStr(strObj, "ExportError") > 0 Then
                ' if you want CSV then uncomment next line and create a sub
folder BUT you cannot IMPORT from a CSV file.
                'DoCmd.TransferText A_EXPORTDELIM, , strObj, strPath &
".CSV", True 'uncomment this if you want CSV file as well (but it cannot be
re-imported as CSV)
                DoCmd.TransferSpreadsheet acExport, , strObj, strObjPath,
True
            End If
        ElseIf strTableType = "XML" Then
            If Not InStr(strObj, "ExportError") > 0 Then
                Application.ExportXML ObjectType:=acExportTable,
DataSource:=strObj, DataTarget:=strObjPath & ".xml",
schemaTarget:=strObjPath & "Schema.xml"
            End If
        End If
    Case 1  'acQuery
       ' Print #pIntFileNumber, strObj & ".txt"
        Set qdf = dbs.QueryDefs(strObj)
        sql = qdf.sql
        pIntFileNumber2 = FreeFile
        Open strObjPath For Output As pIntFileNumber2
        Print #pIntFileNumber2, sql
        Close pIntFileNumber2
    Case 2, 3, 4, 5  'Form, Report, Macro, Module
        Application.SaveAsText lngObjectType, strObj, strObjPath
    Case 6  '  acDataAccessPage not handled - sorry, don't use them.
    Case Else
        MsgBox "Unidentified Object-Type for Export."
        fExport = False
    End Select
exithere:
    Set dbs = Nothing: Set qdf = Nothing
    Exit Function
errhandler:
    fExport = False
    Select Case Err.Number
    Case Else
        MsgBox "Unhandled Error in  fExport(): " & Err.Number & vbCrLf &
Err.Description
        Resume Next
    End Select
    Resume exithere
End Function