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
|
Option Compare Database
Option Explicit
Sub Exporter()
On Error GoTo err
Dim Db As DAO.Database
Dim DbDest As DAO.Database
Dim NomFichier As String
Dim Erreur As String
Dim TblSource As DAO.TableDef
Dim Rlt As DAO.Relation
'Nom de mon fichier : 'Chemin\Temp - date - heure.accd'
Dim nomBaseSauvegarde As String
Dim dateHeureActuelleFormat As String
dateHeureActuelleFormat = Format(Now, "dd-mm-yyyy - hh-mm-ss")
nomBaseSauvegarde = StringFormat("Temp - {0}.accdb", dateHeureActuelleFormat)
NomFichier = StringFormat("C:\Users\cyomont\Documents\#AFFAIRES\#Outil PDC\V8.0.0\{0}", nomBaseSauvegarde)
'Cree la nouvel BD
Set DbDest = DBEngine.CreateDatabase(NomFichier, dbLangGeneral)
DoEvents
'Instancie l'objet DB courant
Set Db = CurrentDb
'Parcours les tables
For Each TblSource In Db.TableDefs
'si la table est attachée & commence par "T_"
If TblSource.Attributes And dbAttachedTable _
And Left(TblSource.Name, 2) = "T_" Then
export TblSource, Erreur, Db, DbDest
End If
Next TblSource
'On parcours les relations
For Each Rlt In Db.Relations
'si le nom de la table reliée commence par "T_"
If Left(Rlt.Table, 2) = "T_" Then
CloneRelation Rlt, Db, DbDest, Rlt.Name
End If
Next Rlt
If Erreur = "" Then
MsgBox "fini"
Else
MsgBox "Les tables suivantes n'ont pas été exportées" & vbCrLf & vbCrLf & Erreur
End If
Exit Sub
err:
Select Case err.number
Case 3204: MsgBox "Le fichier existe déjà", vbCritical, "Erreur"
Case Else: MsgBox "Une erreur inconue est survenue", vbCritical, "Erreur"
End Select
End Sub
Sub export(TblSource As DAO.TableDef, messageerreur As String, Db As DAO.Database, DbDest As DAO.Database)
On Error GoTo err
Dim Fld As DAO.Field
Dim Ind As DAO.Index
Dim Tbldest As DAO.TableDef
Set Tbldest = DbDest.CreateTableDef(TblSource.Name)
'clone les champs
For Each Fld In TblSource.Fields
CloneChamp Fld, Tbldest, Fld.Name
Next Fld
'Clone les index
For Each Ind In TblSource.Indexes
CloneIndex Ind, Tbldest, Ind.Name
Next Ind
'Ajoute la table à la collection
DbDest.TableDefs.Append Tbldest
'Importe les données
Db.Execute StringFormat("INSERT INTO [{0}] IN ""{1}"" SELECT * FROM [{0}]", TblSource.Name, DbDest.Name)
'On supprime les propriétées liées au SharePoint
DbDest.Execute StringFormat("ALTER TABLE {0} DROP COLUMN SharePointTitle, _OldID, [ID de l'instance du flux de travail], [Type de fichier], SharePointEditor, SharePointAuthor, SharePointModifiedDate, SharePointCreatedDate, [Chemin d'URL], [Chemin d'accès], [Type d'élément], [URL absolue codée]", TblSource.Name)
Exit Sub
err:
messageerreur = messageerreur & TblSource.Name & vbCrLf
End Sub
Private Sub EcrirePropriete(Propriete As DAO.Property, ObjetDestination As Object)
On Error GoTo err
'Copie la propriété
With ObjetDestination.Properties
.Item(Propriete.Name) = Propriete.Value
.Refresh
End With
'On ne traite pas les erreurs
err:
End Sub
Public Sub CloneChamp(FldSource As DAO.Field, TableDestination As DAO.TableDef, NouveauNom As String)
On Error GoTo err
Dim Fld As DAO.Field
Dim Prp As DAO.Property
'Cree le champ
Set Fld = TableDestination.CreateField(NouveauNom)
'Pour chaque propriete
For Each Prp In FldSource.Properties
'copier la propriété s'il ne s'agit pas du nom
If Prp.Name <> "Name" And Prp.Name <> "Value" Then
EcrirePropriete Prp, Fld
End If
Next Prp
'Ajoute le champ
TableDestination.Fields.Append Fld
Exit Sub
err:
Select Case err.number
Case 3010, 3191: MsgBox "Le champ " & NouveauNom & " existe déjà"
Case Else: MsgBox "Une erreur inattendue est survenue"
End Select
End Sub
Public Sub CloneIndex(IndSource As DAO.Index, TableDestination As DAO.TableDef, NouveauNom As String)
On Error GoTo err
Dim Ind As DAO.Index
Dim Fld As DAO.Field, FldDest As DAO.Field
Dim Prp As DAO.Property
'Cree le champ
Set Ind = TableDestination.CreateIndex(NouveauNom)
'Copie les champs de l'index
For Each Fld In IndSource.Fields
'Duplique le champ
Set FldDest = Ind.CreateField(Fld.Name)
'applique les mêmes propriétés
For Each Prp In Fld.Properties
EcrirePropriete Prp, FldDest
Next Prp
'Ajoute le champ
Ind.Fields.Append FldDest
Next Fld
'Pour chaque propriete
For Each Prp In IndSource.Properties
'copier la propriété s'il ne s'agit pas du nom
If Prp.Name <> "Name" Then
EcrirePropriete Prp, Ind
End If
Next Prp
'Ajoute l'index
TableDestination.Indexes.Append Ind
Exit Sub
err:
End Sub
Public Sub CloneRelation(RltSource As DAO.Relation, Db As DAO.Database, DbDest As DAO.Database, NouveauNom As String)
On Error GoTo err
Dim Rlt As DAO.Relation
Dim Fld As DAO.Field, FldDest As DAO.Field
Dim Prp As DAO.Property
'Créé la relation
Set Rlt = DbDest.CreateRelation(NouveauNom)
'Copie les champs de l'index
For Each Fld In RltSource.Fields
'Duplique le champ
Set FldDest = Rlt.CreateField(Fld.Name)
'applique les mêmes propriétés
For Each Prp In Fld.Properties
EcrirePropriete Prp, FldDest
Next Prp
'Ajoute le champ
Rlt.Fields.Append FldDest
Next Fld
'Pour chaque propriete
For Each Prp In RltSource.Properties
'copier la propriété s'il ne s'agit pas du nom
If Prp.Name <> "Name" Then
EcrirePropriete Prp, Rlt
End If
Next Prp
'Ajoute la relation
DbDest.Relations.Append Rlt
Exit Sub
err:
End Sub |
