Outlook VBA代码，用于将车身零件导出到Excel不工作

我使用了stackoverflow和其他一些地方的各种资源来获取VBA中的一些代码。这是我尝试过的第三次迭代，但仍然没有成功。第一次迭代基本上是从头开始编写的，但不起作用。第二次迭代基于。我在ThisOutlookSession Outlook对象中有要在启动时运行的代码。当前迭代基于它自己的模块，并且在它自己的模块中。它使用Outlook中的规则运行

从电子邮件正文中获取数据的部分在代码的前几次迭代中似乎工作得很好。但是写入Excel的部分似乎不起作用，而且在以前的任何迭代中都不起作用，我不知道为什么

我在Outlook中设置了一个规则，可以在带有特定主题行的电子邮件上运行宏。这些电子邮件以一种特定的方式组织，使得获取数据变得容易。该规则还将这些电子邮件设置为读取，确实如此，因此我可以看到该规则起作用

我的文档中有一张Excel表格，第一行用于标记列。虽然我也用一张空白的Excel表格尝试过，但仍然不起作用

电子邮件正文如下所示：

---

身份证号码：608

名字：test

姓名首字母：t

姓氏：testet

出生日期：1900年1月1日

性别:男

街道地址：

城市：

声明：

邮编：

种族：

添加日期：2016年1月19日

面积：脱发

地区：皮肤癌

---

可以有0到12个区域，每个区域都简单地标记为区域。下面是我的一些代码。我已经修剪了一些重复的部分，所以没有那么长（还是有点长，对不起）：

选项显式
常量xlUp的长度=-4162
子ExportToExcel（我的邮件作为邮件项）
Dim strID作为字符串，olNS作为Outlook.NameSpace
以Outlook.MailItem的形式发送邮件
将strFileName设置为字符串
“~~>Outlook变量
Dim idNum作为字符串
将firstName设置为字符串
将首字母改为字符串
将lastName设置为字符串
模糊的生日字符串
朦胧的性别
Dim streetAddress作为字符串
朦胧的城市
暗状态为字符串
作为字符串的Dim zipcode
像弦一样模糊
添加为字符串的日期
将区域1变暗为字符串
将区域2调暗为字符串
将区域11调暗为字符串
将区域12调暗为字符串
将区域另设为字符串
将区域变暗为字符串
“~~>处理Outlook内容
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:”）
性别=ParseTextLinePair（olMail.Body，“性别：”）
streetAddress=ParseTextLinePair（olMail.Body，“streetAddress:”）
city=ParseTextLinePair（olMail.Body，“city:”）
state=ParseTextLinePair（olMail.Body，“state:”）
zipcode=ParseTextLinePair（olMail.Body，“zipcode:”）
种族=ParseTextLinePair（olMail.Body，“种族：”）
Dim intLocLabel为整数
Dim intLocCRLF为整数
Dim intLenLabel为整数
“区域1
intLocLabel=InStr（olMail.Body，“区域：”）
intLenLabel=Len（“区域：”）
如果intLocLabel>0，则
'vbCrLf=新行
intLocCRLF=InStr（intLocLabel，olMail.Body，vbCrLf）
如果intLocCRLF>0，则
intLocLabel=intLocLabel+intLenLabel
区域1=中间（olMail.Body_
intLocLabel_
intLocCRLF-intLocLabel）
其他的
“这是中期（。。
区域1=Mid（olMail.Body，intLocLabel+intLenLabel）
如果结束
如果结束
“区域2：
如果intLocCRLF>0，则
intLocLabel=InStr（intLocCRLF，olMail.Body，“区域：”）
如果intLocLabel>0，则
intLocCRLF=InStr（intLocLabel，olMail.Body，vbCrLf）
如果intLocCRLF>0，则
intLocLabel=intLocLabel+intLenLabel
区域2=中间（olMail.Body_
intLocLabel_
intLocCRLF-intLocLabel）
其他的
“这是中期（。。
区域2=Mid（olMail.Body，intLocLabel+intLenLabel）
如果结束
如果结束
如果结束
“区域11：
如果intLocCRLF>0，则
intLocLabel=InStr（intLocCRLF，olMail.Body，“区域：”）
如果intLocLabel>0，则
intLocCRLF=InStr（intLocLabel，olMail.Body，vbCrLf）
如果intLocCRLF>0，则
intLocLabel=intLocLabel+intLenLabel
区域11=中间（olMail.Body_
intLocLabel_
intLocCRLF-intLocLabel）
其他的
“这是中期（。。
区域11=Mid（olMail.Body，intLocLabel+intLenLabel）
如果结束
如果结束
如果结束
“12区
如果intLocCRLF>0，则
intLocLabel=InStr（intLocCRLF，olMail.Body，“区域：”）
如果intLocLabel>0，则
intLocCRLF=InStr（intLocLabel，olMail.Body，vbCrLf）
如果intLocCRLF>0，则
intLocLabel=intLocLabel+intLenLabel
区域12=中间（olMail.Body_
intLocLabel_
intLocCRLF-intLocLabel）
其他的
“这是中期（。。
区域12=Mid（olMail.Body，intLocLabel+intLenLabel）
如果结束
如果结束
如果结束
“areaOther很容易，因为它有其他皮肤问题标签
areaOther=ParseTextLinePair（olMail.Body，“其他皮肤问题”）
如果InStr（区域1，“其他皮肤问题”）=0，则
面积=面积和面积1
如果结束
如果InStr（区域2，“其他皮肤问题”）=0，则
面积=面积和面积2
如果结束
如果InStr（区域3，“其他皮肤问题”）=0，则
面积=面积和面积3
如果结束
如果InStr（区域4，“其他皮肤问题”）=0，则
面积=面积和面积4
如果结束
如果InStr（区域5，“其他皮肤问题”）=0，则
面积=面积和面积5
如果结束
如果仪表（区域6，“其他
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