Probleme sur code envoie de mail

**xboulney** · 20/04/2006, 12h37

Bonjour a tous,

Voici mon souci du jour. J'ai recuperer ce code pour envoie des mails mais le probleme est que je n'arrive pas à envoyer mon mail si je rentre plusieurs destinataires dans le champ CCi "txtCCi".
Est ce que klkun pourrait m'orienter sur la ligne à changer.

C'est beaucoup trop compliqué pour moi.

Bon je sais c tres long mais j'espere que quelqu'un auras le courage d'aller au bout.

Si vous avez besoin d'autre chose n'hesitez pas....

Donc le code qui suit est le code qui est dans un module :

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
 Option Compare Database
Option Explicit
 
Enum MailPriority
   LOW_PRIORITY = &H0
   HIGH_PRIORITY = &H1
End Enum
 
Public Declare Function SendBlat Lib "blat.dll" Alias "Send" (ByVal sCmd As String) As Integer
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
 
Public Sub SendMail(MailTo As String, _
                    Sujet As String, _
                    Detail As String, _
                    Optional AttachFiles As String, _
                    Optional Mailcc As String, _
                    Optional Mailbcc As String, _
                    Optional Priority As MailPriority = &H2, _
                    Optional Confirmation As Boolean)
 
Dim Signature   As String
Dim ifScinder   As String
Dim ifLog       As String
Dim StringValue As String
Dim result      As Integer
Dim hLib        As Long
 
'// Charge la DLL
hLib = LoadLibrary("Blat.dll")
If hLib = 0 Then
    hLib = LoadLibrary(CurrentProject.Path & "\Blat.dll")
    If hLib = 0 Then
        MsgBox "Impossible de trouver le fichier Blat.dll " & vbCrLf & vbCrLf & "S.V.P. copier le fichier dans le dossier système" & vbCrLf & "ou dans le dossier " & CurrentProject.Path, vbOKOnly, "Envois de l'email"
        Exit Sub
    End If
End If
 
'// Destinataire
StringValue = "Mail -to " & MailTo
 
'// Copie conforme
If Len(Mailcc) > 0 Then
   StringValue = StringValue & " -cc " & Mailcc
End If
 
'// Copie conforme invisible
If Len(Mailbcc) > 0 Then
   StringValue = StringValue & " -bcc " & Mailbcc
End If
 
'// Prorité d'envois
If Priority <> &H2 Then
   StringValue = StringValue & " -Priority " & Priority
End If
 
'// Fichier attachés
If Len(AttachFiles) > 2 Then
   StringValue = StringValue & " -Attach " & AttachFiles
End If
 
'// Confirmation de lecture
If Confirmation = True Then
   StringValue = StringValue & " -d"
End If
 
'// Signature
Signature = ReadRegistry("HKLM", "SoftWare\Public Domain\Blat", "Signature", "S", "")
If Len(Signature) > 0 Then
   StringValue = StringValue & " -sig " & Chr(34) & Signature & Chr(34)
End If
 
'// Fichier Log
ifLog = ReadRegistry("HKLM", "SoftWare\Public Domain\Blat", "Log", "S", "")
If Nz(ifLog) = -1 Then
   StringValue = StringValue & " -log " & Chr(34) & CurrentProject.Path & "\Blat.log" & Chr(34)
End If
 
'// Scinder le message
ifScinder = ReadRegistry("HKLM", "SoftWare\Public Domain\Blat", "Scinder", "S", "")
If Nz(ifScinder) = -1 Then
   StringValue = StringValue & " -multipart " & Nz(ReadRegistry("HKLM", "SoftWare\Public Domain\Blat", "NbrKo", "S", ""))
End If
 
StringValue = StringValue & _
              " -subject " & Chr(34) & IIf(Estvide(Sujet), " ", Sujet) & Chr(34) & _
              " -body " & Chr(34) & IIf(Estvide(Detail), " ", Detail) & Chr(34) & _
              " -noh"
 
'// Envois du courriel
'Problème pour la progress bar à cause du mail Synchrone DoCmd.OpenForm "frmWait": Sleep 1000: DoEvents
result = SendBlat(StringValue)
'DoCmd.Close acForm, "frmWait"
 
If result = 0 Then
   MsgBox "Mail envoyé avec succès !", vbInformation, "Envois de l'email"
   Exit Sub
