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
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olSelection = olApp.ActiveExplorer.Selection
destFolderName = InputBox("Enter the name of the destination folder:", "Destination Folder")
If destFolderName = "" Then
MsgBox "No destination folder specified.", vbExclamation
Exit Sub
End If
Set destFolder = FindFolder(olNamespace.folders, destFolderName)
If destFolder Is Nothing Then
MsgBox "The destination folder """ & destFolderName & """ does not exist.", vbExclamation
Exit Sub
End If
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
For i = 1 To olSelection.Count
If TypeOf olSelection.Item(i) Is Outlook.mailItem Then
Set mailItem = olSelection.Item(i)
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
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
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
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
Set FindFolder = Nothing
End Function