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

asked on

Email Addresses in a txt or excel file . Need a way this could be queried with each mail in a folder and get me Yes/No reply when the mail is found. Is there a macro that can do this from excel or Out

Hi,

Email Addresses in a txt or excel file . Need a way this could be queried with each mail in a folder and get me Yes/No reply when the mail is found. Is there a macro that can do this from excel or Outlook.

Find Email added in the file and get yes/no
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

You want to cycle through a range of email addresses in a column/row/sheet/workbook? and for each email in the range you want to search inbox/sent folder of outlook for any mail to/from that address and set a cell to yes?

Chris
Avatar of bsharath

ASKER

I want to cycle through a sheet in just colum A and get the results to colum B if found or not.
I have the mails in a folder below inbox. I want it to check the reply back mail. That's if the user has replyed to the mail i sent or not...
I want to cycle through a sheet in just colum A and get the results to colum B if found or not.
I have the mails in a folder below inbox. I want it to check the reply back mail. That's if the user has replyed to the mail i sent or not...
How is the reply email to be identified ... i.e. will the subfolder only have an email for the specific sheet check? or do we need to find a reply to a specific email sent where all emails are in the folder.  Not sure if the question makes sense ... but hopefully!

Chris
This folder will have just replied emails.
The email addresses May or may not match. So where no match found has to be "NO"
This folder will have just replied emails.
The email addresses May or may not match. So where no match found has to be "NO"
Sharath,

This code in a folder called "EE" under the inbox, you will need to change it to suit
Set oFolder = .GetDefaultFolder(1).Folders("EE")

It then looks at each email name, ie
Experts Exchange
not
noreply@experts-exchange.com

did you want the display name or full email address

and if it doesn't exist puts a "No" in the corresponding B cell

Cheers

Dave
Sub SelA()
    Dim rng1 As Range, cel As Range
    Dim objSession As Object, oFolder As Object, oMessage As Object, objMessages As Object
    Dim i As Long, tempStr
    Dim X()
   
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    Set objSession = CreateObject("MAPI.Session")
    With objSession
        On Error Resume Next
        .Logon , , False, False
        Set oFolder = .GetDefaultFolder(1).Folders("EE")
        On Error GoTo 0
        If oFolder Is Nothing Then Exit Sub
 
        Set objMessages = oFolder.Messages
    End With
 
    'get all the email addresses in the folfer
    For Each oMessage In objMessages
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = oMessage.Sender.Name
    Next
 
    For Each cel In rng1
        tempStr = Application.Match(cel.Value, X)
        If IsError(tempStr) Then cel.Offset(0, 1) = "No"
    Next
End Sub
 
 
    For Each cel In rng1
        tempStr = Application.Match(cel.Value, X)
        If Not IsError(tempStr) Then cel.Offset(0, 1) = "Found"
    Next
End Sub

Open in new window

I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Only comments may appear after End Sub, End Function, or End Property
---------------------------
OK   Help  
---------------------------
I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

Only comments may appear after End Sub, End Function, or End Property
---------------------------
OK   Help  
---------------------------
apologies, pls delete the leftover code at the end, ie
For Each cel In rng1
        tempStr = Application.Match(cel.Value, X)
        If Not IsError(tempStr) Then cel.Offset(0, 1) = "Found"
    Next
End Sub

Open in new window

This code works on email addresses

Cheers

Dave
Option Explicit
Public Const CdoPR_EMAIL = &H39FE001E
Sub SelA()
    Dim rng1 As Range, cel As Range
    Dim objSession As Object, oFolder As Object, oMessage As Object, objMessages As Object, objAddressEntry
    Dim i As Long, tempStr
    Dim X(), strEMailAddress, strAddressEntryID
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    Set objSession = CreateObject("MAPI.Session")
    With objSession
        On Error Resume Next
        .Logon , , False, False
        Set oFolder = .GetDefaultFolder(1).Folders("EE")
        On Error GoTo 0
        If oFolder Is Nothing Then Exit Sub
 
        Set objMessages = oFolder.Messages
    End With
 
    'get all the email addresses in the folfer
    For Each oMessage In objMessages
        Set objAddressEntry = oMessage.Sender
        strEMailAddress = objAddressEntry.Address
        ' Check if it is an Exchange object
        If Left(strEMailAddress, 3) = "/o=" Then
            ' Get the SMTP address
            strAddressEntryID = objAddressEntry.ID
            strEMailAddress = objSession.GetAddressEntry(strAddressEntryID).Fields(CdoPR_EMAIL).Value
        End If
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = strEMailAddress
    Next
 
    Application.ScreenUpdating = False
    For Each cel In rng1
        tempStr = Application.Match(cel.Value, X)
        If IsError(tempStr) Then cel.Offset(0, 1) = "No"
    Next
    Application.ScreenUpdating = True