Else
   Select Case result
    Case 1
      MsgBox "Bad argument given", vbExclamation, "Erreur"
    Case 2
      MsgBox "File (message text) does not exist", vbExclamation, "Erreur"
    Case 3
      MsgBox "Error reading the file (message text) or attached file", vbExclamation, "Erreur"
    Case 4
      MsgBox "File (message text) not of type", vbExclamation, "Erreur"
    Case 5
      MsgBox "Error Reading File (message text)", vbExclamation, "Erreur"
    Case 12
      MsgBox "-server or -f options not specified and not found in registry", vbExclamation, "Erreur"
    Case 13
      MsgBox "Error opening temporary file in temp directory", vbExclamation, "Erreur"
    Case Else
      MsgBox "Bad argument given", vbExclamation, "Erreur"
   End Select
End If
End Sub

et celui qui suit est dans le formulaire d'envoie de mail.

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
318
319
320
321
322
323
324
325
326
327
328
329
330
 
Option Compare Database
Option Explicit
 
Dim PDFPath      As String
Dim ModeSelected As String
Dim FlipAttache  As Boolean
Dim NumPos       As Long     '1-Normal 2-Bas
Dim BackPos      As Long
Dim FirstOpen    As Boolean
 
Private Sub cmdBrowse_Click()
On Error Resume Next
  Dim strFilter  As String
  Dim lngFlags   As Long
  Dim strReponse As String
  Dim strPath    As String
 
  strFilter = ahtAddFilterItem(strFilter, "Tous les fichiers (*.*)", "*.*")
  strReponse = ahtCommonFileOpenSave(InitialDir:=CurDir, Filter:=strFilter, FilterIndex:=2, Flags:=lngFlags, DialogTitle:="Choisir un fichier")
 
  If strReponse <> "" Then
    Me!lstFiles.AddItem strReponse & ";" & Dir(strReponse)
  End If
 
End Sub
 
Private Sub cmdDelete_Click()
If Me!lstFiles.ListIndex = -1 Then Exit Sub
 
  If MsgBox("Voulez-vous vraiment supprimer '" & Me!lstFiles & "' de la liste ?", 4 + 32 + 256, "Confirmation") = 6 Then
     Me!lstFiles.RemoveItem Me!lstFiles.ListIndex
  End If
End Sub
 
Private Sub cmdOpen_Click()
  If Me!lstFiles.ListIndex = -1 Then Exit Sub
  Call RunShellExecute("Open", PDFPath & Me!lstFiles, 0&, 0&, SW_SHOWNORMAL)
End Sub
 
Private Sub cmdRenomer_Click()
Dim NewFiles    As String
Dim NewFullPath As String
 
On Error GoTo RenErr
 
  If Me!lstFiles.ListIndex = -1 Then Exit Sub
 
  NewFiles = InputBox("Entrez le nom du nouveau fichier :", "Renommer", Me!lstFiles.Column(1))
 
  If NewFiles <> "" Then
     NewFullPath = Left(Me!lstFiles, Len(Me!lstFiles) - Len(Dir(Me!lstFiles))) & NewFiles
     Name Me!lstFiles As NewFullPath
     Me!lstFiles.RemoveItem Me!lstFiles.ListIndex
     Me!lstFiles.AddItem NewFullPath & "," & Dir(NewFullPath)
  End If
  Exit Sub
 
RenErr:
  MsgBox Err.Description, vbExclamation, "Erreur"
End Sub
 
Private Sub Détail_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 ' Call lstPriority_AfterUpdate
End Sub
 
Private Sub Détail_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Me!cdrAttache.Visible = True Then Me!cdrAttache.Visible = False
End Sub
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = 27 Then DoCmd.Close
End Sub
 
Private Sub Form_Open(Cancel As Integer)
  'Call SetFormIcon("Mail.ico", Me.Name, Me.hwnd)
  ModeSelected = "cdrC"
  FirstOpen = True
End Sub
 
Private Sub lblA_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.FlagFocus.SetFocus
End Sub
 
Private Sub lblAnnuler_Click()
  DoCmd.Close
End Sub
 
Private Sub lblConfig_Click()
  DoCmd.OpenForm "frmSMTP_Config"
End Sub
 
Private Sub lblJoindre_Click()
  Call FlipJoindre(True)
End Sub
 
Private Sub lblPrority_Click()
  Me!FlagFocus.SetFocus
  Me!BoxPriority.Visible = True
  Me!lstPriority.Visible = True
