bsharath
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
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
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 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...
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 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
Chris
ASKER
This folder will have just replied emails.
The email addresses May or may not match. So where no match found has to be "NO"
The email addresses May or may not match. So where no match found has to be "NO"
ASKER
This folder will have just replied emails.
The email addresses May or may not match. So where no match found has to be "NO"
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).Folde rs("EE")
It then looks at each email name, ie
Experts Exchange
not
noreply@experts-exchange.c om
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
This code in a folder called "EE" under the inbox, you will need to change it to suit
Set oFolder = .GetDefaultFolder(1).Folde
It then looks at each email name, ie
Experts Exchange
not
noreply@experts-exchange.c
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
ASKER
I get this
-------------------------- -
Microsoft Visual Basic
-------------------------- -
Compile error:
Only comments may appear after End Sub, End Function, or End Property
-------------------------- -
OK Help
-------------------------- -
--------------------------
Microsoft Visual Basic
--------------------------
Compile error:
Only comments may appear after End Sub, End Function, or End Property
--------------------------
OK Help
--------------------------
ASKER
I get this
-------------------------- -
Microsoft Visual Basic
-------------------------- -
Compile error:
Only comments may appear after End Sub, End Function, or End Property
-------------------------- -
OK Help
-------------------------- -
--------------------------
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
This code works on email addresses
Cheers
Dave
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
ASKER
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
When debug goes here
Set objSession = CreateObject("MAPI.Session
When run can the script ask me for the outlook folder to select
ASKER
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
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
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
ASKER
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
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
ASKER
>.the CDO solution above is more robust if it is installed.
Should i install anything?
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
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
ASKER
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
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
ASKER
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
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
ASKER
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
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
ASKER
The email address thats visible is
Sharath hyt
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
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
ASKER
Excel has email id's as
Sharath.HYT@plc.com
and outlook shows the resolved addresses as
Sharath.HYT
Sharath.HYT@plc.com
and outlook shows the resolved addresses as
Sharath.HYT
ASKER
Excel has email id's as
Sharath.HYT@plc.com
and outlook shows the resolved addresses as
Sharath.HYT
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
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
ASKER
I get run time error 13 type mismatch
when debug goes here
tempStr = LCase(Application.Match(Le ft(cel.Val ue, 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(Le ft(cel.Val ue, InStr(cel.Value, "@") - 1), X, 0))
when debug goes here
tempStr = LCase(Application.Match(Le
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(Le
ASKER
I get run time error 13 type mismatch
when debug goes here
tempStr = LCase(Application.Match(Le ft(cel.Val ue, 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(Le ft(cel.Val ue, InStr(cel.Value, "@") - 1), X, 0))
when debug goes here
tempStr = LCase(Application.Match(Le
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(Le
Looking in the cold light of day try replacing:
tempStr = LCase(Application.Match(Le ft(cel.Val ue, InStr(cel.Value, "@") - 1), X, 0))
with
tempStr = Application.Match(Left(cel .Value, InStr(cel.Value, "@") - 1), X, 0)
Chris
tempStr = LCase(Application.Match(Le
with
tempStr = Application.Match(Left(cel
Chris
ASKER
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)
Run time error 5
Invalid procedure call or argument
Debug goes here
tempStr = Application.Match(Left(cel
ASKER
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)
Run time error 5
Invalid procedure call or argument
Debug goes here
tempStr = Application.Match(Left(cel
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
tempStr = Application.Match(Left(cel
with
tempStr = Application.Match(Left(cel
Chris
ASKER
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
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
ASKER
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
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
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
ASKER
I still get "NO" ...
ASKER
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.V alue & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)
Chris
try replacing:
tempStr = Application.Match(Left(cel
with
tempStr = Application.Match(replace(
Chris
ASKER
:-))
Still get "NO"
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
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
ASKER
Chris i have just put in 3 email addresses into the excel
Sorry could not follow the above
Sorry could not follow the above
ASKER
Chris i have just put in 3 email addresses into the excel
Sorry could not follow the above
Sorry could not follow the above
Set a break point on the line:
tempStr = Application.Match(replace( Left(cel.V alue & "@", 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
tempStr = Application.Match(replace(
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
ASKER
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
Attached a screenshot on what i could do...
ScreenShot004.bmp
Click the left button on the line:
tempStr = Application.Match(replace( Left(cel.V alue & "@", 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
tempStr = Application.Match(replace(
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
ASKER
I did as you said and it highlighted this line
tempStr = Application.Match(Replace( Left(cel.V alue & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)
I have attached the image that shows no data in the immediate window.
ScreenShot005.bmp
tempStr = Application.Match(Replace(
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
Chris
ASKER
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
WHat if you add thevariables as watches and examine them there?
cel.value
Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)
Chris
ASKER
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...
i really dont know if i did that right...
HAve you run the routine to the break point since adding the watches?
Chris
Chris
Just before the breakpoint put two lines of code:
debug.print ">" & cel.value & "<" & vbtab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)& "<<"
Chris
debug.print ">" & cel.value & "<" & vbtab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)& "<<"
Chris
ASKER
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.V alue & "@", 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.V alue & "@", 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
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(
i.e.
debug.print ">" & cel.value & "<" & vbtab & ">>" & Left(cel.Value & "@", InStr(cel.Value & "@", "@") - 1)& "<<"
tempStr = Application.Match(Replace(
Run the sub and then when execution has finished provide a copy of the data from the immediate window
Chris
ASKER
I get this in the immediate window
>Sharath.ben@plc.com< >>Sharath.ben<<
>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.V alue & "@", InStr(cel.Value & "@", "@") - 1), ".", " "), X, 0)
Chris
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(
Chris
ASKER
Should i add the whole code to the module or should i replace some thing.
ASKER
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<<
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
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
Chris
ASKER
Here is the data
178: /o=HTgroup/ou=first administrative group/cn=recipients/cn=nar hs
179: /o=HTgroup/ou=first administrative group/cn=recipients/cn=pra up
180: /o=HTgroup/ou=first administrative group/cn=recipients/cn=dev ajans
181: /o=HTgroup/ou=first administrative group/cn=recipients/cn=anb vamt
182: /o=HTgroup/ou=first administrative group/cn=recipients/cn=dev ans
183: /o=HTgroup/ou=first administrative group/cn=recipients/cn=rag m
184: /o=HTgroup/ou=first administrative group/cn=recipients/cn=ana rka
1: /o=HTgroup/ou=first administrative group/cn=recipients/cn=sar ava
2: /o=HTgroup/ou=first administrative group/cn=recipients/cn=saj eev
3: knakumar.r@HThealth.com
4: /o=HTgroup/ou=first administrative group/cn=recipients/cn=moh and
5: krishmar.r@HThealth.com
6: /o=HTgroup/ou=first administrative group/cn=recipients/cn=moh and
7: kris.r@HThealth.com
8: /o=HTgroup/ou=first administrative group/cn=recipients/cn=kri s
9: krhnakumar.r@HThealth.com
186: /o=HTgroup/ou=first administrative group/cn=recipients/cn=sha ra
>Sharath re< >>Sharath re<<
>Sharath.re@HTplc.com< >>Sharath.re<<
HTplc.com< >>Sharath.re<<
Hope this helps
178: /o=HTgroup/ou=first administrative group/cn=recipients/cn=nar
179: /o=HTgroup/ou=first administrative group/cn=recipients/cn=pra
180: /o=HTgroup/ou=first administrative group/cn=recipients/cn=dev
181: /o=HTgroup/ou=first administrative group/cn=recipients/cn=anb
182: /o=HTgroup/ou=first administrative group/cn=recipients/cn=dev
183: /o=HTgroup/ou=first administrative group/cn=recipients/cn=rag
184: /o=HTgroup/ou=first administrative group/cn=recipients/cn=ana
1: /o=HTgroup/ou=first administrative group/cn=recipients/cn=sar
2: /o=HTgroup/ou=first administrative group/cn=recipients/cn=saj
3: knakumar.r@HThealth.com
4: /o=HTgroup/ou=first administrative group/cn=recipients/cn=moh
5: krishmar.r@HThealth.com
6: /o=HTgroup/ou=first administrative group/cn=recipients/cn=moh
7: kris.r@HThealth.com
8: /o=HTgroup/ou=first administrative group/cn=recipients/cn=kri
9: krhnakumar.r@HThealth.com
186: /o=HTgroup/ou=first administrative group/cn=recipients/cn=sha
>Sharath re< >>Sharath re<<
>Sharath.re@HTplc.com< >>Sharath.re<<
HTplc.com< >>Sharath.re<<
Hope this helps
ASKER
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.
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
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
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
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
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
ASKER
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)
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)
ASKER
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)
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
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
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
You will of course apply the points as you see fit but I think he deserves some of them.
Chris
ASKER
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...
--------------------------
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...
ASKER
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...
--------------------------
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
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
ASKER
ASKER
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
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
ASKER
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...
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
Chris
ASKER
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
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.
2: sharathyu@plc.com
1: kankrishnan.kandasamy@plc.
2: sharathyu@plc.com
1: kankrishnan.kandasamy@plc.
2: sharathyu@plc.com
1: kankrishnan.kandasamy@plc.
2: sharathyu@plc.com
In excel just 2 email id's
1: kankrishnan.kandasamy@plc.
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
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
ASKER
Re-introduce the error when cut and pasting.
replace:
For Each oMessage In TargetFolderItems
with
For Each oMessage In TargetFolderItems.items
Chris
replace:
For Each oMessage In TargetFolderItems
with
For Each oMessage In TargetFolderItems.items
Chris
ASKER
I get the same above error when debug goes here
X(i) = LCase(GetSMTPAddress(oMess age.Sender name))
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.
X(i) = LCase(GetSMTPAddress(oMess
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.
ASKER
I get the same above error when debug goes here
X(i) = LCase(GetSMTPAddress(oMess age.Sender name))
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.
X(i) = LCase(GetSMTPAddress(oMess
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
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
ASKER
Stil get the same error....
ASKER
Stil get the same error....
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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... :-)
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
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
ASKER
:-)
Any help with the similar post i raised. To search the body of the mail...
Any help with the similar post i raised. To search the body of the mail...
Chris