Beste VBA'ers,
Ik ben met behulp van voorbeelden gekomen tot onderstaande code om één excel-sheet naar PDFCreator te sturen en daar vervolgens twee andere bestaande Pdf-bestanden aan toe te voegen, maar de code werkt nog niet helemaal goed.
Het gaat fout bij het toevoegen van de bestaande Pdf's of eigenlijk gebeurt er gewoon niks. Hij doorloopt gewoon de .cPrintFile regels, maar er verschijnen geen extra bestanden in de PDF-creator wachtrij en ik heb dus geen foutmeldingen, dus ook geen idee wat er mis gaat. Kan iemand mij vertellen wat er ontbreekt/misgaat?
Ik ben met behulp van voorbeelden gekomen tot onderstaande code om één excel-sheet naar PDFCreator te sturen en daar vervolgens twee andere bestaande Pdf-bestanden aan toe te voegen, maar de code werkt nog niet helemaal goed.
Het gaat fout bij het toevoegen van de bestaande Pdf's of eigenlijk gebeurt er gewoon niks. Hij doorloopt gewoon de .cPrintFile regels, maar er verschijnen geen extra bestanden in de PDF-creator wachtrij en ik heb dus geen foutmeldingen, dus ook geen idee wat er mis gaat. Kan iemand mij vertellen wat er ontbreekt/misgaat?
Code:
Sub Factuur_opslaan()
Dim pdfjob As Object
Dim PDFnaam As String
Dim PDFpad As String
Dim bRestart As Boolean
Dim factuurnummer As String
Dim werknummer As String
Dim werkoms As String
Dim factuurdatum As String
Dim Bedrijf As String
Dim naam As String
Dim OutApp As Object
Dim OutMail As Object
Dim Att As Object
Dim Contact As String
Dim LevBon As String
Dim LevBonNr As String
Dim MDR As String
BeveiligingOpheffen
factuurnummer = Sheets("Factuur").Range("B13").Value 'variabelen instellen
werknummer = Sheets("Factuur").Range("B25").Value
werkoms = Sheets("Factuur").Range("C25").Value
factuurdatum = Sheets("Factuur").Range("B16").Value
Bedrijf = Sheets("Factuur").Range("F2").Value
PDFpad = ThisWorkbook.Path & "\" & werknummer & "\Facturen\"
PDFnaam = factuurnummer & " ; " & factuurdatum & ".pdf"
If Dir(ThisWorkbook.Path & "\" & werknummer, vbDirectory) = Empty Then MkDir ThisWorkbook.Path & "\" & werknummer 'indien nodig mappen aanmaken
If Dir(ThisWorkbook.Path & "\" & werknummer & "\Facturen", vbDirectory) = Empty Then MkDir ThisWorkbook.Path & "\" & werknummer & "\Facturen"
On Error GoTo EarlyExit
Application.ScreenUpdating = False
'pdfjob instellen voor samenvoegen factuur met LevBon en MDR
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Check if PDFCreator is already running and attempt to kill the process if so
Do
bRestart = False
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
If pdfjob.cStart("/NoProcessingAtStartup") = False Then
'PDF Creator is already running. Kill the existing process
Shell "taskkill /f /im PDFCreator.exe", vbHide
DoEvents
Set pdfjob = Nothing
bRestart = True
End If
Loop Until bRestart = False
'Assign settings for PDF job
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = PDFpad
.cOption("AutosaveFilename") = PDFnaam
.cOption("AutosaveFormat") = 0 '0 = PDF
.cDefaultPrinter = "PDFCreator"
.cClearCache
End With
'PDF maken van factuur
ActiveWindow.SelectedSheets.PrintOut copies:=1, ActivePrinter:="PDFCreator"
'Print the attachments to PDFCreator
For Each x In Sheets("Factuur").Range("A28:A33")
If x.Value <> "" Then
With pdfjob
LevBonNr = x.Offset(0, 9).Value
LevBon = ThisWorkbook.Path & "\" & werknummer & "\Leverbonnen\" & LevBonNr & " ; " & werknummer & " ; " & x.Value & ".pdf"
.cPrintFile (LevBon)
Application.Wait Now + TimeValue("0:0:2")
MDR = ThisWorkbook.Path & "\" & werknummer & "\Mandagenregisters\MDR-" & werknummer & " ; " & x.Value & ".pdf"
.cPrintFile MDR
Application.Wait Now + TimeValue("0:0:2")
End With
End If
Next
'Wait until all the print jobs have entered the queue
Do Until pdfjob.cCountOfPrintjobs = Sheets("Factuur").Range("I25").Value + 1
DoEvents
Loop
With pdfjob
.cCombineAll
.cPrinterStop = False
End With
'Wait until the PDF file shows up then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
'Wait a bit longer for PDF Creator to finish
Application.Wait Now + TimeValue("0:0:2")
'reset original Windows' default printer
pdfjob.cDefaultPrinter = DefaultPrinter
pdfjob.cClose
Sheets("Factuur").Range("N2:N3").Find(Bedrijf).Offset(0, 5).Value = Sheets("Factuur").Range("B13").Value 'Factuurnummer vastleggen
BeveiligingInstellen
Contact = Sheets("Factuur").Range("F16").Value 'Emailen
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Sheets("Factuur").Range("F17").Value
.Subject = "HVBW Factuur " & factuurnummer & " dd. " & factuurdatum & " mbt " & werknummer & " " & werkoms
.HTMLbody = "<p style='color:rgb(31,73,125);font-size:15'> Beste " & Contact & ", </font></p>" & vbNewLine & vbNewLine & _
"<p style='color:rgb(31,73,125);font-size:15'>Bijgevoegd vind u onze factuur met betrekking tot " & werknummer & " " & werkoms & ".</font></p>"
Set Att = .Attachments.Add(PDFpad & factuurnummer & " ; " & factuurdatum & ".pdf")
For Each x In Sheets("Factuur").Range("A28:A33")
If x.Value <> "" Then
Set Att = .Attachments.Add(ThisWorkbook.Path & "\" & werknummer & "\Leverbonnen\" & x.Offset(0, 9).Value & " ; " & werknummer & " ; " & x.Value & ".pdf")
Set Att = .Attachments.Add(ThisWorkbook.Path & "\" & werknummer & "\Mandagenregisters\MDR-" & werknummer & " ; " & x.Value & ".pdf")
End If
Next
End With
OutMail.Display
Cleanup:
'Release objects and terminate PDFCreator
Set pdfjob = Nothing
Shell "taskkill /f /im PDFCreator.exe", vbHide
On Error GoTo 0
'Application.ScreenUpdating = True
Exit Sub
EarlyExit:
'Inform user of error, and go to cleanup section
MsgBox ("There was an error encountered. PDFCreator has been terminated on file " & PDFName & " in bind. Please try again.")
Resume Cleanup
End Sub
