Max Wanadoo
max.wanadoo at gmail.com
Thu Feb 11 15:07:33 CST 2010
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