Discussion :

[bibilolo2]

Bonjour à tous,
j'effectue le parcours d'un document Word contenant des adresses mails et je veux les ajouter à une BDD sans créer de doublons. Pour cela, j'effectue, pour chaque mail, un test de présence dans la BD et si il n'est pas présent je l'ajoute (sinon je ne l'ajoute pas).
Le problème est que je n'arrive pas à mettre à jour le recordset à chaque fois que j'examine un mail. Comment faire ?
J'ai essayé de rédéfinir à chaque fois le Recordset, et j'ai essayé aussi les méthodes "Requery", "Update".

Voici mon code :

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
 
Public Sub ExportContacts()
    '****************************************************'
    '******************* Déclarations *******************'
    '****************************************************'
    Dim objWApp As Word.Application
    Dim WordDoc As Word.Document
    Dim pCurrentParagraph As Paragraph
    Dim tableauMails As Variant
    Dim currentMail As Variant
 
    Dim rstContacts As DAO.Recordset
    Dim db As DAO.Database 'Base de données sur laquelle se connecter
    Dim nomBD As String 'Nom de la Base de Données
    Dim cheminBDduCdR As String
    Dim sSQL As String 'Requête de sélection
 
    '****************************************************'
    '***************** Initialisations ******************'
    '****************************************************'
    'Pointer sur le document courant
    Set WordDoc = ThisDocument
 
    nomBD = "nobacontakt.mdb"
 
    'Chemin de la BD (dans le même répertoire)
    cheminBDduCdR = ThisDocument.Path & "\" & nomBD
 
    'Connexion à la BD
    Set db = DAO.OpenDatabase(cheminBDduCdR)
 
    '****************************************************'
    '*************** Ajout des contacts *****************'
    '****************************************************'
 
    For Each pCurrentParagraph In WordDoc.Paragraphs
        pCurrentParagraph.Range.Select
        tableauMails = Split(pCurrentParagraph.Range.Text, ";")
 
        For Each currentMail In tableauMails
        currentMail = CStr(Trim(currentMail))
'Debug.Print currentMail
            If Len(currentMail) > 5 Then
                If IsMail(Trim(currentMail)) = True Then
                DoEvents
                'Rechercher dans la BD le mail courant
                    sSQL = "SELECT Adressedemessagerie FROM Contacts Where Adressedemessagerie=" & """ & Trim(currentMail) & """
 
                    DoEvents
                    Set rstContacts = db.OpenRecordset(sSQL)
                    DoEvents
Debug.Print rstContacts("Adressedemessagerie")
                    With rstContacts
                       .AddNew
                       !Adressedemessagerie = Trim(currentMail)
                       .Update
                       .Bookmark = .LastModified
                    End With
 
                            'Si l'adresse mail n'est pas déjà présente dans la Base de Contacts
 
                            If (rstContacts.RecordCount = 0) = True Then
                                'db.Execute "INSERT INTO Contacts (Adressedemessagerie) VALUES ('" & Trim(currentMail) & "')"
                                DoEvents
Debug.Print "Started"
                        'Pour chaque mail
                                Do Until rstContacts.EOF
Debug.Print "Ajoutéééé"
                                        With rstContacts
                                           .AddNew
                                           !Adressedemessagerie = Trim(currentMail)
                                           .Update
                                           .Bookmark = .LastModified
                                        End With
 
                                    'Réinitialiser la valeur du mail
                                    currentMail = ""
                                    rstContacts.MoveNext
                                Loop
 
                            End If
 
                Else
                    'Debug.Print "Pas mail"
                End If
            Else
            End If
 
        'Réinitialiser la valeur du mail
        currentMail = ""
        DoEvents
        Next currentMail
    Next pCurrentParagraph
 
    'Effacer le contenu du document
    For Each pCurrentParagraph In WordDoc.Paragraphs
        pCurrentParagraph.Range.Select
        pCurrentParagraph.Range.Delete
    Next pCurrentParagraph
 
End Sub

Je vous remercie par avance.

[mout1234]

Bonjour,

Une solution consiste à utiliser un recordset sur ta table contacts et utiliser la méthode FindFirst.

QQ chose du genre (non testé)

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
Set rstContacts = db.OpenRecordset("SELECT Adressedemessagerie FROM Contacts", dbOpenDynaset)
For Each currentMail In tableauMails
	currentMail = CStr(Trim(currentMail))
	If Len(currentMail) > 5 Then
           If IsMail(currentMail) = True Then
 
 
		With rstContacts
			.FindFirst "Adressemessagerie ='" & currentMail & "'"
			if .Nomatch then
				.AddNew
					!Adressedemessagerie = currentMail
				.Update
			endif
		End With
             ENDIF 
	end if
Next currentMail

[bibilolo2]

Thanks Mout, je teste tout cela de suite.

[bibilolo2]

Je te remercie Mout, ce code fonctionne très bien !!
Je pose le code fonctionnant :

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
 
Public Sub ExportContacts()
    '****************************************************'
    '******************* Déclarations *******************'
    '****************************************************'
    Dim objWApp As Word.Application
    Dim WordDoc As Word.Document
    Dim pCurrentParagraph As Paragraph
    Dim tableauMails As Variant
    Dim currentMail As Variant
 
    Dim rstContacts As DAO.Recordset
    Dim db As DAO.Database 'Base de données sur laquelle se connecter
    Dim nomBD As String 'Nom de la Base de Données
    Dim cheminBDduCdR As String
    Dim sSQL As String 'Requête de sélection
 
    '****************************************************'
    '***************** Initialisations ******************'
    '****************************************************'
    'Pointer sur le document courant
    Set WordDoc = ThisDocument
 
    nomBD = "nobacontakt.mdb"
 
    'Chemin de la BD (dans le même répertoire)
    cheminBDduCdR = ThisDocument.Path & "\" & nomBD
 
    'Se connecter à la BD
    Set db = DAO.OpenDatabase(cheminBDduCdR)
 
    '****************************************************'
    '*************** Ajout des contacts *****************'
    '****************************************************'
    For Each pCurrentParagraph In WordDoc.Paragraphs
        pCurrentParagraph.Range.Select
        tableauMails = Split(pCurrentParagraph.Range.Text, ";")
 
            'Rechercher dans la BD le mail courant
                DoEvents
                Set rstContacts = db.OpenRecordset("SELECT Adressedemessagerie FROM Contacts", dbOpenDynaset)
                For Each currentMail In tableauMails
                    currentMail = CStr(Trim(currentMail))
                    If Len(currentMail) > 5 Then
                           If IsMail(currentMail) = True Then
                                With rstContacts
                                    .FindFirst "Adressedemessagerie ='" & currentMail & "'"
                                    If .NoMatch Then
                                        .AddNew
                                            !Adressedemessagerie = currentMail
                                        .Update
                                    End If
                                End With
                             End If
                    End If
                'Réinitialiser la valeur du mail
                currentMail = ""
                DoEvents
                Next currentMail
    Next pCurrentParagraph
 
    'Effacer le contenu du document
    For Each pCurrentParagraph In WordDoc.Paragraphs
        pCurrentParagraph.Range.Select
        pCurrentParagraph.Range.Delete
    Next pCurrentParagraph
 
End Sub

[mout1234]

de rien