Hallo zusammen,

ich habe folgende Aufgabe: In Outlook markierte E-Mails sollen in einen Zielordner einkopiert werden, dessen Namen man im Abfragefesnter einträgt. Danach sollen die Originalmails in den Ordner '_01_erhalten' verschoben werden.

Folgende Makros stehen mir zur VErfügung:

Makro 1: Funktioniert nur für eine markierte Mail

Sub CopySelectedEmailToFolderAndMoveToReceived()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olSelection As Outlook.Selection
    Dim olMail As Outlook.mailItem
    Dim olMailCopy As Outlook.mailItem
    Dim olDestFolder As Outlook.MAPIFolder
    Dim olReceivedFolder As Outlook.MAPIFolder
    Dim folderName As String
    Dim foundFolder As Outlook.MAPIFolder

    ' Initialisiere die Outlook-Anwendung und den Namespace
    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")

    ' Hole die ausgewählte E-Mail
    Set olSelection = olApp.ActiveExplorer.Selection

    If olSelection.Count = 0 Then
        MsgBox "Bitte wählen Sie eine E-Mail aus.", vbExclamation
        Exit Sub
    End If

    ' Nur fortfahren, wenn eine E-Mail ausgewählt ist
    If TypeOf olSelection.Item(1) Is Outlook.mailItem Then
        Set olMail = olSelection.Item(1)

        ' Ordnername abfragen
        folderName = InputBox("Bitte geben Sie den Namen des Zielordners ein:", "Zielordner auswählen")

        If folderName = "" Then
            MsgBox "Kein Ordnername eingegeben. Vorgang abgebrochen.", vbExclamation
            Exit Sub
        End If

        ' Suche den Zielordner
        Set foundFolder = FindFolder(olNamespace.folders, folderName)

        If Not foundFolder Is Nothing Then
            ' Kopiere die E-Mail in den gefundenen Ordner
            Set olMailCopy = olMail.Copy
            olMailCopy.Move foundFolder
            MsgBox "Die E-Mail wurde erfolgreich in den Ordner '" & foundFolder.Name & "' kopiert.", vbInformation

            ' Suche den Unterordner "_01_erhalten"
            Set olReceivedFolder = FindFolder(olNamespace.folders, "_01_erhalten")

            If Not olReceivedFolder Is Nothing Then
                ' Verschiebe die E-Mail in den Unterordner "_01_erhalten"
                olMail.Move olReceivedFolder
                MsgBox "Die E-Mail wurde erfolgreich in den Ordner '_01_erhalten' verschoben.", vbInformation
            Else
                MsgBox "Der Ordner '_01_erhalten' wurde nicht gefunden.", vbExclamation
            End If
        Else
            MsgBox "Der Ordner '" & folderName & "' wurde nicht gefunden.", vbExclamation
        End If
    Else
        MsgBox "Bitte wählen Sie eine E-Mail aus.", vbExclamation
    End If

    ' Bereinigen
    Set olApp = Nothing
    Set olNamespace = Nothing
    Set olSelection = Nothing
    Set olMail = Nothing
    Set foundFolder = Nothing
    Set olReceivedFolder = Nothing
End Sub

Function FindFolder(folders As Outlook.folders, folderName As String) As Outlook.MAPIFolder
    Dim folder As Outlook.MAPIFolder
    Dim subFolder As Outlook.MAPIFolder

    On Error Resume Next

    ' Durchlaufe alle Ordner
    For Each folder In folders
        If folder.Name = folderName Then
            Set FindFolder = folder
            Exit Function
        End If
        ' Rekursiver Aufruf für Unterordner
        Set subFolder = FindFolder(folder.folders, folderName)
        If Not subFolder Is Nothing Then
            Set FindFolder = subFolder
            Exit Function
        End If
    Next folder
End Function

Makro 1: Funktioniert für mehrere markierte Mails

Sub CopyAndMoveEmails()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olSelection As Outlook.Selection
    Dim destFolderName As String
    Dim destFolder As Outlook.folder
    Dim receivedFolder As Outlook.folder
    Dim mailItem As Object
    Dim i As Integer

    ' Initialize Outlook objects
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olSelection = olApp.ActiveExplorer.Selection

    ' Prompt user for destination folder name
    destFolderName = InputBox("Enter the name of the destination folder:", "Destination Folder")

    ' Check if user input is empty
    If destFolderName = "" Then
        MsgBox "No destination folder specified.", vbExclamation
        Exit Sub
    End If

    ' Find the destination folder
    Set destFolder = FindFolder(olNamespace.folders, destFolderName)

    If destFolder Is Nothing Then
        MsgBox "The destination folder """ & destFolderName & """ does not exist.", vbExclamation
        Exit Sub
    End If

    ' Find the "_01_erhalten" folder
    Set receivedFolder = FindFolder(olNamespace.folders, "_01_erhalten")

    If receivedFolder Is Nothing Then
        MsgBox "The folder ""_01_erhalten"" does not exist.", vbExclamation
        Exit Sub
    End If

    ' Process each selected email
    For i = 1 To olSelection.Count
        If TypeOf olSelection.Item(i) Is Outlook.mailItem Then
            Set mailItem = olSelection.Item(i)
            ' Copy the email to the destination folder
            On Error Resume Next
            mailItem.Copy.Move destFolder
            If Err.Number <> 0 Then
                MsgBox "Error copying email: " & Err.Description, vbExclamation
                Exit Sub
            End If
            On Error GoTo 0

            ' Move the original email to the "_01_erhalten" folder
            On Error Resume Next
            mailItem.Move receivedFolder
            If Err.Number <> 0 Then
                MsgBox "Error moving email: " & Err.Description, vbExclamation
                Exit Sub
            End If
            On Error GoTo 0
        End If
    Next i

    ' Display success message
    MsgBox "Emails copied to """ & destFolderName & """ and moved to ""_01_erhalten"" successfully.", vbInformation
End Sub

Function FindFolder(parentFolders As Outlook.folders, folderName As String) As Outlook.folder
    Dim folder As Outlook.folder
    Dim subFolder As Outlook.folder

    On Error Resume Next
    ' Iterate through each folder to find the matching folder
    For Each folder In parentFolders
        If folder.Name = folderName Then
            Set FindFolder = folder
            Exit Function
        Else
            Set subFolder = FindFolder(folder.folders, folderName)
            If Not subFolder Is Nothing Then
                Set FindFolder = subFolder
                Exit Function
            End If
        End If
    Next folder
    On Error GoTo 0

    ' If not found, return Nothing
    Set FindFolder = Nothing
End Function

Problem: Das 2. Makro funktioniert nur, wenn man es aus dem VBA-Editor ausführt, nicht wenn man über das Menüband auf Makros geht.

Waran liegt es? Beim 1. Makro klappt es ja auch aus dem Menüband.

Falls jemand das Makro anpassen könnte, gerne auch optimieren, wäre ich sehr dankbar.

VG

Kisska