Sujet Précédent Sujet Suivant

Macro pour envoyer à une liste excel un fichier via outlouok

davidfifi Messages postés 3 Date d'inscription vendredi 18 mai 2012 Statut Membre Dernière intervention 21 mai 2012 - 18 mai 2012 à 17:21
davidfifi Messages postés 3 Date d'inscription vendredi 18 mai 2012 Statut Membre Dernière intervention 21 mai 2012 - 19 mai 2012 à 12:20
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

2 réponses

Réponse 1 / 2
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 137
19 mai 2012 à 08:01
Bonjour,
Regarde de ce côté-ci, le programme à été mis à jour recemment:

http://www.vbfrance.com/codes/ENVOI-AUTOMATIQUE-MAIL-AVEC-PIECE-JOINTE-VBA-EXCEL_31545.aspx

@+Le Pivert
0
Réponse 2 / 2
davidfifi Messages postés 3 Date d'inscription vendredi 18 mai 2012 Statut Membre Dernière intervention 21 mai 2012
19 mai 2012 à 12:20
Bonjour,

Merci beaucoup Le Pivert !!!

A+
0
Rejoignez-nous