https://blog.af-network.de/1613/office/outlook-office/outlook-mail-verschieben-mit-vba/
''' Je Ordner ein Sub Aufruf
''' Teil 1
Sub VerschiebeIn3Monate()
VerschiebeEMail ("\\steffenkoehler@example.com\3_monate")
End Sub
Sub VerschiebeInUnternehmen()
VerschiebeEMail ("\\steffenkoehler@example.com\Unternehmen")
End Sub
''' Verschiebt E-Mails in einen Zielordner
''' Die Pfadangabe aus Outlook kopieren
''' Teil 2
Sub VerschiebeEMail(ZielOrdner As String)
Dim strOutlookFolderPath As String
Dim oulAusgewaehlte As Outlook.Selection
Dim intZähler As Integer
Dim strOutlookMAPIFolders() As String
Dim mapFld As MAPIFolder
Set oulAnwendung = CreateObject("Outlook.Application")
Set oulAusgewaehlte = oulAnwendung.ActiveExplorer.Selection
strOutlookFolderPath = ZielOrdner
strOutlookMAPIFolders = GetOutlookMapiFolder(strOutlookFolderPath)
Set mapFld = GetOutlookMapiObject(strOutlookMAPIFolders)
For intZähler = 1 To oulAusgewaehlte.Count
oulAusgewaehlte.Item(intZähler).UnRead = False
oulAusgewaehlte.Item(intZähler).Move mapFld
Next intZähler
End Sub
''' Erstellt aus einem Outlook Ordner Array eine MAPIFolder Objekt
''' Teil 3
Private Function GetOutlookMapiObject(OutlookMAPIFolders() As String) As MAPIFolder
Dim zaehler As Integer
Dim retVal As MAPIFolder
Dim mapFld As MAPIFolder
zaehler = 0
''Set retVal = Application.Session.Folders()
For Each strFolder In OutlookMAPIFolders
If zaehler = 0 Then
Set retVal = Application.Session.Folders(strFolder)
zaehler = zaehler + 1
Else
Set retVal = retVal.Folders(strFolder)
End If
Next
Set GetOutlookMapiObject = retVal
End Function
''' String mit Pfad zum Outlook Ordner in Array speichern
''' Teil 4
Private Function GetOutlookMapiFolder(OutlookPath As String) As Variant
Dim retVal() As String
If InStr(1, OutlookPath, "\\") Then
strTemp = Mid(OutlookPath, 3)
retVal = Split(strTemp, "\")
End If
GetOutlookMapiFolder = retVal
End Function