Discussion :

[egg3774]

Comment peut-on récupérer une table effacée par erreur ?

[random]

avant tout compactage donner un nouveau nom à la table

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
 
ption Compare Database
Option Explicit
 
 
 
 
' VBA MODULE: Undelete tables and queries in Microsoft Access
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 18/04/2005
'
' REQUIREMENTS: VBA DAO Reference, Access 97/2000/2002(XP)/2003
'
' This module will allow you to undelete tables and queries
' after they have been deleted in Access/Jet.
'
' Please note that this will only work if you haven't run the
' 'Compact' or 'Compact And Repair' option from Access/DAO.
' If you have run the compact option, your tables/queries
' have been permananetly deleted.
'
' You may modify this code as you please,
' However you must leave the copyright notices in place.
' Thank you.
'
' USAGE: Just import this VBA module into your project
' and call FnUndeleteObjects()
'
' If any un-deletable objects are found, you will be prompted
' to choose names for the undeleted objects.
' Note: In Access 2000, table names are usually recovered too.
 
Public Function FnUndeleteObjects() As Boolean
 
'Module (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
'Written 18/04/2005
 
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

[egg3774]

avant tout compactage donner un nouveau nom à la table

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
 
ption Compare Database
Option Explicit
 
 
 
 
' VBA MODULE: Undelete tables and queries in Microsoft Access
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 18/04/2005
'
' REQUIREMENTS: VBA DAO Reference, Access 97/2000/2002(XP)/2003
'
' This module will allow you to undelete tables and queries
' after they have been deleted in Access/Jet.
'
' Please note that this will only work if you haven't run the
' 'Compact' or 'Compact And Repair' option from Access/DAO.
' If you have run the compact option, your tables/queries
' have been permananetly deleted.
'
' You may modify this code as you please,
' However you must leave the copyright notices in place.
' Thank you.
'
' USAGE: Just import this VBA module into your project
' and call FnUndeleteObjects()
'
' If any un-deletable objects are found, you will be prompted
' to choose names for the undeleted objects.
' Note: In Access 2000, table names are usually recovered too.
 
Public Function FnUndeleteObjects() As Boolean
 
'Module (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
'Written 18/04/2005
 
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

Excellent! une fois que j'ai créer mon module. Comment fait-on pour executer le code ?

[FreeAccess]

Bonjour,

' USAGE: Just import this VBA module into your project
' and call FnUndeleteObjects()

....