Inhaltsverzeichnis

Outlook Tricks

Button, um Mails in einen festen Ordner zu verschieben

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

auch noch mal in Kürzer