20170228VBA提取邮件部分信息

Sub 获取OutLook收件箱主题和正文()
    On Error Resume Next
    Dim sht As Worksheet
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim olNameSpace As Outlook.Namespace
    Dim OneFolder As Outlook.Folder
    Dim subFolder As Outlook.Folder
    Dim OneBody As String
    Dim RowIndex As Long
    RowIndex = 1
    Set sht = ThisWorkbook.Worksheets(1)
    sht.Range("A:A").ClearContents
    sht.Range("A1").Value = "Claim Code"
    Set olApp = New Outlook.Application
    Set olNameSpace = olApp.GetNamespace("MAPI")
    For Each OneFolder In olNameSpace.Folders
        If OneFolder.Name = "nextseven@126.com" Then    '此处改为你OutLook的账户名
            OneFolder.Display
            For Each subFolder In OneFolder.Folders
                For Each olMail In subFolder.Items
                 Debug.Print olMail.Subject
                    OneBody = olMail.Body
                    If InStr(1, OneBody, "Claim Code") > 0 Then
                         RowIndex = RowIndex + 1
                        OneBody = Split(OneBody, "Claim Code:")(1)
                        OneBody = Split(OneBody, "$")(0)
                        OneBody = Split(OneBody, ">")(1)
                        OneBody = Replace(OneBody, " ", "")
                        Debug.Print OneBody
                        sht.Cells(RowIndex, 1).Value = OneBody
                    End If
                Next olMail
            Next subFolder
        End If
    Next OneFolder
    'olApp.Quit

    Set sht = Nothing
    Set olApp = Nothing
    Set olNameSpace = Nothing
    Set olMail = Nothing
    Set OneFolder = Nothing
    Set subFolder = Nothing

    MsgBox "提取完成！"
End Sub