Envoi email outlook

Le 18/02/2020 à 08:57

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

22test-mail.xlsm (80.61 Ko)
Le 18/02/2020 à 09:01

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é ...

Le 20/02/2020 à 16:58
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]

Le 20/02/2020 à 19:22

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
Le 21/02/2020 à 02:52

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

Le 21/02/2020 à 18:52

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
Le 23/02/2020 à 04:43

Bonjour

C'est nickel

Un Bon WE

Merci

Rechercher des sujets similaires à "envoi email outlook"