Aide sur code VBA

[Juan]

Bonjour à tous,

J'ai besoin de votre aide sur un code VBA.

Je souhaite, à partir d'un fichier Excel, générer un fichier PDF qui est ensuite directement envoyé par email à certains destinataires.

Concernant mon code, la plupart des requêtes fonctionnent excepté celle qui devrait indiquer : "récupérer le fichier pdf généré et l'insérer dans le PJ du mail".

Voici ci-dessous mon code (que j'ai récupérer puis modifié) :
Sub envoi_Feuille()
Dim olapp As Outlook.Application
Dim malist, Count, Envoi, AdresseRépertoire As Variant
On Error Resume Next
'-------Contrôler dans Bisual Basic/Outils/Références/que Microsoft Outlook --,- Object Librairy est bien coché
Dim adresse(1 To 10)
'----------------------Création de la liste d'adresses mail contenus de la ligne 2 à 10
Set malist = Sheets("Mailing_list").Range("A2:A7")
Count = 1
For Each Envoi In malist
If Len(Envoi) Then adresse(Count) = Envoi: Count = Count + 1
Next

'----------------------Copie de la liste d'adresse dans une cellule vide exemple H1
[H1] = Array(adresse(1) & "; " & adresse(2) & "; " & _
adresse(3) & "; " & adresse(4) & "; " & adresse(5) & "; " & adresse(6), adresse(7))

'-------adresse du répertoire ou sera enregistré le fichier
AdresseRépertoire = "\\dc2fr\Users\Jean Liniere\Reporting\Direction des ventes\Daily sales report"

'---------------------Création fichier PDF
Dim sRep As String
Dim sFilename As String

Sheets(Array("Overview - Sales", "Daily View", "Month to date", "YTD")).Select
sRep = ThisWorkbook.Path
sFilename = "\\dc2fr\Users\Jean Liniere\Reporting\Direction des ventes\Daily sales report" & "\" & "Daily Sales report " & Format(Date, "yyyy-mm-dd") & ".pdf"

ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sFilename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False

'---------------------Nom du fichier à envoyer
ActiveWorkbook.SaveAs AdresseRépertoire & "\" & "Daily Sales report " & Format(Date, "yyyy-mm-dd") & ".pdf" ' ou adresse si le nom est dans une cellule Range("E2").Value & ".xls"

'---------------------Envoi par mail
Sheets("Mailing List").Select
Range("H1").Select

'---------------------contrôle la validité ou la présence d'adresse mail en H1
If [H1] Like "*@*" Then

'---------------------Le mail est envoyé que si y a des adresses feuille 1 en H1
Do While Not IsEmpty(ActiveCell)
Dim msg As MailItem
Set olapp = New Outlook.Application
Set msg = olapp.CreateItem(olMailItem)
msg.To = Range("H1").Value 'Adresse de la cellule contenant la liste des adesses mails

'--------------------Saisir le sujet de l'envoi
msg.Subject = ThisWorkbook.Name ' ou saisir le sujet dans une cellule ex. Range("H2").Value

'---------------------saisie du message
msg.Body = "Bonjour" & Chr(13) & Chr(13) & "Veuillez trouver ci-joint" & Chr(13) & "copie du dossier" & Chr(13) & Chr(13) & "Cordialement"

'---------------------ou saisir le message dans des cellules
'msg.Body = Range("E5").Value & Chr(13) & Chr(13) & Range("E8").Value & Chr(13) & Chr(13)& Range("E10").Value
'---------------------ou saisir le message dans des cellules
'---------------------Adresse de la pièce jointe
msg.Attachments.Add Source:=AdresseRépertoire & "\" & "Daily Sales report " & Format(Date, "yyyy-mm-dd") & ".PDF" ' ou adresse si le nom est dans une cellule Range("E2").Value & ".xls"
msg.Send
'---------------------effacement de la liste d'envoi
[H1].ClearContents
Loop
Else
MsgBox "Aucune adresse valide sélectionnée"
End If
Application.ScreenUpdating = True
End Sub


Merci à tous !
Jean

 

[jpb388]

Re : Aide sur code VBA

Bonsoir à tous
a tester fait avec 2010

Sub envoi_Feuille()
    Dim olApp As New Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim malist As Worksheet
    Dim AdresseRépertoire$, i As Byte
    On Error GoTo Fin
 '----------------------Création de la liste d'adresses mail contenus de la ligne 2 à 10
    Set malist = ThisWorkbook.Worksheets("Mailing_list")
    Set Msg = olApp.CreateItem(olMailItem)
 '---------------------contrôle la validité ou la présence d'adresse mail en A2
    If malist.Range("A2") = "" Then Err.Raise vbObjectError + 1, "Feuille : Mailing_list", "Destinataire en A2 absent"

 '---------------------Création fichier PDF
    Sheets(Array("Overview - Sales", "Daily View", "Month to date", "YTD")).Select
 '-------adresse du répertoire ou sera enregistré le fichier
    AdresseRépertoire = ThisWorkbook.Path & "\" & "Daily Sales report " & Format(Date, "yyyy-mm-dd") & ".pdf"

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=AdresseRépertoire, Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False



 With Msg
    '--------------------Saisir le sujet de l'envoi
    .Subject = ThisWorkbook.Name ' ou saisir le sujet dans une cellule ex. Range("H2").Value
     '---------------------saisie du message
     .Body = "Bonjour" & vbCrLf & vbCrLf & "Veuillez trouver ci-joint" & vbCrLf & "copie du dossier" & vbCrLf & _
                vbCrLf & "Cordialement" 

    i = 2
    Do While malist.Cells(i, 1) <> ""
        .Recipients.Add malist.Cells(i, 1)
        i = i + 1
    Loop
  '---------------------Adresse de la pièce jointe
   .Attachments.Add AdresseRépertoire  ' ou adresse si le nom est dans une cellule Range("E2").Value & ".xls"
    .Send
 End With
 Exit Sub
Fin:
MsgBox Err.Description, vbCritical + vbOKOnly, Err.Source
End Sub