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
|
Public UnObjectConnexion As ADODB.Connection
Public ChaineDeConnexion As String
'Créer un bonton de commande ayant pour nom "CmdExecuter"
Private Sub CmdExecuter_Click()
Dim Resultat As Boolean
Dim UnRsSelection As ADODB.Recordset
Dim uneRequeteLigne As String
Dim UneRequeteSelection As String
Dim unRsligne As ADODB.Recordset
Dim Champ1, Champ2, Champ3, ChampDeRecherche As String
Set unRsligne = New ADODB.Recordset
Set UnRsSelection = New ADODB.Recordset
'Cette requête permet de sélectionner les lignes de la table pour lesquelles la valeur "UnChampDeRecherche" apparait sur 2 lignes au moins
UneRequeteSelection = "SELECT UnChampDeRecherche, COUNT(UnChampDeRecherche) FROM Un_Nom_de_table GROUP BY UnChampDeRecherche HAVING COUNT(UnChampDeRecherche) > 1"
ChaineDeConnexion = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\maBase.mdb;User Id=admin;Password=;"
'fait appel à la procédure d'ouverture de connexion, située plus bas
'en paramètre un booléen pour tester si la connexion s'est bien déroulée
Call OuvertureConnexion(UnObjectConnexion, GlChaineDeConnexion, Resultat)
UnRsSelection.Open UneRequeteSelection, UnObjectConnexion, adOpenStatic, adLockReadOnly
'boucler sur les lignes ayant des doublons
While Not UnRsSelection.EOF And UnRsSelection.BOF
uneRequeteLigne = "SELECT UnChampDeRecherche,Champ1,Champ2,Champ3 FROM Un_Nom_de_table WHERE UnChampDeRecherche='" & UnRsSelection("UnChampDeRecherche") & "'"
unRsligne.Open uneRequeteLigne, UnObjectConnexion, adOpenStatic, adLockReadOnly
'ranger Une valeur de ligne dans des variables
ChampDeRecherche = unRsligne("UnChampDeRecherche")
Champ1 = unRsligne("Champ1DeLaTable")
Champ2 = unRsligne("Champ2DeLaTable")
Champ3 = unRsligne("Champ3DeLaTable")
'Supprimer ttes les lignes de doublons
UnObjectConnexion.Execute "DELETE FROM Un_Nom_de_table WHERE UnChampDeRecherche='" & ChampDeRecherche & "'"
'Insérer une ligne unique
UnObjectConnexion.Execute "INSERT INTO Un_Nom_de_table VALUES ('" & ChampDeRecherche & "', '" & Champ1 & "', '" & Champ2 & "','" & Champ3 & "')"
'fermeture du recordset
unRsligne.Close
UnRsSelection.MoveNext
Wend
MsgBox "Traitement effectué avec succès"
Call FermetureConnexion(UnObjectConnexion, Resultat)
Unload Me
End Sub
Public Sub OuvertureConnexion(ByRef objconnexion As ADODB.Connection, ByVal ChaineConnexion As String, ByRef Resultat As Boolean)
On Error GoTo ErreurOuvertureConnexion
Set objconnexion = New ADODB.Connection
objconnexion.CommandTimeout = 960
objconnexion.Open ChaineConnexion
Resultat = True
ExitOuvertureConnexion:
Exit Sub
ErreurOuvertureConnexion:
Resultat = False
MsgBox Err.Number
MsgBox "Erreur d'ouverture de Connexion..." & "Chaine = " & ChaineConnexion & "..." & Err.Description & " " & Err.Number
GoTo ExitOuvertureConnexion
End Sub
Sub FermetureConnexion(ByRef objconnexion As ADODB.Connection, ByRef Bsucces As Boolean)
On Error GoTo ErreurFermetureConnexion
Bsucces = False
If Not objconnexion Is Nothing Then
Set objconnexion = Nothing
Bsucces = True
End If
ExitFermetureConnexion:
Exit Sub
ErreurFermetureConnexion:
MsgBox "Erreur fermeture de Connexion..." & Err.Description
GoTo ExitFermetureConnexion
End Sub |
Partager