Link to home
Start Free TrialLog in
Avatar of bsharath
bsharathFlag for India

asked on

Excel Macro to query the Outlook sent and received folders and get the missing. need a way to work on contacts also.

Hi,

Excel Macro to query the Outlook sent and received folders and get the missing. need a way to work on contacts also.

When there are contacts in the sent the received should be found and results into colum C
Regards
Sharath

Sub getmailsTest()
Dim sh As Worksheet
Dim olApp As Object
Dim olNS As Object
Dim olSent As Object
Dim olRx As Object
Dim mai As Object
Dim maiToDict As Object
Dim maiFromDict As Object
'Dim mailCOunt As Integer
Dim dictkEY As Variant
Dim rw As Long
Dim recipCount As Integer
 
    Set sh = ThisWorkbook.Worksheets(1)
    Set maiToDict = CreateObject("scripting.dictionary")
    Set maiFromDict = CreateObject("scripting.dictionary")
    Set olApp = CreateObject("outlook.application")
    Set olNS = olApp.getnamespace("MAPI")
    Set olSent = olNS.pickfolder
    Set olRx = olNS.pickfolder
    For Each mai In olSent.items
        On Error GoTo assume_encrypted_to
        If mai.class = olmail Then
            For recipCount = 1 To mai.Recipients.Count
                If Not maiToDict.exists(LCase(mai.Recipients(recipCount).Address)) Then maiToDict.Add LCase(mai.Recipients(recipCount).Address), LCase(mai.Recipients(recipCount).Address)
            Next
        End If
assume_encrypted_to:
    Next
    For Each mai In olRx.items
        On Error GoTo assume_encrypted_rx
        If mai.class = olmail Then
            If Not maiFromDict.exists(LCase(mai.SenderEmailAddress)) Then maiFromDict.Add LCase(mai.SenderEmailAddress), LCase(mai.SenderEmailAddress)
        End If
assume_encrypted_rx:
    Next
' Populate the sheet
 
    sh.Cells.Delete
    sh.Range("A1") = "Email TO:"
    sh.Range("B1") = "Email FROM:"
'    sh.Range("C1") = "Received email - Yes/No"
'    dictKeys = maiToDict.keys
    rw = 2
    For Each dictkEY In maiToDict.Keys
        sh.Range("A" & rw) = maiToDict.Item(dictkEY)
        rw = rw + 1
    Next
    rw = 2
    For Each dictkEY In maiFromDict.Keys
        sh.Range("B" & rw) = maiFromDict.Item(dictkEY)
        rw = rw + 1
    Next
    sh.Range("A:C").Columns.AutoFit
    sh.Range("C:C").HorizontalAlignment = xlCenter
End Sub

Open in new window

Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

For general awareness the situation as I understand it is that the function largely works as expected but because addresses being sent an email:

/o=group/ou=string/cn=recipients/cn=SAMAccountname ... as stored for the recipient address
and as long as there is contact for the same responder then it again looks like:
/o=group/ou=string/cn=recipients/cn=SAMAccountname.

However where a contact exists in the contacts folder thenthe returned mail (senderemailaddress) will reflect the information therein i.e. Fred Flintstone.

What you want to do is if an email is not found is to check the contacts for the Fred Flintstone string and match it to the DN comparing that with the sent mails which are 'missing'

Is that correct. i.e. it is no good using the common name or any other AD fields as the contact field takes precedence?

n.b. in my terms then DN is "/o=group/ou=string/cn=recipients/cn=SAMAccountname " and SAMAccountname is the login ID

Chris
I'm not able to check a networksetting today .. can you advise for one of the contacts that should be recognised what data is stored in which fields and how isit structured ... with specific reference to how the DN and displayed string can be mapped?

Chris
Avatar of bsharath

ASKER

Attached is the contact view.

I want to match which data is in the display name.

Normally we have first name last name and display name filled.
ScreenShot015.jpg
So in terms of the previously supplied data:

/o=grp/ou=astring/cn=recipients/cn=s****ad*s

S****a D*s

What is to be expected ...

