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

Private WithEvents Items As Outlook.Items

' Verzeichnis, in dem die Anlagen gespeichert werden
Private Const ATT_PATH As String = "D:\anlagen\"

Private Sub Application_Startup()
   
   ' Verweis auf die Elemente des zu überwachenden Ordners.
   Set Items = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
   Dim mItem As Outlook.MailItem
    
   If TypeOf Item Is Outlook.MailItem Then
      Set mItem = Item
      If mItem.Attachments.Count > 0 Then PrintAttachments mItem
   End If
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
   Dim oAtt As Outlook.Attachment
   Dim sfile As String

   On Error Resume Next
   For Each oAtt In oMail.Attachments
      ' Nur ausgewählte Dateitypen speichern
      Select Case LCase$(Right$(oAtt.Filename, 4))
         Case ".xls", ".doc"
            If MsgBox("Datei speichern ?", vbYesNo, "HuHu") = vbYes Then
               sfile = ATT_PATH & oAtt.Filename
               oAtt.SaveAsFile sfile
               ShellExecute 0, "print", sfile, vbNullString, vbNullString, 0
            End If
      End Select
   Next
End Sub

Option Explicit
Private Const SHOWMAXIMIZED = 3&

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 Sub Application_NewMail()
   Dim objPosteingang As MAPIFolder
   Dim objNewMail As MailItem
   Dim i As Integer 
   Dim Product As String

   Set objPosteingang = Application.GetNamespace( "MAPI").GetDefaultFolder(olFolderInbox)
   For Each objNewMail In objPosteingang.Items 
      With objNewMail
         If .UnRead = True Then 
            For  i = 1 To .Attachments.Count
                If LCase(Right(.Attachments(i).Filename, 4)) = ".xls" Then 
                   Product = "D:\TEST\" & .Attachments.Item(i).Filename
                   .Attachments.Item(i).SaveAsFile Product
                   ShellExecute 0, "print" , Product, "", "", SHOWMAXIMIZED
                End If
            Next i
         End If
      End With
   Next objNewMail
End Sub

Option Explicit

Function GetUniqueName(strFileName As String) As String
   Dim strName As String, strExt As String, strNewName As String, i%, ipos%
    
   GetUniqueName = strFileName
   If Dir(strFileName) = "" Then Exit Function

   ipos = InStrRev(strFileName, ".")
   If ipos > 0 Then
      strName = Left(strFileName, ipos - 1)
      strExt = Mid(strFileName, ipos)
    Else
      strName = strFileName
      strExt = ""
   End If

   Do
      i = i + 1
      strNewName = strName & "_" & Format(i, "0000") & strExt
   Loop Until Dir(strNewName) = ""
   
   GetUniqueName = strNewName
End Function

Sub TestIt()
   Dim sfile As String, i%, ff%

   For i = 1 To 10
      sfile = "d:\test\hallo.pdf"
      'sfile = "d:\test\hallo"
      'sfile = "d:\test\hallo."
      
      sfile = GetUniqueName(sfile)
      Debug.Print sfile
      
      ' nur hier zum testen, sfile erzeugen
      ff = FreeFile
      Open sfile For Output As #ff
      Write #ff, sfile
      Close #ff
   Next
End Sub