Question

我需要VBA在Outlook选择的邮件中找到一行并复制它。该行包含

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

该行中符号的数量不同

邮件看起来有点像这样

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

请参阅http://www.outlookcode.com/codedetail.aspx?id=89

finalSubj = ParseTextLinePair（initialBod，“Mailbox：”）

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

VBA outlook体字符串搜索

1 个答案: