ipv excel sheet word document invoegen

Sub opslaan_en_mailen()

Range("A75") = "0"

'Application.ScreenUpdating = False
'Workbooks.Open "E:\AfstandANWB-meerderePC.xls"
 '  ActiveWorkbook.Sheets(1).Range("A1") = ThisWorkbook.Sheets(1).Range("P16")
  ' ActiveWorkbook.Sheets(1).Range("A2") = ThisWorkbook.Sheets(1).Range("P17")
 'ThisWorkbook.Sheets(1).Range("P45") = ActiveWorkbook.Sheets(1).Range("B6")
 'ActiveWorkbook.Close True
'Range("L38").Value = ""
Range("L39").Value = "HP LaserJet 4100 PCL 6;(Facturen Lade 2)/Samsung CLX-6200 Series PCL6"
'Outlook openen
If Range("P35") = "0" Then
Dim otl
Set otl = Nothing
Dim oShell
Set oShell = CreateObject("WScript.Shell")
On Error Resume Next
Set otl = GetObject("outlook.application")
On Error GoTo 0
If otl Is Nothing Then
'not running
oShell.Run ("regedit /s " & "H:publicpmtoff.reg")
oShell.Run ("regedit /s " & "H:publicpmt.reg")
oShell.Run ("Outlook"), 2 ',2 = outlook minimized openen

Else
'running
End If

Set otl = Nothing
Set oShell = Nothing
Range("p35") = "1"
End If


' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2010
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

'Range("A75") = "1"
If Range("A75") = "0" Then
Dim SourceDir As String, TargetDir As String, TargetDir2 As String
    Dim Numfiles As Integer, i As Integer

    SourceDir = "C:\Users\Acer\Documents\SmarThru Desktop\"
    TargetDir = "E:\A2B4U\Opdrachten\2016\"
    TargetDir2 = "E:\A2B4U\Opdrachten\2016\New\"
    
    Numfiles = 0      'returns # files copied
    
    Filename = Dir$(SourceDir & "*.pdf")
    
    While Filename <> ""
        For i = 1 To 2
            FileCopy SourceDir & Filename, Choose(i, TargetDir & Filename, TargetDir2 & Filename)
        Next
        Kill SourceDir & Filename
        If Err = 0 Then Numfiles = Numfiles + 1
        On Error GoTo 0
        Filename = Dir$        'get next matching file
        DoEvents            'allow processes to occur
    Wend
    Else
    MsgBox "Number of files copied = " & Numfiles
    
    
    Range("A75") = "1" + 1
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
Range("L46").Value = "PDF File wordt gemaakt"

'If MsgBox("Loes weet je zeker dat de factuur goed is ?", vbQuestion + vbYesNo) = vbYes Then
'If lAnswer = vbYes Then Hoort bij MsgBox Loes....

'End If Hoort bij MsgBox Loes ....
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: Print to PDF file using PDFCreator
' (Download from http://sourceforge.net/projects/pdfcreator/)
' Designed for late bind, no references req'd

Dim lijst As String
Dim pos As String
Dim P1 As String
Dim P2 As String
Dim sMaster As String
Dim sChild As String
Dim blRet As Boolean
Dim pdfjob As Object
Dim sPDFName As String
Dim sPDFPath As String
    Dim dbResultaat As Double
    Dim sPadAdobe As String
    Dim sBestand As String
    Dim sClose As String

Range("L46").Value = "Sheet facturen wordt berekend"


        Application.Calculate
MyName = Range("P29").Value & ""
'/// Change the output file name here! ///
sPDFName = MyName & ".xls"
'"testPDF.pdf"
sPDFPath = "E:\A2B4U\Opdrachten\2016\New\"
'ActiveWorkbook.Path & Application.PathSeparator

'Check if worksheet is empty and exit if so
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")

With pdfjob
If .cStart("/NoProcessingAtStartup") = False Then
MsgBox "Can't initialize PDFCreator.", vbCritical + _
vbOKOnly, "PrtPDFCreator"
Exit Sub
End If
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = sPDFPath
.cOption("AutosaveFilename") = sPDFName
.cOption("AutosaveFormat") = 0 ' 0 = PDF
.cClearCache
End With
oWordDoc.SaveAs2 sPDFPath & Replace(MyName, "doc", "pdf"), 17

