Here is the whole Subroutine
Code:
Private Sub GetAttachments()
Dim db As DAO.Database, _
olNameSpace As Outlook.Namespace, _
olInbox As Outlook.Folder, _
olSubFolder As Outlook.Folder, _
olDestFolder As Outlook.Folder, _
olConv As Outlook.Conversation, _
olMail As MailItem, _
objItems As Outlook.Items, _
Item As Object, _
Attachment As Outlook.Attachment, _
FileName As String, _
sql As String, _
strReceivedTime As String, _
rsOpen As Recordset
Set db = CurrentDb
Set olNameSpace = GetNamespace("MAPI")
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olSubFolder = olInbox.Folders("3-Incoming Inspection").Folders("SyQwest")
Set olDestFolder = olInbox.Folders("3-Incoming Inspection").Folders("SyQwest").Folders("Imported Files")
If olSubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In olSubFolder.Items
Set rsOpen = db.OpenRecordset("tbl_EmailInfo")
For Each Attachment In Item.Attachments
If Attachment.Type = 1 And (InStr(Attachment, "xlsx") Or InStr(Attachment, "xls")) > 0 Then
rsOpen.AddNew
rsOpen![DateEmailRcvd] = Item.ReceivedTime
rsOpen![AttachmentName] = Attachment.FileName
rsOpen.Update
' Debug.Print strReceivedTime
FileName = networkFilepath & Attachment.FileName
'Debug.Print FileName
Debug.Print Attachment.FileName
' Debug.Print Item
Attachment.SaveAsFile FileName
End If
Next Attachment
If TypeOf Item Is Outlook.MailItem Or Item.Class = 43 Or TypeOf Item Is Outlook.ReportItem Then
Set olMail = Item
olMail.Move (olDestFolder)
End If
Next Item
' For Each olMail In olSubFolder.Items
Set xlApp = New Excel.Application
xlApp.Visible = True
xlApp.WindowState = xlMaximized
Set olDestFolder = Nothing
Set olInbox = Nothing
End Sub