Display name = S****a D*s and firstname = s****ad*s?

Chris
Sorry could not follow...
Bear with me as I try to rephrase.

Currently where the returned address displays the distinguished name i.e. (/o=group/ou=string/cn=recipients/cn=SAMAccountname ) then the sub works ok.  In your words when the sender is in the contacts folder then the displayed email is different.

What we need to do is understand what datum in the contact record supercedes the DN and how the replacement is identified so I would expectsomething in teh contact that looks like the id either "/o=group/ou=string/cn=recipients/cn=SAMAccountname " or perhaps SAMAccountname .

When we know where the data is supersceded from then we should be able to close off the checking in teh main sub.

Chris
For the contacts alone can we validate the Email box where the email looks as this

SMTP:sjwqaji2@cyc.com

In the received just the email id without the SMTP:

Query the sent and received folders for a match
In the previous thread you said:

For the ones which work perfect look as this
Sent
/o=group/ou=first administrative group/cn=recipients/cn=swpanp
Received
/o=group/ou=first administrative group/cn=recipients/cn=swpanp

The one which has a sent mail like this
/o=group/ou=first administrative group/cn=recipients/cn=suprnadas

Does not have a match
When i search in the received it does not fetch only when i change it to this i get
Suprna Das

i.e. column B the received email address was displayed as "Suprna Das".  The string Suprna Das is what we need to find the origin of ... can you identify in the case of your contacts folder the contact record for Suprna Das and what is placed in which fields? ... with specific emphasis on:

1. Suprna Das
2. /o=group/ou=first administrative group/cn=recipients/cn=suprnadas
3. suprnadas

Chris
Chris when i go to the properties of the received contact i get this
As this is a contact i get just this properties
ScreenShot010.jpg
THank you.

To try and understand what I am missing in terms of knowledge ... this person is in the exchange server as:

/o=group/ou=first administrative group/cn=recipients/cn=suprnadas

Yet you have  a contact that identifies him as something else ... an SMTO address.  I have seen this form of contact before but not for a long time.  SO that I can test can you advise how to create an SMTP contact like that posted above?

Chris
In ADUC need to click on a OU Right click select Create Contact and after all the first name,Last name > Next then select SMTP and enter the external email id.
Finish thats it..

I am not in from of the DC so please bare with the steps...
Haven't had any luck yet ... ADUC seems to be something ordinary heathens like me are exempt so i'm still thinking as to how to add a simple SMTP contact with network mail address.

Chris
CAn you examine the contact item for suprnadas and tell me the titles for the relevant fields ... so I can try and code it up as i'm not having any luck creating an SMTP address card.

Select the contact card in the contacts folder but do not open it then in the VBE type into the immediate window:

print application.ActiveExplorer.Selection.Item(1).email1address
print application.ActiveExplorer.Selection.Item(1).email1displayname

To confirm if these fields return:
sdas313@ckc.com and
Suprna Das, respectively

Chris
Attached is the mail i received and how it looks...

ScreenShot022.jpg
Sorry thought i'd replied to this.

Before starting on a code construct to try and do this I need to know the correct fields for processing.  Can you please follow the process in http://22937451

Chris
link is rubbish! how about http:#22937451
>>Your comments
Can you examine the contact item for suprnadas and tell me the titles for the relevant fields ... so I can try and code it up as i'm not having any luck creating an SMTP address card.

Select the contact card in the contacts folder but do not open it then in the VBE type into the immediate window:

>> Mycomments

Do you mean i need to select the mail in the outlook folder? or the Contact in Active directory.


Neither I think!

As I understand the problem is the email address stored for the contact is of the form a:bc.com.  I hav einterpreted this to mean that you have a contact in your outlook that is the SMTP form sdas313@ckc.com and display name "suprna Das".

Is this an error on my part ... as I do not understand why the outgoing mail would show /o=grp/ou=astring/cn=recipients/cn=suprnadas and the incoming email suprna Das otherwise.

Note I can imagine you getting sick of this thread but I am still interested to understand what is going wrong so happy to continue.

Chris
No way i am Bored or sick. I really have fun when you ask me for clarification its basically to get my job done. I have no issues in that... :-))

You are right i just saw some contacts as you mentioned...

But there are many that show as this when sent and received.

Is there no way that we can query the exact email id. No matter if its Internal or external contact

As for Internal we have no issue for externl can we look for the SMTP box as shown here "ID: 22921593" or the mail that is shown here "ID: 22937512"
>> Is there no way that we can query the exact email id?

            If Not maiFromDict.exists(LCase(mai.SenderEmailAddress)) Then maiFromDict.Add LCase(mai.SenderEmailAddress), LCase(mai.SenderEmailAddress)

Therein lies the problem.  The script interrogates the sender email from the mail but returns: "Suprna Das" rather than "sdas313@ckc.com".  If it was the email address itself then it would have been solved easily enough in the previous question.  What we need to do is find out how to Get from "Suprna Das" to "sdas313@ckc.com".

Possibly I have made an error in my understanding because if the script does return "sdas313@ckc.com" then it could be "straight forward".

Chris
YOu can see here in the image " ID: 22937512" both name and email are there. Can you pull the email within the { }
So that could solve the issue for my 200 + Contacts
When you ran the script earlier and you got the suprna das informatioion from the contactg in teh output, can you identify exactly what is returned for the address ...

Suparna das
SDAS33@ckc.com
or
Suparna das [SDAS33@ckc.com]

Chris
Hi Chris
I got this

Suparna das [SDAS33@ckc.com]
Maybe not the final answer but what happens with this one does it get everything ... I think it will still need editing but this way the changes should be viable

Chris
Function GetSMTPAddress(ByVal strAddress 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 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
    Set olApp = GetObject(, "outlook.application")
    If olApp Is Nothing Then Set olApp = CreateObject(" outlook.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
            strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        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
 
Sub getmails()
Dim sh As Worksheet
Dim olApp As Object
Dim olNS As Object
Dim olSent As Object
Dim olRx As Object
Dim mai As Object
Dim addy As String
Dim maiToDict As Object
Dim maiFromDict As Object
'Dim mailCOunt As Integer
Dim dictkEY As Variant
Dim rw As Long
Dim recipCount As Integer
 
    Set sh = ThisWorkbook.Worksheets(1)
    Set maiToDict = CreateObject("scripting.dictionary")
    Set maiFromDict = CreateObject("scripting.dictionary")
    Set olApp = CreateObject("outlook.application")
    Set olNS = olApp.getnamespace("MAPI")
    Set olSent = olNS.pickfolder
    Set olRx = olNS.pickfolder
    For Each mai In olSent.items
        On Error GoTo assume_encrypted_to
        If mai.class = 43 Then
            For recipCount = 1 To mai.Recipients.Count
                addy = LCase(GetSMTPAddress(mai.Recipients(recipCount).Address))
                If Not maiToDict.exists(addy) Then maiToDict.Add addy, addy
            Next
        End If
assume_encrypted_to:
    Next
    For Each mai In olRx.items
        On Error GoTo assume_encrypted_rx
        If mai.class = 43 Then
            addy = LCase(GetSMTPAddress(mai.SenderEmailAddress))
            If Not maiFromDict.exists(addy) Then maiFromDict.Add addy, addy
        End If
assume_encrypted_rx:
    Next
' Populate the sheet
 
    sh.Cells.Delete
    sh.Range("A1") = "Email TO:"
    sh.Range("B1") = "Email FROM:"
    sh.Range("C1") = "Received email - Yes/No"
'    dictKeys = maiToDict.keys
    rw = 2
    For Each dictkEY In maiToDict.Keys
        sh.Range("A" & rw) = maiToDict.Item(dictkEY)
        If maiFromDict.exists(maiToDict.Item(dictkEY)) Then
            sh.Range("B" & rw) = maiToDict.Item(dictkEY)
            sh.Range("C" & rw) = "Yes"
        Else
            sh.Range("C" & rw) = "No"
        End If
        rw = rw + 1
    Next
    sh.Range("A:C").Columns.AutoFit
    sh.Range("C:C").HorizontalAlignment = xlCenter
End Sub

Open in new window

Chris i get run time error 91
When debug goes here
 strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Chris i get run time error 91
When debug goes here
 strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Only a small change but full post for your ease of use will hopefully resolve that error.

Chris
Function GetSMTPAddress(ByVal strAddress 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 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
    Set olApp = CreateObject("outlook.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
            strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        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
 
Sub getmails()
Dim sh As Worksheet
Dim olApp As Object
Dim olNS As Object
Dim olSent As Object
Dim olRx As Object
Dim mai As Object
Dim addy As String
Dim maiToDict As Object
Dim maiFromDict As Object
'Dim mailCOunt As Integer
Dim dictkEY As Variant
Dim rw As Long
Dim recipCount As Integer
 
    Set sh = ThisWorkbook.Worksheets(1)
    Set maiToDict = CreateObject("scripting.dictionary")
    Set maiFromDict = CreateObject("scripting.dictionary")
    Set olApp = CreateObject("outlook.application")
    Set olNS = olApp.getnamespace("MAPI")
    Set olSent = olNS.pickfolder
    Set olRx = olNS.pickfolder
    For Each mai In olSent.items
        On Error GoTo assume_encrypted_to
        If mai.class = 43 Then
            For recipCount = 1 To mai.Recipients.Count
                addy = LCase(GetSMTPAddress(mai.Recipients(recipCount).Address))
                If Not maiToDict.exists(addy) Then maiToDict.Add addy, addy
            Next
        End If
assume_encrypted_to:
    Next
    For Each mai In olRx.items
        On Error GoTo assume_encrypted_rx
        If mai.class = 43 Then
            addy = LCase(GetSMTPAddress(mai.SenderEmailAddress))
            If Not maiFromDict.exists(addy) Then maiFromDict.Add addy, addy
        End If
assume_encrypted_rx:
    Next
' Populate the sheet
 
    sh.Cells.Delete
    sh.Range("A1") = "Email TO:"
    sh.Range("B1") = "Email FROM:"
    sh.Range("C1") = "Received email - Yes/No"
'    dictKeys = maiToDict.keys
    rw = 2
    For Each dictkEY In maiToDict.Keys
        sh.Range("A" & rw) = maiToDict.Item(dictkEY)
        If maiFromDict.exists(maiToDict.Item(dictkEY)) Then
            sh.Range("B" & rw) = maiToDict.Item(dictkEY)
            sh.Range("C" & rw) = "Yes"
        Else
            sh.Range("C" & rw) = "No"
        End If
        rw = rw + 1
    Next
    sh.Range("A:C").Columns.AutoFit
    sh.Range("C:C").HorizontalAlignment = xlCenter
End Sub

Open in new window

Still get the same error.
 strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
ASKER CERTIFIED SOLUTION
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
I have found an email that seems to meet similar criteria for the original requirement.  It works as posted above so all we need to do is understand why this previously viable function does not work here ... so first off are you sure the function is in the same module as the subroutine and that it only exists the once in the module?

Chris
In the immediate window i get this in the end "No@email.com>>" and gives me the error.
yes i just have this code...
Can you skip on this error.
In the immediate window i get this in the end "No@email.com>>" and gives me the error.
yes i just have this code...
Can you skip on this error.
That shouldn't resolve so it should not get into the if code!

i.e. If oRec.Resolve Then should be false.

Hoever to fix the observation ... does it return:
"No@email.com>>"
or
"<<No@email.com>>"

Chris
It just shows
No@email.com>>
It just shows
No@email.com>>
Previous outputs are they of the form "<<name>>"?

Chris
No i get as this
No@email.com>>
I'm confused then as I cannot understand why:

debug.print "<<" & strAddress & ">>"

should be displayed as:

fred@fred.com>>

Are you sure the line is correct in the source code?, (line 20 in the last post.

Chris
Thanks a lot Chris ...Sorry was not able to cope with this post...
So accepted. I just have few contact and i can do this manually as large amount of job is done with the above script... Thank U
Chris congrats on the new certificate...