Is there any vba code to autoprint ONLY .pdf files as they arrive in the inbox and after print they redirect to a specific folder?<br><br>Also, is there a way to use the header/footer option to stamp the inbox name to the pdf file?
Is there any vba code to autoprint ONLY .pdf files as they arrive in the inbox and after print they redirect to a specific folder?<br><br>Also, is there a way to use the header/footer option to stamp the inbox name to the pdf file?
The following should work to save and print the PDFs. The stamping is another issue entirely. Use the main macro as a script run from a rule. Test it with a selected message and the test macro
Option Explicit #If Win64 Then Public Declare PtrSafe 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 #Else Public 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 #End If Sub TestSave() 'An Outlook macro by Graham Mayor Dim olMsg As MailItem On Error Resume Next Set olMsg = ActiveExplorer.Selection.Item(1) SaveAttachmentsAndPrint olMsg lbl_Exit: Exit Sub End Sub Public Sub SaveAttachmentsAndPrint(olItem As MailItem) 'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017 Dim olAttach As Attachment Dim strFname As String Dim strExt As String Dim j As Long Dim WSShell As Object Const strSaveFldr As String = "C:\Path\Attachments\" CreateFolders strSaveFldr On Error Resume Next If olItem.Attachments.Count > 0 Then Set WSShell = CreateObject("WScript.Shell") For j = 1 To olItem.Attachments.Count Set olAttach = olItem.Attachments(j) If 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 ShellExecute 0, "Print", strSaveFldr & strFname, 0&, 0&, 3 End If Next j olItem.Save End If lbl_Exit: Set olAttach = Nothing Set olItem = Nothing Exit Sub End Sub Private Function FileNameUnique(strPath As String, _ strFileName As String, _ strExtension As String) As String 'An Outlook macro by Graham Mayor 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 'An Outlook macro by Graham Mayor 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 'An Outlook macro by Graham Mayor 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) 'An Outlook macro by Graham Mayor 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
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com