looping a pdf print in a macro


New Member
Oct 7, 2009
I have used a loop to print ps files. The macro does not work anymore so I would like to modify it to print into a pdf file. The code I had used to combine pdfs and the code I would like to add follows: (The original added a number of sheets to a file. It has 3 sections. I need to loop a print function into it.)

Sub WKMETPRNTANY()<o:p></o:p>
Dim db As Database<o:p></o:p>
Dim Qd As DAO.QueryDef<o:p></o:p>
Dim Rs As DAO.Recordset<o:p></o:p>
Dim Ws As Object<o:p></o:p>
Dim i As Integer<o:p></o:p>
Dim FirstDate As String<o:p></o:p>
Dim LastDate As String<o:p></o:p>
Dim Path As String<o:p></o:p>
Dim Path2 As String<o:p></o:p>
Dim counter As Integer<o:p></o:p>
Dim Destfile As String<o:p></o:p>
Dim Msg, Style, Title, Help, Ctxt, Response, MyString<o:p></o:p>
Msg = "Change default printer to Tektronix Phaser 840 Plus and click OK" ' Define message.<o:p></o:p>
Style = vbDefaultButton1 ' Define buttons.<o:p></o:p>
Title = "Change Printer" ' Define title.<o:p></o:p>
Dim appAccess As Access.Application<o:p></o:p>
Dim objSync As Office.Sync<o:p></o:p>
'Turn off alerts.<o:p></o:p>
Application.DisplayAlerts = False<o:p></o:p>
Application.AskToUpdateLinks = False<o:p></o:p>
'Save and close the workbook.<o:p></o:p>
'Turn on alerts.<o:p></o:p>
Application.DisplayAlerts = True<o:p></o:p>
Application.AskToUpdateLinks = True<o:p></o:p>
End Sub<o:p></o:p>
Sub BASLC_1()<o:p></o:p>
Dim FileName As String<o:p></o:p>
'Call the function with the correct arguments<o:p></o:p>
'FileName = BASLC_F ("addtopdf", "", True, True)<o:p></o:p>
'For a fixed file name and overwrite it each time you run the macro use<o:p></o:p>
sPath = "C:\Users\paulsm\Documents\Jobs\Weekly New Metrics\zTemp\BAS Department Dashboard"<o:p></o:p>
sFilename1 = Format(Now() - Weekday(Now()), "yyyymmdd")<o:p></o:p>
sFileName2 = ".pdf"<o:p></o:p>
'For a fixed file name and overwrite it each time you run the macro use<o:p></o:p>
FileName = BASLC_F("addtopdf", _<o:p></o:p>
sPath & sFilename1 & sFileName2, True, False)<o:p></o:p>
If FileName <> "" Then<o:p></o:p>
'Ok, you find the PDF where you saved it<o:p></o:p>
'You can call the mail macro here if you want<o:p></o:p>
MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _<o:p></o:p>
"Microsoft Add-in is not installed" & vbNewLine & _<o:p></o:p>
"You Canceled the GetSaveAsFilename dialog" & vbNewLine & _<o:p></o:p>
"The path to Save the file in arg 2 is not correct" & vbNewLine & _<o:p></o:p>
"You didn't want to overwrite the existing PDF if it exist"<o:p></o:p>
End If<o:p></o:p>
End Sub<o:p></o:p>
Function BAS10301_F(NamedRange As String, FixedFilePathName As String, _<o:p></o:p>
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String<o:p></o:p>
'This function will create a PDF with every sheet with<o:p></o:p>
'a sheet level name variable <NAMEDRANGE>in it<o:p></o:p>
Dim FileFormatstr As String<o:p></o:p>
Dim Fname As Variant<o:p></o:p>
Dim Ash As Worksheet<o:p></o:p>
Dim sh As Worksheet<o:p></o:p>
Dim ShArr() As String<o:p></o:p>
Dim s As Long<o:p></o:p>
Dim SheetLevelName As Name<o:p></o:p>
'Test If the Microsoft Add-in is installed<o:p></o:p>
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _<o:p></o:p>
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then<o:p></o:p>
'We fill the Array with sheets with the sheet level name variable<o:p></o:p>
For Each sh In ActiveWorkbook.Worksheets<o:p></o:p>
If sh.Visible = -1 Then<o:p></o:p>
Set SheetLevelName = Nothing<o:p></o:p>
On Error Resume Next<o:p></o:p>
Set SheetLevelName = sh.Names(NamedRange)<o:p></o:p>
On Error GoTo 0<o:p></o:p>
If Not SheetLevelName Is Nothing Then<o:p></o:p>
s = s + 1<o:p></o:p>
ReDim Preserve ShArr(1 To s)<o:p></o:p>
ShArr(s) = sh.Name<o:p></o:p>
End If<o:p></o:p>
End If<o:p></o:p>
Next sh<o:p></o:p>
'We exit the function If there are no sheets with<o:p></o:p>
'a sheet level name variable named <NAMEDRANGE><o:p></o:p>
If s = 0 Then Exit Function<o:p></o:p>
If FixedFilePathName = "" Then<o:p></o:p>
'Open the GetSaveAsFilename dialog to enter a file name for the pdf<o:p></o:p>
FileFormatstr = "PDF Files (*.pdf), *.pdf"<o:p></o:p>
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _<o:p></o:p>
Title:="Create PDF")<o:p></o:p>
'If you cancel this dialog Exit the function<o:p></o:p>
If Fname = False Then Exit Function<o:p></o:p>
Fname = FixedFilePathName<o:p></o:p>
End If<o:p></o:p>
'If OverwriteIfFileExist = False we test if the PDF<o:p></o:p>
'already exist in the folder and Exit the function if that is True<o:p></o:p>
If OverwriteIfFileExist = False Then<o:p></o:p>
If Dir(Fname) <> "" Then Exit Function<o:p></o:p>
End If<o:p></o:p>
Application.ScreenUpdating = False<o:p></o:p>
Application.EnableEvents = False<o:p></o:p>
'Remember the ActiveSheet<o:p></o:p>
Set Ash = ActiveSheet<o:p></o:p>
'Select the sheets with the sheet level name in it<o:p></o:p>
'Now the file name is correct we Publish to PDF<o:p></o:p>
On Error Resume Next<o:p></o:p>
ActiveSheet.ExportAsFixedFormat _<o:p></o:p>
Type:=xlTypePDF, _<o:p></o:p>
FileName:=Fname, _<o:p></o:p>
Quality:=xlQualityStandard, _<o:p></o:p>
IncludeDocProperties:=True, _<o:p></o:p>
IgnorePrintAreas:=False, _<o:p></o:p>
On Error GoTo 0<o:p></o:p>
'If Publish is Ok the function will return the file name<o:p></o:p>
If Dir(Fname) <> "" Then<o:p></o:p>
BAS10301_F = Fname<o:p></o:p>
End If<o:p></o:p>
Application.ScreenUpdating = True<o:p></o:p>
Application.EnableEvents = True<o:p></o:p>
End If<o:p></o:p>
End Function<o:p></o:p>
<o:p>The code I would like to add is:

'Working on W/S DEPTS</SPAN>
'Set Ws</SPAN>
Set Ws = Sheets("DEPTS")</SPAN>

'This set of code will activate worksheet and clear any existing data.</SPAN>
'After clearing the data, it will select cell A1.</SPAN>

'Set the Database, and RecordSet. This Table exists in the database.</SPAN>
Set db = Workspaces(0).OpenDatabase(Path, ReadOnly:=True)</SPAN>
Set Qd = db.QueryDefs("5 Depts Q")</SPAN>

'Create a new Recordset from the Query based on the stored QueryDef.</SPAN>
Set Rs = Qd.OpenRecordset()</SPAN>

'This loop will collect the field names and place them in the first</SPAN>
'row starting at "A1."</SPAN>
For i = 0 To Rs.Fields.Count - 1</SPAN>
Ws.Cells(1, i + 1).Value = Rs.Fields(i).Name</SPAN>

'The next three lines will get the data from the recordset and copy</SPAN>
'it into the Worksheet.</SPAN>
Ws.Range("A2").CopyFromRecordset Rs</SPAN>

'Select sheet that contains all depts.</SPAN>
'Select cell A2, *first line of data*.</SPAN>
'Set counter to 1.</SPAN>
counter = 1002</SPAN>
' Set Do loop to stop when an empty cell is reached.</SPAN>
Do Until IsEmpty(ActiveCell)</SPAN>
'Copy dept #</SPAN>

'Go to Input sheet and paste into input cell.</SPAN>
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _</SPAN>
:=False, Transpose:=False</SPAN>

'Go to Metric sheet and print.</SPAN>
Application.CutCopyMode = False</SPAN>
Destfile = (Path2) & (counter) & ".PS"</SPAN>
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, Printtofile:=True, prtofilename:=Destfile</SPAN>

' Step down 1 row from present location.</SPAN>
ActiveCell.Offset(1, 0).Select</SPAN>

'Add 1 to counter</SPAN>
counter = counter + 1</SPAN>

'Loop until active cell is Empty</SPAN>

'Go to Total Metric sheet and print.</SPAN>
'Set Ws</SPAN>
Set Ws = Sheets("TTLMetrics")</SPAN>
Application.CutCopyMode = False</SPAN>
Destfile = (Path2) & "1001.PS"</SPAN>
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, Printtofile:=True, prtofilename:=Destfile</SPAN>

'Save and close the workbook.</SPAN>

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Forum statistics

Latest member

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