Outlook VBA代码导出部分正文到Excel不起作用
我从stackoverflow和其他几个地方使用了各种资源来获取VBA中的一些代码。 这是我尝试过的第三次迭代，仍然没有得到它的工作。 第一次迭代主要是从头开始，但没有奏效。 第二次迭代是基于这个stackoverflowpost 。 我有ThisOutlookSession Outlook对象中的代码启动时运行。 目前的迭代是基于这个stackoveflow后 ，是在它自己的模块。 它使用Outlook中的规则运行。
从电子邮件正文获取数据的部分似乎在以前的代码迭代中工作正常。 但写入Excel的部分似乎没有工作，并没有在任何以前的迭代工作，我不知道为什么。
我在Outlook中设置了一个规则，用于在具有特定主题行的电子邮件上运行macros。 这些电子邮件是以一种特定的方式构build的，可以轻松获取数据。 该规则还设置这些电子邮件阅读，这样做，所以我可以看到规则的作品。
我在“我的文档”中有一个Excel工作表，第一行专用于标记列。 虽然我已经试过这个空的Excel表格，它仍然没有工作。
电子邮件正文如下所示：
ID：608
名字：testing
MiddleInitial：t
姓氏：testet
出生date：01/01/1900
性别：男
街道地址：
市：
州：
压缩：
种族：
dtAdded：01/19/2016
面积：脱发
区域：皮肤癌
可能有0到12个区域，每个区域都简单标记为区域。 以下是我的一些代码。 我已经修剪了一些重复的部分，所以它没有那么长（仍然很长，对不起）：
Option Explicit Const xlUp As Long = -4162 Sub ExportToExcel(MyMail As MailItem) Dim strID As String, olNS As Outlook.NameSpace Dim olMail As Outlook.MailItem Dim strFileName As String '~~> Outlook Variables Dim idNum As String Dim firstName As String Dim middleInitial As String Dim lastName As String Dim birthDate As String Dim gender As String Dim streetAddress As String Dim city As String Dim state As String Dim zipcode As String Dim ethnicity As String Dim dateAdded As String Dim area1 As String Dim area2 As String Dim area11 As String Dim area12 As String Dim areaOther As String Dim areas As String '~~> Process Outlook Stuff idNum = ParseTextLinePair(olMail.Body, "ID:") firstName = ParseTextLinePair(olMail.Body, "FirstName:") middleInitial = ParseTextLinePair(olMail.Body, "MiddleInitial:") lastName = ParseTextLinePair(olMail.Body, "LastName:") birthDate = ParseTextLinePair(olMail.Body, "BirthDate:") gender = ParseTextLinePair(olMail.Body, "Gender:") streetAddress = ParseTextLinePair(olMail.Body, "StreetAddress:") city = ParseTextLinePair(olMail.Body, "City:") state = ParseTextLinePair(olMail.Body, "State:") zipcode = ParseTextLinePair(olMail.Body, "Zipcode:") ethnicity = ParseTextLinePair(olMail.Body, "Ethnicity:") Dim intLocLabel As Integer Dim intLocCRLF As Integer Dim intLenLabel As Integer 'area1 intLocLabel = InStr(olMail.Body, "Area:") intLenLabel = Len("Area:") If intLocLabel > 0 Then 'vbCrLf = new line intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf) If intLocCRLF > 0 Then intLocLabel = intLocLabel + intLenLabel area1 = Mid(olMail.Body, _ intLocLabel, _ intLocCRLF - intLocLabel) Else ' this was Mid(.. area1 = Mid(olMail.Body, intLocLabel + intLenLabel) End If End If 'area2: If intLocCRLF > 0 Then intLocLabel = InStr(intLocCRLF, olMail.Body, "Area:") If intLocLabel > 0 Then intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf) If intLocCRLF > 0 Then intLocLabel = intLocLabel + intLenLabel area2 = Mid(olMail.Body, _ intLocLabel, _ intLocCRLF - intLocLabel) Else ' this was Mid(.. area2 = Mid(olMail.Body, intLocLabel + intLenLabel) End If End If End If 'area11: If intLocCRLF > 0 Then intLocLabel = InStr(intLocCRLF, olMail.Body, "Area:") If intLocLabel > 0 Then intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf) If intLocCRLF > 0 Then intLocLabel = intLocLabel + intLenLabel area11 = Mid(olMail.Body, _ intLocLabel, _ intLocCRLF - intLocLabel) Else ' this was Mid(.. area11 = Mid(olMail.Body, intLocLabel + intLenLabel) End If End If End If 'area12 If intLocCRLF > 0 Then intLocLabel = InStr(intLocCRLF, olMail.Body, "Area:") If intLocLabel > 0 Then intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf) If intLocCRLF > 0 Then intLocLabel = intLocLabel + intLenLabel area12 = Mid(olMail.Body, _ intLocLabel, _ intLocCRLF - intLocLabel) Else ' this was Mid(.. area12 = Mid(olMail.Body, intLocLabel + intLenLabel) End If End If End If 'areaOther is easy because it has the Other Skin Problems label areaOther = ParseTextLinePair(olMail.Body, "Other Skin Problems,") If InStr(area1, "Other Skin Problems,") = 0 Then areas = areas & area1 End If If InStr(area2, "Other Skin Problems,") = 0 Then areas = areas & area2 End If If InStr(area3, "Other Skin Problems,") = 0 Then areas = areas & area3 End If If InStr(area4, "Other Skin Problems,") = 0 Then areas = areas & area4 End If If InStr(area5, "Other Skin Problems,") = 0 Then areas = areas & area5 End If If InStr(area6, "Other Skin Problems,") = 0 Then areas = areas & area6 End If If InStr(area7, "Other Skin Problems,") = 0 Then areas = areas & area7 End If If InStr(area8, "Other Skin Problems,") = 0 Then areas = areas & area8 End If If InStr(area9, "Other Skin Problems,") = 0 Then areas = areas & area9 End If If InStr(area10, "Other Skin Problems,") = 0 Then areas = areas & area10 End If If InStr(area11, "Other Skin Problems,") = 0 Then areas = areas & area11 End If If InStr(area12, "Other Skin Problems,") = 0 Then areas = areas & area12 End If '~~> Excel Variables Dim oXLApp As Object, oXLwb As Object, oXLws As Object Dim lRow As Long strID = MyMail.EntryID Set olNS = Application.GetNamespace("MAPI") Set olMail = olNS.GetItemFromID(strID) '~~> Establish an EXCEL application object On Error Resume Next Set oXLApp = GetObject(, "Excel.Application") '~~> If not found then create new instance If Err.Number <> 0 Then Set oXLApp = CreateObject("Excel.Application") End If Err.Clear On Error GoTo 0 '~~> Show Excel oXLApp.Visible = True '~~> Open the relevant file Set oXLwb = oXLApp.Workbooks.Open("C:\Users\$$MYUSER$$\Documents\$$MYFILENAME$$.xlsx") '~~> Set the relevant output sheet. Change as applicable Set oXLws = oXLwb.Sheets("Sheet1") lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1 '~~> Write to outlook With oXLws ' ' .Range("A" & lRow).Value = idNum .Range("B" & lRow).Value = dateAdded .Range("O" & lRow).Value = firstName .Range("P" & lRow).Value = middleInitial .Range("Q" & lRow).Value = lastName .Range("R" & lRow).Value = birthDate .Range("S" & lRow).Value = gender .Range("T" & lRow).Value = streetAddress .Range("U" & lRow).Value = city .Range("V" & lRow).Value = state .Range("W" & lRow).Value = zipcode .Range("AE" & lRow).Value = ethnicity With .Range("C" & lRow) If InStr(areas, "Acne") > 0 Then .Value = "Yes" End If End With With .Range("H" & lRow) If InStr(areas, "Hair Loss") > 0 Then .Value = "Yes" End If End With With .Range("J" & lRow) If InStr(areas, "Skin Cancer") > 0 Then .Value = "Yes" End If End With With .Range("L" & lRow) If InStr(areas, "Wrinkles") > 0 Then .Value = "Yes" End If End With End With Debug.Print idNum Debug.Print firstName '~~> Close and Clean up Excel oXLwb.Close (True) oXLApp.Quit Set oXLws = Nothing Set oXLwb = Nothing Set oXLApp = Nothing Set olMail = Nothing Set olNS = Nothing End Sub Function ParseTextLinePair(strSource As String, strLabel As String) 'This function extracts the data from any label-data pair that appears 'in a block of text, where all the label-data pairs are on separate 'lines. A typical application would be parsing the text sent as email 'by a form on a web site, where the incoming message has multiple lines 'each with a different Label: Data pair Dim intLocLabel As Integer Dim intLocCRLF As Integer Dim intLenLabel As Integer Dim strText As String ' locate the label in the source text ' InStr returns 0 if srtLabel is not found in strSource ' InStr returns the position of the first occurance of strLabel in strSource intLocLabel = InStr(strSource, strLabel) intLenLabel = Len(strLabel) If intLocLabel > 0 Then intLocCRLF = InStr(intLocLabel, strSource, vbCrLf) If intLocCRLF > 0 Then intLocLabel = intLocLabel + intLenLabel strText = Mid(strSource, _ intLocLabel, _ intLocCRLF - intLocLabel) Else strText = Mid(strSource, intLocLabel + intLenLabel) End If End If ' the Trim function can be useful to remove non-printing and ' leading or ending spaces from text ParseTextLinePair = Trim(strText) End Function 尝试
Sub ExportToExcel(oMail As mailItem)
要么
Set olMail = myMail