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

Excel VBA根据条件转发电子邮件

1 个答案: