Gather message addresses in VBA for MS Outlook

Attribute VB_Name = "GatherMessageAddrs" Option Explicit '--------------------------------------- '2014-02-06-added support for missed conversations Public Const VERSION = "2018.05.10.01.58" '======================================= Const VBQT = """" Private DebugTime As Date Public StartTime As Date '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''--REFERENCE CODE TO CALL FROM OUTLOOK MACROS----------------------------------------------------------- '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub Addressess_GET_for_all_messages_active_folder() Dim ObjFolders As items Dim ForceReset As Boolean Set ObjFolders = Outlook.ActiveExplorer.CurrentFolder.items.Restrict("[Message Class] = 'IPM.note'") Get_Addressess ObjFolders frmProgress.Hide End Sub Sub Addressess_GET_for_all_selected() Dim objSel As Selection Dim i As Integer Dim objMail As MailItem Dim objRept As ReportItem Dim oa As Recipient Dim strStr As String Dim objAct As Action Set objSel = Outlook.ActiveExplorer.Selection Dim colAddrs As New Collection On Error GoTo 0 frmProgress.SetMax (objSel.Count) 'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR On Error GoTo SkipObj: ''for unhandled types For i = 1 To objSel.Count Set objMail = Nothing If objSel(i).Class = olReport Then ''report email addresses 2020-02-12 Set objRept = Nothing Set objRept = objSel(i) For Each objAct In objRept.Actions If objAct.Name = "Reply" Then Set objMail = objAct.Execute Exit For End If Next objAct End If ''fire on objmail or if is omail If objSel(i).Class = olMail Then Set objMail = objSel(i) End If If Not objMail Is Nothing Then DoEvents For Each oa In objMail.Recipients colAddrs.Add GetSMTPAddress(oa.Address) Next oa On Error Resume Next '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< colAddrs.Add GetSMTPAddress(objMail.sender.Address) On Error GoTo 0 '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< objMail.Delete End If SkipObj: frmProgress.SetCurrent (i) Next i SortDedupCollection_PUSH colAddrs frmProgress.Hide End Sub Private Sub Get_Addressess(ByRef Mail_Items As items) Dim objMail As MailItem Dim i As Integer Dim oa As Recipient Dim strStr As String Dim colAddrs As New Collection On Error GoTo 0 frmProgress.SetMax (Mail_Items.Count) 'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR For i = 1 To Mail_Items.Count Set objMail = Mail_Items(i) DoEvents For Each oa In objMail.Recipients colAddrs.Add GetSMTPAddress(oa.Address) Next oa On Error Resume Next colAddrs.Add GetSMTPAddress(objMail.sender.Address) On Error GoTo 0 frmProgress.SetCurrent (i) Next i GoTo Get_AddressessCLEANUP: ''error trap Get_Addressess_ERR: MsgBox Err.Description Stop Resume Get_AddressessCLEANUP: On Error Resume Next Set Mail_Items = Nothing Set objMail = Nothing Set Mail_Items = Nothing On Error GoTo 0 frmProgress.Hide SortDedupCollection_PUSH colAddrs End Sub Sub SortDedupCollection_PUSH(ByRef objColl As Collection) Dim i, j, Vtemp Dim strStr As String ''remove For i = objColl.Count To 2 Step -1 For j = i - 1 To 1 Step -1 If LCase(Trim(objColl(i))) = LCase(Trim(objColl(j))) _ Or objColl(j) Like "*no*reply*" _ Or objColl(j) = "" Then ''Remove it! objColl.Remove j Exit For End If Next j Next i ''sort 'Two loops to bubble sort For i = 1 To objColl.Count - 1 For j = i + 1 To objColl.Count If objColl(i) > objColl(j) Then 'store the lesser item Vtemp = objColl(j) 'remove the lesser item objColl.Remove j 're-add the lesser item before the 'greater Item objColl.Add Vtemp, Vtemp, i End If Next j Next i For i = 1 To objColl.Count strStr = strStr & objColl(i) & ";" & vbCr Next i PushToClipboard strStr End Sub Private Function GetSMTPAddress(ByVal strAddress As String) As String ' As supplied by Vikas Verma ... see ' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx Dim olApp As Object Dim oCon As Object Dim strKey As String Dim oRec As Recipient ' Object Dim strRet As String Dim fldr As Object 'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS On Error Resume Next If InStr(1, strAddress, "@", vbTextCompare) <> 0 Then GetSMTPAddress = strAddress Exit Function End If Set olApp = Application Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random") If fldr Is Nothing Then olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Add "Random" Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random") End If On Error GoTo 0 If CInt(Left(olApp.VERSION, 2)) >= 12 Then Set oRec = olApp.Session.CreateRecipient(strAddress) If oRec.Resolve Then On Error Resume Next strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress If strRet = "" Then strRet = Split(oRec.AddressEntry.Name, "(")(2) ''at least provide name. strRet = Left(strRet, InStr(1, strRet, ")") - 1) End If On Error GoTo 0 End If End If If Not strRet = "" Then GoTo ReturnValue 'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK 'How it works '============ '1) It will create a new contact item '2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD '3) We will assign a random key to this contact item and save it in its Fullname to search it later '4) Next we will save it to local contacts folder '5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name '6) The display name will be something like this " ( email.address@server.com )" '7) Now we need to parse the Display name and delete the contact from contacts folder '8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3 '9) We then need to delete it from Deleted Items folder as well, to clean all the traces Set oCon = fldr.items.Add(2) oCon.Email1Address = strAddress strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "") oCon.FullName = strKey oCon.Save strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, "")) oCon.Delete Set oCon = Nothing Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey) If Not oCon Is Nothing Then oCon.Delete ReturnValue: GetSMTPAddress = strRet End Function

Comments

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Revit area plans adding new types and references (Gross and rentable)

Revit Python in Visual Studio Revit Stubs 2022 for Python Revit Intellisense