End Sub
 
Private Sub lblSend_Click()
 
If IsNull(ReadRegistry("HKLM", "SoftWare\Public Domain\Blat\Mail", "SMTP server", "S", "")) Then
   DoCmd.OpenForm "frmSMTP_Config"
   Exit Sub
End If
 
If FlipAttache = True Then Exit Sub
Dim AttachList As String
Me!txtC.SetFocus
 
If IsNull(Me!txtC) Then
   MsgBox "Le Message n'a pas été envoyé." & vbCrLf & vbCrLf & "Vous devez spécifier des destinataires pour le message.", vbExclamation, "Messagerie"
   Exit Sub
End If
 
If MsgBox("Confirmation de l'envoi du message ?", 4 + 32, "Confirmation") = 7 Then Exit Sub
If Estvide(Me!txtMailSujet) Then
   If MsgBox("Votre message ne comporte pas de sujet, voulez-vous continuer ?", 4 + 32 + 256, "Confirmation") = 7 Then
      Me!txtMailSujet.SetFocus
      Exit Sub
   End If
End If
 
If Estvide(Me!txtMailText) Then
   If MsgBox("Votre message ne comporte pas de message, voulez-vous continuer ?", 4 + 32 + 256, "Confirmation") = 7 Then
      Me!txtMailText.SetFocus
      Exit Sub
   End If
End If
 
'Envois du courriel
DoCmd.Hourglass True
 
Call SendMail(Me!txtC, _
              IIf(IsNull(Me!txtMailSujet), "", Me!txtMailSujet), _
              IIf(IsNull(Me!txtMailText), "", Me!txtMailText), _
              AttacheFiles, _
              IIf(IsNull(Me!txtCc), "", Me!txtCc), _
              IIf(IsNull(Me!txtCci), "", Me!txtCci), _
              Me!lstPriority, _
              Me!chkConfirmation)
 
DoCmd.Hourglass False
End Sub
 
Private Sub lstFiles_Click()
  If Me!lstFiles.ListIndex = -1 Then
     Me!cmdDelete.Enabled = False
     Me!cmdOpen.Enabled = False
     Me!cmdRenomer.Enabled = False
  Else
     Me!cmdOpen.Enabled = True
     Me!cmdDelete.Enabled = True
     Me!cmdRenomer.Enabled = True
  End If
 
 
End Sub
 
Public Function OrderString(Str As String) As String
Dim i           As Integer
Dim Separateur  As Variant
Dim retValue    As String
Dim Position    As Integer
Dim OldPosition As Integer
 
 
'si aucune occurence
If InStr(1, Str, ",", vbTextCompare) = 0 Then
   OrderString = Str
   Exit Function
End If
 
retValue = ""
 
Position = 0
For i = 1 To 26
  Do Until 1 = 2
 
     Separateur = InStr(Position + 1, Str, ",")
     If Position = 0 Then
        If Asc(Left(Str, 1)) = i + 64 Then
           retValue = retValue & IIf(retValue = "", "", ",") & Mid(Str, Position + 1, Separateur - 1)
        End If
        Position = Separateur
     Else
        If Asc(Mid(Str, Position + 1, 1)) = Val(i + 64) Then
           If Separateur = 0 Then Separateur = Len(Str) + 1  'Si c'est la fin de la chaine
           retValue = retValue & IIf(retValue = "", "", ",") & Mid(Str, Position + 1, Separateur - Position - 1)
        End If
        Position = Separateur
     End If
     If Position > Len(Str) Or Position = 0 Then
        Position = 0
        Exit Do
     End If
  Loop
 
Next
 
OrderString = retValue
 
End Function
 
Public Function ClickCadre(ctlActif As String)
  Me!cdrC.BackColor = 15651521
  Me!cdrCc.BackColor = 15651521
  Me!cdrCci.BackColor = 15651521
  Me!cdrAttache.BackColor = 15651521
  Me!cdrConfig.BackColor = 15651521
 
  Me(ctlActif).BackColor = 14857624
 
  ModeSelected = ctlActif
 