'Print the document to PDF
ActiveSheet.PrintOut Copies:=1, ActivePrinter:="PDFCreator"

'Wait until the print job has entered the print queue
Do Until pdfjob.cCountOfPrintjobs = 1
DoEvents
Loop
pdfjob.cPrinterStop = False

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
pdfjob.cClose
Set pdfjob = Nothing
'Sub tst()
If [O40] = "K" Then MsgBox "Wat wil je nou ? Afdrukken of Mailen ?": Exit Sub
If [O40] = "M" Then
'versturen van pdf via mail
Range("L46").Value = "PDF lijst samenstellen."
        
        [AX1].CurrentRegion.ClearContents
    fn = Dir("E:\A2B4U\Opdrachten\2016\New\*.pdf")
        Do While fn <> ""
            myResult = myResult & fn & "|"
            fn = Dir()
        Loop
        [AX1].Resize(UBound(Split(myResult, "|"))) = WorksheetFunction.Transpose(Split(myResult, "|"))
        [AM1].CurrentRegion.ClearContents
    fn = Dir("E:\A2B4U\Opdrachten\2016\*.pdf")
        Do While fn <> ""
            myResult = myResult & fn & "|"
            fn = Dir()
        Loop
        [AP1].Resize(UBound(Split(myResult, "|"))) = WorksheetFunction.Transpose(Split(myResult, "|"))
Range("L46").Value = "Plaatst PDF lijst in sheet."
        
        Application.Calculate
'Set App = CreateObject("Outlook.Application")
'Set Itm = App.CreateItem(0)
sPDFPath = "E:\A2B4U\Opdrachten\2016\New\"
'SigString = "C:\Documents and Settings\A2B4U\Application Data\Microsoft\Handtekeningen\a2b4u.htm"
SigString = "A2B 4U Koeriers Vught"

    'SigString = "C:\Users\" & Environ("username") & _
     "\AppData\Roaming\Microsoft\Signatures\Mysig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
With OutMail 'Itm
   Range("L46").Value = "E-mail wordt opgemaakt."
 
    .Subject = "Betreft rit: " & Range("H47").Value 'Plaats - Plaats
    .To = Range("O32").Value & "" 'vul hier een mail adres in
    Select Case Range("P103").Value
    Case "2"
    .BCC = Range("P102").Value 'vul hier een 2e emailadres in
    Case "1"
    End Select
    '.CC = ""
    '.BCC = ""

    '.Body = Replace([P31] & [O31] & "#" & "#" & [P32] & "#" & [P33] & "#" & "#" & [P34] & "#" & [P35] & "#" & "#" & _
                [P36] & "#" & [P37] & "#" & [P38] & "#" & "#" & [P39] & "#" & [P40], "#", vbNewLine)
    strbody1 = "<table width=""800px""><tr>" & _
    "<td colspan=""2"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><B>" & Range("P31") & " " & Range("O31") & "<br></B><br>" & Range("P32") & "<br />" & Range("P33") & _
    "<td colspan=""2"">&nbsp;</td>" & _
    "</tr><tr>"
   '   strbody8 = "<table width=""800px""><tr>" & _
    "<td colspan=""2"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000"">" & "<br><br>Met vriendelijke groet, <br />Theo Steevens</td>" & _
    "<td colspan=""2"">&nbsp;</td>" & _
    "</tr><tr>"
         If Range("P34") = "0" Then
     strbody2 = "<td width=""15px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><br /></td>" & _
    "<td width=""785px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><p><br />Deze e-factuur inclusief de bijlagen is automatisch verstuurd. <br />Mocht de tenaamstelling en/of het e-mail adres niet juist zijn, <br />of heeft u uw facturen liever per post, dan horen wij (ThSt@A2B4U.nl) dat graag.</p></td></tr>"
    strbody7 = "<td width=""15px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><br /></td>" & _
    "<td width=""785px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><p><br />Bij correspondentie, en of (meerdere) betalingen<br /> graag de laatste 4 cijfers van het factuurnummer vermelden. <br />.</p></td></tr>"
    End If
          strbody4 = "<td width=""15px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><br>  </td>" & _
    "<td width=""785px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><p><br>Google Maps, de website waarmee wij de gereden route uitrekenen,<br>is steeds aan optimalisatie onderhevig.<br>Zo kan het zijn dat eenzelfde opdracht afwijkt van uw vorige factuur.<br><br>Op de vrachtbrief wordt altijd vermeld dat de goederen vanaf uw <br />bedrijfsadres geleverd worden, ook als wij de goederen elders moeten ophalen. <br />Tevens verwijderen wij ook eventuele stickers en plakband van uw leverancier.</p></td></tr>"
         
         'strbody4 = "<td width=""15px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><br>  </td>" & _
    "<td width=""785px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><p><br>Als nieuwe optie plaatsen wij voortaan in onze facturen,<br>een http://www link zodat uzelf de route en de gereden kilometers kunt zien.<br>In het pdf bestand kunt u op de link klikken.<br><br>Op de vrachtbrief wordt altijd vermeld dat de goederen vanaf uw <br />bedrijfsadres geleverd worden, ook als wij de goederen elders moeten ophalen. <br />Tevens verwijderen wij ook eventuele stickers en plakband van uw leverancier.</p></td></tr>"
             If Range("o12") = "Niet bekend" Then
     strbody6 = "<td width=""15px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><br /></td>" & _
    "<td width=""785px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><p><br>Graag willen wij op onze facturen het BTW-identificatienummer van onze klant vermelden. <br />In onze administratie is dit helaas nog niet aanwezig, wij verzoeken u vriendelijk om uw<br /> BTW-identificatienummer naar ons te mailen.</p></td></tr>"
    End If
