Consulting

Results 1 to 2 of 2

Thread: Autoprint ONLY .pdf files as they arrive in the inbox

  1. #1

    Autoprint ONLY .pdf files as they arrive in the inbox

    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?

  2. #2
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •