'This procedure will mail the whole workbook
'You can 't send a Workbook that is open with CDO.
'That's why it use SaveCopyAs to save it with another name and send that file.
Sub CDO_Mail_Workbook()
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "[COLOR="#FF0000"]Fill in your SMTP server here[/COLOR]"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "[COLOR="#FF0000"]Hier tussen het emailadres[/COLOR]"
.CC = ""
.BCC = ""
.From = "[COLOR="#FF0000"]Hier tussen de afzender zijn emailadres[/COLOR]"
.Subject = "This is a test"
.TextBody = "This is the body text"
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
If Err.Number = 0 Then
MsgBox "Sucsesvol verzonden op : " & Format(Date, "dd-mm-yyyy") & Format(TimeValue(Now), " hh:mm"), vbInformation, "Email"
Else
MsgBox "FOUT : Email is niet verzonden." & vbNewLine & vbNewLine & _
"Mogelijke oorzaak :" & vbNewLine & _
"Geen Internet, of smtp server connectie." & vbNewLine & _
"Er is geen emailadres ingevuld.", vbCritical, "Unsuspected error."
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
Exit Sub
End If
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