strbody3 = "<tr><td colspan=""2"">" & _
    "<table width=""150"" border=""0"" cellspacing=""0"" cellpadding=""0"">" & _
    "<tr><br>Met vriendelijke groet, <br />Theo Steevens</td>" & _
    "<td><a href=""http://www.a2b4u.nl""><img src=""http://www.a2b4u.nl/images/a2b4u.logo.jpg"" alt=""A2B 4U Koeriers"" width=""150"" height=""120"" border=""0"" /></a></td>" & _
    "</tr><tr>" & _
    "<td align=""center"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><b>06 - 208 68 209</b><td>" & _
    "</tr><tr>" & _
    "<td align=""center"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 16px; color: #000000""><a href=""http://www.a2b4u.nl"" title=""A2B 4U Koeriers"">www.A2B4U.nl</a></td>" & _
    "</tr></table></td></tr></table>"
'strbody8 = "<br><br>Met vriendelijke groet, <br />Theo Steevens</td>"
strbody5 = "<td width=""8px"" valign=""top"" style=""font-family:Arial, Helvetica, sans-serif; font-size: 4px; color: #000000""><p><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br />Aan dit bericht, waaronder ook de eventuele bijlagen worden bedoeld, <br />kunnen geen rechten worden ontleend. Dit bericht kan persoonlijk en  <br />vertrouwelijk zijn. Als u dit bericht per abuis hebt ontvangen, wordt u<br />" & _
    "verzocht de afzender te informeren en alle informatie hierover uit uw<br />computer(s) te verwijderen. Het is niet toegestaan om dit bericht,<br /> geheel of gedeeltelijk, zonder toestemming te gebruiken of te verspreiden.<br />A2B 4U Koeriers Vught sluit elke aansprakelijkheid uit wanneer informatie<br />in deze e-mail niet correct, onvolledig of niet tijdig overkomt,<br />evenals indien er schade ontstaat ten gevolge van deze e-mail.<br />" & _
    "A2B 4U Koeriers Vught garandeert niet dat het bericht vrij kan zijn van<br />onderschepping of manipulatie daarvan door derden of computerprogramma’s die<br />die worden gebruikt voor elektronische berichten en het overbrengen van virussen.<p><br /><br /><br /><br /><br /><br />"
        .HTMLBody = strbody1 & strbody4 & strbody6 & strbody2 & strbody7 & strbody8 & strbody3 & strbody5 '& Signature
     '   .HTMLBody = strbody1 & strbody6 & strbody2 & strbody8 & strbody3 & strbody5 '& Signature
    sPDFPath = "E:\A2B4U\Opdrachten\2016\New"
    '.Attachments.Add sPDFPath & "\" & Replace(sPDFName, "xls", "pdf") 'Factuur word gemaild. (0123456789.pdf)
    sMaster = sPDFPath & "\" & Replace(sPDFName, "xls", "pdf") 'Factuur is hoofddocument (0123456789.pdf)

    If Range("O34") = "1" Then
        Range("L46").Value = "Vrachtbrief word gemerged en verwijderd."
        sPDFPath = "E:\A2B4U\Opdrachten\2016\New"
