如何從Outlook電子郵件正文中復制電子郵件地址並將其插入新電子郵件的收件人字段中？

Question

每天，我都會收到幾封自動電子郵件，其中包含一些需要轉發到其他電子郵件地址的信息。

該電子郵件地址在自動電子郵件中，並且不會始終相同。 該電子郵件地址位於表格中標記為“備注”的行下方。 我插入了一張圖片來說明這一點。

我想使用Outlook VBA宏自動執行此過程。 一些其他信息：1）我不能使用“規則”下的“運行腳本”功能。 2）傳入的電子郵件是自動的，並且將始終采用相同的格式。

我需要幫助的地方是：1）復制“備注”行的下一列中的電子郵件地址。

我已經設法使識別傳入的電子郵件（按其主題名稱）並將其自動轉發到預定義的電子郵件地址並更改轉發的電子郵件主題名稱的過程自動化。

Private WithEvents Items as Outlook.Items
Private Sub application_startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNameSpace("MAPI")

'Setting target folder as inbox
Set Items = objectNS.GetDefaultFolder(olFolderInbox).Items

End Sub


Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.Mailitem

'act only if it is a mail item
If TypeName(Item) = "MailItem" Then
Set Msg = Item

'Detect emails with specified subject title
If Msg.Subject = "Test" Then
Set myForward = Item.Forward
myForward.Recipients.Add("test@gmail.com")
myForward.Subject = "FW: Success"
myForward.Save
myForward.Send
EndIf

EndIf

ProgramExit: Exit Sub

ErrorHandler:
MsgBox Err.Number & "-" & Err.Description
Resume ProgramExit

End Sub

Answer 1

據我了解，您想在電子郵件正文中獲取地址。

您可以使用以下代碼：

Option Explicit
Sub Example()
    Dim Item As MailItem
    Dim RegExp As Object
    Dim Search_Email As String
    Dim Pattern As String
    Dim Matches As Variant
    Dim len1 As String
    Dim result As String
    Set RegExp = CreateObject("VbScript.RegExp")
    Pattern = "remarks\s+(\b[A-Z0-9._%+-]+\b)"

    For Each Item In ActiveExplorer.Selection

        Search_Email = Item.Body
        With RegExp
            .Global = False
            .Pattern = Pattern
            .IgnoreCase = True
            Set Matches = .Execute(Search_Email)
        End With
        If Matches.Count > 0 Then
             len1 = Matches(0).Length() - 8
             result = Mid(Matches(0), 12, len1)
             result = result + "@gmail.com"
             MsgBox result
             Debug.Print Matches(0)
        Else
             Debug.Print "Not Found "
        End If

    Next

    Set RegExp = Nothing

End Sub

有關更多信息，您可以參考以下鏈接：

從.HTMLbody中的表中提取電子郵件地址