Extracting email addresses from Outlook Using Access 1

[accessguy52]

Hi -

Does anyone know how to extract a full email address from Outlook? In essence, I need to find code that will return or determine not just the SenderName, but the full email address of that sender IN ACCESS. A book I have, "VBA For Microsoft Office 2000 Unleashed", has a function that is supposed to do this in Outlook, but all I get is still a sendername, e.g. Bob Jones, rather than "bjones@some-place.com".

Thanks!

BTW, here is that code for anyone who is curious:
'---------------------------------------------------

Public Function SenderAddress(msg As MailItem) As String
Dim replyItem As MailItem

'Create a temporary reply
'
Set replyItem = msg.Reply

'The reply's To property holds the sender's address
'
SenderAddress = replyItem.To
Set replyItem = Nothing
End Function

'Sub to test the function
Public Sub SenderAddressTest()
Dim ns as Namespace
Dim ib as MapiFolder

Set ns = ThisOutLookSession.Session
Set ib = ns.GetDefaultFolder(olFolderInbox)

MsgBox SenderAddress(oFolder.Items(2))


End Sub
accessguy52

 

[RivetHed]

I don't know if this helps you but this is some code I used recently to extract some email addresses from outlook into XL, I'm sure you can easily adapt it to access

Public Sub Mail()

Dim Application
Dim Namespace As Namespace
Dim Folder
Dim ItemCollection As Mailitem
Dim MailCounter As Integer
Dim Sender As String
Dim SubFolder
Dim FolderName As String
Dim ReplyMail As Mailitem

FolderName = InputBox("Please enter full name of folder&quot
Set Application = CreateObject("Outlook.Application&quot
Set Namespace = Application.GetNamespace("MAPI&quot
Set Folder = Namespace.GetDefaultFolder(olFolderInbox)
Set SubFolder = Folder.Folders(FolderName)

For MailCounter = 1 To SubFolder.Items.Count

Set ItemCollection = SubFolder.Items(MailCounter)
On Error Resume Next

Set ReplyMail = ItemCollection.Reply

If InStr(1, ReplyMail.Recipients.Item(1).Address, "@&quot Then
Sender = ReplyMail.Recipients.Item(1).Address
Else: Sender = ReplyMail.Recipients.Item(1)
End If

Cells(MailCounter, 1).Select
ActiveCell.Value = Sender

Next MailCounter

End Sub

 

[accessguy52]

RivetHed - hmmm.. that's interesting! I didn't know there was an Address object method. I'll give your code a try. Many thanks and I'll let you know if it works for me. accessguy52

 

[accessguy52]

RivetHed - What am I supposed to put into the InputBox? My own Inbox path? What do you usually put in? Thanks! accessguy52

 

[RivetHed]

the inputbox was for selecting subfolders of the inbox, if you just want to go through the inbox remove references to the subfolder and have things run from the folder variable instead.

 

[RivetHed]

this should do it

Public Sub Mail()

Dim Application
Dim Namespace As Namespace
Dim Folder
Dim ItemCollection As Mailitem
Dim MailCounter As Integer
Dim Sender As String
Dim ReplyMail As Mailitem

Set Application = CreateObject("Outlook.Application&quot
Set Namespace = Application.GetNamespace("MAPI&quot
Set Folder = Namespace.GetDefaultFolder(olFolderInbox)

For MailCounter = 1 To Folder.Items.Count

Set ItemCollection = Folder.Items(MailCounter)
On Error Resume Next

Set ReplyMail = ItemCollection.Reply

If InStr(1, ReplyMail.Recipients.Item(1).Address, "@&quot Then
Sender = ReplyMail.Recipients.Item(1).Address
Else: Sender = ReplyMail.Recipients.Item(1)
End If

Cells(MailCounter, 1).Select
ActiveCell.Value = Sender

Next MailCounter

End Sub

 

[accessguy52]

RivetHed -yup, that worked (in Excel)! I gave you a star. ALthough my email addresses from outside the company intranet were extracted, it didn't extract my own address from within. Hmm. However, I think my boss might be happy with it anyway.

Now I'll adapt it Access.

Many thanks again! accessguy52

 

[RivetHed]

hmm.. coming to think about it I had that problem too, if you do find a solution at any point please post it, I'd be interested to see how it's done.