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

Outlook: „Datei/Optionen/Menüband anpassen“

Neue Registrierkarte

Neue Gruppe

„Befehle: Macros“ auswählen und das oben neu erstellte VBA- Macro als Knopf anlegen

auch noch mal in Kürzer

Sub moveSelected() Dim olMailItem As Object If Application.ActiveExplorer.Selection.Count = 0 Then MsgBox "Keine Mails ausgewählt!", vbCritical, "Error" Exit Sub End If On Error Resume Next For Each olMailItem In Application.ActiveExplorer.Selection Set myNameSpace = Application.GetNamespace("MAPI") 'Set myDestFolder = myNameSpace.Folders("yourFolderName").Folders("Completed") 'Set myDestFolder = myNameSpace.Folders("Gelesen") Set myDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Gelesen") olMailItem.Move myDestFolder DoEvents Next olMailItem Err_Handler: Set olMailItem = Nothing lbl_Exit: Exit Sub End Sub