looping a pdf print in a macro

[paultsmith]

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

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

'Go to Metric sheet and print.</SPAN>
Sheets("Metrics").Select</SPAN>
Application.CutCopyMode = False</SPAN>
Destfile = (Path2) & (counter) & ".PS"</SPAN>
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, Printtofile:=True, prtofilename:=Destfile</SPAN>
Sheets("DEPTS").Select</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>
Loop</SPAN>

'Go to Total Metric sheet and print.</SPAN>
'Set Ws</SPAN>
Set Ws = Sheets("TTLMetrics")</SPAN>
Ws.Activate</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>
ActiveWorkbook.Save</SPAN>
ActiveWindow.Close</SPAN>
</SPAN></o>