Help for the Access 2000-2003 developer with 'Out of Memory' issues or problematic codebase

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