如何根据标准转发电子邮件？

Question

如何根据条件自动发送邮件？

我想根据 A 列提供的主题打开邮件，添加默认内容并将此邮件转发到 B 列提供的电子邮件地址。

我知道如何根据主题打开 Outlook 邮件。

Sub Test()
    Dim olApp As Outlook.Application
    Dim olNs As Namespace
    Dim Fldr As MAPIFolder
    Dim olMail As Variant
    Dim i As Integer

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
    i = 1

    For Each olMail In Fldr.Items
        If InStr(olMail.Subject, "") <> 0 Then
            olMail.Display
            i = i + 1
        End If
    Next olMail
End Sub

Subject (column A)      Send to (Column B) 
SP12345667              aaa@gmail.com
SP12345668              bbb@gmail.com
SP12345669              xxx@abc.com
SP12345670              yyy@abc.com
SP12345671              mmm@abc.com
SP12345672              nnn@abc.com
SP12345673              yyy@abc.com

Answer 1

这是一个关于如何循环的示例...

Option Explicit
Public Sub Example()
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder
    Dim Item As MailItem
    Dim MsgFwd As MailItem
    Dim Items As Outlook.Items
    Dim Recip As Recipient
    Dim Email As String
    Dim ItemSubject As String
    Dim lngCount As Long
    Dim i As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

    i = 2 '  i = Row 2

    With Worksheets("Sheet1") ' Sheet Name
        Do Until IsEmpty(.Cells(i, 1))

        ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1) 
        Email = .Cells(i, 2).Value '(i, 2) = (Row 2,Column 2) 

            '// Loop through Inbox Items backwards
            For lngCount = Items.Count To 1 Step -1
                Set Item = Items.Item(lngCount)

                If Item.Subject = ItemSubject Then ' if Subject found then
                    Set MsgFwd = Item.Forward
                    Set Recip = MsgFwd.Recipients.Add(Email) ' add Recipient
                        Recip.Type = olTo

                        MsgFwd.Display

                End If
            Next ' exit loop

            i = i + 1 '  = Row 2 + 1 = Row 3
        Loop
    End With

    Set olApp = Nothing
    Set olNs = Nothing
    Set Inbox = Nothing
    Set Item = Nothing
    Set MsgFwd = Nothing
    Set Items = Nothing
End Sub