|
Sunday, June 20, 2010 - 12:15 AM
Option Compare Database
Option Explicit
Option Base 1
'this code is for exporting Access databases to text files (which are compatible with version control software, such as MS SourceSafe)
' and for rebuilding the database from said text files
'converting to and rebuilding from text files is an important way of identifying, preventing, and repairing corruption
'this code will export everything needed to fully rebuild files,
' including references, linked tables, as well as all standard Access objects
'this is setup to use the command-line version of Subversion, which is free
'you can easily find an Access add-in for MS SourceSafe though, and SourceSafe comes with Visual Studio
'if using svn software, export must go into a folder containing no
text files
' because old text files won't be over-written by new ones with the same names,
' so they would get
added to the rebuilt access file
'similar code can be written for Excel, but there is less worry about corruption with Excel
'compatible with Access 03 and Access 07
Public Sub ExportDatabaseObjects(sExportLocation$, Optional
UseBaseFile As Boolean)
On Error GoTo ErrHandler
Dim td
As TableDef, d As Document, c As Container, dap As AccessObject
Dim i&, r As Reference, sErrType$, sErrName$, tempStr$
Dim db As Database: Set db = CurrentDb()
sExportLocation =
sExportLocation & "\"
RunCommand
acCmdCompileAndSaveAllModules
sErrType = "Reference"
sErrName = "Object Name NA"
If UseBaseFile Then
'export base (ie, non-linked tables with
data, references) - must be .accdb format, not .accde
Dim filename$: filename = sExportLocation & "Base_" &
Replace(CurrentProject.name, CurrentProject.path, "")
SaveAsText 6, "", filename
Else
tempStr =
sExportLocation & "References_All.txt"
If (Len(Dir(tempStr)) > 0) Then Kill tempStr
Open
tempStr For Append As #1
For Each r In
CurrentProject.Application.References
With r
If Not .BuiltIn Then Write #1, .Guid & "|||" & .Major &
"|||" & .Minor
End With
Next
Close #1
End If
sErrType = "LinkedTable"
tempStr = sExportLocation &
"LinkedTables_All.txt"
If (Len(Dir(tempStr)) > 0) Then Kill
tempStr
Open tempStr For Append As #1
For Each td In db.TableDefs
With td
sErrName = td.name
If (.SourceTableName <>
"") Then Write #1, .Connect & "|||" & .SourceTableName &
"|||" & .name
End With
Next
Close #1
sErrType =
"Table"
For Each td In db.TableDefs
sErrName = td.name
If
(Left(sErrName, 4) <> "MSys") And (td.SourceTableName = "") Then
'skipping linked tables
DoCmd.TransferText acExportDelim, , sErrName,
sExportLocation & "Table_" & sErrName & ".txt", True
End If
Next
sErrType = "Form"
Set c =
db.Containers("Forms")
For Each d In c.documents
sErrName = d.name
SaveAsText
acForm, sErrName, sExportLocation & "Form_" & sErrName &
".txt"
Next
sErrType = "Report"
Set c = db.Containers("Reports")
For Each d In c.documents
sErrName = d.name
SaveAsText acReport, sErrName,
sExportLocation & "Report_" & sErrName & ".txt"
Next
sErrType = "Macro"
Set c =
db.Containers("Scripts")
For Each d In c.documents
sErrName = d.name
SaveAsText acMacro, sErrName, sExportLocation & "Macro_" &
sErrName & ".txt"
Next
sErrType = "Module"
Set c =
db.Containers("Modules")
For Each d In c.documents
sErrName = d.name
SaveAsText acModule, sErrName, sExportLocation & "Module_" &
sErrName & ".txt"
Next
sErrType = "Query"
For i = 0 To
db.QueryDefs.Count - 1
sErrName = db.QueryDefs(i).name
SaveAsText acQuery, sErrName, sExportLocation & "Query_" &
sErrName & ".txt"
Next
sErrType = "DataAccessPage"
For Each dap
In CurrentProject.AllDataAccessPages
sErrName = dap.name
SaveAsText acDataAccessPage, sErrName, sExportLocation &
"DataAccessPage_" & sErrName & ".txt"
Next
Set db = Nothing: Set c = Nothing
' Call
SubversionCommit 'optional
Exit Sub
ErrHandler:
'could trigger decompile, and start export over (only one time though,
if it fails again)
Call MsgBox("The file appears to be corrupted.
It may need to be decompiled," & _
"using the undocumented Access.exe command line switch:" & _
"msaccess /decompile <your database name>" & Chr(10) &
Chr(10) & _
sErrName & ". " & sErrType & ". "
& Err.number & ". " & Err.description & ".",
vbCritical, "")
Resume Next
End Sub
Public Sub RecreateDatabase(sSourceFilePath$,
sNewFilePath$, Optional sNewFileName$, Optional UseBaseFile As Boolean)
'could check for base file instead of using argument, but that might be confusing in practice
Dim filename$, ObjName$, sObjType$,
iObjType&, Index As Byte, aTypes, td As TableDef
Dim r As References,
aParams, bErrObj As Boolean, sErrMsg$, StopMsgBoxes As Byte
Dim app As Access.Application: Set app = New Access.Application
On Error GoTo ErrFailed
If (Len(sNewFileName) = 0) Then
_
sNewFileName = Replace(CurrentProject.name,
CurrentProject.path, "")
'make
sure there isn't already a file with the new file name
Dim i As Byte, tempStr$: tempStr = sNewFileName
If Not
(Dir(tempStr) = "") Or Not (Dir(Left(tempStr, Len(tempStr) - 1) &
"e") = "") Then
For i = 1 To 100
tempStr =
sNewFilePath & "\" & Left(sNewFileName, InStrRev(sNewFileName,
".") - 1) & _
i & Right(sNewFileName, Len(sNewFileName) -
InStrRev(sNewFileName, ".") + 1)
If (Dir(tempStr) = "")
And (Dir(Left(tempStr, Len(tempStr) - 1) & "e") = "") Then Exit For
Next
sNewFileName = tempStr
End If
With app
If UseBaseFile Then
'find base file
filename = Dir(sSourceFilePath & "\") 'first file in directory
Do
Index = InStr(filename, "_")
If (Index >= 0) Then
sObjType =
Left(filename, Index - 1)
If (sObjType = "Base")
Then
filename = sSourceFilePath & "\" &
filename
Exit Do
End
If
End If
filename = Dir 'next
file in directory
Loop Until (filename = "")
If (filename = "")
Then MsgBox ("Couldn't find base file. Creating blank file instead."):
GoTo CreateBlankFile
'copy base file to new location and
rename it
FileCopy
filename, sNewFileName
.OpenCurrentDatabase sNewFileName
Else
CreateBlankFile:
'create blank file in new
location
Dim ws As Workspace, dbNew As DAO.Database
Set ws = DBEngine.Workspaces(0) 'get default workspace
sNewFileName = sNewFileName
'sNewFilePath & "\" & sNewFileName
Set dbNew =
ws.CreateDatabase(sNewFileName, dbLangGeneral)
Set
dbNew = Nothing
.OpenCurrentDatabase sNewFileName
'get references from text file
On Error GoTo ErrHandler
Dim
iFileNum&, sBuf$
iFileNum = FreeFile()
Open sSourceFilePath & "\" & "References_All.txt" For Input As
iFileNum
On Error Resume Next
Do While Not
EOF(iFileNum)
Line Input #iFileNum, sBuf
aParams = Split(Replace(sBuf, Chr(34), ""), "|||")
.References.AddFromGuid Trim(aParams(0)),
CLng(Trim(aParams(1))), CLng(Trim(aParams(2))) '.Guid, .Major, .Minor
Loop
On Error GoTo ErrHandler
Close iFileNum
'get linked tables from text
file
iFileNum = FreeFile()
Open sSourceFilePath & "\" & "LinkedTables_All.txt"
For Input As iFileNum
On Error Resume Next
Do While Not EOF(iFileNum)
Line Input #iFileNum,
sBuf
aParams = Split(Replace(sBuf, Chr(34), ""), "|||")
Set td = .CurrentDb.CreateTableDef(Trim(aParams(2)))
With td
.Connect = Trim(aParams(0))
.SourceTableName = Trim(aParams(1))
End With
.CurrentDb.TableDefs.Append td
Loop
On Error GoTo ErrHandler
Close iFileNum
End If
'import objects
On Error GoTo
ErrHandler
filename = Dir(sSourceFilePath
& "\") 'first file in directory
bErrObj = True
aTypes = Array("Base", "References", "LinkedTables")
Do
Index = InStr(filename, "_")
If (Index >=
0) Then
sObjType = Left(filename, Index - 1)
ObjName = MID(filename, Index + 1)
ObjName =
Left(ObjName, Len(ObjName) - 4)
filename = sSourceFilePath & "\" & filename
If Not fIn(sObjType, aTypes) And (Left(ObjName, 3) <> "~sq") Then
Select Case sObjType
Case
"Table": iObjType = acTable
Case "Query":
iObjType = acQuery
Case "Form": iObjType = acForm
Case "Report": iObjType = acReport
Case "Macro": iObjType = acMacro
Case "Module":
iObjType = acModule
Case "DataAccessPage":
iObjType = acDataAccessPage
Case Else: Stop
End Select
If (iObjType <> acTable) Then
.LoadFromText iObjType, ObjName, filename
Else
.DoCmd.TransferText acImportDelim, , ObjName,
filename, True
End If
End If
End If
filename = Dir 'next file in directory
Loop Until (filename = "")
bErrObj = False
End
With
On Error GoTo ErrFailed
'clean up
With app
.RunCommand
acCmdCompileAndSaveAllModules
.CloseCurrentDatabase
.Quit
End With
Set app = Nothing
Exit Sub
ErrHandler:
'could trigger
decompile, and start export over (just repeat once though - if it fails
after decompile, give up)
If bErrObj Then sErrMsg = Chr(10) &
Chr(10) & ObjName & ". " & sObjType & ". " Else sErrMsg
= ""
If (StopMsgBoxes <> 1) Then
Call MsgBox("The file
appears to be corrupted. It may need to be decompiled," & _
"using the undocumented Access.exe command line switch:" & _
"msaccess /decompile <your database name>" &
Chr(10) & Chr(10) & _
sErrMsg & Err.number
& ". " & Err.description, vbCritical, "")
If (StopMsgBoxes < 2) Then If (MsgBox("Stop showing message
boxes for errors?", vbYesNo, "") = vbYes) Then _
StopMsgBoxes = 1 Else StopMsgBoxes = 2
End If
Debug.Print
ObjName & ". " & sObjType & ". " & Err.number & ". "
& Err.description
Resume Next
ErrFailed:
Call MsgBox(Err.number & ". "
& Err.description & ".", vbCritical, "")
Exit Sub
End
Sub
Public Sub SetDirectoryForSVN()
ExecCMD
("cd " & gvSvnSourceFilePath)
End Sub
'svn functions
Public Function
SubversionCheckout()
Call SetDirectoryForSVN
ExecCMD ("svn
checkout --username " & gvUserName & gvSvnUrl)
End Function
Public Function SubversionCommit()
Call
SetDirectoryForSVN
ExecCMD ("svn commit") 'text editor will be
launched for entering comments - google 'svn-book.pdf' for instructions
for setting text editor preferences
End Function
Public Function SubversionUpdate()
Call
SetDirectoryForSVN
ExecCMD ("svn update")
End Function
'functions for calling above subs
Public
Function fExportDatabaseObjects()
Call ExportDatabaseObjects(gvSvnSourceFilePath)
End Function
Public Function fRecreateDatabase()
Call
RecreateDatabase(gvSvnSourceFilePath, gvSvnNewFilePath)
End
Function
'this is in lieu of excel's match function
Public Function fIn(inVal, inArray) As Boolean
Dim i&: On Error GoTo Failed
For i = LBound(inArray) To UBound(inArray)
If (inArray(i) = inVal) Then fIn = True: Exit Function
Next
Failed:
End Function
|