Question

我正在尝试将数据从电子邮件表单传输到Excel。

电子邮件的格式为..

表格提交：

选择地点：
STACK
  名字：
约翰   姓氏：
Doe   电话号码：
07555555555
  电子邮件：
john.doe@example.com
  查询字符串：

我想使用分隔符来分隔变量字符串。

我尝试调整类似的代码，但这并没有正确区分信息。

Sub Extract1()

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
Set myNameSpace = myOlApp.GetNamespace("MAPI")

Set myOlFolder = myOlApp.ActiveExplorer.CurrentFolder




Set xlObj = CreateObject("excel.application")
xlObj.Visible = True
xlObj.Workbooks.Add

Set anchor = xlObj.Range("a1")

anchor.offset(0, 0).Value = "Place"
anchor.offset(0, 1).Value = "First"
anchor.offset(0, 2).Value = "Last"
anchor.offset(0, 3).Value = "Phone"
anchor.offset(0, 4).Value = "Email"


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

i = 0
      For Each myOlMailItem In myOlFolder.Items

    i = i + 1


    msgText = myOlMailItem.Body

    messageArray = Split(msgText, vbCrLf)

    For j = 0 To UBound(messageArray)

        msgLine = Split(messageArray(j) & ":", ":")

        Select Case Left(msgLine(0), 5)

            Case "Select"
                anchor.offset(i, 0).Value = messageArray(j + 1)

            Case "First"
                anchor.offset(i, 1).Value = messageArray(j + 1)

            Case "Last "
                anchor.offset(i, 2).Value = messageArray(j + 1)

            Case "Phone"
                anchor.offset(i, 3).Value = messageArray(j + 1)

            Case "Email"
                anchor.offset(i, 4).Value = messageArray(j + 1)

        End Select


    Next
Next
End Sub

结果应格式化为这样。

Place     First     Last     Phone         Email
STACK     John      Doe      07555555555   john.doe@example.com

所以目前它并没有复制选择...我觉得我真的很愚蠢。

Answer 1

vbCrLf是您当前或以前代码的答案。其余的只是调试。

使用您当前的代码并使用带有文本副本/粘贴样本的测试电子邮件。

Option Explicit

Sub Extract2()

    'Dim myOlApp As Outlook.Application     ' Not necessary if code in Outlook
    'Dim myNameSpace As Outlook.namespace   ' Not used
    'Dim topOlFolder As Outlook.MAPIFolder  ' Necessary for 2003

    Dim topOlFolder As folder               ' 2007 and subsequent
    Dim myOlFolder As folder

    'Dim myOlMailItem As mailItem
    ' The type of item in a folder is not necessarily a mailitem
    Dim myOlMailItem As Object

    Dim xlObj As Object
    Dim Anchor As Object
    Dim i As Long
    Dim j As Long

    'Set myOlApp = Outlook.Application
    'Set myNameSpace = myOlApp.GetNamespace("MAPI")

    'Set myOlFolder = myOlApp.ActiveExplorer.CurrentFolder
    Set myOlFolder = ActiveExplorer.CurrentFolder

    Set xlObj = CreateObject("excel.application")
    xlObj.Visible = True
    xlObj.Workbooks.Add

    Set Anchor = xlObj.Range("a1")

    Anchor.Offset(0, 0).Value = "Place"
    Anchor.Offset(0, 1).Value = "First"
    Anchor.Offset(0, 2).Value = "Last"
    Anchor.Offset(0, 3).Value = "Phone"
    Anchor.Offset(0, 4).Value = "Email"

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

    i = 1

    'Perhaps instead
    'i = 0

    ' You should have indicated there was an error in this line
    'For Each myOlMailItem In myOlFolder
    For Each myOlMailItem In myOlFolder.Items

        If myOlMailItem.Class = olMail Then

            Debug.Print myOlMailItem.subject

            i = i + 1

            msgText = myOlMailItem.body

            messageArray = Split(msgText, vbCrLf)

            For j = 0 To UBound(messageArray)

                ' this seems unnecessary
                'msgLine = Split(messageArray(j) & ":", ":")
                'Select Case Left(msgLine(0), 5)

                Debug.Print "Left(messageArray(j), 5): " & Left(messageArray(j), 5)
                Select Case Left(messageArray(j), 5)

                'Case "Select"
                ' Typo
                Case Left("Select", 5)

                    Debug.Print "messageArray(j): " & messageArray(j)
                    Debug.Print "messageArray(j + 1): " & messageArray(j + 1)
                    Debug.Print "messageArray(j + 2): " & messageArray(j + 2)
                    'Anchor.Offset(i, 0).Value = messageArray(j + 1)
                    Anchor.Offset(i, 0).Value = messageArray(j + 2)

                Case "First"
                    'Anchor.Offset(i, 1).Value = messageArray(j + 1)
                    Anchor.Offset(i, 1).Value = messageArray(j + 2)

                Case "Last "
                    'Anchor.Offset(i, 2).Value = messageArray(j + 1)
                    Anchor.Offset(i, 2).Value = messageArray(j + 2)

                Case "Phone"
                    'Anchor.Offset(i, 3).Value = messageArray(j + 1)
                    Anchor.Offset(i, 3).Value = messageArray(j + 2)

                Case "Email"
                    'Anchor.Offset(i, 4).Value = messageArray(j + 1)
                    Anchor.Offset(i, 4).Value = messageArray(j + 2)

                End Select

                ' You should have indicated there was an error in this line
                ' Appears to be unnecessary anyway
                'Anchor.Offset(i, -1).Value = i

            Next

        End If

    Next

End Sub

解析Outlook电子邮件，以查找标识标签

1 个答案: