nube-li
Dec 10, 2009
view5782
view5
0
Goto Top

Makro um Attachments abzuspeichern

GermansolvedQuestionOutlook MailMicrosoft

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
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 131430

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

Printed on: April 24, 2024 at 20:04 o'clock

5 Comments
Latest comment
Goto Top
Member: Tommy70
Tommy70 Dec 10, 2009 at 14:43:42 (UTC)
Goto Top
Hallo,

was genau funktioniert nicht? Gibts eine Fehlermeldung?
Du kannst auch mal das On Error Resume Next rausnehmen. Dann solltest du eine Fehlermeldung erhalten.
Member: nube-li
nube-li Dec 10, 2009 at 14:52:01 (UTC)
Goto Top
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
Member: Tommy70
Tommy70 Dec 10, 2009 at 15:04:32 (UTC)
Goto Top
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
Member: nube-li
nube-li Dec 14, 2009 at 13:27:46 (UTC)
Goto Top
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
Member: Tommy70
Tommy70 Dec 15, 2009 at 15:14:58 (UTC)
Goto Top
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 face-wink
GermansolvedQuestionOutlook MailMicrosoft
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 Comments