PDF bestanden meesturen met VBA mailopdracht

Status
Niet open voor verdere reacties.

1965Peter

Gebruiker
Lid geworden
20 jun 2016
Berichten
197
Hallo,
Ik heb van internet een werkende VBA mail-opdracht gevonden. Nu zou ik aan deze gegenereerde mail, alle PDF-bestanden mee willen sturen van een bestands locatie:
C:\Peter\Mijn Documenten\Mail\

Wat voor code kan ik daar voor gebruiken? , en waar moet deze ertussen komen?



Code:
Sub Mail_versturen()
 Application.ScreenUpdating = False
    Debug.Print RangetoHTML(Range("B12:C13"))
    
    Dim OutApp As Object
    Dim OutMail As Object
            
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = Sheets("Parameters").Range("B3")
        .CC = Sheets("Parameters").Range("B5")
        .BCC = ""
        .Subject = Sheets("Parameters").Range("B9") & " " & Range("C9")
        .HTMLBody = RangetoHTML(Sheets("Parameters").Range("B12:C13"))
        .Display
    End With
     
    Set OutMail = Nothing
    Set OutApp = Nothing
     Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Iets als dit:
Code:
[COLOR="#FF0000"]    Dim PDFdir As String
    PDFdir = "C:\Peter\Mijn Documenten\Mail"[/COLOR]

    With OutMail
        .To = Sheets("Parameters").Range("B3")
        .CC = Sheets("Parameters").Range("B5")
        .BCC = ""
        .Subject = Sheets("Parameters").Range("B9") & " " & Range("C9")
        .HTMLBody = RangetoHTML(Sheets("Parameters").Range("B12:C13"))
[COLOR="#FF0000"]        PDF = Dir(PDFdir & "\*.pdf")
        While PDF <> ""
            .Attachments.Add PDFdir & "\" & PDF
            PDF = Dir()
        Wend[/COLOR]
        .Display
    End With
 
Laatst bewerkt:
Edmoor, Geweldig, dit werkt prima!!.
Dank voor de snelle reactie.:)
 
Als je dan toch in HTML bezig bent zou ik de handtekening er ook bij doen:
Code:
Dim PDFdir As String
[COLOR="#FF0000"]Dim Sig As String[/COLOR]
PDFdir = "C:\Peter\Mijn Documenten\Mail"

With OutMail
    [COLOR="#FF0000"].Display[/COLOR]
    [COLOR="#FF0000"]Sig = .HTMLBody[/COLOR]
    .To = Sheets("Parameters").Range("B3")
    .CC = Sheets("Parameters").Range("B5")
    .BCC = ""
    .Subject = Sheets("Parameters").Range("B9") & " " & Range("C9")
    .HTMLBody = RangetoHTML(Sheets("Parameters").Range("B12:C13"))[COLOR="#FF0000"] & "<br>" & Sig[/COLOR]
    PDF = Dir(PDFdir & "\*.pdf")
    While PDF <> ""
        .Attachments.Add PDFdir & "\" & PDF
        PDF = Dir()
    Wend
    .Display
End With
 
En deze code
Code:
   Dim OutApp As Object
    Dim OutMail As Object
            
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
vervangen door 1 regel:

Code:
   With CreateObject("Outlook.Application").CreateItem(0)
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan