Hallo zusammen,

ich habe auf der Arbeit ein Makro geschrieben, welches Anhänge an den PDFCreator schickt, diese dort druckt, in einem Standardordner ablegt und anschließend alle Dokumente dieses Ordners in eine neue Mail anhängt. Nun habe ich komischerweise erst seit gestern das Problem, dass ein PDF nur 4KB hat, und nicht geöffnet werden kann, "Adobe Reader konnte ... nicht öffnen, da der Dateityp nicht unterstützt wird oder die Datei beschädigt ist ( z.B. wenn sie als E-mail-Anhang geschickt und nicht korrekt dekodiert wurde).

Alle PDF kann man im Ordner öffnen, nur in der Mail nicht. Liegt das am Outlook, oder wird von VBA die Mail losgeschickt, bevor die Mail vollständig angehängt ist? Mit einem "Sleep 5000" konnte ich es jedenfalls nicht beheben.

 Vielen Dank im voraus schonmal :)

Hier der Code:

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




'Speichert Anhänge und druckt diese
For Each oAtt In mail.Attachments
If oAtt.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") = "" Then
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   'Bei Fehler alle Dokumente in Ordner löschen
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


'Entfernt Anhänge, nicht eingebettete
Dim z As Integer
Dim push As Integer
push = 1
For z = 1 To mail.Attachments.Count
If mail.Attachments(push).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E") = "" Then
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