Category-Manager | |
Mit dem Category-Manager können Sie Outlook Kategorien gruppieren, synchronisieren und filtern, neuen Emails automatisch die Kategorie des Absenders zuweisen und vieles mehr. Das Addin ist auch für IMAP geeignet. |
Wenn Sie in das Adressfeld (An, CC, BCC) einer Email Buchstaben eingeben, dann schlägt Outlook Adressen vor, die Sie schon mal verwendet haben. Dabei sucht Outlook die eingegebenen Zeichen aber nur am Anfang der Adresse. Geben Sie z.B 'vboffice' ein, findet Outlook 'vboffice@domain' aber nicht 'name@vboffice'.
Das folgende Makro sucht einen Begriff innerhalb aller Emailadressen aus Ihrem Standard-Kontakteordner. Dabei ist es egal, an welcher Stelle der Adresse sich der Begriff befindet. Starten Sie das Makro z.B. über ALT+F8. Wenn Sie das Makro aus einer bereits geöffneten Email heraus starten, werden die ausgewählten Adressen in die Email eingetragen, ansonsten wird eine neue Email erstellt.
Um das Beispiel einfach zu halten, werden die gefundenen Adressen in einer MsgBox angezeigt. Sie könnten den Code aber z.B. auch in einer eigenen MSForm verwenden und die Adressen in einer Listbox anzeigen.
Damit der Code funktioniert, müssen Sie die Redemption installieren, die für den Privatgebrauch kostenlos ist. Setzen Sie nach der Installation über Extras/Verweise einen Verweis auf die Redemption * Library.
Public Sub SuggestAddresses() Dim Session As Redemption.RDOSession Dim Folder As Redemption.RDOFolder Dim Items As Redemption.RDOItems Dim Filter As Redemption.TableFilter Dim ResContent As Redemption.RestrictionContent Dim ResOr As Redemption.RestrictionOr Dim Item As Redemption.RDOContactItem Dim CollAdr As VBA.Collection Dim obj As Object Dim Mail As Outlook.MailItem Dim Email1 As Long, Email2 As Long, Email3 As Long Dim i As Long, Index As Long Dim AdrType As Long Dim IsNewMail As Boolean Dim FindString As String Dim Adr As String, Msg As String Dim UseAdr() As String FindString = InputBox("Suchbegriff:") If Len(FindString) = 0 Then Exit Sub Set Session = CreateObject("redemption.rdosession") Session.MAPIOBJECT = Application.Session.MAPIOBJECT Set Folder = Session.GetDefaultFolder(olFolderContacts) Set Items = Folder.Items If Items.Count Then Set Item = Items(1) Email1 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H8083) Or &H1E Email2 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H8093) Or &H1E Email3 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H80A3) Or &H1E Set Filter = Items.MAPITable.Filter Filter.Clear Set ResOr = Filter.SetKind(RES_OR) Set ResContent = ResOr.Add(RES_CONTENT) ResContent.ulPropTag = Email1 ResContent.lpProp = FindString ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING Set ResContent = ResOr.Add(RES_CONTENT) ResContent.ulPropTag = Email2 ResContent.lpProp = FindString ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING Set ResContent = ResOr.Add(RES_CONTENT) ResContent.ulPropTag = Email3 ResContent.lpProp = FindString ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING Filter.Restrict If Items.Count Then Set CollAdr = New VBA.Collection Index = 0 Msg = "" Items.Sort "FileAs", False For Each Item In Items Adr = "" If Len(Item.Email1Address) Then Index = Index + 1 Adr = Index & ": " & Item.Email1Address & vbCrLf & vbTab CollAdr.Add Item.Email1Address End If If Len(Item.Email2Address) Then Index = Index + 1 Adr = Adr & Index & ": " & Item.Email2Address & vbCrLf & vbTab CollAdr.Add Item.Email2Address End If If Len(Item.Email3Address) Then Index = Index + 1 Adr = Adr & Index & ": " & Item.Email3Address & vbCrLf CollAdr.Add Item.Email3Address End If If Len(Adr) Then Msg = Msg & vbCrLf & Item.FileAs & vbCrLf & vbTab & Adr End If Next If CollAdr.Count Then Msg = "Geben Sie die Adressziffer ein (mehrere durch Semikolon trennen):" & vbCrLf & Msg FindString = InputBox(Msg, Items.Count & " Kontakte mit '" & FindString & "' in einer Adresse") If Len(FindString) = 0 Then Exit Sub FindString = Replace(FindString, ",", ";") UseAdr = Split(FindString, ";") Msg = "Ziffer für Adresstyp eingeben:" & vbCrLf Msg = Msg & "1 = AN" & vbCrLf Msg = Msg & "2 = CC" & vbCrLf Msg = Msg & "3 = BCC" AdrType = Val(InputBox(Msg, , 1)) If AdrType = 0 Then Exit Sub If TypeOf Application.ActiveWindow Is Outlook.Inspector Then Set obj = Application.ActiveInspector.CurrentItem If TypeOf obj Is Outlook.MailItem Then Set Mail = obj End If End If If Mail Is Nothing Then Set Mail = Application.CreateItem(olMailItem) IsNewMail = True End If Adr = "" For i = 0 To UBound(UseAdr) Index = Val(UseAdr(i)) If Index > 0 And Index <= CollAdr.Count Then Adr = Adr & CollAdr(Index) & "; " End If Next Select Case AdrType Case 2: Mail.cc = Adr Case 3: Mail.BCC = Adr Case Else: Mail.To = Adr End Select If IsNewMail Then Mail.Display End If Mail.Recipients.ResolveAll End If End If End If If Mail Is Nothing Then MsgBox "Der Begriff '" & FindString & "' wurde nicht gefunden", vbInformation End If End Sub
ReplyAll | |
Mit diesem Addin für Outlook erhalten Sie in verschiedenen Situationen eine Warnung, bevor Sie auf eine Email versehentlich allen anderen Empfängern antworten. |