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
|
Sub Envoyer(Trans As Long, Objet As String, Test As Boolean)
'Test sert à savoir si tout s'est bien déroulé
'Trans contient le numéro de transmission
'Objet contient le texte du sujet/objet du message
Dim FichierCM As String 'Corps du message
Dim FichierPJ As String 'Pièce jointe
Dim objConfig As Object 'Objet CDO configuration
Dim objMessage As Object 'Objet CDO Message
Dim Serveur As String 'Nom du serveur SMTP
Dim Expéditeur As String 'Courriel de l'expéditeur
Dim Usager As String 'Nom du compte de courriel
Dim MotPasse As String 'Mot de passe du compte de courriel
Dim Destinataire As String 'Adresse du destinataire
Dim Compteur As Byte 'Compteur
Dim Port As Integer 'Port du courrier sortant
Dim Authen As Byte 'Authentification requise
Dim Livraison As Byte 'Notification de l'état de remise
Dim Lecture As Boolean 'Demande d'accusé de réception
Dim Délai As Byte 'Délai de connexion au serveur
Const CDO$ = "http://schemas.microsoft.com/cdo/configuration/"
Const Méthode = 2 'Utiliser un serveur SMTP distant
Me.MousePointer = fmMousePointerHourGlass
'Ces 2 fichiers sont générés par la procédure appelante
FichierPJ = Chemin & "Transmissions\T" & Format(Trans, "00000") & "PJ.htm"
'Remplacer "C:" par "C|" que l'on retrouve dans "Chemin"
FichierCM = Replace(Chemin, ":", "|") & "Transmissions\T" & Format(Trans, "00000") & "CM.htm"
'Cette fonction "GetChamp" lit un champ de ma base de données
Call GetChamp(Transmission, Trans, Trsm.No_Destinataire)
Call GetChamp(Personne, CLng(Data(Transmission).Champs(Trsm.No_Destinataire)), Prsn.Courriel_1)
Destinataire = Trim(Data(Personne).Champs(Prsn.Courriel_1))
'Point de reprise en cas d'erreur
Start:
On Error GoTo Traitement
Test = True 'Si Test devient faux, on sait qu'il y a erreur
'Cette fonction "GetRecord" lit un enregistrement de ma base de données
Call GetRecord(Paramètre, 1)
'Les valeurs sont déterminées ici
Serveur = Trim(Data(Paramètre).Champs(Parm.Serveur))
Délai = Data(Paramètre).Champs(Parm.Délai_Connexion)
Port = Data(Paramètre).Champs(Parm.Port_De_Sortie)
Authen = Abs(Data(Paramètre).Champs(Parm.Authentification))
Usager = Trim(Data(Paramètre).Champs(Parm.Usager))
MotPasse = Trim(Data(Paramètre).Champs(Parm.Mot_Passe_Usager))
Livraison = Data(Paramètre).Champs(Parm.Confirmer_livraison)
Lecture = Data(Paramètre).Champs(Parm.Confirmer_Lecture)
Expéditeur = Trim(Data(Paramètre).Champs(Parm.Expéditeur))
'Début du processus de préparation à l'envoi du courriel
Set objConfig = CreateObject("CDO.Configuration")
With objConfig.Fields
.Item(CDO & "sendusing") = Méthode
.Item(CDO & "smtpserver") = Serveur
.Item(CDO & "smtpserverport") = Port
.Item(CDO & "smtpconnectiontimeout") = Délai
.Item(CDO & "smtpauthenticate") = Authen '1 Requis, 0 Anonyme
.Item(CDO & "sendusername") = Usager
.Item(CDO & "sendpassword") = MotPasse
.Update
End With
Set objMessage = CreateObject("CDO.Message")
With objMessage
.Configuration = objConfig
.To = Destinataire
.From = Expéditeur
.Subject = Objet
.CreateMHTMLBody "file://" & FichierCM
.AddAttachment FichierPJ
.DSNOptions = Livraison 'Options de notification
If Livraison <> 1 Then 'Demande notification de l'état de remise
.Fields("urn:schemas:mailheader:disposition-notification-to") = Expéditeur
Else 'Sinon
.Fields.Delete ("urn:schemas:mailheader:disposition-notification-to")
End If
If Lecture = True Then 'Demande accusé de réception
.Fields("urn:schemas:mailheader:return-receipt-to") = Expéditeur
Else 'Sinon
.Fields.Delete ("urn:schemas:mailheader:return-receipt-to")
End If
.Fields.Update
.Send
End With
'Permettre au système d'exploitation de terminer avant de redonner la main au programme
DoEvents
Set objConfig = Nothing
Set objMessage = Nothing
Me.MousePointer = fmMousePointerDefault
Exit Sub
'Si une erreur survient, donnons 3 chances de recommencer avant de signaler l'erreur
Traitement:
Compteur = Compteur + 1
If Compteur < 3 Then
Set objConfig = Nothing
Set objMessage = Nothing
Resume Start
Else
Test = False
Message = Error
Me.MousePointer = fmMousePointerDefault
End If
End Sub |
Partager