Envoi email outlook
Bonjour Le Forum,
Novice en VBA
Je cherche à envoyer un mail à partir d'Excel via Outlook.
Dans le fichier onglet TdB De A1 AQ68 à joindre en Pièce jointe au format PDF
Onglet Test une plage de A1 E4 à coller au format Image dans le corps du message Outlook
Onglet mail Colonne A adresse mail en destinataire principale Colonne B en copie
Objet "ci joint fichier...."
Dans le corps du message
"Bonjour"
"Ci-joint fichier audit du (c'est la date cellule AS1 onglet Tdb"
"Cordialement"
Je ne sais si c'est faisable c'est de mettre la signature des options Outlook courrier signature
D'avance merci
Le fichier n'est pas l'original trop lourd
Bonjour,
Au bas de cette page ... tu trouveras six discussions identiques à la tienne ...
Tu dois te douter que ce genre de question a déjà été très largement traité par le passé ...
Bonjour
J'ai trouvé cela çà fonctionne mais pour le reste peut on m'aider
Onglet Test une plage de A1 E4 à coller au format Image dans le corps du message Outlook
Onglet mail Colonne A adresse mail en destinataire principale Colonne B en copie
D'avance merci
[code]Sub mail()
' Nécessite la référence : Microsoft Outlook 1x Object Library
Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim CurFile As String
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
CurFile = ThisWorkbook.Path & "\" & "PHC.Pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=CurFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
With olMail
.To = ""
.CC = ""
.Subject = "SUIVI"
.Body = "Bonjour" & vbNewLine & "" & vbNewLine & "Cordialement" & vbNewLine & "Jean"
.Attachments.Add CurFile
.Display
'MsgBox "Merci de vérifier que le message apparait dans -messages envoyés- dans votre messagerie OUTLOOK."
' Effacer les variables objets
Set olMail = Nothing
Set olApp = Nothing
End With
End Sub
[/code]
Bonjour val59552 et le Forum
une proposition à tester:
Sub test()
'https://forum.excel-pratique.com/viewtopic.php?f=2&t=136653
Dim OutApp As Object, OutMail As Object
Dim WsTdB As Worksheet, WsMail As Worksheet, WsTest As Worksheet
Dim Sujet As String, MyDate As String
Dim Chemin As String, Fichier As String, TempFilePath As String, strbody As String
Dim ImageRange As Range, PdfRange As Range, Cel As Range
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set WsTdB = ThisWorkbook.Sheets("TdB")
Set WsMail = ThisWorkbook.Sheets("Mail")
Set WsTest = ThisWorkbook.Sheets("Test")
WsMail.Activate
MyDate = WsTdB.Range("AS1")
Set PdfRange = WsTdB.Range("A1:AQ68")
Set ImageRange = WsTest.Range("A1:E4")
Chemin = Environ$("temp") & "\"
Fichier = Chemin & "PHC.Pdf"
Set OutApp = CreateObject("Outlook.Application")
Call createJpg(ActiveSheet.Name, ImageRange.Address, "PlageImage")
TempFilePath = Environ$("temp") & "\"
strbody = "<BODY style=""font-size:12pt;font-family:Calibri"">Bonjour," & "<br>" & _
"Ci-joint fichier audit du " & MyDate & " :<br> " _
& "<br>" _
& "<img src= cid:PlageImage.jpg'>" _
& "<br><br>Cordialement</font>"
PdfRange.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fichier, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
For Each Cel In WsMail.Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Sujet = "ci joint fichier...."
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Cel.Value
.Cc = Cel.Offset(, 1).Value
.Subject = Sujet
.HTMLBody = strbody & "<br>" & .HTMLBody
.Attachments.Add Fichier
.Attachments.Add TempFilePath & "PlageImage.jpg", 1
.display
'.send
End With
On Error GoTo 0
Set OutMail = Nothing
Next Cel
Kill Fichier
Kill TempFilePath & "PlageImage.jpg"
cleanup:
Set OutApp = Nothing
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets("Test").Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
Bonjour le forum,
j'ai testé ça fonctionne bien mais un petit souci, il envoie un mail à chaque destinataire ex 3 moi si c'est possible c'est d'envoyer un seul mail avec tous les destinataires et ceux en copie, dans mon fichier source j'ai environ 30 destinataires et 7 en copie
D'avance merci
Bonjour val59552,
voici le code adapté:
Sub test2()
'https://forum.excel-pratique.com/viewtopic.php?f=2&t=136653
Dim OutApp As Object, OutMail As Object
Dim WsTdB As Worksheet, WsMail As Worksheet, WsTest As Worksheet
Dim Sujet As String, MyDate As String, Destinataire As String, DestCopie As String
Dim Chemin As String, Fichier As String, TempFilePath As String, strbody As String
Dim ImageRange As Range, PdfRange As Range, Cel As Range
Dim DestArray As Variant, DestCopArray As Variant
Dim LastRowA As Integer, LastRowB As Integer
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set WsTdB = ThisWorkbook.Sheets("TdB")
Set WsMail = ThisWorkbook.Sheets("Mail")
Set WsTest = ThisWorkbook.Sheets("Test")
LastRowA = WsMail.Range("A" & Rows.Count).End(xlUp).Row
LastRowB = WsMail.Range("B" & Rows.Count).End(xlUp).Row
DestArray = Application.Transpose(WsMail.Range("A2:A" & LastRowA).Value)
DestCopArray = Application.Transpose(WsMail.Range("B2:B" & LastRowB).Value)
Destinataire = Join(DestArray, ";")
DestCopie = Join(DestCopArray, ";")
MyDate = WsTdB.Range("AS1")
Set PdfRange = WsTdB.Range("A1:AQ68")
Set ImageRange = WsTest.Range("A1:E4")
Chemin = Environ$("temp") & "\"
Fichier = Chemin & "PHC.Pdf"
Set OutApp = CreateObject("Outlook.Application")
Call createJpg(ActiveSheet.Name, ImageRange.Address, "PlageImage")
TempFilePath = Environ$("temp") & "\"
strbody = "<BODY style=""font-size:12pt;font-family:Calibri"">Bonjour," & "<br>" & _
"Ci-joint fichier audit du " & MyDate & " :<br> " _
& "<br>" _
& "<img src= cid:PlageImage.jpg'>" _
& "<br><br>Cordialement</font>"
PdfRange.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fichier, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Sujet = "ci joint fichier...."
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Destinataire
.Cc = DestCopie
.Subject = Sujet
.HTMLBody = strbody & "<br>" & .HTMLBody
.Attachments.Add Fichier
.Attachments.Add TempFilePath & "PlageImage.jpg", 1
.display
'.send
End With
On Error GoTo 0
Set OutMail = Nothing
Kill Fichier
Kill TempFilePath & "PlageImage.jpg"
cleanup:
Set OutApp = Nothing
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets("Test").Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
Bonjour
C'est nickel
Un Bon WE
Merci