Enregistrement d'un mail généré depuis excel VBA dans un répertoire choisi.

**regixel** · 20/06/2014, 14h17

Bonjour,

Je vous expose mon problème:
Je génère des mails depuis un fichier Excel que je doit adresser à des destinataires différents.
Je souhaiterai que chaque mail créé et envoyé soit enregistré dans un répertoire spécifique dans mon disque dur et bien sur en dehors de outlook.
Vous trouverez ci-après un début de procédure qui fonctionne parfaitement jusqu'à la création du mail mais qui n'enregistre pas ce dernier sur mon disque dur.

Je vous remercie d'avance pour l'aide apportée.
Cordialement

Sub envoimail()
'Mail aux concessionnaires
Dim Outlook As Object
Dim objCurrentMessage As Object
Dim Mail As Object
Dim dest As String
Dim Objet As String
Dim Corps As String
Dim Adr As String

Dim num, dest1
Range("V1").Select
dest = ActiveCell
Range("N2").Select
num = ActiveCell
dest1 = dest 'adresse du destinataire
Objet = "Dossier DICT-DT N° " & Range("B" & num).Value & " - " & Range("V1").Value
Range("N1").Select
Adr = ActiveCell
'corps de texte avec texte et sauts de ligne
Corps = "Bonjour, " & _
vbCrLf & _
"Veuillez trouver ci-joint en annexe, une déclaration de projet de travaux concernant :" & " " & Range("M" & num).Value & " ayant pour objet :" & Range("K" & num).Value & _
vbCrLf & _
"Vous en souhaitant bonne réception." & _
vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & _
"PS : Ce mail est généré automatiquement, merci de ne pas y répondre." & _
vbCrLf & vbCrLf & _
"XXXX" & _
vbCrLf & _
"YYYYY" & _
vbCrLf & _
"ZZZZ" & _
vbCrLf & _
"Secrétaire AAAA" & _
vbCrLf & _
"Adresse" & _
vbCrLf & _
"CP" & _
vbCrLf & _
"Mailto: " & Adr
Set Outlook = CreateObject("Outlook.Application")
Set Mail = Outlook.CreateItem(0)
With Mail
.To = dest
.CC = ""
.BCC = ""
.Subject = Objet
.Body = Corps
Workbooks.Open Filename:= _
Range("Q" & num).Value
On Error GoTo 100
.Attachments.Add ActiveWorkbook.FullName
ActiveWindow.Close
Workbooks.Open Filename:= _
Range("R" & num).Value
.Attachments.Add ActiveWorkbook.FullName
On Error GoTo 100
ActiveWindow.Close
.Display
End With
With Mail
Dim Repertoire, NomExport
NomExport = objCurrentMessage.Subject & objCurrentMessage.CreationTime ' Range("V" & num).Value
Repertoire = Range("U" & num).Value
.Mail.SaveAs.Filename = Repertoire
End With
100
End Sub

**Daniel.C** · 20/06/2014, 14h51

Bonjour,

Un conseil : mets ton code entre balises de code (surligne-le et appuie sur "#") avant qu'un modo te botte le c..

Sinon, peut-être :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

.Mail.SaveAs.Filename = Repertoire & "\" & NomExport

**regixel** · 25/06/2014, 13h42

Envoyé par Daniel.C

Bonjour,

Un conseil : mets ton code entre balises de code (surligne-le et appuie sur "#") avant qu'un modo te botte le c..

Sinon, peut-être :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

.Mail.SaveAs.Filename = Repertoire & "\" & NomExport

Merci pour l'information cependant je débute dans le domaine et je reconnais ne pas être au point dans l'usage du forum.
Désolé, mais je vais tenter de m'appliquer.
En ce qui concerne la réponse à mon problème, l'enregistrement ne s'effectue pas et ce sans qu'aucun message d’erreur n'apparaisse.
Peut-être auriez vous une idée.
Cordialement.