End Sub

Open in new window

I get a runtime error 429

When debug goes here

Set objSession = CreateObject("MAPI.Session")
When run can the script ask me for the outlook folder to select
I get a runtime error 429

When debug goes here

Set objSession = CreateObject("MAPI.Session")
When run can the script ask me for the outlook folder to select
Sharath,

You may:
a) not have installed CDO with Outlook, see http://j-integra.intrinsyc.com/support/kb/article.aspx?id=113792 for installation instructions
b) have Norton or Macafee scannining sofwtare

so unless you can confirm that you should have CDO I will need to reconfigure the code

Cheers

Dave
Dave could not follow the above...?
Sharath,

Here is an Outlook Object solution

The potential problem is that this will not retrieve the users full SMTP address - the CDO solution above  is more robust if it is installed. But see how you go

Cheers

Dave
Sub Email2()
    Dim rng1 As Range, cel As Range
    Dim olApp As Object, ns As Object, TargetFolderItems As Object, oMessage As Object
    Dim i As Long, tempStr
    Dim X()
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    
    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Set TargetFolderItems = ns.GetDefaultFolder(6).Folders("ee").Items
          
    For Each oMessage In TargetFolderItems
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = oMessage.SenderEmailAddress
    Next
 
    Application.ScreenUpdating = False
    For Each cel In rng1
        tempStr = Application.Match(cel.Value, X, 0)
        If IsError(tempStr) Then cel.Offset(0, 1) = "No"
    Next
    Application.ScreenUpdating = True
End Sub

Open in new window

>.the CDO solution above  is more robust if it is installed.
Should i install anything?
Sharath,

Best initially to see if the code above suffices, if not then look at http://j-integra.intrinsyc.com/support/kb/article.aspx?id=113792 for CDO installation instructions

Cheers

Dave
Dave i put in some email id's in the excel colum A and run the macro and it gets as NO.
Where as the Mails are in the folder.
As the email i'd are resolved if a mail is from sharath
Mail ID
Sharath.HYT@plc.com
Then the name would be as
Sharath.hyt
Dave i put in some email id's in the excel colum A and run the macro and it gets as NO.
Where as the Mails are in the folder.
As the email i'd are resolved if a mail is from sharath
Mail ID
Sharath.HYT@plc.com
Then the name would be as
Sharath.hyt
Dave any help on this....
Hi Sharath,

So the email iD in A is
Sharath.HYT@plc.com

and what is the corresponding senderemail address in your subfolder (stored in the X(i) array)?

Cheers

Dave

The email address thats visible is
Sharath hyt
Hi Sharath,

I'm on leave so not getting much EE time in ... on this one

this in in column A
Sharath.hyt
this is the matching address in the email folder
Sharath.HYT@plc.com

is that correct?
And if so will all of the matches be similar?

Cheers

Dave


Excel has email id's as
Sharath.HYT@plc.com
and outlook shows the resolved addresses as
Sharath.HYT
Excel has email id's as
Sharath.HYT@plc.com
and outlook shows the resolved addresses as
Sharath.HYT
To try and start simple, assuming the only issue is teh mismatch between addresses ... what happens with the following tweaks to Daves code:

Render tests on lcase and select left part of full name for equivalence check

Chris
Sub Email2()
    Dim rng1 As Range, cel As Range
    Dim olApp As Object, ns As Object, TargetFolderItems As Object, oMessage As Object
    Dim i As Long, tempStr
    Dim X()
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    
    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Set TargetFolderItems = ns.GetDefaultFolder(6).Folders("ee").Items
          
    For Each oMessage In TargetFolderItems
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = lcase(oMessage.SenderEmailAddress)
    Next
 
    Application.ScreenUpdating = False
    For Each cel In rng1
        tempStr = lcase(Application.Match(left(cel.value, instr(cel.value, "@")-1), X, 0))
        If IsError(tempStr) Then cel.Offset(0, 1) = "No"
    Next
    Application.ScreenUpdating = True
End Sub

Open in new window

I get run time error 13 type mismatch
when debug goes here
 tempStr = LCase(Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0))

