工作表名称: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”。
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