Macro pour envoyer à une liste excel un fichier via outlouok

[davef]

Bonjour à tous,

Je crée une macro me permettant d'envoyer un mail à toute cette mailing list excel (de type colonne A=Prénom, B= Nom, C= adresse mail) avec un sujet,un corps de texte et un fichier joins que je changerai à chaque utilisation.

Après plusieurs recherche sur le net, je me tourne vers vous car je ne suis pas parvenu à trouver une réponse me satisfaisant.

J'arrive à entrer ma pièce jointe mais je ne parviens pas à la joindre aux mails.

Voici ma macro :

Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Sub SendEMail()
    Dim Email As String, Subj As String
    Dim Msg As String, URL As String
    Dim r As Integer, x As Double
    Dim NbLigne As Integer
    Dim Core As String
    Dim Filename As Variant
    
    
    ' Select the first sheet line
        Range("A1").Select

'       Count the number of no empty lines
    Do While Not (IsEmpty(ActiveCell))
        NbLigne = NbLigne + 1
        Selection.Offset(1, 0).Select
    Loop
    
'       Message subject
        Subj = InputBox("What is the Subject ?", "Subject")
        
'       Message Core
        Core = InputBox("What is the Core of your Mail ?", "Core")
        
'       Attach your file
        Filename = Application _
        .GetOpenFilename("Pdf Files (*.pdf), *.pdf")
        If fileToOpen <> False Then
        MsgBox "Open " & fileToOpen
        End If
        

    For r = 2 To NbLigne

'       Get the email address
        Email = Cells(r, 3)


'       Compose the message
        Msg = ""
        Msg = Msg & "Dear " & Cells(r, 1) & " " & Cells(r, 2) & "," & vbCrLf & vbCrLf
        Msg = Msg & Core & vbCrLf & vbCrLf
        Msg = Msg & "Galaxy Team"
        
'       Replace spaces with %20 (hex)
        Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
        Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
                
'       Replace carriage returns with %0D%0A (hex)
        Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
        

'       Create the URL
        URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg
        Filename.SendMail

'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

'       No Wait before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    
    Next r
    
End Sub

 

[Compte Supprimé 979]

Re : Macro pour envoyer à une liste excel un fichier via outlouok

Davef,

pas de double post STP
https://www.excel-downloads.com/thr...via-outlouok-a-une-mailing-list-excel.184660/