Outlook VBA代码无法将正文部分导出到Excel [英] Outlook VBA code to export parts of body to Excel not working

问题描述

我已经使用了来自stackoverflow和其他一些地方的各种资源来在VBA中获得一些代码.这是我尝试过的第三次迭代，但仍然没有奏效.第一次迭代大部分是从头开始编写的，但是没有用.第二次迭代基于此stackoverflow帖子.我在ThisOutlookSession Outlook对象中有代码可以在启动时运行.当前迭代基于此stackoveflow发布，并且位于其自己的模块中.它是使用Outlook中的规则运行的.

I've used a variety of resources from stackoverflow and a few other places to get some code in VBA. This is the third iteration I've tried and still haven't gotten it to work. The first iteration was written mostly from scratch, but didn't work. The second iteration was based on this stackoverflow post. I had the code in the ThisOutlookSession Outlook Object to run at startup. The current iteration is based on this stackoveflow post and is in it's own Module. It's run using a rule in Outlook.

从电子邮件正文获取数据的部分在代码的先前迭代中似乎工作正常.但是写入Excel的部分似乎无效，并且在以前的任何迭代中均无效，我也不知道为什么.

The part that gets the data from the email body has seemed to work fine in the previous iterations of the code. But the part that writes to Excel doesn't seem to be working, and hasn't worked in any of the previous iterations and I don't know why.

我在Outlook中设置了一条规则，以在具有特定主题行的电子邮件上运行宏.这些电子邮件以特定的方式构造，使获取数据变得容易.该规则还将这些电子邮件设置为可以阅读，因此可以看到该规则有效.

I have a rule set in Outlook to run the macro on emails with a specific subject line. These emails are structured in a specific way that makes it easy to get the data. The rule also sets these emails to read, which it does, so I can see the rule works.

我的文档中有一个Excel工作表，第一行专用于标记各列.尽管我也尝试过使用一个空的Excel工作表，但仍然无法正常工作.

I have an Excel sheet in My Documents with the first row being dedicated to labeling the columns. Though I've tried this with an empty Excel sheet as well and it still didn't work.

电子邮件正文看起来像这样:

The email body looks something like this:

ID:608

名字:测试

MiddleInitial:t

MiddleInitial: t

姓氏:睾丸

生日:1900年1月1日

BirthDate: 01/01/1900

性别:男性

街道地址:

城市:

状态:

邮政编码:

种族:

dt已添加:2016年1月19日

dtAdded: 01/19/2016

领域:脱发

领域:皮肤癌

可能存在0到12个区域，每个区域都简单地标记为Area.以下是我拥有的一些代码.我已经修剪了一些重复的部分，所以它没有那么长(仍然很长，对不起):

There could be anywhere from 0 to 12 Areas, each simply labeled as Area. Below is some of the code I have. I've trimmed some of the repetitive parts so it isn't as long (still kind of long, sorry):

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

这篇关于Outlook VBA代码无法将正文部分导出到Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！