vba outlook: get emails and export to excel and save attachments - vba

Question

I have tried to put together a piece of vba code which does the following.
first it looks for all emails in my inbox folder for the account NewSuppliers#Hewden.co.uk where the subject contains certain key words.
Secondly it looks for all emails in my inbox folder CreditChecks#Hewden.co.uk where the subject contains certain keywords.
Then it exports certain data into excel row after row.
This works fine except with my emails which I export from the CreditChecks#Hewden.co.uk inbox, I want to export only the emails which contains a pdf attachment and save this attachment in a directory and place each seperate pdf document in a folder with the same name as the pdf file.
I've tested my save attachment and export emails scripts separate and they work fine but when I put them together I get an error saying
method or object not found
Set objAttachments = Outlook.Attachments
Can someone please help me get my code to do what I need it to do? Thanks in advance
Here is my code:
'On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = "X:\New_Supplier_Set_Ups_&_Audits\NewSupplierSet-Up.xls"
'On the next line edit the name of the sheet you want to export to
Const SHEET_NAME = "Validations"
Const SHEET_NAME2 = "BankSetup"
Const SHEET_NAME3 = "CreditChecks"
Const MACRO_NAME = "Export Messages to Excel (Rev 7)"
Private Sub Application_Startup()
Dim olkMsg As Object, _
olkMsg2 As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
excWks2 As Object, _
excWks3 As Object, _
intRow As Integer, _
intRow2 As Integer, _
intRow3 As Integer, _
intExp As Integer, _
intVersion As Integer
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
Set excWks = excWkb.Worksheets(SHEET_NAME)
Set excWks2 = excWkb.Worksheets(SHEET_NAME2)
Set excWks3 = excWkb.Worksheets(SHEET_NAME3)
intRow = excWks.UsedRange.Rows.Count + 1
intRow2 = excWks2.UsedRange.Rows.Count + 1
intRow3 = excWks3.UsedRange.Rows.Count + 1
'Write messages to spreadsheet
Dim ns As Outlook.NameSpace
Dim Items As Outlook.Items
Dim Items2 As Outlook.Items
Dim objAttachments As Outlook.Attachments
Dim objMsg As Outlook.MailItem 'Object
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the MAPI Namespace
Set ns = Application.GetNamespace("MAPI")
' Get the Items for the Inbox in the specified account
Set Items = ns.Folders("New Suppliers").Folders("Inbox").Items
Set Items2 = ns.Folders("Credit Checks").Folders("Inbox").Items
Set objAttachments = Outlook.Attachments
' Start looping through the items
For Each olkMsg In Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.class = olMail Then
If olkMsg.Subject Like "Accept: New Supplier Request*" Or olkMsg.Subject Like "Reject: New Supplier Request*" Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
Dim LResult As String
LResult = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult = Left(LResult, InStrRev(LResult, "#") - 1)
excWks.Cells(intRow, 2) = LResult
excWks.Cells(intRow, 3) = olkMsg.VotingResponse
Dim s As String
s = olkMsg.Subject
Dim indexOfName As Integer
indexOfName = InStr(1, s, "Reference: ")
Dim finalString As String
finalString = Right(s, Len(s) - indexOfName - 10)
excWks.Cells(intRow, 4) = finalString
intRow = intRow + 1
End If
End If
If olkMsg.class = olMail Then
If olkMsg.Subject Like "Complete: Bank Details Set-Up for New Supplier*" Or olkMsg.Subject Like "Incomplete: Bank Details Set-Up for New Supplier*" Then
'Add a row for each field in the message you want to export
excWks2.Cells(intRow2, 1) = olkMsg.ReceivedTime
Dim LResult2 As String
LResult2 = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult2 = Left(LResult2, InStrRev(LResult2, "#") - 1)
excWks2.Cells(intRow2, 2) = LResult2
excWks2.Cells(intRow2, 3) = olkMsg.VotingResponse
Dim s2 As String
s2 = olkMsg.Subject
Dim indexOfName2 As Integer
indexOfName2 = InStr(1, s2, "Reference: ")
Dim finalString2 As String
finalString2 = Right(s2, Len(s2) - indexOfName2 - 10)
excWks2.Cells(intRow2, 4) = finalString2
intRow2 = intRow2 + 1
End If
End If
Next
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
For Each olkMsg2 In Items2
If olkMsg2.class = olMail Then
If olkMsg2.Subject Like "RE: New Supplier Credit*" Then
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
'Add a row for each field in the message you want to export
excWks3.Cells(intRow3, 1) = olkMsg2.ReceivedTime
Dim LResult3 As String
LResult3 = Replace(GetSMTPAddress(olkMsg2, intVersion), ".", " ")
LResult3 = Left(LResult3, InStrRev(LResult3, "#") - 1)
excWks3.Cells(intRow3, 2) = LResult3
excWks3.Cells(intRow3, 3) = "Complete"
excWks3.Cells(intRow3, 4) = "File Attached"
Dim s3 As String
s3 = olkMsg2.Subject
Dim indexOfName3 As Integer
indexOfName3 = InStr(1, s3, "Reference: ")
Dim finalString3 As String
finalString3 = Right(s3, Len(s3) - indexOfName3 - 10)
excWks3.Cells(intRow3, 5) = finalString3
excWks3.Cells(intRow3, 6) = "File Path"
intRow3 = intRow3 + 1
End If
Next i
End If
End If
End If
Next
Set olkMsg = Nothing
Set olkMsg2 = Nothing
excWkb.Close True
Set excWks = Nothing
Set excWks2 = Nothing
Set excWks3 = Nothing
Set excWkb = Nothing
Set excApp = Nothing
On Error GoTo ErrHandle
ErrHandle:
Resume Next
End Sub
Private Function GetSMTPAddress(item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(item)
Else
GetSMTPAddress = item.SenderEmailAddress
End If
Case Else
Set olkSnd = item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function

Answer 1

Set objAttachments = Outlook.Attachments is not the correct syntax.
Just remove the line as you have this later.
Set objAttachments = objMsg.Attachments