As you appear to have realised Excel cannot open and print PDFs. Rather than try and debug the posted code, I have posted an alternative that should work. All the code goes in a standard module and not ThisOutlookSession. (The declaration section will need modifying for 64 bit Office).
The code includes a macro that will enable you to test with a selected message with PDF attachment.
There is also a macro to process a folder. That macro has code for using a progress bar userform commented out. If you want to use the progress bar, you can download it from http://www.gmayor.com/Zips/ProgressBar.zip
The code uses the Shell function to print to the associated application. If you want to program Acrobat directly then Diane Poremsky has it covered at http://www.poremsky.com/office/print-pdf-vba/
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub ProcessSelectedMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
PrintAttachments olMsg
lbl_Exit:
Exit Sub
End Sub
Sub ProcessFolder()
Dim olNs As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
'Dim oFrm As New frmProgress
'Dim PortionDone As Double
Dim i As Long
On Error GoTo err_Handler
Set olNs = GetNamespace("MAPI")
Set olMailFolder = olNs.PickFolder
Set olItems = olMailFolder.Items
'oFrm.Show vbModeless
i = 0
For Each olMailItem In olItems
i = i + 1
' PortionDone = i / olItems.Count
' oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
PrintAttachments olMailItem
DoEvents
Next olMailItem
err_Handler:
'Unload oFrm
'Set oFrm = Nothing
Set olNs = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Sub PrintAttachments(olItem As MailItem)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Const strSaveFldr As String = "C:\Temp\"
CreateFolders strSaveFldr
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If LCase(olAttach.FileName) Like "*.pdf" Then
strFname = olAttach.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
PrintFile 0, strSaveFldr & strFname
End If
Next olAttach
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(fldr) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Private Function PrintFile(lngForm As Long, strFileName As String)
Dim retVal As Long
On Error Resume Next
retVal = ShellExecute(lngForm, "Print", strFileName, 0&, 0&, 3)
lbl_Exit:
Exit Function
End Function