Print Outlook Attachment - AdobeReader ist zu langsam für Makro!

Option Explicit


Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)  
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(Outlook.OlDefaultFolders.olFolderInbox) 'Ordner definieren (hier Posteingang)  
    Set Items = Folder.Items
End Sub


Private Sub Items_ItemAdd(ByVal Item As Object)
   
   
   Dim i As Integer 'Variable i wird als Integer definiert  

   AttachmentFolder 'Ordner Bereinigungs-Funktion aufrufen  
   
   'PrintAttachments Item 'Print-Funktion aufrufen  
   Item.UnRead = False 'Mail als ungelesen markieren  
  
   'Anzahl Mails im Posteingang zählen und in die Variable i schreiben  
   i = Items.count
   
   'While-Schlaufe, die alle Mails durchgeht und die Anhänge der ungelesenen Mails ausdruckt  
    Do While i <> 1
        'Falls Mail(x) = ungelesen...  
        If Items.Item(i).UnRead = True Then
              ' PrintAttachments Items.Item(i)  'Print-Funktion aufrufen  
               Items.Item(i).UnRead = False   'Mail als ungelesen markieren  
        End If
        i = i - 1 'Variabel i verkleinern  
    Loop
        
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
    'Variabeln definieren  
    'On Error Resume Next    'Fehlermeldungen ignorieren  
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String
   
    Dim txt As String
    
    Dim filename_count As Integer
    filename_count = 1
    
    sDirectory = "C:\tmp\Attachment\" 'Dahin werden Anhänge temporär abgespeichert  
        
    Set colAtts = oMail.Attachments   'Mailanhang  

        If colAtts.count Then
        
            'Anzahl Anhnänge = Anzahl Durchläufe  
            For Each oAtt In colAtts
    
                'die letzten 4 Zeichen = Dateiendung  
                sFileType = LCase$(Right$(oAtt.FileName, 4))
    
                Select Case sFileType
                    Case ".xls", ".doc", ".pdf" 'Hier alle gewünschten Dateiendungen dazupacken  
                        sFile = sDirectory & filename_count & oAtt.FileName 'Pfad erstellen  
                        oAtt.SaveAsFile sFile 'Angang abspeichern...  
                        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0 'ausdrucken  
                        'MsgBox ("Print" + sFile)  
                        
                        '10 Sek. warten bevor Datei gelöscht wird  
                        Sleep 10000
                            
                            'Logdatei schreiben (Datum, Zeit: Dateiname)  
                                txt = (Date & ", " & Time & ": " & filename_count & oAtt.FileName)  
                                 
                                Open "C:\PrintAttLogfile.txt" For Append As #1  
                                Print #1, txt
                                Close #1
                                
                              '!Kill File ausgeschaltet, da die Datei so gelöscht wird, bevor der AdobeReader die Datei drucken kann  
                             'Kill sFile  
                    
                        'filename_count + 1  
                        filename_count = filename_count + 1

                    End Select
                Next
        End If
        
End Sub

Private Sub AttachmentFolder()

'[gespeicherte Anhänge müssen gelöscht werden damit die Festplatte nicht vollläuft].  

    Dim fso As Object
    Dim count As Integer

   'Falls der Ordner "Attachment" existiert...  
   If Dir("C:\tmp\Attachment", vbDirectory) <> "" Then  
  
           'Anzahl Dateien in Ordner zählen  
           Set fso = CreateObject("Scripting.FileSystemObject")  
           count = fso.GetFolder("C:\tmp\Attachment").Files.count 'zählen  
           
                'Wenn Ordner Dateien enthält, alle Dateien löschen.  
                If count <> 0 Then
                 Kill "C:\tmp\Attachment\*.*" 'Alle Dateien im Ordner Attachment löschen  
                End If
        
          RmDir ("C:\tmp\Attachment")  'Temp Ordner löschen  
   End If
        
  
    MkDir ("C:\tmp\Attachment") 'Temp Ordner für Anhänge erstellen  
    

End Sub