Saving an outlook attachment (1 Viewer)

[Steve400]

Hi,
The below code is intended to:
1. open outlook mail;
2. copy the email details into the database;
3. save the attachment into a E: drive location;
4. move the email to another folder.

1,2 and 4 were working fine until I tries to save the attachment and got stuck on the SaveAs line.

Any suggestions? Thanks in adavnce.



Dim Ola As Outlook.Application
Dim Nsp As Outlook.NameSpace
Dim pf, Inbox, ib, newdest As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim Atts As Outlook.Attachments
Dim TAt As Outlook.Attachment
Dim Atmt As Attachment
Dim FileName As String
Dim Mctr As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset


Set Ola = New Outlook.Application
Set Nsp = Ola.GetNamespace("MAPI")
Set Inbox = Nsp.GetDefaultFolder(olFolderInbox)
Set pf = Nsp.Folders("Personal Folders")
Set ib = pf.Folders("Inbox")
Set newdest = ib.Folders("Copied")

Set rs = CurrentDb.OpenRecordset("tblEmail", dbOpenDynaset)

If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If

For Each msg In Inbox.Items
For Each Atmt In msg.Attachments
If Right(Atmt.FileName, 3) = "doc" Then
FileName = "E:\" & msg.SenderName & ".doc"
Atmt.SaveAsFile FileName
'Atmt.SaveAs FileName:=FileName
End If
Next Atmt

Set msg = Inbox.Items(1)
rs.AddNew
rs("Subject") = msg.Subject
rs("Body") = msg.Body
rs("FromName") = msg.SenderName
rs("ToName") = msg.To
rs("FromAddress") = msg.SenderEmailAddress
rs("DateReceived") = msg.ReceivedTime
rs.Update
msg.Move newdest
Next msg


Set rs = Nothing
Set FileName = Nothing
Set Atmt = Nothing
Set newdest = Nothing
Set Inbox = Nothing
Set ib = Nothing
Set pf = Nothing
Set Nsp = Nothing
Set Ola = Nothing

End Sub

 

[MarkK]

What does it mean that it "gets stuck?" Does it raise an error? What error? If there are two attachments in a single message, they'll get saved with the same name. Is that the error?

 

[Steve400]

Yes it raises an error on the SaveAsFile line - Compile Error: Method or data member not found.

I haven't come across that error before so not sure of the way around it.

There should only ever be 1 email attachment so I'm not too concerned about that part but if you wanted to distinguish them could you use the msg.filename in the new filename?

 

[MarkK]

Change this . . .

Dim Atmt As Attachment

. . . to this . . .

Dim Atmt As Outlook.Attachment

. . . and see what happens.

 

[Steve400]

Thanks Lagbolt,
That cleared that error, now I have an Error 13:Type mismatch on line "For Each msg In Inbox.Items".
Can you see what I've done wrong?
Thanks

Private Sub Test_Click()

Dim rs As DAO.Recordset
Dim Ola As Outlook.Application
Dim Nsp As Outlook.NameSpace
Dim pf, Inbox, ib, newdest As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim db As DAO.Database


Set Ola = New Outlook.Application
Set Nsp = Ola.GetNamespace("MAPI")
Set Inbox = Nsp.GetDefaultFolder(olFolderInbox)
Set pf = Nsp.Folders("Personal Folders")
Set ib = pf.Folders("Inbox")
Set newdest = ib.Folders("CopiedRCSResponse")

If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the inbox.", vbInformation, _
"Nothing Found"
'Exit Sub
End If

For Each msg In Inbox.Items

Set Atmt = msg.Attachments(1)
If msg.Attachments.Count > 0 Then
For Each Atmt In msg.Attachments
If Right(Atmt.FileName, 3) = "doc" Then
FileName = "E:\EmailAttachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
End If

Set rs = CurrentDb.OpenRecordset("tblEmail", dbOpenDynaset)
Set msg = Inbox.Items(1)
rs.AddNew
rs("Subject") = msg.Subject
rs("Body") = msg.Body
rs("FromName") = msg.SenderName
rs("ToName") = msg.To
rs("FromAddress") = msg.SenderEmailAddress
rs("DateReceived") = msg.ReceivedTime
rs.Update
msg.Move newdest
Next msg

MsgBox "Your mail has been imported to database and move to Copied folder"

Set rs = Nothing
Set Atmt = Nothing
Set newdest = Nothing
Set Inbox = Nothing
Set ib = Nothing
Set pf = Nothing
Set Nsp = Nothing
Set Ola = Nothing

End Sub

 

[stopher]

"Dim pf, Inbox, ib, newdest As Outlook.MAPIFolder"

I'm pretty sure the first three variables in this list will default to type "variant". You need to define them individually:

Dim pf As Outlook.MAPIFolder
Dim Inbox As Outlook.MAPIFolder
Dim ib As Outlook.MAPIFolder
Dim newdest As Outlook.MAPIFolder

Also, be wary that while using FOR EACH, the items are being removed which causes a bit of an issue for FOR EACH. Take a look here.

Chris

 

[Steve400]

Thanks Stopher,
Changed a few things, mainly your do loop suggestion and got it working well.

Only issue is the attachment is not copying to the table, not sure why. Dont need it to be copied as an attachment, text filename would be fine. Any suggestions?


Code below for future member reference:


Dim rs As DAO.Recordset
Dim Ola As Outlook.Application
Dim Nsp As Outlook.NameSpace
Dim pf, Inbox, ib, newdest As Outlook.MAPIFolder
Dim msg As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim db As DAO.Database

On Error Resume Next

Set Ola = New Outlook.Application
Set Nsp = Ola.GetNamespace("MAPI")
Set Inbox = Nsp.GetDefaultFolder(olFolderInbox)
Set pf = Nsp.Folders("Personal Folders")
Set ib = pf.Folders("Inbox")
Set newdest = ib.Folders("CopiedResponse")
Set rs = CurrentDb.OpenRecordset("tblEmail", dbOpenDynaset)

If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If

Do Until Inbox.Items.Count = 0

With rs
Set msg = Inbox.Items(1)
rs.AddNew
rs("Subject") = msg.Subject
rs("Body") = msg.Body
rs("FromName") = msg.SenderName
rs("ToName") = msg.To
rs("FromAddress") = msg.SenderEmailAddress
rs("DateReceived") = msg.ReceivedTime
rs("Attachment") = msg.Attachment(1)
rs("ImportDate") = Time & Date
rs.Update
End With

If msg.Attachments.Count > 0 Then
Set Atmt = msg.Attachments(1)
For Each Atmt In msg.Attachments
If Right(Atmt.FileName, 3) = "doc" Then
FileName = "E:\EmailAttachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
End If

msg.Move newdest
Set msg = Inbox.Items.FindNext
Loop


If Inbox.Items.Count = 0 Then
MsgBox "All your mail has been imported to database and move to CopiedResponses folder"
End If


Set rs = Nothing
Set Atmt = Nothing
Set newdest = Nothing
Set Inbox = Nothing
Set ib = Nothing
Set pf = Nothing
Set Nsp = Nothing
Set Ola = Nothing

End Sub