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
Post a Comment