Carry string over to sub routine

B

bensko

Board Regular
Joined
Mar 4, 2008
Messages
173
I use the following Code to print muliple PDF's into a new folder. How can I carry over the "strDefpath & strDirname" string to the sub module (PrintToPDF) rather than duplicate the string in the sub module. The problem is because it takes several minutes to create all of the PDF's 2 or 3 folders get created instead of just one.

Code: 
Sub B_Create_Client_Sheet_PDF_Mon()
    Dim strDirname, strDefpath As String
strDirname = Format(Now(), "yy-mm-dd_hhmm") 'Range("A1").Value ' New directory name
strDefpath = "C:\Users\BWS-Dell_540\Desktop\Client Sheet\" 'Default path name
MkDir strDefpath & strDirname
 
    Sheets("Schedule").Select
CreateListAlpha_A 'update before printing
Application.ScreenUpdating = False
    Range("C4:C5").Select
100
If ActiveCell.Value = "" Or ActiveCell.Value = "OFF" Then
ActiveCell.Offset(2, 0).Select
Else
    Selection.Copy
    Sheets("Client Sheet").Select
    Range("AO1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Sheets("Schedule").Select
    Application.CutCopyMode = False
    Cells(2, ActiveCell.Column).Copy
    Sheets("Client Sheet").Select
    Range("AO3").Select
    ActiveSheet.Paste
    'B_Add_Hard_Returns
 
PrintToPDF
 
    'ActiveWindow.SelectedSheets.PrintOut copies:=1, Collate:=True ', Preview:=True
    Sheets("Schedule").Select
    ActiveCell.Offset(2, 0).Select
End If
If ActiveCell.Value = "" Or ActiveCell.Value = "OFF" Then
ActiveCell.Offset(2, 0).Select
Else
    Selection.Copy
    Sheets("Client Sheet").Select
    Range("AO1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
    Sheets("Schedule").Select
    Application.CutCopyMode = False
    Cells(2, ActiveCell.Column).Copy
    Sheets("Client Sheet").Select
    Range("AO3").Select
    ActiveSheet.Paste
PrintToPDF
    Sheets("Schedule").Select
    ActiveCell.Offset(1, 0).Select
End If
If ActiveCell.Value = "" Or ActiveCell.Value = "OFF" Then
If ActiveCell.Address = "$DD$8" Then
GoTo 200
End If
ActiveCell.Offset(-4, 7).Select
Else
    Selection.Copy
    Sheets("Client Sheet").Select
    Range("AO1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Sheets("Schedule").Select
    Application.CutCopyMode = False
    Cells(2, ActiveCell.Column).Copy
    Sheets("Client Sheet").Select
    Range("AO3").Select
    ActiveSheet.Paste
PrintToPDF
    Sheets("Schedule").Select
If ActiveCell.Address = "$DD$8" Then
GoTo 200
End If
ActiveCell.Offset(-4, 7).Select
End If
GoTo 100
200
Range("A3").Select
Application.ScreenUpdating = True
End Sub

Code: 
Sub PrintToPDF()
'Author       : Ken Puls ([URL="http://www.excelguru.ca"]www.excelguru.ca[/URL])
'Macro Purpose: Print to PDF file using PDFCreator
'   (Download from [URL]http://sourceforge.net/projects/pdfcreator/[/URL])
'   Designed for early bind, set reference to PDFCreator
    Dim pdfjob As PDFCreator.clsPDFCreator
    Dim sPDFName As String
    Dim sPDFPath As String
    Dim bRestart As Boolean
 
''''''''''//////Moved to Print_PDF
    Dim strFilename, strDirname, strPathname, strDefpath As String
strDirname = Format(Now(), "yy-mm-dd_hhmm") 'Range("A1").Value ' New directory name
strDefpath = "C:\Users\BWS-Dell_540\Desktop\Client Sheet\" 'Default path name
'MkDir strDefpath & strDirname
''''''''''//////
 
 
    Application.ScreenUpdating = False
    '/// Change the output file name here! ///
    'sPDFName = "testPDF.pdf"
    'sPDFPath = ActiveWorkbook.Path & Application.PathSeparator
    sPDFName = ActiveSheet.Range("X3").Value & " - " & ActiveSheet.Range("O1").Value & " - " & ActiveSheet.Range("AQ4").Value & ".pdf"
    sPDFPath = strDefpath & strDirname
    'sPDFPath = "C:\Users\BWS-Dell_540\Desktop\Client Sheet"
    'Check if worksheet is empty and exit if so
    If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
    'Activate error handling and turn off screen updates
    On Error GoTo EarlyExit
    Application.ScreenUpdating = False
    Set pdfjob = New PDFCreator.clsPDFCreator
    'Check if PDFCreator is already running and attempt to kill the process if so
    Do
        bRestart = False
        Set pdfjob = New 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") = sPDFPath
        .cOption("AutosaveFilename") = sPDFName
        .cOption("AutosaveFormat") = 0    ' 0 = PDF
        .cClearCache
    End With
    'Delete the PDF if it already exists
    If Dir(sPDFPath & sPDFName) = sPDFName Then Kill (sPDFPath & sPDFName)
    '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 the PDFCreator queue is clear
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
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" & vbCrLf & _
           "has been terminated.  Please try again.", _
           vbCritical + vbOKOnly, "Error"
    Resume Cleanup
End Sub

Appreciate any help with this,

Ben
 
Sort by date Sort by votes
I haven't checked the code, but you would declare them as parameters to PrintToPDF:

Sub PrintToPDF(strDefPath As String, strDirName As String)

and delete the same declarations in PrintToPDF.

The pass the arguments in the call like this:

PrintToPDF strDefPath, strDirName
 
Upvote 0
Thanks John, though not sure I did it properly, I am getting a compile error "ByRef argument type mismatch"

Using Excel 2003 if that makes any difference

Heres: what I tried

Code: 
Sub B_Create_Client_Sheet_PDF_Mon()
    Dim strDirName, strDefPath As String
strDirName = Format(Now(), "yy-mm-dd_hhmm") 'Range("A1").Value ' New directory name
strDefPath = "C:\Users\BWS-Dell_540\Desktop\Client Sheet\" 'Default path name
MkDir strDefPath & strDirName
    
    Sheets("Schedule").Select
CreateListAlpha_A 'update before printing
Application.ScreenUpdating = False
    Range("C4:C5").Select
100
If ActiveCell.Value = "" Or ActiveCell.Value = "OFF" Then
ActiveCell.Offset(2, 0).Select
Else
    Selection.Copy
    Sheets("Client Sheet").Select
    Range("AO1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Sheets("Schedule").Select
    Application.CutCopyMode = False
    Cells(2, ActiveCell.Column).Copy
    Sheets("Client Sheet").Select
    Range("AO3").Select
    ActiveSheet.Paste
    'B_Add_Hard_Returns
    
[B]PrintToPDF strDefPath, strDirName
[/B]    
    'ActiveWindow.SelectedSheets.PrintOut copies:=1, Collate:=True ', Preview:=True
    Sheets("Schedule").Select
    ActiveCell.Offset(2, 0).Select
End If
If ActiveCell.Value = "" Or ActiveCell.Value = "OFF" Then
ActiveCell.Offset(2, 0).Select
Else
    Selection.Copy
    Sheets("Client Sheet").Select
    Range("AO1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Sheets("Schedule").Select
    Application.CutCopyMode = False
    Cells(2, ActiveCell.Column).Copy
    Sheets("Client Sheet").Select
    Range("AO3").Select
    ActiveSheet.Paste
PrintToPDF strDefPath, strDirName
    Sheets("Schedule").Select
    ActiveCell.Offset(1, 0).Select
End If
If ActiveCell.Value = "" Or ActiveCell.Value = "OFF" Then
If ActiveCell.Address = "$DD$8" Then
GoTo 200
End If
ActiveCell.Offset(-4, 7).Select
Else
    Selection.Copy
    Sheets("Client Sheet").Select
    Range("AO1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Sheets("Schedule").Select
    Application.CutCopyMode = False
    Cells(2, ActiveCell.Column).Copy
    Sheets("Client Sheet").Select
    Range("AO3").Select
    ActiveSheet.Paste
PrintToPDF strDefPath, strDirName
    Sheets("Schedule").Select
If ActiveCell.Address = "$DD$8" Then
GoTo 200
End If
ActiveCell.Offset(-4, 7).Select
End If
GoTo 100
200
Range("A3").Select
Application.ScreenUpdating = True
End Sub

Code: 
Sub PrintToPDF(strDefPath As String, strDirName As String)
'Author       : Ken Puls ([URL="http://www.excelguru.ca"]www.excelguru.ca[/URL])
'Macro Purpose: Print to PDF file using PDFCreator
'   (Download from [URL]http://sourceforge.net/projects/pdfcreator/[/URL])
'   Designed for early bind, set reference to PDFCreator
    Dim pdfjob As PDFCreator.clsPDFCreator
    Dim sPDFName As String
    Dim sPDFPath As String
    Dim bRestart As Boolean
        
''''''''''//////Moved to Print_PDF
'Dim strFilename, strDirName, strPathname, strDefPath As String
'strDirName = Format(Now(), "yy-mm-dd_hhmm") 'Range("A1").Value ' New directory name
'strDefPath = "C:\Users\BWS-Dell_540\Desktop\Client Sheet\" 'Default path name
'MkDir strDefpath & strDirname
''''''''''//////
   
    
    Application.ScreenUpdating = False
    '/// Change the output file name here! ///
    'sPDFName = "testPDF.pdf"
    'sPDFPath = ActiveWorkbook.Path & Application.PathSeparator
    sPDFName = ActiveSheet.Range("X3").Value & " - " & ActiveSheet.Range("O1").Value & " - " & ActiveSheet.Range("AQ4").Value & ".pdf"
    sPDFPath = strDefPath & strDirName
    'sPDFPath = "C:\Users\BWS-Dell_540\Desktop\Client Sheet"
    'Check if worksheet is empty and exit if so
    If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
    'Activate error handling and turn off screen updates
    On Error GoTo EarlyExit
    Application.ScreenUpdating = False
    Set pdfjob = New PDFCreator.clsPDFCreator
    'Check if PDFCreator is already running and attempt to kill the process if so
    Do
        bRestart = False
        Set pdfjob = New 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") = sPDFPath
        .cOption("AutosaveFilename") = sPDFName
        .cOption("AutosaveFormat") = 0    ' 0 = PDF
        .cClearCache
    End With
    'Delete the PDF if it already exists
    If Dir(sPDFPath & sPDFName) = sPDFName Then Kill (sPDFPath & sPDFName)
    '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 the PDFCreator queue is clear
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
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" & vbCrLf & _
           "has been terminated.  Please try again.", _
           vbCritical + vbOKOnly, "Error"
    Resume Cleanup
End Sub
 
Upvote 0
The error occurs because the line:

Dim strDirName, strDefPath As String

declares strDirName as a Variant and PrintToPDF is expecting a string.

Change the line to:

Dim strDirName As String, strDefPath As String
 
Upvote 0
Hi bensko,

You may want to make a small modification to the PDFCreator routine as well. That's an older build of the code that I wrote, and I've found that a change to the way we close off PDFCreator makes it more stable.

You can find up to date examples here

Specific part that I would change is this:
Code: 
     'Wait until the PDFCreator queue is clear
    Do Until pdfjob.cCountOfPrintjobs = 0
          DoEvents
    Loop

To this:
Code: 
    'Wait until the file shows up before closing PDF Creator
    Do
        DoEvents
    Loop Until Dir(sPDFPath & sPDFName) = sPDFName

What this does is change the method to check the file system looking to see when the file is actually created and shows up, rather than relying on PDFCreator to tell you from it's own properties. For whatever reason, I've found that we can't always rely on PDFCreator to give us accurate information there.

Hope this helps,
 
Upvote 0
Hi Ken, when I updated your code it took longer than usual to print the first page then never printed a page after that and seemed to loop endlessly until I killed it. When I put back the old code, it worked fine?
 
Upvote 0
Try also modifying the assignment of the path to include the trailing slash on the directory:

Change this line:
Code: 
sPDFPath = strDefPath & strDirName

To this:
Code: 
sPDFPath = strDefPath & strDirName & Application.PathSeparator

I think that should take care of it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
VBA Macro issue-excel spreadsheet to PDF with password encoding
Replies
1
Views
4K
Logit
Logit
R
  • Question Question
Code running in vbe page but not in workbook
Replies
2
Views
572
rkotha
R
M
  • Question Question
User type not defined error!
Replies
9
Views
6K
merveak
M
J
  • Question Question
macro print to pdf.... SIZE CONUMDRUM
6 7 8
Replies
73
Views
9K
JytteC
J
P
  • Question Question
Adding PDF as background (watermark)
Replies
4
Views
15K
Pastafarian
P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top