Script/Makro für Outlook um Anhänge zu speichern

Guten Morgen liebe Community,

ich schreibe nur selten Beiträge hier, da ich meistens mit den vorhandenen bereits alle meine Probleme lösen kann. Aber für die aktuelle Herausforderung finde ich einfach nichts passendes.

Situation: Ich habe eine Excel-Liste mit 700+ neun-stelligen Zahlen. Jede dieser Zahlen ist ein bestimmter Vorgang bei uns im Geschäft.
Zu jedem Vorgang liegen in unserem Outlook-Postfach mehrere E-Mails, die die Zahlenfolge entweder im Betreff oder im Dateinamen eines Anhangs haben.

Ich benötige ein Script, dass mir der Reihe nach jede Zahlenfolge aus der Excel-Liste nimmt, in Outlook eine Suche nach dieser Zahlenfolge im gesamten Postfach durchführt und dann aus den Suchergebnissen die Anhänge derjenigen E-Mails die "Begriff1" und "Begriff2" im Betreff stehen haben in einem Ordner mit der Zahlenfolge als Ordnernamen abspeichert.

Ich hoffe ich habe das verständlich ausgedrückt. Falls es dafür eine Lösung gäbe, wäre ich mehr als glücklich das uns das erheblichen Zeitaufwand für dümmliche Fleissarbeit sparen würde.

Vielen lieben Dank.
Der Werner

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub SentItem_auflisten() 'Unter Anbindung ("Extras", "Verweise..") von "Microsoft Outlook 16.0 Object Library" Dim NS As Namespace Dim I As Outlook.MailItem Dim A As Outlook.Attachment Set NS = Outlook.GetNamespace("MAPI") With O.GetDefaultFolder(olFolderInbox) For Each I In .Items Debug.Print I.Subject If InStr(1, I.Subject, "abc") Then Debug.Print F.Items.Count Else If I.Attachments.Count Then For Each A In I.Attachments Debug.Print A.Filename Next End If End If Next End With End Sub

Moin!

Hab den Code von Yal mal adaptiert, damit kommst du sicher weiter...

Sub SentItem_auflisten()
    'Unter Anbindung ("Extras", "Verweise..") von "Microsoft Outlook 16.0 Object Library"
    'Dim NS As Namespace
    Dim MyOutApp As Object
    Dim I ' As MyOutApp.MailItem
    Dim A 'As MyOutApp.Attachment
    Dim nummer As String
   
    Set MyOutApp = CreateObject("Outlook.Application")
    Set NS = MyOutApp.GetNamespace("MAPI")
      
    For Each nummer In Range("A:A").SpecialCells(xlCellTypeConstants)
        With NS.Folders(olFolderInbox) 'ggf. anpassen, mein Outlook hat mehrere Accounts
            For Each I In .Items 'Schleife durch alle mails
                If InStr(I.Subject, nummer) > 0 Then 'wenn nummer im Betreff
                    If I.Attachments.Count > 0 Then 'wenn anhang
                        Ordn_nam = "C:\temp\" & nummer 'Anpassen
                        If Dir(Ordn_nam, vbDirectory) = vbNullString Then MkDir Ordn_nam 'ggf Ordner erstellen
                        For Each anhang In I.Attachments 'alle Anhänge speichern
                            anhang.SaveAsFile Ordn_nam & "/" & nummer & IIf(InStr(Right(anhang, 4), ".") > 0, vbNullString, ".msg")
                        Next
                    End If
                End If
            Next
        End With
    Next nummer
End Sub

Gruß, MCO

Beliebteste Forumthreads (12 Monate)

Script/Makro für Outlook um Anhänge zu speichern

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

80 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Script/Makro für Outlook um Anhänge zu speichern

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

80 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread