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
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