[Résolu] Envois en masse pièces jointes dans Outlook

[Lone-wolf]

Bonjour le Forum

Je suis entrain de donner un coup de main à Bearn ("In USA" ) et j'ai un soucis pour inserer en pièces jointes des fichiers .pdf. dans Outlook. Après plusieures tentatives, j'ai fais la manipulation normale, en ouvrant le dossier et en sélectionnant les fichiers(pour l'instant 6) et je n'ai pas eu de problème.

Si quelqu'un peut m'aider à solutionner le problème en VBA, ce serait sympa.

 

[Lone-wolf]

Re : Envois en masse pièces jointes dans Outlook

Bonjour Pierre

En attendant l'aide, jai fait comme ceci et ça insère les pdf avec leurs noms respectifs.

Option Explicit

Public titre, nom, prenom, adresse, cp, ville, civilite, adrMail, chDoc, corps, PremAdresse, _
chemin, NomDoc, nom_doc, chPdf, NomPdf, nom_pdf, fichier, rep, chem, Fch1, Fch2, nf, lt As String
Public x, i As Long, cel As Range, c As Range, t


Sub Envois_Pdf()
Dim oApp As Word.Application, doc As Word.Document

    On Error Resume Next
    nf = ThisWorkbook.Path & "\Modele.doc"
    Set oApp = CreateObject("Word.Application")
    oApp.Visible = False
    Set doc = oApp.Documents.Open(nf)
    If Err <> 0 Then
      MsgBox "Le fichier doit être dans " & ThisWorkbook.Path, , "Envois PDF"
      Exit Sub
    End If
    
    With Feuil3
    x = 1
    For i = 1 To 5
    x = x + 1
    titre = .Cells(x, 2)
    prenom = .Cells(x, 3)
    nom = .Cells(x, 4)
    adresse = .Cells(x, 5)
    cp = .Cells(x, 6)
    ville = .Cells(x, 7)
    civilite = .Cells(x, 2)
    adrMail = .Cells(x, 8)
    NomPdf = .Cells(x, 1) & ".pdf"
   With doc
      .Bookmarks("titre").Range.Text = titre
      .Bookmarks("prenom").Range.Text = prenom
      .Bookmarks("nom").Range.Text = nom
      .Bookmarks("adresse").Range.Text = adresse
      .Bookmarks("cp").Range.Text = cp
      .Bookmarks("ville").Range.Text = ville
      .Bookmarks("civilite").Range.Text = civilite & ","
    End With
    
    nom_doc = prenom & " " & nom
    doc.SaveAs ThisWorkbook.Path & "\Fichiers doc\" & nom_doc & ".doc"
        
        doc.ExportAsFixedFormat OutputFileName:= _
        ThisWorkbook.Path & "\Fichiers pdf\" & nom_doc, ExportFormat:=wdExportFormatPDF
    nom_pdf = ThisWorkbook.Path & "\Fichiers pdf\" & nom_doc & ".pdf"
    
    Application.WindowState = xlMinimized
    t = Timer + 1: Do Until Timer > t: DoEvents: Loop
    Next i
        oApp.Quit
    End With
    

   Dim OlApp As Outlook.Application
    Dim Msg As MailItem
    Dim Objet, Corp, Mois, Strcc, Stf As String
    Dim CopieC, AdressMailBCC
    
    Set OlApp = New Outlook.Application
    Set Msg = OlApp.CreateItem(olMailItem)
    
Mois = LCase(Format(Date, "mmmm"))

If Left(Mois, 1) = "a" Or Left(Mois, 1) = "o" Then
lt = "d'"
Objet = "Rapport du mois " & lt & Mois

Corps = "Bonjour," & _
vbCrLf & vbCrLf & _
"ci-joint le rapport du mois " & lt & Mois & " pour votre agence." & _
vbCrLf & vbCrLf & _
"Nous restons bien entendu à votre disposition pour tout renseignement complémentaire." & _
vbCrLf & vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & vbCrLf & _
"Bearn in USA - Directeur Général"
Else
lt = "de"
Objet = "Rapport du mois " & lt & " " & Mois

Corps = "Bonjour," & _
vbCrLf & vbCrLf & _
"ci-joint le rapport du mois " & lt & " " & Mois & " pour votre agence." & _
vbCrLf & vbCrLf & _
"Nous restons bien entendu à votre disposition pour tout renseignement complémentaire." & _
vbCrLf & vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & vbCrLf & _
"Bearn in USA - Directeur Général"
End If

With Feuil3
PremAdresse = .Range("a2") & "<" & .Range("h2") & ">" & ";"
End With

With Feuil3       'Nom complet  et adresse mail
For Each cel In .Range("a3:a6")
                               'Nom complet  et adresse mail
       Strcc = Strcc & cel.Offset(0, 0).Value & "<" & cel.Offset(0, 7).Value & ">" & ";"
    Next cel
    CopieC = Split(Strcc, ";")
   
    For i = 0 To UBound(CopieC) - 1
        If CopieC(i) = AdressMailBCC Then
        Exit For
        Else
            AdressMailBCC = AdressMailBCC & CopieC(i) & ";"
        End If
    Next i
        End With

    Chemin = ThisWorkbook.Path & "\Fichiers pdf\"
    rep = ThisWorkbook.Path & "\Fichiers doc\"
    With Msg
    .To = PremAdresse
    .CC = Mid(AdressMailBCC, 1, Len(AdressMailBCC) - 1)
    .Subject = Objet
    .Body = Corps
    .Display
    For Each c In Feuil3.Range("i2:i6")
    fichier = c.Offset(0, 0).Value
    NomDoc = c.Offset(0, 0).Value & ".doc"
    .Attachments.Add Chemin & fichier
    Next c
    End With
    Set OlApp = Nothing
    Set Msg = Nothing

    Fch1 = Dir(chemin & "*.*")
    Do While Fch1 <> ""
        Kill chemin & Fch1
        Fch1 = Dir
    Loop
        Fch2 = Dir(rep & "*.*")
    Do While Fch2 <> ""
        Kill rep & Fch2
        Fch2 = Dir
    Loop            
                On Error GoTo 0  ' Annule la gestion d'erreur
End Sub

Je vais faire comme tu m'a montrer et je croise les doigts.

Comme tu peux le voir, j'ai les lignes tueuses de fichiers, mais elles ne veulent pas tuer(c'est ferié aujourd'hui )
Comment les supprimer?

EDIT: C'est bon j'ai trouvé, voir macro corrigée