**Marc-L** · 25/06/2014, 14h00

Bonjour,

les deux étant pourtant directement consultables, rappels :

• Règles du forum (point III-E en particulier …)

• Editorial - A lire avant de poster …

Cordialement.

**Menhir** · 25/06/2014, 14h49

Pour quelle raison veux-tu le sauvegarder ? Pour pouvoir en garder une trace ou pour pouvoir le réutiliser en tant que mail ?

Dans le premier cas, je te conseille d'en faire tout simplement un PDF : c'est simple, pas gourmand en mémoire, facile à utilisé, pérenne, transmissible, etc.
Perso, c'est la solution que j'utilise pour archiver mes mails quand ils ne sont plus d'actualité.

**regixel** · 25/06/2014, 15h46

Tout d'abord merci pour les infos d'usage du forum.
Je viens d'imprimer les docs que je consulte

.
En ce qui concerne les mails, je souhaiterai conserver ces mails pour chaque dossier créés afin qu'il reste une trace de ces derniers en cas de réclamations.En deux mots, je doit émettre des mails à différents professionnels qui devront en retour préciser la présence ou non de réseaux.
Cette consultation est particulièrement sensible car elle engage notre responsabilité en cas de problème survenu sur les chantiers.
Le code fonctionne parfaitement mais l'enregistrement des mails n'est pas réalisé.

voici le 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
Sub envoimail()
'Mail aux concessionnaires
Dim Outlook As Object
Dim objCurrentMessage As Object
Dim Mail As Object
Dim dest As String
Dim Objet As String
Dim Corps As String
Dim Adr As String
Dim num, dest1
Range("V1").Select
dest = ActiveCell
Range("N2").Select
num = ActiveCell
dest1 = dest 'adresse du destinataire
Objet = "Dossier DICT-DT N° " & Range("B" & num).Value & " - " & Range("V1").Value
Range("N1").Select
Adr = ActiveCell
'corps de texte avec texte et sauts de ligne
Corps = "Bonjour, " & _
vbCrLf & _
"Veuillez trouver ci-joint en annexe, une déclaration de projet de travaux concernant :" & "  " & Range("M" & num).Value & " ayant pour objet :" & Range("K" & num).Value & _
vbCrLf & _
"Vous en souhaitant bonne réception." & _
vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & _
"PS : Ce mail est généré automatiquement, merci de ne pas y répondre." & _
vbCrLf & vbCrLf & _
"CGHG" & _
vbCrLf & _
"DVI" & _
vbCrLf & _
"SRD M" & _
vbCrLf & _
"SPA" & _
vbCrLf & _
"Adresse" & _
vbCrLf & _
"CP commune" & _
vbCrLf & _
"Mailto: " & Adr
Set Outlook = CreateObject("Outlook.Application")
Set Mail = Outlook.CreateItem(0)
With Mail
.To = dest
.CC = ""
.BCC = ""
.Subject = Objet
.Body = Corps
Workbooks.Open Filename:= _
Range("Q" & num).Value
On Error GoTo 100
.Attachments.Add ActiveWorkbook.FullName
ActiveWindow.Close
Workbooks.Open Filename:= _
Range("R" & num).Value
.Attachments.Add ActiveWorkbook.FullName
On Error GoTo 100
ActiveWindow.Close
.Display
Mail.PrintOut
Dim Repertoire, NomExport
NomExport = Mail.Subject
Repertoire = Range("U" & num).Value
Mail.SaveAs.Filename = Repertoire & "\" & NomExport & ".msg"
End With
100
End Sub

.

Merci pour la suite que vous souhaiterez donner à ce problème.
Cordialement.

**SCryptCypher** · 25/06/2014, 19h55

Bonsoir,

Essaye avec

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
SavePath = Repertoire & "\" & NomExport & ".msg"
Mail.SaveAs SavePath, OlSaveAsType.olMSG

