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

Question

我在 SO 上找到的这段代码在 Excel 2013 上完美运行，但在 Excel 2010 上却没有。该代码在 2010 年执行，但在运行到一半时，它产生一个

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 = "anemail@myemail.com"
        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 编辑器中工作表的属性）。
刚刚注意到 - 我没有检查邮件对象的类型，所以需要添加它。

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