Hallo zusammen,

nach mehreren Versuchen das Problem selber zu beheben, muss ich mich doch an Profis wenden.

Ein Kunde benutzt seit längerem ein Script zum archivieren von Mails. Er verschiebt die gewünschten Mails in einem Outlook Ordner (Ablage_Sammelordner). Diese Mails werden dann über das Makro in einem Ordner auf C: abgelegt. Das hat bis gestern Problemlos funktioniert.

Nun taucht seit gestern beim Ausführen des Makro diese Fehlermeldung auf: Laufzeitfehler -2147221233 (8004010f): Der versuchte Vorgang konnte nicht ausgeführt werden. Ein Objekt wurde nicht gefunden.

Beim Debuggen zeigt er ein Fehler in dieser Zeile an:

Set SO_Folder = Outlook.Application.Session.Folders.Item("E-Mail-Adresse").Folders.Item("Ablage_Sammelordner")

Habe den Script mal testweise auch auf meinem Laptop getestet, aber da kommt die gleiche Fehlermeldung raus. Habe auch versucht einen anderen Ordner zu archivieren (dachte evtl stimmt etwas mit dem Ordnerinhalt nicht), führte jedoch zu keinem Ergebnis.

Anbei noch das komplette Script:

Private Sub SaveOnCDrive_JJJJ()

    Dim myOlApp As New Outlook.Application
    Dim myItem As Outlook.Inspector
    Dim objItem As Object
    Dim Pfad, DatNam, Empf, Absend, Betr, EDat, ETime, EPfad As String
    Dim SaveOK As Boolean
    Dim EmpfDat As Date
    Dim Kat As String
    
    Set myItem = myOlApp.ActiveInspector
    
    Pfad = "C:\E-Mail-Archiv\"
    
    If Not TypeName(myItem) = "Nothing" Then
        Set objItem = myItem.CurrentItem
        Empf = Left(objItem.To, 25)
        Betr = Left(objItem.Subject, 30)
        If InStr(objItem.SenderEmailAddress, "@") = 0 Then
            Absend = objItem.SenderName
        Else
            Absend = objItem.SenderEmailAddress
        End If
'   entfernen von Sonderzeichen
        Call SonderzeichenErsetzen(Empf)
        Call SonderzeichenErsetzen(Betr)
        Call SonderzeichenErsetzen(Absend)
'   Kategorie "abgelegt" setzen
        Kat = objItem.Categories
        If InStr(1, Kat, "abgelegt") = 0 Then
            objItem.Categories = Kat & "; abgelegt"
            objItem.Save
        End If
        
        EmpfDat = objItem.ReceivedTime
        EDat = Year(EmpfDat) & "-" & Right("0" & Month(EmpfDat), 2) & "-" & Right("0" & Day(EmpfDat), 2)
        EPfad = Pfad & Year(EmpfDat) & "\"
        ETime = Right("0" & Hour(EmpfDat), 2) & Right("0" & Minute(EmpfDat), 2)
        DatNam = EDat & "_" & ETime & "__" & Absend & "__" & Betr & "__An_" & Empf
        SaveOK = objItem.SaveAs(EPfad & DatNam & ".msg", olMSG)
    Else
        MsgBox "There is no current active inspector."
    End If
End Sub

Sub Ordnerablage_JJJJ_starten()

Dim SO_Name As Variant
Dim SO_AnzahlMails, SO_Abgelegt As Integer


'Dim SO_olApp As Outlook.Application
'Dim SO_Folder As Outlook.Folder
'Dim SO_Mail, SO_Item As Variant


Set SO_olApp = Outlook.Application
Set SO_Folder = Outlook.Application.Session.Folders.Item("E-Mail-Adresse").Folders.Item("Ablage_Sammelordner")
Set SO_Mail = SO_Folder.Items

SO_AnzahlMails = SO_Mail.Count
SO_Abgelegt = 0

MsgBox (SO_AnzahlMails & " Mails sind im Ordner vorhanden.")

For Each SO_Item In SO_Mail
    SO_Item.Display
    Call SaveOnCDrive_JJJJ
    SO_Item.Save
    SO_Abgelegt = SO_Abgelegt + 1
    SO_Item.Close olSave
Next

MsgBox ("Es wurden " & SO_Abgelegt & " Mails abgelegt")

End Sub

Sub SonderzeichenErsetzen(Text)

    Text = Replace(Text, "\", "{")
    Text = Replace(Text, "/", "{")
    Text = Replace(Text, ":", ";")
    Text = Replace(Text, "*", "+")
    Text = Replace(Text, "?", "¿")
    Text = Replace(Text, """", "'")
    Text = Replace(Text, "<", "[")
    Text = Replace(Text, ">", "]")
    Text = Replace(Text, "|", "{")


End Sub