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