VBA Code works on Excel 2013 but not Excel 2010; -
this code found on works on excel 2013 not on excel 2010. code executes on 2010 halfway through running, produces
"object not defined error" @
xlsh.range("a1").resize(ubound(aoutput, 1), ubound(aoutput, 2)).value = aoutput
.
the new output workbook indeed have information require, half of it. seems code runs smoothly until messes up, can't source error starts.
if has 2010 , can give me insights great.
option explicit dim aoutput() variant dim lcnt long sub subfolders() ' ' code outlook versions 2007 , subsequent ' declare folder rather mapifolder ' dim xlapp excel.application dim xlsh excel.worksheet dim wbo workbook dim olns namespace dim outlookapp object dim outlookmailitem object dim olparentfolder folder dim subj string dim bod string dim maildest string set olns = getnamespace("mapi") set olparentfolder = olns.getdefaultfolder(olfolderinbox) lcnt = 0 redim aoutput(1 100000, 1 5) processfolder olparentfolder on error resume next set xlapp = getobject(, "excel.application") on error goto 0 if xlapp nothing set xlapp = createobject("excel.application") set xlsh = xlapp.workbooks.add.sheets(1) xlsh.range("a1").resize(ubound(aoutput, 1), ubound(aoutput, 2)).value = aoutput xlapp.visible = true application.displayalerts = false xlsh.saveas filename:="c:\users\rliu\desktop\barryreport.xls", fileformat:=56 activeworkbook.close savechanges:=true set outlookapp = createobject("outlook.application") set outlookmailitem = outlookapp.createitem(0) outlookmailitem subj = "" maildest = "anemail@myemail.com" bod = "" .bcc = maildest .subject = "barry monthly update" .body = " " .attachments.add ("c:\users\rliu\desktop\barryreport.xls") .send end application.displayalerts = true exitroutine: set olns = nothing set olparentfolder = nothing set xlapp = nothing set xlsh = nothing end sub private sub processfolder(byval oparent folder) dim ofolder folder dim omail object dim wbo workbook each omail in oparent.items if typename(omail) = "mailitem" lcnt = lcnt + 1 aoutput(lcnt, 1) = omail.senderemailaddress aoutput(lcnt, 2) = omail.receivedtime aoutput(lcnt, 3) = omail.subject end if next if (oparent.folders.count > 0) each ofolder in oparent.folders processfolder ofolder next end if end sub
this code works me in 2010.
you'll need give worksheet codename of shtanalysis
(look @ properties of sheet in visual basic editor).
noticed - haven't checked type of mail object, need add in.
public sub createreport() dim ooutlook object 'outlook.application dim nnamespace object 'outlook.namespace dim mfolderselected object 'outlook.mapifolder 'getobject creates if need outlook. set ooutlook = getobject(, "outlook.application") set nnamespace = ooutlook.getnamespace("mapi") 'ask folder or inbox. 'set mfolderselected = nnamespace.pickfolder set mfolderselected = nnamespace.getdefaultfolder(6) 'olfolderinbox shtanalysis.cells.delete shift:=xlup shtanalysis.range("a1:d1") = array("sent on", "sender", "subject", "received") processfolder mfolderselected, ooutlook end sub private sub processfolder(oparent object, olapp object) dim ofolder object 'outlook.mapifolder dim omail object dim sname string on error resume next each omail in oparent.items placedetails omail, oparent, olapp next omail if (oparent.folders.count > 0) each ofolder in oparent.folders processfolder ofolder, olapp next ofolder end if on error goto 0 end sub private sub placedetails(omailitem object, ofolder object, olapp object) dim rlastcell range set rlastcell = lastcell(shtanalysis).offset(1) shtanalysis .cells(rlastcell.row, 1) = omailitem.senton .cells(rlastcell.row, 2) = resolvedisplaynametosmtp(omailitem.senderemailaddress, olapp) .cells(rlastcell.row, 3) = omailitem.subject .cells(rlastcell.row, 4) = omailitem.receivedtime end end sub '---------------------------------------------------------------------------------- ' procedure : resolvedisplaynametosmtp ' author : sue mosher - updated d.bartrup-cook work in excel late binding. '----------------------------------------------------------------------------------- private function resolvedisplaynametosmtp(sfromname, olapp object) string select case val(olapp.version) case 11 'outlook 2003 dim osess object dim ocon object dim skey string dim sret string set ocon = olapp.createitem(2) 'olcontactitem set osess = olapp.getnamespace("mapi") osess.logon "", "", false, false ocon.email1address = sfromname skey = "_" & replace(rnd * 100000 & format(now, "ddmmyyyyhmmss"), ".", "") ocon.fullname = skey ocon.save sret = trim(replace(replace(replace(ocon.email1displayname, "(", ""), ")", ""), skey, "")) ocon.delete set ocon = nothing set ocon = osess.getdefaultfolder(3).items.find("[subject]=" & skey) '3 = 'olfolderdeleteditems if not ocon nothing ocon.delete resolvedisplaynametosmtp = sret case 14 'outlook 2010 dim orecip object 'outlook.recipient dim oeu object 'outlook.exchangeuser dim oedl object 'outlook.exchangedistributionlist set orecip = olapp.session.createrecipient(sfromname) orecip.resolve if orecip.resolved select case orecip.addressentry.addressentryusertype case 0, 5 'olexchangeuseraddressentry & olexchangeremoteuseraddressentry set oeu = orecip.addressentry.getexchangeuser if not (oeu nothing) resolvedisplaynametosmtp = oeu.primarysmtpaddress end if case 10, 30 'oloutlookcontactaddressentry & 'olsmtpaddressentry resolvedisplaynametosmtp = orecip.addressentry.address end select else resolvedisplaynametosmtp = sfromname end if case else 'name not resolved return sfromname. resolvedisplaynametosmtp = sfromname end select end function '--------------------------------------------------------------------------------------- ' procedure : lastcell ' author : darren bartrup-cook ' date : 26/11/2013 ' purpose : finds last cell containing data or formula within given worksheet. ' if optional col passed finds last row specific column. '--------------------------------------------------------------------------------------- private function lastcell(wrksht worksheet, optional col long = 0) range dim llastcol long, llastrow long on error resume next wrksht if col = 0 llastcol = .cells.find("*", , , , xlbycolumns, xlprevious).column llastrow = .cells.find("*", , , , xlbyrows, xlprevious).row else llastcol = .cells.find("*", , , , xlbycolumns, xlprevious).column llastrow = .columns(col).find("*", , , , xlbycolumns, xlprevious).row end if if llastcol = 0 llastcol = 1 if llastrow = 0 llastrow = 1 set lastcell = wrksht.cells(llastrow, llastcol) end on error goto 0 end function
Comments
Post a Comment