End Function
 
 
Private Function FlipCadre(ctlActif As String)
  If Me!cdrC.Visible = True Then Me!cdrC.Visible = False
  If Me!cdrCc.Visible = True Then Me!cdrCc.Visible = False
  If Me!cdrCci.Visible = True Then Me!cdrCci.Visible = False
  If Me!cdrAttache.Visible = True Then Me!cdrAttache.Visible = False
  If Me!cdrConfig.Visible = True Then Me!cdrConfig.Visible = False
 
  If ctlActif = "All" Then
     Me(ModeSelected).Visible = True
  Else
     Me(ctlActif).Visible = True
  End If
 
 
End Function
 
Public Sub FlipJoindre(EstVisible As Boolean)
Me!FlagFocus.SetFocus
 
If EstVisible = False Then GoTo OffAttache
 
If FlipAttache = False Then
   FlipAttache = True
   Me!lblFiles.Visible = True
   Me!cdrFiles.Visible = True
   Me!lstFiles.Visible = True
   Me!cmdBrowse.Visible = True
   Me!cmdDelete.Visible = True
   Me!cmdOpen.Visible = True
   Me!cmdRenomer.Visible = True
   Me!txtMailText.Locked = True
   Me!txtMailText.Enabled = False
   Me!txtC.Enabled = False
   Me!txtC.Locked = True
   Me!txtCci.Enabled = False
   Me!txtCc.Locked = True
   Me!txtCc.Enabled = False
   Me!txtCci.Locked = True
   Me!txtCci.Enabled = False
   Me!txtMailSujet.Locked = True
   Me!txtMailSujet.Enabled = False
   Me!cmdMask.Visible = True
Else
OffAttache:
   FlipAttache = False
   Me!lblFiles.Visible = False
   Me!cdrFiles.Visible = False
   Me!lstFiles.Visible = False
   Me!cmdBrowse.Visible = False
   Me!cmdDelete.Visible = False
   Me!cmdOpen.Visible = False
   Me!cmdRenomer.Visible = False
   Me!txtMailText.Locked = False
   Me!txtMailText.Enabled = True
   Me!txtC.Locked = False
   Me!txtC.Enabled = True
   Me!txtCc.Locked = False
   Me!txtCc.Enabled = True
   Me!txtCci.Locked = False
   Me!txtCci.Enabled = True
   Me!txtMailSujet.Locked = False
   Me!txtMailSujet.Enabled = True
   Me!cmdMask.Visible = False
End If
End Sub
 
Public Function AttacheFiles() As String
'Concatène les fichiers
Dim i        As Long
Dim retValue As String
 
For i = 0 To Me.lstFiles.ListCount - 1
    retValue = retValue & Me!lstFiles.ItemData(i) & ","
Next i
 
AttacheFiles = Chr(34) & retValue & Chr(34)
End Function
 
Private Sub lstPriority_AfterUpdate()
  Me!FlagFocus.SetFocus
  Me!lstPriority.Visible = False
  Me!BoxPriority.Visible = False
  Select Case Me!lstPriority.Column(0)
    Case 1 'Haute
       Me!lblProrité.Visible = True
       Me.lblProrité.Caption = Space(8) & "Ce message à une priorité haute."
       Me!imgBas.Visible = False
       Me!imgHaut.Visible = True
    Case 2 'Normal
       If FirstOpen = True Then
          FirstOpen = False
       Else
          Me!lblProrité.Visible = False
          Me!imgBas.Visible = False
          Me!imgHaut.Visible = False
       End If
    Case 0 'Basse
       Me!lblProrité.Visible = True
       Me.lblProrité.Caption = Space(8) & "Ce message à une priorité basse."
       Me!imgBas.Visible = True
       Me!imgHaut.Visible = False
 
  End Select
End Sub
 
Public Function MaskPriority()
  Me!lstPriority.Visible = False
  Me!BoxPriority.Visible = False
End Function

**Demco** · 20/04/2006, 13h21

je n'arrive pas à envoyer mon mail si je rentre plusieurs destinataires dans le champ CCi "txtCCi".

Peut-etre faut-il les separer par une virgule ou point-virgule par exemple. As-tu fait ce genre d'essaie ?

**xboulney** · 20/04/2006, 21h31

Oui pardon...
En effet j'ai essayer avec un espace, une virgule, un point virgule un trait d'union mais rien de fonctionne.
Par contre si je ne met qu'une seule adresse dans le champs "txtCCi" cela fonctionne correctement.

Le but recherché etant de pouvoir envoyer un mail a plusieurs destinataire en copie caché en meme temp.

Merci.

Probleme sur code envoie de mail

Access

Discussions similaires

Partager

Partager