Hi Ron, herewith is the complete code....
Sub emailToAll()
'
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, ccAdd As String, Subj As String
Dim BodyText As String, contact As String, comment As String
Dim myComm As Integer, cell As Range
Application.ScreenUpdating = True
'------------------ E-mail address
------------------------------------------------------
On Error Resume Next
For Each cell In ThisWorkbook.Sheets("New gams") _
.Range("T2:T100").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
On Error GoTo 0
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
'------------------ CC E-mail address
---------------------------------------------------
ccAdd = "DL-ZA-GAMSCC;record kevin, ZA-T-M-22;stout les, ZA-T-M-22"
'------------------ Get the contact persons Surname name
--------------------------------
Subj = "Weekly gAMS Report " & Format(Date, "dd/mm/yy")
With ThisWorkbook.ActiveSheet
BodyText = "Good Day all, " & vbNewLine & vbNewLine & _
"Please find attached the latest gAMS report." &
vbNewLine & vbNewLine & _
" • This report is for new gAMS Documents that
were not created by or allocated to ZA-T-M." & vbNewLine & vbNewLine & _
" • Please open the attachment and refer to the
UPG responsibilities per department on the right of the spreadsheet." &
vbNewLine & vbNewLine & _
" • Then check in the gAMS system to check if it
is valid for you or not, if it is valid for W.9 and you require " &
vbNewLine & _
" funds or an action, you will be required to
contact your CoC or the gAMS Prime Mover to action an AFO." & vbNewLine
& vbNewLine & vbNewLine & vbNewLine & _
"**** Should a UPG be allocated incorrectly or changed,
please advise Les Stout of the changes. ****" & vbNewLine & vbNewLine &
vbNewLine & _
"If you have any queries regarding this document, please
contact the sender." & vbNewLine & vbNewLine & vbNewLine & _
"Best Regards," & vbNewLine & vbNewLine & _
"gAMS_Auto_Macro" & vbNewLine & vbNewLine & _
"ZA-T-M-22" & vbNewLine & vbNewLine & _
"Please Note:" & vbNewLine & _
"The attachment and this e-mail are generated
automatically"
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = strto
.CC = ccAdd
.BCC = ""
.Subject = Subj
.Body = BodyText
.ReadReceiptRequested = True
.Importance = 2
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
chkWkbToCloseGams
End Sub
Les Stout
