eMails verschieben in Outlook
27.02.2022 08:58:50
Heinzs
ich habe ein Mapi Outlook Postfach mailbox retouren auf einem Exchange Server.
Aus diesem Postfach mailbox retouren sollen Einträge vom Ordner Posteingang in Posteingang\Retourenbegleitschein verarbeitet verschoben werden.
Im Posteingang liegen ursprünglich 2500 Einträge; es werden aber nur genau 1250 Einträge ; d.h. die Hälfte verschoben.
Das Makro ist diesem Eintrag angehangen.
Wenn ich Item.Move movetofolder auskommentiere werden alle eMails gelesen und im Sheet emails protokolliert.
Hat jemand eine Idee?
Danke für Hilfe!
MfG
Heinz
Sub test()
Sheets("emails").Select
' Outlook-Konstanten
Const olFolderInbox = 6
Const olTXT = 0
Application.StatusBar = False
Application.ScreenUpdating = False
' Outlook-Objekt erstellen
Set oOutlook = CreateObject("Outlook.Application")
' Namespace: MAPI
Set oNamespace = oOutlook.GetNamespace("MAPI")
' Recipient anbinden
Set myRecipient = oNamespace.CreateRecipient("mailbox retouren")
myRecipient.Resolve
' Outlook-Ordner: "Neue Nachrichten"
Set oFolder = oNamespace.Folders("mailbox dpg-retouren").Folders("Posteingang")
' Outlook-Ordner: Archiv
Set movetofolder = oNamespace.Folders("mailbox retouren").Folders("Posteingang")
Set movetofolder = movetofolder.Folders("Retourenbegleitschein verarbeitet")
e1 = oFolder.Items.Count
i1 = 0
For Each Item In oFolder.Items
i1 = i1 + 1
If i1 Mod 10 = 0 Or i1 = e1 Then
Application.StatusBar = gn_sheet & " Protokollverarbeitung, Datensatz " & Format(i1, "0000000") & " von " & Format(e1, "0000000") & " Endzeit = " & Anfangszeit1 + (Now() - Anfangszeit1) / i1 * e1
DoEvents
End If
Sheets("emails").Select
e2 = i1 + 1
gn_creationtime = Item.CreationTime
gn_mailtyp = TypeName(Item)
gn_sendername = Item.sendername
gn_senderemailaddress = Item.SenderEmailAddress
gn_betreff = Item.Subject
gn_anhang_anzahl = Item.attachments.Count
Cells(e2, 1) = e2
Cells(e2, 2) = gn_mailtyp
Cells(e2, 3) = gn_creationtime
Cells(e2, 4) = gn_sendername
Cells(e2, 5) = gn_senderemailaddress
Cells(e2, 6) = gn_betreff
Item.Move movetofolder
Next
End Sub
Anzeige