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
| Option Compare Database
Private Function RenommerChamp(oBaseDeDonnees As DAO.Database, strNomTable As String, _
strAncienNomChamp As String, strNouveauNomChamp As String, ByVal NumFicLog As Integer) As Boolean
On Error GoTo err
Dim Tbl As DAO.TableDef
'Récupère la table
Set Tbl = oBaseDeDonnees.TableDefs(strNomTable)
'Renomme le champ
Tbl.Fields(strAncienNomChamp).Name = strNouveauNomChamp
'Renvoie True
RenommerChamp = True
' Fichier Log complété pour le suivi
Print #NumFicLog, "Table : " & strNomTable & " - Champ : " & strAncienNomChamp & " remplacé par : " & strNouveauNomChamp
'Gère les erreurs
Exit Function
err:
Select Case err.Number
'Si impossible de trouver l'élément dans la collection
Case 3265
'Si tbl=nothing alors tbl est la cause de l'erreur
If Tbl Is Nothing Then
MsgBox "Impossible de trouver la table : " & strNomTable
Else
MsgBox "Impossible de trouver le champ : " & strAncienNomChamp
End If
Case 3010, 3191: MsgBox "Le champ " & strNouveauNomChamp & " existe déjà"
Case Else
' Fichier Log complété avec cette erreur
Print #NumFicLog, "Une erreur inattendue est survenue - Détail technique : " & err.Number & " - " & err.Description
End Select
End Function
'** Fonction de remplacement des occurences d'une sous-chaîne
'** par une autre sous-chaîne dans une chaîne de caractères
'** Retourne la nouvelle chaîne de caractères ainsi obtenue
Function RemplaceChaine(ByVal Texte As String, ByVal ChAnc As String, ChNew As String) As String
Dim PosDepart As Long ' position où débute la recherche d'une chaîne à remplacer
Dim PosChAnc As Long ' position début d'une chaîne à remplacer, = 0 si non trouvée
RemplaceChaine = Texte
PosDepart = 1
Do Until PosDepart > Len(RemplaceChaine)
PosChAnc = InStr(PosDepart, RemplaceChaine, ChAnc, 1)
If PosChAnc <> 0 Then ' ChAnc trouvée, on la remplace par ChNew
RemplaceChaine = Left(RemplaceChaine, PosChAnc - 1) & ChNew _
& Right(RemplaceChaine, Len(RemplaceChaine) - PosChAnc - Len(ChAnc) + 1)
PosDepart = PosChAnc + Len(ChNew)
Else ' Pas ou plus de ChAnc dans Texte, on sort
Exit Function
End If
Loop
End Function
Function RemplaceCarSpeciaux(ByVal Chaine As String) As String
RemplaceCarSpeciaux = RemplaceChaine(Chaine, "°", "o")
RemplaceCarSpeciaux = RemplaceChaine(RemplaceCarSpeciaux, "'", " ")
RemplaceCarSpeciaux = RemplaceChaine(RemplaceCarSpeciaux, "/", " ")
RemplaceCarSpeciaux = RemplaceChaine(RemplaceCarSpeciaux, "-", " ")
End Function
Private Sub Commande0_Click()
Dim db As DAO.Database, tdf As DAO.TableDef, fld As DAO.Field
Dim strDescription As String
Dim NumFicLog As Integer
' Ouverture en écriture du fichier Log pour le suivi
NumFicLog = FreeFile
Open "C:\renommage.log" For Output As NumFicLog
Set db = CurrentDb
On Error GoTo GestionErreur
For Each tdf In db.TableDefs ' Pour chaque Table
For Each fld In tdf.Fields ' Pour chaque Champ de la Table courante
strDescription = fld.Properties("Description")
If RenommerChamp(db, tdf.Name, fld.Name, RemplaceCarSpeciaux(fld.Name), NumFicLog) = False Then
'If MsgBox("Continuez le traitement malgré cette erreur ?", vbOKCancel, "Erreur renommage") = vbCancel Then
' Close #NumFicLog
' Exit Sub
'End If
End If
Next fld
Next tdf
MsgBox ("Renommage terminé !")
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
Close #NumFicLog
Exit Sub
GestionErreur:
Select Case err.Number
Case 3270
strDescription = ""
Resume Next
Case Else
MsgBox "Erreur num. " & err.Number & " : " & err.Description, vbCritical
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
Close #NumFicLog
Exit Sub
End Select
End Sub |
[Champs] Renommer en masse les champs/tables
Répondre avec citation
Envoyé par jfc
Partager