If you are experiencing 'Out of Memory' issues with Access 2003 SP3 when you save code/forms, please download Hotfix KB945674 from Microsoft. This hotfix was developed for us specifically to remedy the 'Out of Memory' issues. This does not completely resolve them, but it does help a little.
This filter routine essentially creates a new .MDB file, and imports all of your objects into it (excluding Tables, linked tables, and menu items).
This has saved our butts many many times. So I thought I would share it with you...
You need to create a new .MDB that contains a single module named '
modFilterDatabaseObjects'. Once it is created, simply paste the code below into the editor window of that module.
Now, once you compile, you can execute the following in your Immediate Window...
FilterDB("[File path to DB to filter]")
NOTE: If you have an Autoexec macro in your database, you will need to HOLD THE SHIFT KEY when you press 'Enter' to execute the routine.
When executed, it will create a new file next to the specified database. If your file was called '
CodeBase.mdb', the new file will be '
CodeBaseFiltered.mdb'.
When it runs, you will see the status being updated in the Immediate Window. Once it is complete, you can open the newly created database and import your Tables & Menus from your old, non-filtered data file.
Option Compare Database
Option Explicit
'This function was provided by Microsoft to filter all of the objects in a database.
'It saves every object in the database to a text file, and then reloads those objects
'individually from the text files into a new database.
'It will reload every object in our code base, EXCEPT for the toolbars and tables.
'It does, however, bring over the references.
Function FilterDB(strFilePath As String)
Dim objAccess As Object
Dim strFolder As String
Dim strCurrentFile As String
Dim strCurrentObject As String
Dim strFilteredDB As String
Dim fs
Dim ref
Dim f As Object
Dim objtype As AcObjectType
Dim objAllObjects As New Collection
Dim objObjectGroup As Object
Dim intObjType As Integer
Dim I As Integer
Dim j As Integer
Dim intRefNum As Integer
Dim refItem As Reference
Dim arrayRefs() As String
Dim strErrMsg As String
'Open the source database
Set objAccess = CreateObject("Access.Application")
On Error GoTo ErrorHandler
objAccess.OpenCurrentDatabase strFilePath, False
strFolder = GetDirectoryFromPath(strFilePath)
strFilteredDB = Left(strFilePath, Len(strFilePath) - 4) & "filtered.mdb"
With objAllObjects
.add objAccess.CurrentData.AllQueries
.add objAccess.CurrentProject.AllForms
.add objAccess.CurrentProject.AllReports
.add objAccess.CurrentProject.AllMacros
.add objAccess.CurrentProject.AllModules
.add objAccess.CurrentProject.AllDataAccessPages
End With
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(strFolder & "\texttmp") Then
fs.CreateFolder (strFolder & "\texttmp")
End If
For I = 1 To objAllObjects.Count
If objAllObjects(I).Count > 0 Then
For j = 0 To objAllObjects(I).Count - 1
Set objObjectGroup = objAllObjects(I)
strCurrentObject = objObjectGroup(j).Name
intObjType = objObjectGroup(j).Type
Debug.Print "Saving object " & strCurrentObject
objAccess.SaveAsText intObjType, strCurrentObject, _
strFolder & "texttmp\" & strCurrentObject & intObjType & ".txt"
Next j
End If
Next I
'Bring in All the references
On Error Resume Next
ReDim arrayRefs(objAccess.References.Count - 1, 2) As String
For Each refItem In objAccess.References()
If Not IsError(refItem.Name) Then
arrayRefs(intRefNum, 0) = refItem.Name
arrayRefs(intRefNum, 1) = refItem.FullPath
intRefNum = intRefNum + 1
End If
Next refItem
On Error GoTo ErrorHandler
Debug.Print ""
objAccess.Quit
Set objAccess = Nothing
Set objAccess = CreateObject("Access.Application")
objAccess.NewCurrentDatabase strFilteredDB
'Finds the first occurrence of a text file in the
'texttmp folder.
strCurrentFile = dir(strFolder & "\texttmp" & "\*.txt")
'Count the files in the folder.
Set f = fs.GetFolder(strFolder)
'Check to see if the folder is empty.
'If not, load in all the files from there
If f.Files.Count <> 0 Then
Do Until strCurrentFile = ""
intObjType = Mid(strCurrentFile, Len(strCurrentFile) - 4, 1)
Debug.Print "Loading Object " & strCurrentFile
objAccess.LoadFromText intObjType, _
Left(strCurrentFile, Len(strCurrentFile) - 5), _
strFolder & "\texttmp\" & strCurrentFile
strCurrentFile = dir
Loop
End If
On Error Resume Next
For I = 0 To UBound(arrayRefs())
Set ref = objAccess.References.AddFromFile(arrayRefs(I, 1))
Next I
MsgBox "Finished creating filtered file:" & Chr(10) _
& objAccess.CurrentProject.FullName & "."
FunctionEnd:
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(strFolder & "\texttmp") Then
fs.DeleteFolder (strFolder & "\texttmp")
End If
objAccess.Quit
Set objAccess = Nothing
Set f = Nothing
Exit Function
ErrorHandler:
Select Case err.Number
Case 58, 7866
strErrMsg = "The path\file name " & strFilePath _
& " may be incorrect or the " _
& Chr(10) & " database is opened exclusively by someone else." _
& Chr(10) & Chr(10) & _
"Please insure your path and file name are correct " _
& Chr(10) & "and the database is not open."
Case 7865
strErrMsg = "The follwing database:" & Chr(10) & Chr(10) _
& strFilteredDB & Chr(10) & Chr(10) _
& "already exists." _
& Chr(10) & Chr(10) & _
" Please rename, move, or delete it before running" _
& "the FilterDB function."
Case Else
strErrMsg = "Access Error #" & err.Number & Chr(10) & Chr(10) & _
err.Description
End Select
MsgBox strErrMsg
GoTo FunctionEnd
End Function
