Makro um Attachments abzuspeichern

Hallo Zusammen

Ich habe folgendes Makro:

Sub Anhänge_Abspeichern()
Dim Ordnername As String
    Dim objPosteingang As MAPIFolder
    Dim objNewMail As MailItem
    On Error Resume Next
    Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  
    For Each objNewMail In objPosteingang.Items
        With objNewMail
            If .UnRead = True Then
                Anzahl = .Attachments.Count
                If Anzahl > 0 Then
                    Ordnername = "C:\temp\" & objNewMail.SenderName  
                    MkDir Ordnername
                    For i = 1 To Anzahl
                        .Attachments.Item(i).SaveAsFile Ordnername & "\" & .Attachments.Item(i).FileName  
                    Next i
                End If
            End If
        End With
    Next objNewMail
End Sub

Ziel dieses Macros ist es, neu ankommende E-Mails auf Attachments (Anhänge) zu prüfen. Falls vorhanden sind, diese in den Ordner C:\Temp\Absendername\ abzuspeichern, nur leider funktioniert es so nicht. Wieso, weiss ich leider nicht. Kann hier einer helfen?

P.s: Ich wäre auch froh über ein Macro das bestehende E-Mails (Gelesen und ungelesen) "durchscannt" und ggf. Attachments so abspeichert..

Liebe Grüsse

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 131430

Url: https://administrator.de/contentid/131430

Ausgedruckt am: 22.11.2024 um 18:11 Uhr

5 Kommentare

Neuester Kommentar

Hallo,

was genau funktioniert nicht? Gibts eine Fehlermeldung?
Du kannst auch mal das On Error Resume Next rausnehmen. Dann solltest du eine Fehlermeldung erhalten.

Hallo

Sorry habe mich falsch ausgedrückt: Es funktioniert soweit, dass wenn man es laufen lässt alle Anhänge gespeichert werden.

Wie krieg ich das jetzt so hin, dass dieses Mackro eigentlich immer "Aktiv" ist?

denn sobald es durchgelaufen ist und keine neuen Mails reinkommen sind, bekomme ich die Fehlermeldung:

Laufzeitfehler '75':
Fehler beim Zugriff auf Pfad/Datei

Wenn ich dann auf Debuggen klicke, ist folgende stelle gelb markiert:

MkDir Ordnername

Gruss

Zitat von @nube-li:
Laufzeitfehler '75':
Fehler beim Zugriff auf Pfad/Datei

Wenn ich dann auf Debuggen klicke, ist folgende stelle gelb markiert:

> MkDir Ordnername
> 

Das kommt daher weil es den Ordner schon gibt. Du musst vor dem Erstellen des Ordners prüfen ob es schon einen mit diesem Namen gibt.
Kannst du z.Bsp. so machen:

Function DirExists(ByVal sDirName As String) As Boolean 
    'liefert True zurück, wenn der Ordner existiert   
    If (Dir(sDirName , vbDirectory) <> "") Then   
        DirExists= True 
    Else 
        DirExists= False 
    End If 
End Function

Allerdings wirst du dann auch das Problem haben dass wenn eine Mail zweimal abgearbeitet wird er die Anhänge nochmal abspeichern will und auch da mit einem Fehler beendet da es die Datei schon gibt.

Das geht so.

Function FileExists(sFilePath As String) As Boolean
    On Error Resume Next
    FileExists = Dir(sFilePath) <> ""  
    FileExists = FileExists And Err.Number = 0
    On Error GoTo 0
 End Function

Hallo Tommy

Ok, danke für deine Hilfe. Aber ich weiss ehrlich gesagt nicht wie und wo ich das einbauen sollte/kann?!

Kannst du mir weiterhelfen? Schlussendlich sollte das Macro so aussehen, dass sobald ein Mail mit Attachment ankommt, dieses Attachment gespeichert wird und der E-Mail- Betreff mit dem Pfad des gespeicherten Attachments erweitert wird.

Sprich das Macro muss immer "aktiv" sein.

Liebe Grüsse

Dann versuchen wir mal das zusammen zu bauen.

UNGETESTET

Sub Anhänge_Abspeichern()
Dim Ordnername As String
    Dim objPosteingang As MAPIFolder
    Dim objNewMail As MailItem
    On Error Resume Next
    Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)  
    For Each objNewMail In objPosteingang.Items
        With objNewMail
            If .UnRead = True Then
                Anzahl = .Attachments.Count
                If Anzahl > 0 Then
                    Ordnername = "C:\temp\" & objNewMail.SenderName  
                    If (Dir(sDirName , vbDirectory) = "") Then  
                        MkDir Ordnername
                    end if
                    For i = 1 To Anzahl
                         if Dir(Ordnername & "\" & .Attachments.Item(i).FileName) = "" then  
                            .Attachments.Item(i).SaveAsFile Ordnername & "\" & .Attachments.Item(i).FileName  
                         else
                             msgbox "Datei " & Ordnername & "\" & .Attachments.Item(i).FileName & " bereits vorhanden!"  
                         end if
                    Next i
                End If
            End If
        End With
    Next objNewMail
End Sub

So in etwa sollte es schon besser funktionieren. Allerdings hast du das Problem, dass das Mail ja ungelesen bleibt und daher immer wieder gelesen wird.
Allerdings finde ich, macht es auch keinen Sinn das Mail automatisch auf gelesen zu setzen. Denn das erschwert dem User das Erkennen neuer Nachrichten.

Edit: Und hier ist ein Tipp wie du das Makro automatisch ausführen lassen kannst wenn ein neues Mail reinkommt. Und ganz unten ist sogar ein Beispiel um die Anhänge zu speichern