|
Question : Need help with exisiting code. reading attachments and save to MS Access
|
|
I have a bit of code whereas I have basically given up. I know that I am close by examining the output but this is what is happening. I want to be able to read an outlook email and then the attachments. I want to be able to export the name, subject, DateSent, Filename and message to an MS Access table. I have it "somewhat" working but what is happening is that the subject is duplicating. The situation is that an email can have several attachments but naturally one subject. What I get is the:
txtName txtSubject txtDateSent txtFileName txtMessage
donald donaldduck 9/29/2004 9:09:09 AM C:\Donald\0305.xls "Test
"
donald donaldduck 9/29/2004 9:09:09 AM C:\Donald\0302 (2).xls "Test
"
donald donaldduck 9/29/2004 9:09:09 AM C:\Donald\0302 (2)_OK.xls "Test
"
What I should get is
txtName txtSubject txtDateSent txtFileName txtMessage
donald donaldduck 9/29/2004 9:09:09 AM C:\Donald\0305.xls "Test
"
donald donaldduck 9/29/2004 9:09:09 AM C:\Donald\0302 (2).xls "Test
"
donald Duck 9/29/2004 9:09:09 AM C:\Donald\0302 (2)_OK.xls "Test
"
The code I have using is:
Public Sub StoreOutlookItems()
Dim OlApp As Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim OlFolder As Outlook.MAPIFolder
Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up
Dim OlItems As Outlook.Items
Dim rst As Recordset
Dim Item As Object
Dim Atmt As Attachment
Dim Filename As String
Dim i As Integer
Set rst = CurrentDb.OpenRecordset("tblMyTable") ' - Create a connection to outlook
Set OlApp = CreateObject("Outlook.Application") ' or Set OlApp = New Outlook.Application
Set OlMapi = OlApp.GetNamespace("MAPI") ' - Open the inbox
Set OlFolder = OlMapi.Folders("Personal Folders").Folders("Inbox")
Set OlItems = OlFolder.Items ' - For each mail in the collection check the subject line and process accordingly
For Each OlMail In OlItems
If OlFolder.Items.Count > 0 Then
For Each Item In OlFolder.Items
For Each Atmt In Item.Attachments
rst.AddNew
rst!txtName = OlMail.SenderName
rst!txtsubject = OlMail.subject
rst!txtdatesent = OlMail.ReceivedTime
rst!txtMessage = OlMail.Body
rst!txtFilename = "C:\Donald\" & Atmt.Filename '& OlFolder.Subject
rst.Update
i = i + 1
Next Atmt
Next Item
End If
Screen.MousePointer = 0
Next
End Sub
Where am I going wrong?
|
|
|
Answer : Need help with exisiting code. reading attachments and save to MS Access
|
|
I believe you might have one extra level of looping in there or you are loading your recordset with the wrong object. I indented my copy of your code as follows...
For Each OlMail In OlItems
If OlFolder.Items.Count > 0 Then
For Each Item In OlFolder.Items
For Each Atmt In Item.Attachments
rst.AddNew
rst!txtName = OlMail.SenderName
rst!txtsubject = OlMail.subject
rst!txtdatesent = OlMail.ReceivedTime
rst!txtMessage = OlMail.Body
rst!txtFilename = "C:\Donald\" & Atmt.Filename '& OlFolder.Subject
rst.Update
i = i + 1
Next Atmt
Next Item
End If
Screen.MousePointer = 0
Next
< end snip>
I noticed that your recordset is being loaded using the OLMail object
(i.e. rst!txtName = OlMail.SenderName)
I think this should be the Item Object
(i.e. rst!txtName = Item.SenderName)
And again perhaps there is an extra level of looping here.
The two lines of code (sorry for taking them out of context):
Set OlItems = OlFolder.Items
For Each Item In OlFolder.Items
Refer to the same collection correct?
I think if you use the following code to replace the code listed above, you will get the results you are after.
If OlFolder.Items.Count > 0 Then
For Each Item In OlFolder.Items
For Each Atmt In Item.Attachments
rst.AddNew
rst!txtName = Item.SenderName
rst!txtsubject = Item.subject
rst!txtdatesent = Item.ReceivedTime
rst!txtMessage = Item.Body
rst!txtFilename = "C:\Donald\" & Atmt.Filename '& Item.Subject
rst.Update
i = i + 1
Next Atmt
Next Item
End If
Screen.MousePointer = 0
< end snip>
Hope that helps
|
|
|
|