'.Attachments.Add sPDFPath & "\" & (Range("O35").Value) 'Vrachtbrief word gemaild. (0123456789v.pdf)
      sChild = sPDFPath & "\" & (Range("O35").Value) 'Vrachtbrief word gemerged. (0123456789v.pdf)
    Call loadlib
        blRet = MergePDFDocuments(sMaster, sChild)
        sMaster = sPDFPath & "\" & (Range("O29").Value)
        sChild = sPDFPath & "\" & (Range("O35").Value)
        Kill sPDFPath & "\" & (Range("O35").Value)
    End If
    If Range("O36") = "1" Then
            Range("L46").Value = "Bevestiging word gemerged en verwijderd."
    sPDFPath = "E:\A2B4U\Opdrachten\2016\New"
'.Attachments.Add sPDFPath & "\" & (Range("O37").Value) 'Bevestiging word gemaild. (0123456789b.pdf)
      sChild = sPDFPath & "\" & (Range("O37").Value) 'Bevestiging word gemerged. (0123456789b.pdf)
    Call loadlib
        blRet = MergePDFDocuments(sMaster, sChild)
        sMaster = sPDFPath & "\" & (Range("O29").Value)
        sChild = sPDFPath & "\" & (Range("O37").Value)
        Kill sPDFPath & "\" & (Range("O37").Value)
    End If
    If Range("O38") = "1" Then
         Range("L46").Value = "Pakbon word gemerged en verwijderd."
       sPDFPath = "E:\A2B4U\Opdrachten\2016\New"
'.Attachments.Add sPDFPath & "\" & (Range("O39").Value) 'Pakbon word gemaild. (0123456789p.pdf)
          sChild = sPDFPath & "\" & (Range("O39").Value) 'Pakbon word gemerged. (0123456789p.pdf)
    Call loadlib
        blRet = MergePDFDocuments(sMaster, sChild)
        sMaster = sPDFPath & "\" & (Range("O29").Value)
        sChild = sPDFPath & "\" & (Range("O39").Value)
        Kill sPDFPath & "\" & (Range("O39").Value)
    
            End If
Range("L46").Value = "Factuur word toegevoegd als bijlage."
   .Attachments.Add sPDFPath & "\" & (Range("O29").Value) 'Factuur word gemaild. (0123456789.pdf)
   '.Attachments.Add sPDFPath & "\" & (Range("P29").Value) & ".mht" 'kilometerberekening
      'laat pdf file zien
   'sPadAdobe = "C:\Program Files\Adobe\Acrobat 9.0\Acrobat\Acrobat.exe" 'MAIN
   'sPadAdobe = "C:\Program Files\Adobe\Reader 8.0\Reader\AcroRd32.exe" 'Note_20
     sPadAdobe = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe" 'Note_20 en Acer-PC
     sBestand = "E:\A2B4U\Opdrachten\2016\New\" & Range("o29").Value 'save
   '  dbResultaat = Shell(sPadAdobe & " " & sBestand, vbMaximizedFocus)
     dbResultaat = Shell(sPadAdobe & " " & sBestand, vbNormalFocus)
    ' dbResultaat = Shell(sPadAdobe & " " & sBestand, vbMinimizedFocus)