jeviiii
12-15-2011, 08:34 AM
Hi All:
I am just a brand new member and I am looking for a code to send an email automatically. I have to send this email on monthly basis and it has to be sent to 45 people.
The email has an attachement, To: (two names ), CC: three names.
Subject that is the same, and some text..
I have found this code wich is supposed to work but is not working. Please, have a look and let me know if there is a solution to my problem. Your help will be much appreciated:).
I have found the code in the following website at Rondebruin.nl
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("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "A1" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.CC = cell.Value
.Subject = "Realizimi i Objektivave per muajin Dhjetor 2011"
Dim strbody As String
strbody = "hello" & vbNewLine & vbNewLine & _
"" hi there mr...smith please find attached etc& vbNewLine & _
"sincerely" & vbNewLine & vbNewLine & vbNewLine & _
"Name of employee Name of boss "
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
.Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
[/font]
I am just a brand new member and I am looking for a code to send an email automatically. I have to send this email on monthly basis and it has to be sent to 45 people.
The email has an attachement, To: (two names ), CC: three names.
Subject that is the same, and some text..
I have found this code wich is supposed to work but is not working. Please, have a look and let me know if there is a solution to my problem. Your help will be much appreciated:).
I have found the code in the following website at Rondebruin.nl
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("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "A1" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.CC = cell.Value
.Subject = "Realizimi i Objektivave per muajin Dhjetor 2011"
Dim strbody As String
strbody = "hello" & vbNewLine & vbNewLine & _
"" hi there mr...smith please find attached etc& vbNewLine & _
"sincerely" & vbNewLine & vbNewLine & vbNewLine & _
"Name of employee Name of boss "
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
.Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
[/font]