When i have the email in row 2 and below get this
Run time error 5
Invalid procedure call or argument
When debug goes here
 tempStr = LCase(Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0))
I get run time error 13 type mismatch
when debug goes here
 tempStr = LCase(Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0))

When i have the email in row 2 and below get this
Run time error 5
Invalid procedure call or argument
When debug goes here
 tempStr = LCase(Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0))
Looking in the cold light of day try replacing:

tempStr = LCase(Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0))
with
tempStr = Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0)

Chris
I Get
Run time error 5
Invalid procedure call or argument
Debug goes here
      tempStr = Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0)
I Get
Run time error 5
Invalid procedure call or argument
Debug goes here
      tempStr = Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0)
Do you have a header row in the worksheet?  if so try replacing:

      tempStr = Application.Match(Left(cel.Value, InStr(cel.Value, "@") - 1), X, 0)
with
      tempStr = Application.Match(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), X, 0)

Chris
I changed it but get no error now. But get "NO" for an email ID thats there.

The outlook folder has email id's that are resolved like
Excel has
Sharath.hyk@plc.com
And Outlook when opened the mail looks like
Sharath HYK
I changed it but get no error now. But get "NO" for an email ID thats there.

The outlook folder has email id's that are resolved like
Excel has
Sharath.hyk@plc.com
And Outlook when opened the mail looks like
Sharath HYK
Possibly the NO is already there ...

try replacing line 22 ...

        If IsError(tempStr) Then cel.Offset(0, 1) = "No"
with
        If IsError(tempStr) Then
            cel.Offset(0, 1) = "No"
        else
            cel.Offset(0, 1) = "Yes"
        end if

Chris
I still get "NO" ...
I still get "NO" ...
Believe it or not we are hopefully close:

try replacing:
      tempStr = Application.Match(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), X, 0)
with
     tempStr = Application.Match(replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)

Chris
:-))
Still get "NO"
Notwithstandingwhat you have said previously, can you stop the code with a breakpoint and where you kinow there is an email provide a copy of cel.value and the corresponding entry in array X ... or if there are too many to find it the email address.

Make sure you mark any spaces at the start/end as well just in case.

BTW, I hope Dave is not tooo depressed at the butchery herein!

Chris
Chris i have just put in 3 email addresses into the excel
Sorry could not follow the above
Chris i have just put in 3 email addresses into the excel
Sorry could not follow the above
Set a break point on the line:
     tempStr = Application.Match(replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)

Select the row itself, click toggle and breakpoint off the sub menu ensuring the line is highlighted.  Run teh code and when it stops:

In the immediate pane, (ctrl + G to toggle) type:

print cel.value
print Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)
then look at the values in X via a watch, find the relating email detail and the index number of the array typing
print X(index)

and uploadthe data

Chris
Chris i just went through your above comments many times but it goes off my Brains. Sorry for that
Attached a screenshot on what i could do...
ScreenShot004.bmp
Click the left button on the line:

tempStr = Application.Match(replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)

and right click to ensure theline is hihglighted via the toggle.

Run the software as before it should now break on this specific line.

With the commands in teh immediate window press enter on teh line and the current values should b displayed.  It is teh actual current values that are missing in the graphic ... and you are broaking on the wrong line anyway.

ANy help?

Chris
I did as you said and it highlighted this line
    tempStr = Application.Match(Replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)
I have attached the image that shows no data in the immediate window.
ScreenShot005.bmp
there has to be an 'enter' of the commands in teh immedite window ... i.e. press enter to force display of the calculated values after the application 'breaks'.

Chris
I pressed enter and the line goes to the next row. Nothing else happens... :-(
Huh!

WHat if you add thevariables as watches and examine them there?

cel.value
Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)

Chris
I get expression not defined in context in the Watch windows when i paste the above data in.

i really dont know if i did that right...
HAve you run the routine to the break point since adding the watches?

Chris
Just before the breakpoint put two lines of code:

debug.print ">" & cel.value & "<" & vbtab &  ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)& "<<"

Chris

I get this...
Attached is the message in the watches
ScreenShot005.bmp
The watch window isn't visible ... but if you followeed the last recommendation isn't required.

Remove all breakpoints : ctrl + Shift + F9
clear the immediate window of all text : cursor in the window, ctrl + A then delete
Put the debug print in the code just before the line:
    tempStr = Application.Match(Replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)

i.e.

debug.print ">" & cel.value & "<" & vbtab &  ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)& "<<"
    tempStr = Application.Match(Replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)

