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 = "[email protected]" 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