每个案例的 Excel VBA 发送电子邮件

Posted 2023-05-07

【中文标题】每个案例的 Excel VBA 发送电子邮件

【英文标题】：Excel VBA For Each Case Send Email

【发布时间】：2014-04-11 00:37:55

【问题描述】：

您好，我正在使用以下代码根据不同情况发送多封电子邮件。 （电子邮件地址和其他信息存储在工作表中）代码可以正常工作，但是我有 20 种不同的情况（下面的示例仅显示了两种）。将 Outlook 应用程序代码放在每个案例中似乎很麻烦。

有没有一种方法可以针对每个案例执行电子邮件，而不必在每个案例中表达 Outlook 代码？

我使用 For Each Case 进行了搜索，但没有任何运气。非常感谢您的帮助。

Sub RequestUpdates()

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim blRunning As Boolean
Dim email As String
Dim fname As String
Dim fllink As String
Dim cpname As String
Dim v As Integer
Dim y As Integer
Dim rng As Range
Dim rdate As Date
Dim signature As String


v = Sheets("Contributors").Range("A" & Rows.Count).End(xlUp).Row
Set rng = Sheets("Contributors").Range("A1")
rdate = Sheets("Contributors").Range("A1").Value

For y = 0 To v
    Select Case rng.Offset(1 + y, 0).Value

     Case "PCR"
        email = Sheets("Contributors").Range("E4").Value
        fname = Sheets("Contributors").Range("D4").Value
        fllink = Sheets("Contributors").Range("F4").Value
        cpname = Sheets("Contributors").Range("B4").Value

            'get application
            blRunning = True
            Set olApp = GetObject(, "Outlook.Application")
            If olApp Is Nothing Then
            Set olApp = New Outlook.Application
            blRunning = False
            End If
            On Error GoTo 0

                Set olMail = olApp.CreateItem(olMailItem)
                With olMail
                .Display
                End With
                signature = olMail.htmlBody
                With olMail
                'Specify the email subject
                .Subject = "test " & rdate
                'Specify who it should be sent to
                'Repeat this line to add further recipients
                .Recipients.Add email
                 'specify the file to attach
                 'repeat this line to add further attachments
                '.Attachments.Add "LinktoAttachment"
                 'specify the text to appear in the email
                .HTMLBody = "<p>Hi " & fname & ",</p>" & _
                "<P>Please follow the link below to update the " & cpname & " test" _
                & "For month ending " & rdate & ".</p>" & _
                "<P> </br> </p>" & _
                fllink & _
                "<P> </br> </p>" & _
                "<p>If you face issues with file access please contact me directly.</p>" & _
                "<P>Note: xxxxx.</p>" & _
                signature
                 'Choose which of the following 2 lines to have commented out
                .Display 'This will display the message for you to check and send yourself
                 '.Send ' This will send the message straight away
                End With

       Case "NFG"

            email = Sheets("Contributors").Range("E6").Value
            fname = Sheets("Contributors").Range("D6").Value
            fllink = Sheets("Contributors").Range("F6").Value
            cpname = Sheets("Contributors").Range("B6").Value

               'get application
            blRunning = True
            Set olApp = GetObject(, "Outlook.Application")
            If olApp Is Nothing Then
            Set olApp = New Outlook.Application
            blRunning = False
            End If
            On Error GoTo 0

                Set olMail = olApp.CreateItem(olMailItem)
                With olMail
                .Display
                End With
                signature = olMail.HTMLBody
                With olMail
                'Specify the email subject
                .Subject = "Test" & rdate
                'Specify who it should be sent to
                'Repeat this line to add further recipients
                .Recipients.Add email
                 'specify the file to attach
                 'repeat this line to add further attachments
                '.Attachments.Add "LinktoAttachment"
                 'specify the text to appear in the email
                .HTMLBody = "<p>Hi " & fname & ",</p>" & _
                "<P>Please follow the link below to update the " & cpname & " component Test" _
                & "For month ending " & rdate & ".</p>" & _
                "<P> </br> </p>" & _
                fllink & _
                "<P> </br> </p>" & _
                "<p>If you face issues with file access please contact me directly.</p>" & _
                "<P>Note: Test.</p>" & _
                signature
                 'Choose which of the following 2 lines to have commented out
                .Display 'This will display the message for you to check and send yourself
                 '.Send ' This will send the message straight away
                End With
            End Select
            Next
End Sub

【参考方案1】：

我看到你展示的两个案例遵循一个模板，如何创建 sub 发送电子邮件检索主题等，然后从 Select Case 中调用它并传递正确的值？