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