Outlook 2007 - Automatisch PDF-Anhänge ausdrucken bei mehreren Emails gleichzeitig

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

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder

Set Ns = Application.GetNamespace("MAPI")  
Set Folder = Ns.GetDefaultFolder(olFolderInbox).Folders("Auto_Rechnungsdruck") 'Kontrollordner in Outlook  
Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)

If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
End If
End Sub

Public Function Pause(NumberOfSeconds As Variant)
    On Error GoTo Error_GoTo

    Dim PauseTime As Variant
    Dim Start As Variant
    Dim Elapsed As Variant

    PauseTime = NumberOfSeconds
    Start = Timer
    Elapsed = 0
    Do While Timer < Start + PauseTime
        Elapsed = Elapsed + 1
        If Timer = 0 Then
            'Crossing midnight  
            PauseTime = PauseTime - Elapsed
            Start = 0
            Elapsed = 0
        End If
        DoEvents
    Loop

Exit_GoTo:
    On Error GoTo 0
    Exit Function
Error_GoTo:
    Debug.Print Err.Number, Err.Description, Erl
    GoTo Exit_GoTo
End Function

Private Sub PrintAttachments(oMail As Outlook.MailItem)
On Error Resume Next
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim bla As Boolean
bla = True
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String
sDirectory = "C:\tmp\Attachment\" 'Temporärer Speicherort PDF-Anhang  
Set colAtts = oMail.Attachments
If colAtts.count Then
    For Each oAtt In colAtts
        sFileType = LCase$(Right$(oAtt.FileName, 4))
        Select Case sFileType
            Case ".pdf"  
            sFile = sDirectory & oAtt.FileName
            oAtt.SaveAsFile sFile
            ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0  
            Pause (45) 'Zeit in Sekunden nach löschen der PDF  
            Kill "C:\tmp\Attachment\" & oAtt.FileName  
        End Select
    Next
End If
End Sub