VBA代码适用于Excel 2013，但不适用于Excel 2010;

我在SO上find的代码在Excel 2013中完美工作，但在Excel 2010上完美无缺。代码在2010年执行，但在运行的中途执行，它生成

xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput 。“Object not defined error”在xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput

新的输出工作簿确实有我需要的信息，但只有一半。 所以看起来，代码运行顺利，直到东西混乱，但我不能从错误开始的地方来源。

如果任何人有2010年，可以给我一些很好的见解。

 Option Explicit Dim aOutput() As Variant Dim lCnt As Long Sub SubFolders() ' ' Code for Outlook versions 2007 and subsequent ' Declare with Folder rather than MAPIfolder ' Dim xlApp As Excel.Application Dim xlSh As Excel.Worksheet Dim wbo As Workbook Dim olNs As Namespace Dim OutLookApp As Object Dim OutLookMailItem As Object Dim olParentFolder As Folder Dim subj As String Dim bod As String Dim MailDest As String Set olNs = GetNamespace("MAPI") Set olParentFolder = olNs.GetDefaultFolder(olFolderInbox) lCnt = 0 ReDim aOutput(1 To 100000, 1 To 5) ProcessFolder olParentFolder On Error Resume Next Set xlApp = GetObject(, "Excel.Application") On Error GoTo 0 If xlApp Is Nothing Then 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) With OutLookMailItem subj = "" MailDest = "[e-mail]" bod = "" .BCC = MailDest .Subject = "Barry Monthly Update" .Body = " " .Attachments.Add ("C:\Users\rliu\Desktop\BarryReport.xls") .Send End With Application.DisplayAlerts = True ExitRoutine: Set olNs = Nothing Set olParentFolder = Nothing Set xlApp = Nothing Set xlSh = Nothing End Sub Private Sub ProcessFolder(ByVal oParent As Folder) Dim oFolder As Folder Dim oMail As Object Dim wbo As Workbook For Each oMail In oParent.Items If TypeName(oMail) = "MailItem" Then 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) Then For Each oFolder In oParent.Folders ProcessFolder oFolder Next End If End Sub 

Answer 1

这个代码在2010年适用于我。
你将需要给一个工作表的代号为shtAnalysis （查看Visual Basic编辑器中工作表的属性）。
只是注意到 – 我没有检查邮件对象的types，所以将需要添加。

 Public Sub CreateReport() Dim oOutlook As Object 'Outlook.Application Dim nNameSpace As Object 'Outlook.Namespace Dim mFolderSelected As Object 'Outlook.MAPIFolder 'GetObject also creates if need be with Outlook. Set oOutlook = GetObject(, "Outlook.Application") Set nNameSpace = oOutlook.GetNameSpace("MAPI") 'Ask for a folder or get the 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 As Object, OLApp As Object) Dim oFolder As Object 'Outlook.MAPIFolder Dim oMail As Object Dim sName As String On Error Resume Next For Each oMail In oParent.Items PlaceDetails oMail, oParent, OLApp Next oMail If (oParent.Folders.Count > 0) Then For Each oFolder In oParent.Folders ProcessFolder oFolder, OLApp Next oFolder End If On Error GoTo 0 End Sub Private Sub PlaceDetails(oMailItem As Object, oFolder As Object, OLApp As Object) Dim rLastCell As Range Set rLastCell = LastCell(shtAnalysis).Offset(1) With 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 With End Sub '---------------------------------------------------------------------------------- ' Procedure : ResolveDisplayNameToSMTP ' Author : Sue Mosher - updated by D.Bartrup-Cook to work in Excel late binding. '----------------------------------------------------------------------------------- Private Function ResolveDisplayNameToSMTP(sFromName, OLApp As Object) As String Select Case Val(OLApp.Version) Case 11 'Outlook 2003 Dim oSess As Object Dim oCon As Object Dim sKey As String Dim sRet As 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 Is Nothing Then oCon.Delete ResolveDisplayNameToSMTP = sRet Case 14 'Outlook 2010 Dim oRecip As Object 'Outlook.Recipient Dim oEU As Object 'Outlook.ExchangeUser Dim oEDL As Object 'Outlook.ExchangeDistributionList Set oRecip = OLApp.Session.CreateRecipient(sFromName) oRecip.Resolve If oRecip.Resolved Then Select Case oRecip.AddressEntry.AddressEntryUserType Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry Set oEU = oRecip.AddressEntry.GetExchangeUser If Not (oEU Is Nothing) Then 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 so return sFromName. ResolveDisplayNameToSMTP = sFromName End Select End Function '--------------------------------------------------------------------------------------- ' Procedure : LastCell ' Author : Darren Bartrup-Cook ' Date : 26/11/2013 ' Purpose : Finds the last cell containing data or a formula within the given worksheet. ' If the Optional Col is passed it finds the last row for a specific column. '--------------------------------------------------------------------------------------- Private Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range Dim lLastCol As Long, lLastRow As Long On Error Resume Next With wrkSht If Col = 0 Then 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 Then lLastCol = 1 If lLastRow = 0 Then lLastRow = 1 Set LastCell = wrkSht.Cells(lLastRow, lLastCol) End With On Error GoTo 0 End Function