Option Compare Database
Option Explicit
Public iCountForms As Integer
Public iCountReports As Integer
Public iCountQueries As Integer
Public iCountModules As Integer
Public iCountScripts As Integer 'macros
Public iCountTables As Integer
Public Sub ExportOnClose()
Dim strPath As String
Dim strFullPath As String
Dim objFSO As Object
Dim strMsg As String
Dim strDBName As String
Dim iStartName As Integer
Dim iStartExt As Integer
Dim iLength As Integer
Dim SeqNum As Integer
Dim EndLoop As Boolean
On Error GoTo ErrProc
'''' 'create new folder
iStartName = InStrRev(CurrentDb.Name, "\") + 1
iStartExt = InStrRev(CurrentDb.Name, ".")
iLength = iStartExt - iStartName
strDBName = Mid(CurrentDb.Name, iStartName, iLength)
strPath = DLookup("NetworkPath", "tblBackupTheseUserNames", "UserName = " & QUOTE & Environ("UserName") & QUOTE) & ""
If strPath = "" Then 'no back up for logged in user
Exit Sub
End If
'''' 'Create path for database
If Right(strPath, 1) = "\" Then
Else
strPath = strPath & "\"
End If
strPath = strPath & strDBName
Debug.Print "strpath = " & strPath
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strPath) Then
objFSO.CreateFolder (strPath)
End If
'''' 'create path for database for today --- Add suffix if necessary
EndLoop = False
SeqNum = 0
strPath = strPath & "\"
strFullPath = strPath & strDBName & "_" & Format(Date, "yyyymmdd")
Debug.Print "strfullpath = " & strFullPath
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strFullPath) Then
objFSO.CreateFolder (strFullPath)
Else
Do Until EndLoop = True
SeqNum = SeqNum + 1
strFullPath = strPath & strDBName & "_" & Format(Date, "yyyymmdd") & "_" & Format(SeqNum, "000")
If Not objFSO.FolderExists(strFullPath) Then
objFSO.CreateFolder (strFullPath)
EndLoop = True
Debug.Print strFullPath
Else
End If
Loop
End If
'''' 'export all objects
MsgBox "This may take a few minutes. Please wait for the count message.", vbOKOnly
Call ExportDatabaseObjects("forms", strFullPath, CurrentDb.Name)
Call ExportDatabaseObjects("reports", strFullPath, CurrentDb.Name)
Call ExportDatabaseObjects("modules", strFullPath, CurrentDb.Name)
Call ExportDatabaseObjects("QueryDefs", strFullPath, CurrentDb.Name)
Call ExportDatabaseObjects("scripts", strFullPath, CurrentDb.Name)
strMsg = "Exported Forms = " & iCountForms & vbCrLf
strMsg = strMsg & " Reports = " & iCountReports & vbCrLf
strMsg = strMsg & " Modules = " & iCountModules & vbCrLf
strMsg = strMsg & " Queries = " & iCountQueries & vbCrLf
strMsg = strMsg & " Macros = " & iCountScripts & vbCrLf
strMsg = strMsg & " Tables = " & iCountTables & vbCrLf
MsgBox "Selected objects have been exported as a text file to " & strPath, vbInformation
Debug.Print strMsg
MsgBox strMsg, vbOKOnly
ExitProc:
Exit Sub
ErrProc:
Select Case Err.Number
Case Else
MsgBox Err.Number & "--" & Err.Description
End Select
Resume ExitProc
Resume
End Sub
Public Sub ExportDatabaseObjects(ExportType As String, sExportLocation As Variant, strDatabase As Variant)
On Error GoTo Err_ExportDatabaseObjects
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim d As Document
Dim c As Container
Dim i As Integer
If strDatabase & "" = "" Then
Set db = CurrentDb()
Else
Set db = DBEngine.Workspaces(0).OpenDatabase(strDatabase)
End If
If Right(sExportLocation, 1) = "\" Then
Else
sExportLocation = sExportLocation & "\"
End If
Select Case ExportType
Case "Tables"
iCountTables = 0
For Each td In db.TableDefs 'Tables
If Left(td.Name, 4) <> "MSys" Then
DoCmd.TransferText acExportDelim, , td.Name, sExportLocation & "Table_" & td.Name & ".txt", True
iCountTables = iCountTables + 1
End If
Next td
Case "Forms"
Set c = db.Containers("Forms")
iCountForms = 0
For Each d In c.Documents
Application.SaveAsText acForm, d.Name, sExportLocation & "Form_" & d.Name & ".txt"
iCountForms = iCountForms + 1
Next d
Case "Reports"
Set c = db.Containers("Reports")
iCountReports = 0
For Each d In c.Documents
Application.SaveAsText acReport, d.Name, sExportLocation & "Report_" & d.Name & ".txt"
iCountReports = iCountReports + 1
Next d
Case "Scripts"
Set c = db.Containers("Scripts")
iCountScripts = 0
For Each d In c.Documents
Application.SaveAsText acMacro, d.Name, sExportLocation & "Macro_" & d.Name & ".txt"
iCountScripts = iCountScripts + 1
Next d
Case "Modules"
Set c = db.Containers("Modules")
iCountModules = 0
For Each d In c.Documents
Application.SaveAsText acModule, d.Name, sExportLocation & "Module_" & d.Name & ".txt"
iCountModules = iCountModules + 1
Next d
Case "Querydefs"
iCountQueries = 0
For i = 0 To db.QueryDefs.Count - 1
Application.SaveAsText acQuery, db.QueryDefs(i).Name, sExportLocation & "Query_" & db.QueryDefs(i).Name & ".txt"
iCountQueries = iCountQueries + 1
Next i
Case Else
End Select
Set db = Nothing
Set c = Nothing
'''' MsgBox "Selected objects have been exported as a text file to " & sExportLocation, vbInformation
Exit_ExportDatabaseObjects:
Exit Sub
Err_ExportDatabaseObjects:
MsgBox Err.Number & " - " & Err.Description
Resume Exit_ExportDatabaseObjects
