Vba 将特定文本（包括格式）从邮件复制到新邮件

如何将邮件中的特定文本（包括格式）解析为新的Outlook邮件

我有一个代码，它将收到的邮件逐行拆分，以查找邮件正文中的电子邮件地址

然后，它会创建一条新邮件，收件人是原始邮件中的电子邮件地址：

Sub AutoReply(Item As Outlook.MailItem)
Dim i As Long, j As Long
Dim vText As Variant
Dim vAddr As Variant
Dim vItem As Variant
Dim sAddr As String
Dim sName As String
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim olOutMail As Outlook.MailItem

With Item
    'Get the text of the message
    'and split it by paragraph
    vText = Split(Item.Body, Chr(13))
    'Examine each paragraph

    For i = 1 To UBound(vText)

        If InStr(1, vText(i), "Email:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            sAddr = ""
            For j = 1 To UBound(vItem)
                sAddr = sAddr & vItem(j)
            Next j
            If InStr(1, UCase(sAddr), "HYPERLINK") > 0 Then
                vAddr = Split(sAddr, Chr(34))
                sAddr = vAddr(UBound(vAddr))
            End If
        End If

    Next i

    Set olOutMail = Application.CreateItem(0)

    With olOutMail
        .BodyFormat = olFormatHTML
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor 'Edit the message body
        'Set a range to the start of the body (thus preserving the signature)
        Set oRng = wdDoc.Range(Start:=0, End:=0) 
        .To = sAddr
        .Subject = "Subject Goes Here"
        'personalise the reply message body
        oRng.Text = "Message body goes here"

        .Display 'This line is required
        'add .Send after testing if you are happy 
        'not to check the message before sending.
        '.Send 
    End With

    Set olOutMail = Nothing
End With
End Sub

我是否可以修改上述内容，将原始消息中两个特定点之间的文本解析为新消息

原始消息如下所示：

Dear Mr Bloggs,

Random text here random text here random text here random text here random 
text here random text here random text here random text here random text here 
random text here random text here random text here random text here random 
text here random text here random text here random text here random text here 
random text here random text here random text here random text here.

Some text here (will always be the same text)

This is the text I need to parse to new message this is the text I need to 
parse to new message this is the text I need to parse to new message this is 
the text I need to parse to new message this is the text I need to parse to 
new message.

More text here (will always be the same text)

---

下面的脚本已向我指出。虽然我不知道如何使用函数，但我正在尽我所能地混日子。如何在代码中实现

Function ParseTextLinePair(strSource As String, strLabel As String)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String

' locate the label in the source text
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
        intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
    End If
End If
ParseTextLinePair = Trim(strText)
End Function

---

我让它使用类似的函数，因为总是相同的第一位文本与总是相同的第二位文本不同。我使用了下面定义结束字符串的代码：

Function ParseTextLineDown(strSource As String, strLabel As String, strEnd As String)

Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim intLocEnd As Integer
Dim strText As String

' locate the label in the source text
intLocLabel = InStr(strSource, strLabel)
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
    intLocEnd = InStr(strSource, strEnd)
    intLocCRLF = intLocEnd
    ' testing message boxes
      ' MsgBox ("First IF" & vbCrLf & intLocLabel & "=intLocLabel, " _
        & intLocCRLF & "=intLocCRLF, " & intLenLabel & "=intLenLabel, ")
      ' MsgBox (strText)

    If intLocCRLF > 0 Then
        intLocLabel = intLocLabel + intLenLabel
        strText = Mid(strSource, intLocLabel, intLocCRLF - intLocLabel)
    ' testing message boxes SECOND IF
      ' MsgBox ("Second IF" & vbCrLf & intLocLabel & "=intLocLabel, " _
        & intLocCRLF & "=intLocCRLF, " & intLenLabel & "=intLenLabel, ")
      ' MsgBox (strText)
    Else
    ' testing message box ELSE
      '  MsgBox (strEnd & " " & " " & intLocLabel & " " & intLocEnd)
        strText = Mid(strSource, intLocLabel + intLenLabel)
    End If
End If
ParseTextLineDown = (strText)

End Function

---

是否可以将捕获的文本插入表中，或者保留复制数据的格式，因为它已经在表中了？

是的，这是可行的。搜索（将始终是相同的文本）并将文本从该点复制到下一点（将始终是相同的文本）谢谢，这就是我的想法。我只是不知道怎么做。我不太擅长VBA，也不是有编程背景。谢谢@zpontikas的可能副本我已经更新了我的问题。是的，它是可行的。搜索（将始终是相同的文本）并将文本从该点复制到下一点（将始终是相同的文本）谢谢，这就是我的想法。我只是不知道怎么做。我不太擅长VBA，也不是有编程背景。谢谢@zpontikas的可能重复我已经更新了我的问题。