Reading Outlook

Hello All,
I'm trying to read my Outlook Inbox and add email addresses to an Access
table. My code is below. It works fine except there doesn't seem to be a
mailobject property for the senders email address. Can anyone help?
Fred Zuckerman


Private Sub btnScanInbox_Click()
Dim rst As DAO.Recordset
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Object

Set rst = CurrentDb.OpenRecordset("tblAddresses")
Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set InboxItems = Inbox.Items
For Each Mailobject In InboxItems
If InStr(Mailobject.Subject, "SUBSCRIBE") > 0 Then
rst.AddNew

'this line doesn't work
rst!SenderAddress = Mailobject.SenderAddress

rst!SenderName = Mailobject.SenderName
rst!AddDate = Date
rst.Update
End If
Next

rst.Close
Set rst = Nothing
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
End Sub

Re: Reading Outlook

"Fred Zuckerman" wrote in message news:...
> Hello All,
> I'm trying to read my Outlook Inbox and add email addresses to an Access
> table. My code is below. It works fine except there doesn't seem to be a
> mailobject property for the senders email address. Can anyone help?
> Fred Zuckerman
>
>
> Private Sub btnScanInbox_Click()
> Dim rst As DAO.Recordset
> Dim OlApp As Outlook.Application
> Dim Inbox As Outlook.MAPIFolder
> Dim InboxItems As Outlook.Items
> Dim Mailobject As Object
>
> Set rst = CurrentDb.OpenRecordset("tblAddresses")
> Set OlApp = CreateObject("Outlook.Application")
> Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
> Set InboxItems = Inbox.Items
> For Each Mailobject In InboxItems
> If InStr(Mailobject.Subject, "SUBSCRIBE") > 0 Then
> rst.AddNew
>
> 'this line doesn't work
> rst!SenderAddress = Mailobject.SenderAddress
>
> rst!SenderName = Mailobject.SenderName
> rst!AddDate = Date
> rst.Update
> End If
> Next
>
> rst.Close
> Set rst = Nothing
> Set OlApp = Nothing
> Set Inbox = Nothing
> Set InboxItems = Nothing
> Set Mailobject = Nothing
> End Sub
>

After doing some more research, I found an article at Microsoft.com on this
issue. Below is my revised code to manage subscriptions.
Comments welcome.
Fred Zuckerman


** caution - watchout for word wrap

Private Sub btnScanInbox_Click()
Dim NewSubscribers As Integer
Dim ReSubscribers As Integer
Dim UnSubscribers As Integer

Dim rst As DAO.Recordset

Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Object
Dim objReply As MailItem
Dim objRecips As Outlook.Recipients
Dim objRecip As Outlook.Recipient
Dim ReplyAddress As String

Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set InboxItems = Inbox.Items
For Each Mailobject In InboxItems
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set objReply = Mailobject.Reply
Set objRecips = objReply.Recipients
For Each objRecip In objRecips
ReplyAddress = objRecip.Address
Exit For '''I'm only interested in the 1st sender, there's not
likely more
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rst = CurrentDb.OpenRecordset("Select * From tblAddresses Where
SenderAddress='" & ReplyAddress & "'")

If InStr(Mailobject.Subject, "SUBSCRIBE") > 0 And rst.RecordCount = 0
Then '''NEW SUBSCRIBER
NewSubscribers = NewSubscribers + 1
rst.AddNew
rst!SenderAddress = ReplyAddress
rst!SenderName = Mailobject.SenderName
rst!AddDate = Date
rst!DelDate = Null
rst.Update

ElseIf InStr(Mailobject.Subject, "SUBSCRIBE") > 0 And rst.RecordCount
> 0 Then '''RE-SUBSCRIBER
ReSubscribers = ReSubscribers + 1
rst.Edit
rst!SenderName = Mailobject.SenderName
rst!AddDate = Date
rst!DelDate = Null
rst.Update

ElseIf InStr(Mailobject.Subject, "DELETE") > 0 And rst.RecordCount > 0
Then '''UNSUBSCRIBER
UnSubscribers = UnSubscribers + 1
rst.Edit
rst!DelDate = Date
rst.Update

End If
Next

rst.Close
Set rst = Nothing
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Set objReply = Nothing
Set objRecip = Nothing

MsgBox "New Subscribers = " & NewSubscribers & vbCrLf & _
"UnSubscribers = " & UnSubscribers & vbCrLf & _
"Re-Subscribers = " & ReSubscribers
End Sub