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

Popular posts from this blog

php - Wordpress website dashboard page or post editor content is not showing but front end data is showing properly -

javascript - Get parameter of GET request -

javascript - Twitter Bootstrap - how to add some more margin between tooltip popup and element -