Question

如何将特定文本（包括格式）从邮件解析为新的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

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

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

0 个答案: