Outlook VBA - Anhang autom. speichern

Hallo,

ich bekomme an eine bestimmte E-Mail-Adresse immer wieder Nachrichten mit einem Anhang. Der Name vom Anhang ist immer gleich. Nun soll dieser Anhang automatisch in einen Ordner abgelegt werden. Dort holt ihn sich ein weiteres Programm ab und verarbeitet die Datei.

Ich habe in Outlook ein Script erstellt, welches bei Erhalt einer Nachricht an diese E-Mail-Adresse in einen bestimmten Outlook-Ordner verschiebt, dann das Script ausführt und im Anschluss die Nachricht auf gelesen setzt.

Jetzt das Script:


Sub Anlagen_Speichern(OlMail As MailItem)

Dim Anlagen As Attachments
Dim i As Integer
Dim Ziel As String
Dim Ziel2 As String
Dim ErrMsg As String

'Primärer Zielpfad'

On Error GoTo Errorhandler

Ziel = "C:\Sandbox\EDI\"

einsziel:

Set Anlagen = OlMail.Attachments
If Anlagen > 0 Then
For i = 1 To Anlagen.Count
Anlagen.Item(i).SaveAsFile Ziel & "\" & Anlagen.Item(i).FileName
Next i
Else: GoTo Errorhandler
MsgBox "Der Anhang wurde erfolgreich im primären Ziel gespeichert."

Exit Sub

'Sekundärer Zielpfad'

zweiziel:

Err.Clear
On Error GoTo Errorhandler

Ziel2 = "C:\Sandbox\EDI_manuell\"

Set Anlagen = OlMail.Attachments
If Anlagen > 0 Then
For i = 1 To Anlagen.Count
Anlagen.Item(i).SaveAsFile Ziel2 & "\" & Anlagen.Item(i).FileName
Next i
Else: GoTo Errorhandler
MsgBox "Der Anhang wurde erfolgreich im sekundären Ziel gespeichert. Bitte prüfen Sie das primäre Verzeichnis."

Exit Sub

'Fehlerbehandlung'
Errorhandler:
Select Case Err.Number
Case -2147024893:
ErrMsg = "Der primäre Zielpfad ist nicht vorhanden. Es wird versucht im sekundären Zielpfad zu speichern."
Result = MsgBox(ErrMsg, vbOKOnly)
If Result = vbOK Then GoTo zweiziel

Case 5:
ErrMsg = "Es ist kein Anhang vorhanden. Die E-Mail wird nun geöffnet."
Result = MsgBox(ErrMsg, vbOKOnly)
If Result = vbOK Then OlMail.Display

Case Else:
MsgBox "Error # " & Err.Number & ":" & Error(Err.Number)

End Select

End If
End If
End Sub


Nun ist folgendes mein Ziel mit diesem Script:
- E-Mail soll auf Anhang geprüft werden. Ist ein Anhang da, soll er im Pfad gespeichert werden. Ist der Pfad nicht verfügbar, weiche auf sekundären Pfad aus. Ist kein Anhang dabei, soll die E-Mail geöffnet werden.

Problem:
- Im aktuellen Script wird jede E-Mail, egal ob Anhang oder nicht, an Case 5 im Errorhandler geleitet.

Hinweis:
- Entferne ich If Anlagen > 0 Then funktioniert es. Allerdings wird dann nicht mehr geprüft ob ein Anhang verfügbar ist.

Wo ist mein Fehler?

Sub AnlagenSpeichern(olMail As MailItem)
    Dim att As Attachment, fso As Object, ziel As String, ziel1 As String, ziel2 As String
    Set fso = CreateObject("Scripting.FilesystemObject")  
    ziel1 = "C:\Sandbox\EDI"  
    ziel2 = "C:\Sandbox\EDI_manuell\"  
  
    If olMail.Attachments.Count > 0 Then
        If Not fso.FolderExists(ziel1) Then
            If fso.FolderExists(ziel2) Then
                MsgBox "Ziel 1 ist nicht erreichbar, speichere unter Ziel2!", vbExclamation  
                ziel = ziel2
            Else
                MsgBox "Beide Ziele nicht erreichbar!", vbCritical  
                Exit Sub
            End If
        Else
            ziel = ziel1
        End If
        
        For Each att In olMail.Attachments
            targetPath = ziel & "\" & att.FileName  
            if not fso.FileExists(targetPath ) then
               att.SaveAsFile targetPath
            else
               if msgbox("Attachment existiert schon im Zielordner: " & targetPath & vbNewline & "Soll es überschrieben werden ?",vbYesNo or vbQuestion) = vbYes then  
                 fso.DeleteFile targetPath, True
                 att.SaveAsFile targetPath
               end if
            end if
        Next
    Else
        MsgBox "Kein Anhang vorhanden! Mail wird nun geöffnet.", vbInformation  
        olMail.Display
    End If
End Sub