想要通过循环添加cc收件人和多个附件

时间:2018-05-17 10:34:41

标签: excel-vba basic vba excel

工作表名称:EmailList

基本上我在工作表名称中有3列为“EmailList”。

在col。 A有一个(ToRecipients)列表,Col.B有一个(CC Recipients)列表和col。 C header(fileBasename)有一个想要附加到电子邮件中的文件列表 我有代码添加“ToRecipeints”,但我需要帮助添加“cc收件人”,并将每个文件附加到每个单元格中提到的邮件中。

例如:如果我有3个文件名为1. AP 2.电话3. J& K需要附加相同的“ToRecipients”和“CC Recipients”。

#ToRecipients ## | CC收件人## | fileBasename |#

abc@xyz.com; xyz.das@abc.com; |a1234@xyz.com; | AP,Tel,J& K |

a1234@xyz.com; xyz.das@abc.com; |xyz.das@abc.com; |阿萨姆,JH,PB |

Option Explicit

Public Sub ProcessFiles()

    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")


    Dim rowCount As Integer, i As Integer
    Dim fileName As String, emailTo As String

    With Worksheets("Email List")
        rowCount = Application.WorksheetFunction.CountA(.Columns(1))

        For i = 2 To rowCount
            emailTo = .Cells(i, 1)
            'If Left(filename, 0) <> "," Then filename = "," & filename
            fileName = getFileName(.Cells(i, 2))
            If Len(Dir(fileName)) Then SendMail emailTo, fileName, OutApp
        Next
    End With

    Set OutApp = Nothing
End Sub
Public Function getFileName(filebasename As String)
    Dim folderPath As String, fileExtension As String, fileName As String, x As String

    folderPath = Range("Settings!B1")
    fileExtension = Range("Settings!B2")
    x = Range("EmailList!B1")

    If Left(fileExtension, 1) <> "." Then fileExtension = "." & fileExtension
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    If Right(x, 0) <> "," Then x = x & ","

    getFileName = folderPath & filebasename & fileExtension

End Function
Public Sub SendMail(emailTo As String, fileName As String, OutApp As Object)

    'Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next


    Application.ScreenUpdating = False


    With OutMail


        .To = emailTo
        .CC = ""
        .Subject = "Sales Forecast -" & " " & Format(Now, "dd/mmm/yyyy")
        '"Sales Forecast -  " & " " & Format(Now, "dd/mmm/yyyy")
        .body = "Dear " & "," & vbNewLine _
        & vbNewLine _
        & "Please find the attached file of Sales History of Last 6 Months" & vbNewLine _
        & vbNewLine _
        & "Requesting you to kindly provide the Retail Forecast for June 2018 at earliest by 27th of this month" & vbNewLine _
        & vbNewLine _
        & "Please feel free to contact if you have any questions regarding the same." & vbNewLine _
        & vbNewLine _
        & "Rgds" & vbNewLine _

         .Attachments.Add fileName
        .display
        'use.Send


        On Error GoTo 0
        Set OutMail = Nothing
        Set OutApp = Nothing

       Application.ScreenUpdating = True

    End With

End Sub

RGDS 的Pankaj

0 个答案:

没有答案