Category-Manager | |
With Category-Manager you can group your Outlook categories, share them with other users, filter a folder by category, automatically categorize new emails, and more. You can use the Addin even for IMAP. |
When you type letters into an address field (To, CC, BCC) of an email, Outlook suggests addresses you have already used. However, Outlook looks for the letters only at the beginning of the addresses. For instance, if you type 'vboffice', Outlook finds 'vboffice@domain' but not 'name@vboffice'.
This macro looks for a string within all email addresses in your default contacts folder. The position of the string within the address doesn't matter. Start the macro for instance by pressing ALT+F8. If you start it from an opened email, it will add the selected addresses to that email else it will create a new email.
In order to keep it simple, the found addresses will be listed in a MsgBox. You could, however, also add the code to your own MSForm and display the items in a listbox.
To get the code running you need to install the Redemption, which is free for private users. After the installation set a reference on the Redemption * Library via Tools/References.
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 = "Enter a number for the address (use the semi-kolon to enter multiple numbers):" & vbCrLf & Msg FindString = InputBox(Msg, Items.Count & " contacts found with '" & FindString & "' in an address") If Len(FindString) = 0 Then Exit Sub FindString = Replace(FindString, ",", ";") UseAdr = Split(FindString, ";") Msg = "Enter a number for the address type:" & 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 "The phrase '" & FindString & "' was not found", vbInformation End If End Sub
ReplyAll | |
ReplyAll alerts you before unintentionally replying all, or if you are a confidential BCC recipient of the e-mail. |