VBA代码适用于Excel2013，但不适用于Excel2010;-VBACodeworksonExcel2013butnotExcel2010;

1  

This code works for me in 2010.
You'll need to give a worksheet the codename of shtAnalysis (look at Properties of the sheet in the Visual Basic Editor).
Just noticed - I haven't checked the type of the mail object, so will need to add that in.

这段代码在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