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

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

i have tried set piece of vba code following.

first looks emails in inbox folder business relationship newsuppliers@hewden.co.uk subject contains key words.

secondly looks emails in inbox folder creditchecks@hewden.co.uk subject contains keywords.

then exports info excel row after row.

this works fine except emails export creditchecks@hewden.co.uk inbox, want export emails contains pdf attachment , save attachment in directory , place each seperate pdf document in folder same name pdf file.

i've tested save attachment , export emails scripts separate , work fine when set them error saying

method or object not found

set objattachments = outlook.attachments

can please help me code need do? in advance

here code:

'on next line edit path spreadsheet want export const workbook_path = "x:\new_supplier_set_ups_&_audits\newsupplierset-up.xls" 'on next line edit name of sheet want export const sheet_name = "validations" const sheet_name2 = "banksetup" const sheet_name3 = "creditchecks" const macro_name = "export messages excel (rev 7)" private sub application_startup() dim olkmsg object, _ olkmsg2 object, _ excapp object, _ excwkb object, _ excwks object, _ excwks2 object, _ excwks3 object, _ introw integer, _ introw2 integer, _ introw3 integer, _ intexp integer, _ intversion 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 spreadsheet dim ns outlook.namespace dim items outlook.items dim items2 outlook.items dim objattachments outlook.attachments dim objmsg outlook.mailitem 'object dim long dim lngcount long dim strfile string dim strfolderpath string dim strdeletedfiles string dim withparts string dim withoutparts string ' mapi namespace set ns = application.getnamespace("mapi") ' items inbox in specified business relationship 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 items each olkmsg in items 'only export messages, not receipts or appointment requests, etc. if olkmsg.class = olmail if olkmsg.subject "accept: new supplier request*" or olkmsg.subject "reject: new supplier request*" 'add row each field in message want export excwks.cells(introw, 1) = olkmsg.receivedtime dim lresult 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 string s = olkmsg.subject dim indexofname integer indexofname = instr(1, s, "reference: ") dim finalstring string finalstring = right(s, len(s) - indexofname - 10) excwks.cells(introw, 4) = finalstring introw = introw + 1 end if end if if olkmsg.class = olmail if olkmsg.subject "complete: bank details set-up new supplier*" or olkmsg.subject "incomplete: bank details set-up new supplier*" 'add row each field in message want export excwks2.cells(introw2, 1) = olkmsg.receivedtime dim lresult2 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 string s2 = olkmsg.subject dim indexofname2 integer indexofname2 = instr(1, s2, "reference: ") dim finalstring2 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 each olkmsg2 in items2 if olkmsg2.class = olmail if olkmsg2.subject "re: new supplier credit*" if lngcount > 0 = lngcount 1 step -1 strfile = objattachments.item(i).filename if right(strfile, 3) = "pdf" ' combine path temp folder. withparts = strfile withoutparts = replace(withparts, ".pdf", "") strfile = strfolderpath & withoutparts & "\" & strfile ' save attachment file. objattachments.item(i).saveasfile strfile 'add row each field in message want export excwks3.cells(introw3, 1) = olkmsg2.receivedtime dim lresult3 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 string s3 = olkmsg2.subject dim indexofname3 integer indexofname3 = instr(1, s3, "reference: ") dim finalstring3 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 end if end if end if next set olkmsg = nil set olkmsg2 = nil excwkb.close true set excwks = nil set excwks2 = nil set excwks3 = nil set excwkb = nil set excapp = nil on error goto errhandle errhandle: resume next end sub private function getsmtpaddress(item outlook.mailitem, intoutlookversion integer) string dim olksnd outlook.addressentry, olkent object on error resume next select case intoutlookversion case < 14 if item.senderemailtype = "ex" getsmtpaddress = smtp2007(item) else getsmtpaddress = item.senderemailaddress end if case else set olksnd = item.sender if olksnd.addressentryusertype = olexchangeuseraddressentry set olkent = olksnd.getexchangeuser getsmtpaddress = olkent.primarysmtpaddress else getsmtpaddress = item.senderemailaddress end if end select on error goto 0 set olkprp = nil set olksnd = nil set olkent = nil end function function getoutlookversion() integer dim arrver variant arrver = split(outlook.version, ".") getoutlookversion = arrver(0) end function function smtp2007(olkmsg outlook.mailitem) string dim olkpa 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 = nil end function

set objattachments = outlook.attachments not right syntax.

just remove line have later.

set objattachments = objmsg.attachments

vba email outlook