Option Explicit
Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Public Sub drucken()
Dim oMail As Outlook.MailItem
Set oMail = Outlook.ActiveExplorer.Selection.Item(1)
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String
Dim mail As Outlook.MailItem
Set mail = oMail.Forward
Set colAtts = mail.Attachments
Dim p As String
p = "H:\1\"
Dim strPath As String, strShortPath As String, strFile As String
Dim FSO2
Dim FSO1
Dim F1
Dim datei As String
strPath = "H:\2\"
Set FSO2 = CreateObject("Scripting.FileSystemObject")
Set FSO2 = FSO2.Getfolder(strPath)
Set FSO1 = CreateObject("Scripting.FileSystemObject")
Set FSO1 = FSO1.Getfolder("H:\1\")
For Each F1 In FSO1.Files
If FSO1.Files.Count > 0 Then
F1.Delete
End If
Next
For Each F1 In FSO2.Files
If FSO2.Files.Count > 0 Then
F1.Delete
End If
Next
For Each oAtt In mail.Attachments
sFileType = LCase$(Right$(oAtt.Filename, 4))
Select Case sFileType
Case ".xls", ".doc", "docx", ".tif", "tiff", ".pdf", ".png", ".jpg", "jpeg", ".dot", ".odt", ".bmp", "xlsx", "xlsm"
If sFileType = ".pdf" Or sFileType = ".jpg" Or sFileType = "jpeg" Or sFileType = "tiff" Or sFileType = ".tif" Or sFileType = ".png" Or sFileType = ".bmp" Or sFileType = ".doc" Or sFileType = "docm" Or sFileType = "docx" Then
sFile = p & oAtt.Filename
oAtt.SaveAsFile sFile
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
Else
sFile = "H:\2\" & oAtt.Filename
oAtt.SaveAsFile sFile
sFile = "H:\1\" & oAtt.Filename
oAtt.SaveAsFile sFile
End If
Case Else
For Each F1 In FSO1.Files
F1.Delete
Next
For Each F1 In FSO2.Files
F1.Delete
Next
MsgBox "Nicht unterstützter Dateityp im Anhang!"
Exit Sub
End Select
End If
While FSO2.Files.Count <> FSO1.Files.Count
Wend
Next
Dim a As Integer
Dim z As Integer
Dim push As Integer
push = 1
For z = 1 To mail.Attachments.Count
mail.Attachments.Remove (push)
Else
push = push + 1
End If
Next
For Each F1 In FSO2.Files
mail.Attachments.Add (CStr(F1))
Next
mail.To = "x.xx@xxx.de"
mail.Send
End Sub