我在SO上找到的这段代码完全适用于Excel 2013，但不适用于Excel 2010.代码在2010年执行，但在运行中途，它产生了一个
＆＃34;对象未定义错误＆＃34;在
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
答案 0 :(得分：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