Sinon vérifie que le répertoire de sauvegarde est correct.

**arosec** · 25/06/2014, 23h03

Bonsoir,

Tu peux ajouter ce bout de code pour contrôler l’existence du dossier avant enregistrement.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
  If Not fso.FolderExists(Repertoire & "\") Then MsgBox "Le dossier n''existe pas.", vbCritical, "Error Path"
  Set fso = Nothing

Cdlt,

**regixel** · 26/06/2014, 09h08

Bonjour,

Je fait suite à votre dernière réponse pour laquelle je vous adresse mes remerciements.
J'ai effectivement rajouté le code que vous m'avez proposé, cependant, aucune sauvegarde n'est réalisée.

Après vérification du nom du répertoire, il semble que la procédure ne s'effectue pas.
Peut-être aurais-je omis de vous préciser que je travaille avec Outlook 2010 et excel 2003.
Cela pourrait influer sur le résultat.
De plus, lors de l'exécution de ce code, VBA me précise qu'une erreur de compilation : Variable non définie concerne le "OlSaveAsType" comme indiqué ci-dessous en rouge dans le code.
Je vous remercie de bien vouloir m'éclairer sur ce sujet.

Je me permet de vous joindre le code après saisie de votre proposition.

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
Sub envoimail()
'Mail aux concessionnaires
Dim Outlook As Object
Dim objCurrentMessage As Object
Dim Mail As Object
Dim dest As String
Dim Objet As String
Dim Corps As String
Dim Adr As String
Dim num, dest1
Range("V1").Select
dest = ActiveCell
Range("N2").Select
num = ActiveCell
dest1 = dest 'adresse du destinataire
Objet = "Dossier DICT-DT N° " & Range("B" & num).Value & " - " & Range("V1").Value
Range("N1").Select
Adr = ActiveCell
'corps de texte avec texte et sauts de ligne
Corps = "Bonjour, " & _
vbCrLf & _
"Veuillez trouver ci-joint en annexe, une déclaration de projet de travaux concernant :" & "  " & Range("M" & num).Value & " ayant pour objet :" & Range("K" & num).Value & _
vbCrLf & _
"Vous en souhaitant bonne réception." & _
vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & _
"PS : Ce mail est généré automatiquement, merci de ne pas y répondre." & _
vbCrLf & vbCrLf & _
"CONSEIL GENERAL DE LA HAUTE GARONNE" & _
vbCrLf & _
"Direction de la voirie et des infrastructures" & _
vbCrLf & _
"Secteur Routier de MURET" & _
vbCrLf & _
"Secrétaire Pôle Aménagement" & _
vbCrLf & _
"50 Boulevard de Lamasquère" & _
vbCrLf & _
"31600 MURET" & _
vbCrLf & _
"Mailto: " & Adr
Set Outlook = CreateObject("Outlook.Application")
Set Mail = Outlook.CreateItem(0)
With Mail
.To = dest
.CC = ""
.BCC = ""
.Subject = Objet
.Body = Corps
Workbooks.Open Filename:= _
Range("Q" & num).Value
On Error GoTo 100
.Attachments.Add ActiveWorkbook.FullName
ActiveWindow.Close
Workbooks.Open Filename:= _
Range("R" & num).Value
.Attachments.Add ActiveWorkbook.FullName
On Error GoTo 100
ActiveWindow.Close
.Display
'Mail.PrintOut
Dim Repertoire, NomExport
NomExport = Mail.Subject
Repertoire = Range("U" & num).Value
'Mail.SaveAs.Filename = Repertoire & "\" & NomExport & ".msg"
Dim fso, savepath
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(Repertoire & "\") Then MsgBox "Le dossier n''existe pas.", vbCritical, "Error Path"
Set fso = Nothing
Savepath = Repertoire & "\" & NomExport & ".msg"
Mail.SaveAs Savepath, OlSaveAsType.olMSG
End With
100
End Sub