SoFunction
Updated on 2025-04-08

How to recover deleted records under access; how to recover deleted tables, forms and other objects


If it has not been compressed, it is theoretically OK. Try this code. Added in the access module
Recover deleted worksheets (not compressed)
 
Public Function FnUndeleteObjects() As Boolean
  On Error GoTo ErrorHandler:
  Dim strObjectName           As String
  Dim rsTables                As 
  Dim dbsDatabase             As 
  Dim tDef                    As 
  Dim qDef                    As 
  Dim intNumDeletedItemsFound As Integer
  Set dbsDatabase = CurrentDb
  For Each tDef In 
      'This is actually used as a 'Deleted Flag'
      If  And dbHiddenObject Then
         strObjectName = FnGetDeletedTableNameByProp()
         strObjectName = InputBox("A deleted TABLE has been found." & _
                         vbCrLf & vbCrLf & _
                         "To undelete this object, enter a new name:", _
                         "Access Undelete Table", strObjectName)

         If Len(strObjectName) > 0 Then
            FnUndeleteTable CurrentDb, , strObjectName
         End If
         intNumDeletedItemsFound = intNumDeletedItemsFound + 1
      End If
  Next tDef

  For Each qDef In 
      'Note 'Attributes' flag is not exposed for QueryDef objects,
      'We could look up the flag by using MSysObjects but
      'new queries don't get written to MSysObjects until
      'Access is closed. Therefore we'll just check the
      'start of the name is '~TMPCLP' ...
      If InStr(1, , "~TMPCLP") = 1 Then
         strObjectName = ""
         strObjectName = InputBox("A deleted QUERY has been found." & _
                         vbCrLf & vbCrLf & _
                         "To undelete this object, enter a new name:", _
                         "Access Undelete Query", strObjectName)

         If Len(strObjectName) > 0 Then
            If FnUndeleteQuery(CurrentDb, , strObjectName) Then
               'We'll rename the deleted object since we've made a
               'copy and won't be needing to re-undelete it.
               '(To break the condition "~TMPCLP" in future...)
                 = "~TMPCLQ" & Right$(, Len() - 7)
             End If
         End If
         intNumDeletedItemsFound = intNumDeletedItemsFound + 1
      End If
  Next qDef
  If intNumDeletedItemsFound = 0 Then
     MsgBox "Unable to find any deleted tables/queries to undelete!"
  End If

  Set dbsDatabase = Nothing
  FnUndeleteObjects = True
ExitFunction:
  Exit Function
ErrorHandler:
  MsgBox "Error occured in FnUndeleteObjects() - " & _
          & " (" & CStr() & ")"
  GoTo ExitFunction
End Function


Private Function FnUndeleteTable(dbDatabase As , _
                 strDeletedTableName As String, _
                 strNewTableName As String)

  'Module (c) 2005 Wayne Phillips ()
  'Written 18/04/2005
  Dim tDef As 
  Set tDef = (strDeletedTableName)
  'Remove the Deleted Flag...
   =  And Not dbHiddenObject
  'Rename the deleted object to the original or new name...
   = strNewTableName
  
  
  Set tDef = Nothing
End Function

Private Function FnUndeleteQuery(dbDatabase As , _
                 strDeletedQueryName As String, _
                 strNewQueryName As String)

  'Module (c) 2005 Wayne Phillips ()
  'Written 18/04/2005
  'We can't just remove the Deleted flag on queries
  '('Attributes' is not an exposed property)
  'So instead we create a new query with the SQL...

  'Note: Can't use  as it copies the dbHiddenObject attribute!

  If FnCopyQuery(dbDatabase, strDeletedQueryName, strNewQueryName) Then
     FnUndeleteQuery = True
     
  End If
End Function


Private Function FnCopyQuery(dbDatabase As , _
                 strSourceName As String, _
                 strDestinationName As String)

  'Module (c) 2005 Wayne Phillips ()
  'Written 18/04/2005
  On Error GoTo ErrorHandler:

  Dim qDefOld As 
  Dim qDefNew As 
  Dim Field As 

  Set qDefOld = (strSourceName)
  Set qDefNew = (strDestinationName, )

  'Copy root query properties...
  FnCopyLvProperties qDefNew, , 

  For Each Field In 
      'Copy each fields individual properties...
      FnCopyLvProperties (), _
                         , _
                         ().Properties
  Next Field
  
  FnCopyQuery = True
ExitFunction:
  Set qDefNew = Nothing
  Set qDefOld = Nothing
  Exit Function
ErrorHandler:
  MsgBox "Error re-creating query '" & strDestinationName & "':" & vbCrLf & _
          & " (" & CStr() & ")"
  GoTo ExitFunction
End Function

Private Function PropExists(Props As , strPropName As String) As Boolean
  'Module (c) 2005 Wayne Phillips ()
  'Written 18/04/2005
  'If properties fail to be created, we'll just ignore the errors
  On Error Resume Next
  Dim Prop As 
  For Each Prop In Props
      If  = strPropName Then
         PropExists = True
         Exit Function ' Short circuit
      End If
  Next Prop
  PropExists = False
End Function

Private Sub FnCopyLvProperties(objObject As Object, OldProps As , NewProps As )
  'Module (c) 2005 Wayne Phillips ()
  'Written 18/04/2005
  'If properties fail to be created, we'll just ignore the errors
  On Error Resume Next
  Dim Prop As 
  Dim NewProp As 
  For Each Prop In OldProps
      If Not PropExists(NewProps, ) Then
         If IsNumeric() Then
             (, , CLng())
         Else
             (, , )
         End If
      Else
         With NewProps()
              .Type = 
              .Value = 
         End With
      End If
  Next Prop
End Sub

Private Function FnGetDeletedTableNameByProp(strRealTableName As String) As String
  'Module (c) 2005 Wayne Phillips ()
  'Written 18/04/2005
  'If an error occurs here, just ignore (user will override the blank name)
  On Error Resume Next
  Dim i As Long
  Dim strNameMap As String

  'Look up the Unicode translation NameMap property to try to guess the
  'original table name... (Access 2000+ only - and doesn't always exist?!)

  strNameMap = (strRealTableName).Properties("NameMap")
  strNameMap = Mid(strNameMap, 23) 'Offset of the table name...

  'Find the null terminator...
  i = 1
  If Len(strNameMap) > 0 Then
     While (i < Len(strNameMap)) And (Asc(Mid(strNameMap, i)) <> 0)
       i = i + 1
     Wend
  End If
  FnGetDeletedTableNameByProp = Left(strNameMap, i - 1)
End Function