Access恢复被删除的表和查询的函数

时　间:2014-10-21 07:56:55
作　者:Wayne Phillips   ID：43  城市：江阴
摘　要:Access恢复被删除的表和查询
正　文:

可以将以下的代码放在新建的模块中再调用函数测试
Public Function FnUndeleteObjects() As Boolean
On Error GoTo ErrorHandler:
Dim strObjectName           As String
Dim rsTables                As DAO.Recordset
Dim dbsDatabase             As DAO.Database
Dim tDef                    As DAO.TableDef
Dim qDef                    As DAO.QueryDef
Dim intNumDeletedItemsFound As Integer
Set dbsDatabase = CurrentDb
For Each tDef In dbsDatabase.TableDefs
      'This is actually used as a 'Deleted Flag'
      If tDef.Attributes And dbHiddenObject Then
         strObjectName = FnGetDeletedTableNameByProp(tDef.Name)
         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, tDef.Name, strObjectName
         End If
         intNumDeletedItemsFound = intNumDeletedItemsFound + 1
      End If
Next tDef


For Each qDef In dbsDatabase.QueryDefs
      '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, qDef.Name, "~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, qDef.Name, 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...)
                qDef.Name = "~TMPCLQ" & Right$(qDef.Name, Len(qDef.Name) - 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() - " & _
         Err.Description & " (" & CStr(Err.Number) & ")"
GoTo ExitFunction
End Function


Private Function FnUndeleteTable(dbDatabase As DAO.Database, _
                 strDeletedTableName As String, _
                 strNewTableName As String)
'Module (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
'Written 18/04/2005
Dim tDef As DAO.TableDef
Set tDef = dbDatabase.TableDefs(strDeletedTableName)
'Remove the Deleted Flag...
tDef.Attributes = tDef.Attributes And Not dbHiddenObject
'Rename the deleted object to the original or new name...
tDef.Name = strNewTableName
dbDatabase.TableDefs.Refresh
Application.RefreshDatabaseWindow
Set tDef = Nothing
End Function


Private Function FnUndeleteQuery(dbDatabase As DAO.Database, _
                 strDeletedQueryName As String, _
                 strNewQueryName As String)
'Module (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
'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 DoCmd.CopyObject as it copies the dbHiddenObject attribute!

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

Private Function FnCopyQuery(dbDatabase As DAO.Database, _
                 strSourceName As String, _
                 strDestinationName As String)
'Module (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
'Written 18/04/2005
On Error GoTo ErrorHandler:
Dim qDefOld As DAO.QueryDef
Dim qDefNew As DAO.QueryDef
Dim Field As DAO.Field
Set qDefOld = dbDatabase.QueryDefs(strSourceName)
Set qDefNew = dbDatabase.CreateQueryDef(strDestinationName, qDefOld.SQL)
'Copy root query properties...
FnCopyLvProperties qDefNew, qDefOld.Properties, qDefNew.Properties
For Each Field In qDefOld.Fields
      'Copy each fields individual properties...
      FnCopyLvProperties qDefNew.Fields(Field.Name), _
                         Field.Properties, _
                         qDefNew.Fields(Field.Name).Properties
Next Field
dbDatabase.QueryDefs.Refresh
FnCopyQuery = True
ExitFunction:
Set qDefNew = Nothing
Set qDefOld = Nothing
Exit Function
ErrorHandler:
MsgBox "Error re-creating query '" & strDestinationName & "':" & vbCrLf & _
         Err.Description & " (" & CStr(Err.Number) & ")"
GoTo ExitFunction
End Function


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


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


Private Function FnGetDeletedTableNameByProp(strRealTableName As String) As String
'Module (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
'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 = CurrentDb.TableDefs(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
 


Access软件网官方交流QQ群 (群号:54525238) 　　　　　　Access源码网店