Run the sub and then when execution has finished provide a copy of the data from the immediate window

Chris
I get this in the  immediate window

>Sharath.ben@plc.com<    >>Sharath.ben<<
Now need to examine what is in X:

Add the following:
        Dim arrCount As Long
        For arrCount = 1 To UBound(X)
            Debug.Print arrCount & ": " & X(arrCount)
        Next
to get:
    For Each cel In rng1
        Dim arrCount As Long
        For arrCount = 1 To UBound(X)
            Debug.Print arrCount & ": " & X(arrCount)
        Next
        Debug.Print ">" & cel.Value & "<" & vbTab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1) & "<<"
        tempStr = Application.Match(Replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)

Chris
Should i add the whole code to the module or should i replace some thing.
I used this as the whole code
I get a lot of data in the "immediate window"

The last shows as this

>Sharath.re@plc.com<    >>Sharath.re<<
plc.com<    >>Sharath.re<<
Sub Email2()
    Dim rng1 As Range, cel As Range
    Dim olApp As Object, ns As Object, TargetFolderItems As Object, oMessage As Object
    Dim i As Long, tempStr
    Dim X()
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    
    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Set TargetFolderItems = ns.GetDefaultFolder(6).Folders("Closed Nas").Items
          
    For Each oMessage In TargetFolderItems
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = LCase(oMessage.SenderEmailAddress)
    Next
 
    Application.ScreenUpdating = False
    
 
    For Each cel In rng1
        Dim arrCount As Long
        For arrCount = 1 To UBound(X)
            Debug.Print arrCount & ": " & X(arrCount)
        Next
        Debug.Print ">" & cel.Value & "<" & vbTab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1) & "<<"
        tempStr = Application.Match(Replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)
 
 
 
         If IsError(tempStr) Then cel.Offset(0, 1) = "No"
    Next
    Application.ScreenUpdating = True
End Sub
 
 
 
 
 
   

Open in new window

A whole load of data ... yeah can you supply some of the numbered data with your email i.e. n: data, n+1: data?

Chris
Here is the data

178: /o=HTgroup/ou=first administrative group/cn=recipients/cn=narhs
179: /o=HTgroup/ou=first administrative group/cn=recipients/cn=praup
180: /o=HTgroup/ou=first administrative group/cn=recipients/cn=devajans
181: /o=HTgroup/ou=first administrative group/cn=recipients/cn=anbvamt
182: /o=HTgroup/ou=first administrative group/cn=recipients/cn=devans
183: /o=HTgroup/ou=first administrative group/cn=recipients/cn=ragm
184: /o=HTgroup/ou=first administrative group/cn=recipients/cn=anarka
1: /o=HTgroup/ou=first administrative group/cn=recipients/cn=sarava
2: /o=HTgroup/ou=first administrative group/cn=recipients/cn=sajeev
3: knakumar.r@HThealth.com
4: /o=HTgroup/ou=first administrative group/cn=recipients/cn=mohand
5: krishmar.r@HThealth.com
6: /o=HTgroup/ou=first administrative group/cn=recipients/cn=mohand
7: kris.r@HThealth.com
8: /o=HTgroup/ou=first administrative group/cn=recipients/cn=kris
9: krhnakumar.r@HThealth.com

186: /o=HTgroup/ou=first administrative group/cn=recipients/cn=shara
>Sharath re< >>Sharath re<<
>Sharath.re@HTplc.com<    >>Sharath.re<<
HTplc.com<    >>Sharath.re<<

Hope this helps
I think not sure that even though i am mentioning the folder name in the macro it is refering to some other location.
As i just tried having just 1 mail and email address in the excel. When i query i get the same list of names.
Leave it with me ... it looks like another case for the function.

Chris
Sorry to be 'vague.  Can you ceck the following as the specifics of your system are necessary to finish it up.  Again please supply samples of the X trace.

Chris
Sub Email2()
    Dim rng1 As Range, cel As Range
    Dim olApp As Object, ns As Object, TargetFolderItems As Object, oMessage As Object
    Dim i As Long, tempStr
    Dim X()
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    
    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Set TargetFolderItems = ns.GetDefaultFolder(6).Folders("experts exchange").Items
          
    For Each oMessage In TargetFolderItems
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = LCase(GetSMTPAddress(oMessage.Sendername))
    Next
 
    Application.ScreenUpdating = False
    For Each cel In rng1
        Dim arrCount As Long
        For arrCount = 1 To UBound(X)
            Debug.Print arrCount & ": " & X(arrCount)
        Next
