Laufende Nummer vor den Betreff einer E-Mail einfügen

Mit diesem Code werden bei neu eintreffenden E-Mails automatisch eine laufende Nummer vor den Betreff eingefügt.

Der Wert für die laufende Nummer kann mit der Prozedur "SetCounter" angepasst werden. Damit die Nummerierung wieder von 1 beginnt, setzen Sie den Zähler bitte auf 0.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden.

Ab Outlook® 2000

Dieser Codeteil muss in das Modul DieseOutlookSitzung kopiert werden:

Option Explicit
 
Private WithEvents m_objInboxItems As Outlook.Items
 
Private Sub Application_Startup()
    Set m_objInboxItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
 
Private Sub m_objInboxItems_ItemAdd(ByVal Item As Object)
    Call InsertNumber(Item)
End Sub
 
Private Sub Application_Quit()
    Set m_objInboxItems = Nothing
End Sub

Diesen Codeteil bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor):

Option Explicit
 
Public Sub InsertNumber(ByVal objItem As Object)
 
    '=====================================================================
    ' Fügt an den Anfang des Betreffs eine laufende Nummer ein.
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2009-02-09 - Version 1.0.0
    '=====================================================================
    
    Dim lngNumber As Long
 
    '---------------------------------------------------------------------
    ' Aktuelle Nummer aus Registrierung lesen
    '---------------------------------------------------------------------
    lngNumber = CLng(GetSetting("VBA-Project", "Settings", "CurrentNumber", "0"))
 
    '---------------------------------------------------------------------
    ' Nummer um 1 erhöhen
    '---------------------------------------------------------------------
    lngNumber = lngNumber + 1
 
    '---------------------------------------------------------------------
    ' Nummer vor den Betreff anfügen
    '---------------------------------------------------------------------
    objItem.Subject = lngNumber & " " & objItem.Subject
 
    '---------------------------------------------------------------------
    ' Änderung speichern
    '---------------------------------------------------------------------
    objItem.Save
 
    '---------------------------------------------------------------------
    ' Neue Nummer in Registrierung speichern
    '---------------------------------------------------------------------
    Call SaveSetting("VBA-Project", "Settings", "CurrentNumber", CStr(lngNumber))
 
    '---------------------------------------------------------------------
    ' Referenz auf Element löschen
    '---------------------------------------------------------------------
    Set objItem = Nothing
 
End Sub
 
Public Sub InsertNumbers()
 
    '=====================================================================
    ' Nummeriert die Elemente im aktuellen Ordner durch
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2009-02-18 - Version 1.0.0
    '=====================================================================
    
    Dim objItems As Object
    Dim objItem As Object
 
    '---------------------------------------------------------------------
    ' Elemente im aktuellen Ordner referenzieren
    '---------------------------------------------------------------------
    Set objItems = Outlook.ActiveExplorer.CurrentFolder.Items
 
    '---------------------------------------------------------------------
    ' Nach Eingangsdatum aufsteigend sortieren
    '---------------------------------------------------------------------
    Call objItems.Sort("[ReceivedTime]", False)
 
    '---------------------------------------------------------------------
    ' Alle Elemente bearbeiten
    '---------------------------------------------------------------------
    For Each objItem In objItems
 
        '-----------------------------------------------------------------
        ' Wenn noch keine laufende Nummer vorhanden, dann einfügen
        '-----------------------------------------------------------------
        If Not IsNumeric(Left(Trim(objItem.Subject), 1)) Then
            Call InsertNumber(objItem)
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Referenzen löschen
    '---------------------------------------------------------------------
    Set objItem = Nothing
    Set objItems = Nothing
 
End Sub
 
Public Sub RemoveNumbers()
 
    '=====================================================================
    ' Entfernt die Nummerierung der E-Mails
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2009-02-18 - Version 1.0.0
    '=====================================================================
    
    Dim objItems As Object
    Dim objItem As Object
 
    '---------------------------------------------------------------------
    ' Elemente im aktuellen Ordner referenzieren
    '---------------------------------------------------------------------
    Set objItems = Outlook.ActiveExplorer.CurrentFolder.Items
 
    '---------------------------------------------------------------------
    ' Alle Elemente bearbeiten
    '---------------------------------------------------------------------
    For Each objItem In objItems
 
        '-----------------------------------------------------------------
        ' Ist eine laufende Nummer vorhanden, wird sie entfernt
        '-----------------------------------------------------------------
        If IsNumeric(Left(Trim(objItem.Subject), 1)) Then
            Call RemoveNumber(objItem)
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Referenzen löschen
    '---------------------------------------------------------------------
    Set objItem = Nothing
    Set objItems = Nothing
 
End Sub
 
Private Function RemoveNumber(ByVal objItem As Object)
 
    '=====================================================================
    ' Entfernt die Nummerierung 
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2009-02-18 - Version 1.0.0
    '=====================================================================
    
    Dim lngSpace As Long
 
    '---------------------------------------------------------------------
    ' Leerzeichen zwischen Nummer und Betreff ermitteln
    '---------------------------------------------------------------------
    lngSpace = InStr(Trim(objItem.Subject), " ")
 
    '---------------------------------------------------------------------
    ' Wenn gefunden, alles links vom Leerzeichen entfernen
    '---------------------------------------------------------------------
    If lngSpace Then
        objItem.Subject = Mid(objItem.Subject, lngSpace + 1)
        objItem.Save
    End If
 
    '---------------------------------------------------------------------
    ' Referenz löschen
    '---------------------------------------------------------------------
    Set objItem = Nothing
 
End Function
 
Public Sub SetCounter()
 
    '=====================================================================
    ' Setzt den Zähler der laufenden Nummer
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2009-02-18 - Version 1.0.0
    '=====================================================================
    
    Dim strNumber As String
 
    '---------------------------------------------------------------------
    ' Aktuellen Wert aus der Registrierung lesen
    '---------------------------------------------------------------------
    strNumber = GetSetting("VBA-Project", "Settings", "CurrentNumber", "0")
 
    '---------------------------------------------------------------------
    ' Nach neuem Wert fragen
    '---------------------------------------------------------------------
    Do
        strNumber = InputBox("Neuen Zählerwert speichern:", _
            "Laufende Nummer", strNumber)
    Loop Until IsNumeric(strNumber)
 
    '---------------------------------------------------------------------
    ' Wurde nicht abgebrochen, dann neuen Wert zurückschreiben
    '---------------------------------------------------------------------
    If Not strNumber = "" Then
        Call SaveSetting("VBA-Project", "Settings", "CurrentNumber", strNumber)
    End If
 
End Sub