解析Outlook電子郵件和導出到Excel VBA

Question

我目前正在編寫一個在Microsoft Outlook中運行的VBA宏腳本，它應該解析來自電子郵件的關鍵信息並將它們存儲到Excel電子表格中。

現在，我陷入瞭解析和提取我想要的邏輯。

下面是需要被提取並保存到Excel中的黃色圓圈的信息電子郵件的一個簡單的例子（XS是大寫或小寫字母和＃爲數字）

這裏Excel佈局和我當前的代碼發生了什麼，除了標題外什麼都沒有彈出！

這裏是我當前的代碼：

Sub Extract() 

On Error Resume Next 
    Dim messageArray(3) As String 
    Set myOlApp = Outlook.Application 
    Dim OlMail As Variant 
    Set mynamespace = myOlApp.GetNamespace("mapi") 

    'Open the current folder, I want to be able to name a specific folder if possible… 

    Set myfolder = myOlApp.ActiveExplorer.CurrentFolder 
    Set xlobj = CreateObject("excel.application.14") 
    xlobj.Visible = True 
    xlobj.Workbooks.Add 

    'Set headings 
    xlobj.Range("a" & 1).Value = "Priority" 
    xlobj.Range("b" & 1).Value = "Summary" 
    xlobj.Range("c" & 1).Value = "Description of Trouble" 
    xlobj.Range("d" & 1).Value = "Device" 
    'xlobj.Range("e" & 1).Value = "Sender" 


    For i = 1 To myfolder.Items.Count 
    Set myitem = myfolder.Items(i) 
    msgtext = myitem.Body 

    'Search for specific text 
    delimtedMessage = Replace(msgtext, "Priority:", "###") 
    delimtedMessage = Replace(delimtedMessage, "Summary:", "###") 
    delimtedMessage = Replace(delimtedMessage, "Description of Trouble:", "###") 
    delimtedMessage = Replace(delimtedMessage, "Device:", "###") 
    messageArray(i) = Split(delimtedMessage, "###") 

    'Write to Excel 
    xlobj.Range("a" & i + 1).Value = messageArray(0) 
    xlobj.Range("b" & i + 1).Value = messageArray(1) 
    xlobj.Range("c" & i + 1).Value = messageArray(2) 
    xlobj.Range("d" & i + 1).Value = messageArray(3) 
    'xlobj.Range("e" & i + 1).Value = myitem.To 

Next 

End Sub 

這是我第一次在VB編碼過所以任何幫助/建議將是巨大的！

Answer 1

未經測試：

Sub Extract() 

    'On Error Resume Next '<< don't use this! 
    Dim messageArray '<< use a variant here 
    Set myOlApp = Outlook.Application 
    Dim OlMail As Variant 
    Set mynamespace = myOlApp.GetNamespace("mapi") 

    'Open the current folder, I want to be able to name a specific folder if possible… 

    Set myfolder = myOlApp.ActiveExplorer.CurrentFolder 
    Set xlobj = CreateObject("excel.application.14") 
    xlobj.Visible = True 
    xlobj.Workbooks.Add 

    'Set headings 
    xlobj.Range("a" & 1).Value = "Priority" 
    xlobj.Range("b" & 1).Value = "Summary" 
    xlobj.Range("c" & 1).Value = "Description of Trouble" 
    xlobj.Range("d" & 1).Value = "Device" 
    'xlobj.Range("e" & 1).Value = "Sender" 


    For i = 1 To myfolder.Items.Count 
    Set myitem = myfolder.Items(i) 
    msgtext = myitem.Body 

    'Search for specific text 
    delimtedMessage = Replace(msgtext, "Priority:", "###") 
    delimtedMessage = Replace(delimtedMessage, "Summary:", "###") 
    delimtedMessage = Replace(delimtedMessage, "Description of Trouble:", "###") 
    delimtedMessage = Replace(delimtedMessage, "Device:", "###") 
    messageArray = Split(delimtedMessage, "###")'<<edit 

    'Write to Excel 
    If ubound(messageArray) = 3 then 
     xlobj.Range("a" & i + 1).Value = Trim(messageArray(0)) 
     xlobj.Range("b" & i + 1).Value = Trim(messageArray(1)) 
     xlobj.Range("c" & i + 1).Value = Trim(messageArray(2)) 
     xlobj.Range("d" & i + 1).Value = Trim(messageArray(3)) 
     'xlobj.Range("e" & i + 1).Value = myitem.To 
    Else 
     Msgbox "Message format? - " & myitem.Subject 
    End If 

Next 

End Sub 

Answer 2

這裏是一些代碼，可能讓你開始

的電子郵件消息被分成行

則每行以冒號分割...「：」

（結腸被添加到每一行的結束操作的方式分裂之前，使空行不產生錯誤）

然後採取動作，根據各行的前幾個字符

---

把代碼在這篇文章的末尾到Excel工作簿

確保前景是開放的，當你運行它

它是不是一個好主意，使在因安全問題的前景VBA（宏）可能存在的接收到的電子郵件

---

一些指針，你可能已經知道里面：

您可以通過單步通過將光標的任意位置的代碼內並按下F8代碼重複

黃色高亮指示哪個指令將執行下一個

懸停鼠標指針的變量名稱將指示理論值的值在變量（當在任何斷點處停止）

點擊旁邊的一個指令將設置一個斷點（不是所有的指令都是「斷點能力」）左側灰色條中（再次單擊以清除）

按F5將運行程序直到下一個斷點或者到程序結束，如果沒有斷點

使用「監視窗口」仔細檢查對象（變量）

彈出監視窗口進入「菜單欄「...」查看「...」觀看窗口「

拖動任何對象名稱或變量名到監視窗口，或右鍵單擊它並選擇「添加表」

，那麼你可以監測變量值，而在斷點

如停止。拖「topOlFolder」從第三Dim語句（或任何其他地方的程序）

化妝使用「立即窗口」的

按ctrl-G，彈出「立即窗口」 ...... 任何「 Debug.print「命令將打印到」立即窗口「中... 這是用來顯示你需要，而無需編寫VBA代碼時，在斷點處停止

---

一個很好的起點任何調試信息，就是「錄製宏」，然後進入VBE IDE和編輯導致宏代碼，以滿足您的需求

很多代碼在錄製的宏是不必要的，可以縮短了

例如，你可能在工作表「Sheet5」，你需要從「Sheet2的」刪除一切並繼續在「Sheet5」上工作：

你會錄製宏以下操作：

「單擊Sheet2的標籤...選擇所有細胞（CTRL-A）...按刪除...點擊Sheet5選項卡」

產生下面的宏

Sub Macro1() 
    Sheets("Sheet2").Select 
    Cells.Select 
    Selection.ClearContents 
    Sheets("Sheet5").Select 
End Sub 

它可以改寫爲：

Sub Macro1() 
    Sheets("Sheet2").Cells.ClearContents 
End Sub 

這將清除名爲 「Sheet2的」 沒有 「選擇」 工作吧，所以從未閃爍BR iefly在屏幕上

它可以是惱人，如果一些代碼，做了很多的更新不同的工作表的每個更新在屏幕上閃爍了短暫的片刻

---

這裏是你的代碼

Sub Extract() 

' On Error Resume Next    ' do not use .... masks errors 

    Dim myOlApp As Outlook.Application 
    Dim myNameSpace As Outlook.Namespace 
    Dim topOlFolder As Outlook.MAPIFolder 
    Dim myOlFolder As Outlook.Folder 
    Dim myOlMailItem As Outlook.mailItem 

    Set myOlApp = Outlook.Application          ' roll these two into one command line 
    Set myNameSpace = myOlApp.GetNamespace("MAPI")      ' as noted on next line 

' Set myNameSpace = Outlook.Application.GetNamespace("mapi")   ' can do this instead (then no need to do "dim myOlApp" above) 

    Set topOlFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Parent ' top folder ... contains all other folders 


' Set myOlFolder = myNameSpace.Folders(2).Folders("Test")    ' this one is unreliable ... Folders(2) seems to change 
    Set myOlFolder = topOlFolder.Folders("Test")       ' this one seems to always work 

' Set myOlFolder = topOlFolder.Folders(myNameSpace.PickFolder.Name)  ' pick folder name in a dialog 

' Debug.Print myOlFolder.Items.Count 

' For Each myOlMailItem In myOlFolder.Items        ' print subject lines for all emails in "Test" folder 
'  Debug.Print myOlMailItem.Subject 
' Next 

    Dim xlObj As Worksheet 
    Set xlObj = Sheets("Sheet1")      ' refer to a specific worksheet 
' Set xlObj = ActiveSheet       ' whichever worksheet is being worked on 

    Dim anchor As Range 
    Set anchor = xlObj.Range("b2")     ' this is where the resulting table is placed ... can be anywhere 
' Set anchor = Sheets("Sheet1").Range("b2")  ' "xlObj" object does not have to be created if you use this form 

    ' Set headings 
    '  Offset(row,col) 
    anchor.Offset(0, 0).Value = "Priority"   ' technically the line should be "anchor.Value = ...", but it lines up this way 
    anchor.Offset(0, 1).Value = "Summary"   ' used "offset". that way all the cells are relative to "anchor" 
    anchor.Offset(0, 2).Value = "Description of Trouble" 
    anchor.Offset(0, 3).Value = "Device" 
    anchor.Offset(0, 4).Value = "Sender" 


    Dim msgText As String 
    Dim msgLine() As String 
    Dim messageArray() As String 

    i = 0           ' adjust excel starting row here, if desired 
    For Each myOlMailItem In myOlFolder.Items 
     i = i + 1         ' first parsed message ends up on worksheet one row below headings 

'  msgText = testText       ' use test message that is defined above 
     msgText = myOlMailItem.Body     ' or use actual email body 

     messageArray = Split(msgText, vbCrLf)  ' split into lines 

     For j = 0 To UBound(messageArray) 
'   Debug.Print messageArray(j) 

      msgLine = Split(messageArray(j) & ":", ":") ' split up line (add ':' so that blank lines do not error out) 

      Select Case Left(msgLine(0), 6)    ' check only first six characters 

       Case "Priori" 
        anchor.Offset(i, 0).Value = msgLine(1)    ' text after "Priority:" 

       Case "Summar" 
        anchor.Offset(i, 1).Value = messageArray(j + 1) ' text on next line 

       Case "Descri" 
        anchor.Offset(i, 2).Value = messageArray(j + 1) ' text on next line 

       Case "Device" 
        anchor.Offset(i, 3).Value = msgLine(1)    ' text after "Device:" 

      End Select 
      anchor.Offset(i, 4).Value = myOlMailItem.SenderName 
      anchor.Offset(i, -1).Value = i        ' add row number on left of "Priority" column (make sure that "anchor" is not in first worksheet column) 

     Next 
    Next 
End Sub