'        Debug.Print ">" & cel.Value & "<" & vbTab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1) & "<<"
        tempStr = Application.Match(Replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)
        If IsError(tempStr) Then
            cel.Offset(0, 1) = "No"
        Else
            cel.Offset(0, 1) = "Yes"
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
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 oCon As ContactItem
Dim strKey As String
Dim oRec As Recipient
Dim strRet As String
Dim fldr As MAPIFolder
    'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
    On Error Resume Next
    Set fldr = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.Item("Random")
    If fldr Is Nothing Then
        Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.Add "Random"
        Set fldr = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.Item("Random")
    End If
    On Error GoTo 0
    If CInt(Left(Application.Version, 2)) >= 12 Then
        Set oRec = 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(olContactItem)
    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 = Session.GetDefaultFolder(olFolderDeletedItems).Items.Find("[Subject]=" & strKey)
    If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
    GetSMTPAddress = strRet
End Function

Open in new window

thx for picking this up Chris , much appreciated:)

We are in not so sunny Ireland and EE is a very much a distant third behind family, and then late night work catch-up

Sharath, when this is sorted pls award all the points to Chris.

Cheers

Dave
Sorry for the delay...
I get this for the above code

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

User-defined type not defined
---------------------------
OK   Help  
---------------------------

I think this line
Function GetSMTPAddress(ByVal strAddress As String)
Sorry for the delay...
I get this for the above code

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

User-defined type not defined
---------------------------
OK   Help  
---------------------------

I think this line
Function GetSMTPAddress(ByVal strAddress As String)
The GetSMTPAddress was configured for Outlook as the application whereas in this case we are using excel as the caller.  I have modified it accordingly and replace the GetSMTPAddress function as below.  APologies for the 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 = 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

Open in new window

And as for Daves considerate post, pay no mind.  He did put effort into the project since all I have been doing is playing around the edges of his original post.

You will of course apply the points as you see fit but I think he deserves some of them.

Chris
I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

User-defined type not defined
---------------------------
OK   Help  
---------------------------

And the yellow line goes here
Function GetSMTPAddress(ByVal strAddress As String)

Can the script ask me to select the folder. I dout it quering the folder i mentioned in the script...
I get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

User-defined type not defined
---------------------------
OK   Help  
---------------------------

And the yellow line goes here
Function GetSMTPAddress(ByVal strAddress As String)

Can the script ask me to select the folder. I dout it quering the folder i mentioned in the script...
Sorry for the delay spent a lot of time learning something on another question

You are correct I do apologise but modified to use pick folder anyway.

See code below

Chrs
Sub Email2()
    Dim rng1 As Range, cel As Range
    Dim olApp As Object, ns As Object, TargetFolderItems As Object, oMessage As Object
    Dim i As Long, tempStr
    Dim X()
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    
    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Set TargetFolderItems = ns.pickfolder
          
    For Each oMessage In TargetFolderItems
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = LCase(GetSMTPAddress(oMessage.Sendername))
    Next
 
    Application.ScreenUpdating = False
    For Each cel In rng1
        Dim arrCount As Long
        For arrCount = 1 To UBound(X)
            Debug.Print arrCount & ": " & X(arrCount)
        Next
