在 Outlook 正文中搜索结构化文本

Question

我需要在选定的邮件中找到一行并复制它。

该行包含

邮箱：??????????????????

该行的符号数不同

邮件看起来有点像这样

Mailbox Details
==============================================================================
Mailbox:          /xxxxxx/xxxxxxxxxx/xxxxxxxxx
Message Name:     xxxxxxxxxxxxxxxxxxxxxxxxx
Message Id:       xxxxxxxxxxxxxxx
==============================================================================

复制的行应该进入由代码创建的新邮件的主题。

我所缺少的只是如何将这一行复制到主题中。

Sub SterlingForward()    
    Set objItem = ForwardB()
    Set objItem = ForwardA()
End Sub


Function ForwardA() As Object
    Dim oAccount As Outlook.Account
    Dim initialSubj, finalSubj As String
    Dim oMail As Outlook.MailItem
    Set oMail = Application.ActiveExplorer.Selection(1).Reply
    oMail.SentOnBehalfOfName = "lol@.herp.com"
    oMail.To = "lol@.herp.com"
    oMail.Display

    Set myitem = Application.ActiveInspector.CurrentItem
    initialSubj = myitem.Subject
    initialBod = myitem.Body

    finalSubj = ??????????????????????

    finalBody = "Hello Team," + vbCrLf + "resend was successful" + vbCrLf & CStr(initialBod)
    myitem.Subject = finalSubj
    myitem.Body = finalBody
End Function


Function ForwardB() As Object
    Dim objMail As Outlook.MailItem
    Dim initialSubj, initialBod, finalSubj, finalBody As String
    Set objItem = GetCurrentItem()
    Set objMail = objItem.Forward
    objMail.To = "lol@derp.com"
    objMail.Display
    Set objItem = Nothing
    Set objMail = Nothing

    Set myitem = Application.ActiveInspector.CurrentItem
    initialSubj = myitem.Subject
    initialBod = myitem.Body

    finalSubj = ????????????????????????????

    finalBody = "Hello Team," + vbCrLf + "resend was successful" + vbCrLf & CStr(initialBod)
    myitem.Subject = finalSubj
    myitem.Body = finalBody
End Function


Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
    Case "Explorer"
    Set GetCurrentItem = _
    objApp.ActiveExplorer.Selection.Item(1)
    Case "Inspector"
    Set GetCurrentItem = _
    objApp.ActiveInspector.CurrentItem
    Case Else
    End Select
End Function

Answer 1

finalSubj = ParseTextLinePair(initialBod, "Mailbox:")

参见“清单 17.1. 从结构化文本块中提取数据”。 https://docs.microsoft.com/en-us/previous-versions/office/developer/office-2007/dd492012(v=office.12)

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

注意：OP 表示有效的行是

finalSubj = ParseTextLinePair((CStr(initialBod)), "Mailbox:")