我使用了stackoverflow和其他一些地方的各种资源来获取VBA中的一些代码。这是我尝试过的第三次迭代，仍然没有让它发挥作用。第一次迭代主要是从头开始编写，但没有用。第二次迭代基于this stackoverflow post。我有ThisOutlookSession Outlook对象中的代码在启动时运行。当前迭代基于this stackoveflow post并且在其自己的模块中。它使用Outlook中的规则运行。
从电子邮件正文中获取数据的部分似乎在前面的代码迭代中正常工作。但写入Excel的部分似乎不起作用，并且在以前的任何迭代中都没有工作，我不知道为什么。
我在Outlook中有一个规则集，可以在具有特定主题行的电子邮件上运行宏。这些电子邮件以特定方式构建，可以轻松获取数据。该规则还将这些电子邮件设置为已读取，因此我可以看到该规则有效。
我的“我的文档”中有一个Excel工作表，第一行专门用于标记列。虽然我也尝试使用空的Excel工作表，但它仍然无效。
电子邮件正文如下所示：
ID：608
FirstName：test
MiddleInitial：t
姓氏：testet
BirthDate：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
答案 0 :(得分：0)
尝试
Sub ExportToExcel(oMail As mailItem)
或
Set olMail = myMail