B
beancurdjelly2003
I can send out with different attached workbook by different email
address (to, but if I need to send email with cc and bcc, how can I
do it?
column B = .To
column C = .cc
column D = .Bcc
Below is my marco, please help me. Thanks!
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("SendFiles")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In
sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the file names in the E:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Cc = ""
.Bcc = ""
.Subject = cell.Offset(0, -1).Value & " SmarTone-
Vodafone Bill" & " - " & Format(Now, "mmmm yy")
.Body = "Dear Customer," & vbNewLine & vbNewLine & _
"Please contact us on or before " &
Format(Now, "mmmm")
For Each FileCell In
rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
address (to, but if I need to send email with cc and bcc, how can I
do it?
column B = .To
column C = .cc
column D = .Bcc
Below is my marco, please help me. Thanks!
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("SendFiles")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In
sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the file names in the E:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Cc = ""
.Bcc = ""
.Subject = cell.Offset(0, -1).Value & " SmarTone-
Vodafone Bill" & " - " & Format(Now, "mmmm yy")
.Body = "Dear Customer," & vbNewLine & vbNewLine & _
"Please contact us on or before " &
Format(Now, "mmmm")
For Each FileCell In
rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub