Max Wanadoo
max.wanadoo at gmail.com
Fri Feb 12 03:50:38 CST 2010
ModEATBloat - Max
Option Compare Database
Option Explicit
Const conPathStem As String = "\ExportedAsText\"
Const conPathPages As String = "Pages\"
Const conPathForms As String = "Forms\"
Const conPathMacros As String = "Macros\"
Const conPathModules As String = "Modules\"
Const conPathQueries As String = "Queries\"
Const conPathReports As String = "Reports\"
Const conPathTables As String = "Tables\"
Const conpathTablesLocal As String = "Tables\Local\"
Const conpathTablesLinked As String = "Tables\Linked\"
Private strObjPath As String
Private strObj As String
Private strDir As String
Private pIntFileNumber As Integer, pIntFileNumber2 As Integer
Private Sub sStart()
Call sCheckAndCreateSubDirs(strDir)
Call sExportAllObjects
Call sImportAllObjects
MsgBox "Done"
End Sub
Private Sub sCheckAndCreateSubDirs(strDir As String)
On Error GoTo errhandler
strDir = Application.CurrentProject.Path & conPathStem
Call fCreateFolder(strDir)
Call fCreateFolder(strDir & conPathPages)
Call fCreateFolder(strDir & conPathForms)
Call fCreateFolder(strDir & conPathMacros)
Call fCreateFolder(strDir & conPathModules)
Call fCreateFolder(strDir & conPathQueries)
Call fCreateFolder(strDir & conPathReports)
Call fCreateFolder(strDir & conPathTables)
Call fCreateFolder(strDir & conpathTablesLocal)
Call fCreateFolder(strDir & conpathTablesLinked)
exithere:
Exit Sub
errhandler:
MsgBox "Unhandled Error in sCheckAndCreateSubDirs(): " & Err.Number &
vbCrLf & Err.Description
Resume Next
End Sub
Private Function fCreateFolder(sFolder As String) As Boolean
'An error occurs if the specified folder already exists, and that is ok.
On Error GoTo errhandler
Dim fs
fCreateFolder = False
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateFolder sFolder
fCreateFolder = True
exithere:
Exit Function
errhandler:
fCreateFolder = False
Select Case Err.Number
Case 58 ' Folder already exists
fCreateFolder = True
Resume exithere
Case 76 ' path not found, create intermediate folders
Resume exithere
Case 70 ' system not allowing
Resume exithere
Case Else
MsgBox "Cannot Create Folder Error in fCreateFolder():" & Err.Number
& vbCrLf & Err.Description
End Select
Resume exithere
End Function
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 youcannot IMPORT from a CSV file.
'DoCmd.TransferText A_EXPORTDELIM, , strObj, strPath &
".CSV", True
DoCmd.TransferSpreadsheet acExport, , strObj, strObjPath,
True
End If
ElseIf strTableType = "XML" Then
If Not InStr(strObj, "ExportError") > 0 Then ' v.e.r.y slow.
'Application.ExportXML ObjectType:=acExportTable,
DataSource:=strObj, DataTarget:=strObjPath & ".xml",
schemaTarget:=strObjPath & "Schema.xml"
End If
End If
Case 1 'acQuery
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
Private Sub sImportAllObjects()
On Error GoTo errhandler
Dim strTemp As String, strFile As String, strPath As String, sql As
String, strIn As String
Dim dbs As DAO.Database, qdf As DAO.QueryDef
Set dbs = CurrentDb
strDir = Application.CurrentProject.Path & conPathStem
' ' Forms
strPath = strDir & "Forms\"
strTemp = Dir(strPath)
Do While strTemp <> ""
strFile = Left(strTemp, InStrRev(strTemp, ".txt") - 1)
' Application.LoadFromText acForm, strFile, strPath & strTemp
strTemp = Dir()
Loop
' ' Macros
strPath = strDir & "Macros\"
strTemp = Dir(strPath)
Do While strTemp <> ""
strFile = Left(strTemp, InStrRev(strTemp, ".txt") - 1)
'Application.LoadFromText acMacro, strFile, strPath & strTemp
strTemp = Dir()
Loop
' ' Modules
strPath = strDir & "Modules\"
strTemp = Dir(strPath)
Do While strTemp <> ""
strFile = Left(strTemp, InStrRev(strTemp, ".txt") - 1)
If strFile <> "modEatBloat" Then 'don't overright self
'Application.LoadFromText acModule, strFile, strPath & strTemp
End If
strTemp = Dir()
Loop
' ' Queries
strPath = strDir & "Queries\"
strTemp = Dir(strPath)
Do While strTemp <> ""
strFile = Left(strTemp, InStrRev(strTemp, ".txt") - 1)
pIntFileNumber2 = FreeFile: sql = ""
Open strPath & strTemp For Input As pIntFileNumber2
Do While Not EOF(pIntFileNumber2)
Line Input #pIntFileNumber2, strIn: sql = sql & strIn & vbCrLf
Loop
Close pIntFileNumber2
On Error Resume Next ' if it exists then delete first, then
recreate it
DoCmd.DeleteObject acQuery, strFile
On Error GoTo errhandler
Set qdf = dbs.CreateQueryDef(strFile, sql)
strTemp = Dir()
Loop
' Reports
strPath = strDir & "Reports\"
strTemp = Dir(strPath)
Do While strTemp <> ""
strFile = Left(strTemp, InStrRev(strTemp, ".txt") - 1)
Application.LoadFromText acReport, strFile, strPath & strTemp
strTemp = Dir()
Loop
' Tables
strPath = strDir & "Tables\Local\"
strTemp = Dir(strPath)
Do While strTemp <> ""
Select Case Right(strTemp, 4)
Case ".xls"
strFile = Left(strTemp, InStrRev(strTemp, ".xls") - 1)
On Error Resume Next
sql = "Drop Table " & strFile
DoCmd.TransferSpreadsheet acImport, , strFile, strPath &
strTemp, True
Case ".xml"
' If Not InStr(strObj, "Schema") > 0 Then
' Application.ImportXML strObjPath,
acStructureAndData
' End If
End Select
strTemp = Dir()
Loop
exithere:
Set dbs = Nothing: Set qdf = Nothing
Exit Sub
errhandler:
Select Case Err.Number
Case Else
MsgBox "Unhandled Error in sImportAllObjects(): " & Err.Number &
vbCrLf & Err.Description
End Select
Resume Next
End Sub