'        Debug.Print ">" & cel.Value & "<" & vbTab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1) & "<<"
        tempStr = Application.Match(Replace(Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)
        If IsError(tempStr) Then
            cel.Offset(0, 1) = "No"
        Else
            cel.Offset(0, 1) = "Yes"
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
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

Open in new window

I get this...

When clicked debug goes here

    For Each oMessage In TargetFolderItems

ScreenShot005.bmp
Sorry not the above screenshot this one...

ScreenShot002.jpg
DUe of course to the change in preset folder to dynamic folder ...

replace:
    For Each oMessage In TargetFolderItems
with
    For Each oMessage In TargetFolderItems.items

Whilst the variable name is not absolutely reflecting its nature it'll do for this purpose

Chris
Now get no error but shows as No
The excel Colum A row 2 has 2 email addreses.
When run the macro asks me for the folder path when i show it the folder where these 2 mails are it says "NO" for both. Where as both the mails are in the folder...
Only to be expected ... the purpose is to establish what the returned email addresses look like.  Can you provide the data from the immediate window?

Chris
I have this

  For Each oMessage In TargetFolderItems1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: sharathyu@plc.com
1: kankrishnan.kandasamy@plc.com
2: sharathyu@plc.com
1: kankrishnan.kandasamy@plc.com
2: sharathyu@plc.com
1: kankrishnan.kandasamy@plc.com
2: sharathyu@plc.com
1: kankrishnan.kandasamy@plc.com
2: sharathyu@plc.com

In excel just 2 email id's
1: kankrishnan.kandasamy@plc.com
2: sharathyu@plc.com
Ok with a bit of luck just need to make sure that we compare for like now.  It is of course possible that there are still a few issues with spaces but ...


Chris
Sub Email2()
    Dim rng1 As Range, cel As Range
    Dim olApp As Object, ns As Object, TargetFolderItems As Object, oMessage As Object
    Dim i As Long, tempStr
    Dim X()
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    
    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Set TargetFolderItems = ns.pickfolder
          
    For Each oMessage In TargetFolderItems
        i = i + 1
        ReDim Preserve X(1 To i)
        X(i) = LCase(GetSMTPAddress(oMessage.Sendername))
    Next
 
    Application.ScreenUpdating = False
    For Each cel In rng1
'        Dim arrCount As Long
'        For arrCount = 1 To UBound(X)
'            Debug.Print arrCount & ": " & X(arrCount)
'        Next
'        Debug.Print ">" & cel.Value & "<" & vbTab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1) & "<<"
        tempStr = Application.Match(cel.Value, X, 0)
        If IsError(tempStr) Then
            cel.Offset(0, 1) = "No"
        Else
            cel.Offset(0, 1) = "Yes"
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
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

Open in new window

I get this erro. When debug goes here
For Each oMessage In TargetFolderItems
ScreenShot010.jpg
Re-introduce the error when cut and pasting.

replace:
    For Each oMessage In TargetFolderItems
with
    For Each oMessage In TargetFolderItems.items

Chris
I get the same above error when debug goes here

   X(i) = LCase(GetSMTPAddress(oMessage.Sendername))

I just had 2 mails and when i ran it worked perfect... So this is the right one... You made it :-)
Now when i put in 50 + mail id's and showed a different folder i got the error.
I get the same above error when debug goes here

   X(i) = LCase(GetSMTPAddress(oMessage.Sendername))

I just had 2 mails and when i ran it worked perfect... So this is the right one... You made it :-)
Now when i put in 50 + mail id's and showed a different folder i got the error.
Added a debug statement to see what we get for the sendername ... I suspect that there are unsent messages or other items so I have bracketed the call with a resume next as well.

If it works you should comment out or delete the debug message, (debug.print omessage.sendername)

Chris
Sub Email2()
    Dim rng1 As Range, cel As Range
    Dim olApp As Object, ns As Object, TargetFolderItems As Object, oMessage As Object
    Dim i As Long, tempStr
    Dim X()
 
    Set rng1 = Range(Cells(ActiveSheet.Rows.Count, "A").End(xlUp), [a1])
    
    Set olApp = CreateObject("Outlook.Application")
    Set ns = olApp.GetNamespace("MAPI")
    Set TargetFolderItems = ns.pickfolder
          
    For Each oMessage In TargetFolderItems.items
        i = i + 1
        ReDim Preserve X(1 To i)
        on error resume next
        debug.print omessage.sendername
        on error goto 0
        X(i) = LCase(GetSMTPAddress(oMessage.Sendername))
    Next
 
    Application.ScreenUpdating = False
    For Each cel In rng1
'        Dim arrCount As Long
'        For arrCount = 1 To UBound(X)
'            Debug.Print arrCount & ": " & X(arrCount)
'        Next
'        Debug.Print ">" & cel.Value & "<" & vbTab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1) & "<<"
        tempStr = Application.Match(cel.Value, X, 0)
        If IsError(tempStr) Then
            cel.Offset(0, 1) = "No"
        Else
            cel.Offset(0, 1) = "Yes"
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
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

Open in new window

Stil get the same error....
Stil get the same error....
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
Sorry for the delay in replying...
This worked perfect i was in such a need of this that started and finished the job... Only them wanted to comment back.... :-))

Thank U Dave & Chris for this... :-)
I've been in longer threads ... or thread!

A lot of hassle understanding the data we had to work with but once we understood it then all was well.  So I am in fact most pleased to see the back of it!

Best Regards
Chris
:-)
Any help with the similar post i raised. To search the body of the mail...