Copy range of cells from Excel to body of email in Outlook - excel

How can I copy a range of cells from Excel to the body of an email in Outlook using VBA?
I just need the content to be a body of the Outlook mail.

You can find a packaged solution here : http://www.rondebruin.nl/mail/folder1/mail4.htm
Sub Mail_Range()
'Working in 2000-2010
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long
Set Source = Nothing
On Error Resume Next
Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, " & _
"please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Range of " & wb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
For I = 1 To 3
.SendMail "ron#debruin.nl", _
"This is the Subject line"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Regards,

See here if it can help you.
I was looking for a solution to copy/paste multiple Excel 2007 cells into an Outlook mail body with VBA but neither a direct copy/paste, a MsgBody.HTMLBody = Range.Text or a clipboard (through DataObject) worked.
Then I fell on this previous solution and it solves my problem, hope this will help you too :)
Cheers!

Related

Export several sheets VBA

I'm working on a macro in my Excel File.
I want to export six worksheets as new backup files.
There are several sheets that I also don't want to export.
When I run the code as it is now there is one/two sheets that are being exported while the remaining four aren't exported.
The two exported sheets are then also being closed after they are saved as a new file.
I hope someone is able to help me and give me advice and feedback.
Thanks in advance.
My code is:
'''
Sub SplitWorkbook2()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "mm-dd hh-mm")
FolderName = "I:\Export\Backup\TEMPS\2021\Urenlijsten\" & " Werkbriefjes week " & Range("C4") & " " & DateString
MkDir FolderName
Application.DisplayAlerts = False
On Error GoTo NErro
DoNotInclude = "Actions" & "Adressbook" & "Import" & "Hours_Database"
FileExtStr = ".xls"
For Each xWs In xWb.Sheets
If InStr(DoNotInclude, xWs.Name) = 0 Then
xWs.Copy
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
With xNWb
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
xFile = FolderName & "\" & Range("C6") & FileExtStr
xNWb.SaveAs xFile, FileFormat:=xlOpenXMLWorkbook
End With
End If
Next xWs
NErro: xWb.Activate
xWb.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "You can find the files in " & FolderName
End Sub
Export Worksheets
Not tested.
Option Explicit
Sub SplitWorkbook2()
Dim wb As Workbook
Dim ws As Worksheet
Dim DoNotInclude As Variant
Dim FileFormatNum As Long
Dim FileExtStr As String
Dim FolderName As String
FolderName = "I:\Export\Backup\TEMPS\2021\Urenlijsten\" & " Werkbriefjes week " & Range("C4") & " " & DateString
FileExtStr = ".xlsx" ' ??? not '.xls'
DateString = Format(Now, "mm-dd hh-mm")
DoNotInclude = Array("Actions" & "Adressbook" & "Import" & "Hours_Database")
On Error Resume Next
MkDir FolderName
On Error GoTo 0
Set wb = ThisWorkbook
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, DoNotInclude, 0)) Then
ws.Copy
With ActiveWorkbook.Worksheets(1)
.UsedRange.Value = .UsedRange.Value
xFile = FolderName & "\" & .Range("C6") & FileExtStr
Application.DisplayAlerts = False
.Parent.SaveAs xFile, FileFormat:=xlOpenXMLWorkbook
.Parent.Close
Application.DisplayAlerts = True
End With
End If
Next ws
Application.ScreenUpdating = True
MsgBox "You can find the files in " & FolderName
'wb.FollowHyperlink FolderName ' open in Windows File Explorer
End Sub

Excel Send Emails Based on Worksheet Names

I made a macro that splits a main worksheet into different tabs and renames the tabs. I want to email the tabs to different people, by matching the tab name to a list containing email addresses.
What I have right now is this:
Sub Split_To_Workbook_and_Email_with_Body()
'Working in 2013/2016
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
Dim myOutlook As Object
Dim myMailItem As Object
Dim mySubject As String
Dim myto As String
Dim myPath As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Prompt for Email Subject
Set otlApp = CreateObject("Outlook.Application")
'mySubject = InputBox("Subject for Email")'this shows a dialog where you can enter the email subject (right now it is hard coded)
'myto = Application.VLOOKUP(SheetId, Sheet1!A3:B48, 2, FALSE)
'myto = Application.VLookup(SheetId, Sheet1!A3:B48, 2, range_lookup)
'Copy every sheet from the workbook with this macro
Set Sourcewb = ActiveWorkbook
'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = "Z:\user\report" & Sourcewb.Name & " " & DateString
MkDir FolderName
'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy
'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
If Sourcewb.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
End With
'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
'Save the new workbook, email it, and close it
Set otlNewMail = otlApp.CreateItem(olMailItem)
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
End With
myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
idkfile = "C:\Users\UniaHa\Desktop\Testing.txt"
With Destwb
.Close False
End With
With otlNewMail
'.Subject = mySubject
.to = test#test.ca
.Subject = "Diversion Report"
.Body = "Dear customer," & vbNewLine & vbNewLine & _
"This is your report please..... blah blah" & _
vbNewLine & vbNewLine & "Regards," & vbNewLine & vbNewLine & "Sender Name"
.Attachments.Add myPath
.Attachments.Add idkfile
.Display
End With
Set otlNewMail = Nothing
End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
For your vlookup, you can try something like:
On Error Resume Next
for each sht in activeworkbook.worksheets
err.clear
sEmailTo = Application.worksheetfunction.VLOOKUP(sh.name, Sheet1!A3:B48, 2, FALSE)
if err<>0 and semailto like "*#*" Then
'send your email
end if
next sht
On Error goto 0

How can I process the same workbook as control passes from one sub to another?

I am making a macro to take my originfile, SaveAsCopy tempfile, delete some sheets and some columns from tempfile and finally send tempfile by Outlook mail.
My code compiles and runs. It does not work great. It doesn't do any modification: so the deleting stuff in the newly generated tempfile is missing.
This is my code :
Macro Master
Sub run_all()
Call files_mang
Call delete
Call mailing_tempfile
End Sub
Sub files_mang()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010,
' Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OrigFileName As String
Dim FileExtStr As String
TempFilePath = "filepathhere"
FileExtStr = ".xlsx"
OrigFileName = TempFilePath & "Suivi interne déploiements OINIS S40" & FileExtStr
TempFileName = "Suivi déploiements OINIS - NOKIA S40" & FileExtStr
Set wb1 = Workbooks.Open(OrigFileName)
Set wb1 = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file. There will" & vbNewLine & _
"be no VBA code in the file you send. Save the" & vbNewLine & _
"file as a macro-enabled (. Xlsm) and then retry the macro.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Make a copy of the file.
' If you want to change the file name then change only TempFileName variable.
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
Set wb2 = ActiveWorkbook
End Sub
Sub delete()
Application.DisplayAlerts = False
'Delete columns like intern com ect ...
With Worksheets("Suivi Projet WELDON")
.Columns("R:X").delete
End With
With Worksheets("Suivi projet Highway")
.Columns("T:Z").delete
End With
'Delete non usful sheets for client
Worksheets("SuiviCarteOrange").delete
Worksheets("Cartes Orange En Panne").delete
Application.DisplayAlerts = True
End Sub
Sub mailing_tempfile()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run this procedure.
With OutMail
.To = "emailaddresshere"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hello World!"
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
ActiveWorkbook.Close SaveChanges:=False
' Delete the file.
'Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Excel VBA - Send Email via CDO.message - cannot add attachment

I am following this tutorial to send emails via Gmail SMTP which is working well, but fails when it comes to adding an attachment.
http://www.learnexcelmacro.com/wp/2011/12/how-to-send-an-email-using-excel-macro-from-gmail-or-yahoo/
I am trying to send a copy of the active workbook which is saved into the users TEMP Appdata folder. I traced the temp file, checked for the files existence which is alright and should not be a problem, however, excel doesnt seem to attach it. I can however attach a file if I hardcode it (eg. "C:\temp\file.xls"), but not when the file path is given via variables.
Can anyone point me in the right direction please? I am out of ideas...
EDIT:
just to clarify, I tried several syntax's such as defining the path in the Gmail_Attachment variable or adding the TempFilePath & TempFileName & FileExtStr variables. None of them work, only if I literally code it as .addattachment "C:/path/file.xls" does it attach.
Sub Mail_Gmail()
'Working in 2000-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb, Destwb As Workbook
Dim TempFilePath, TempFileName As String
Dim SendTo, SendCC, Holidex, Property, QCI_Mgr, Position As Range
Dim Gmail_ID, Gmail_PWD, Gmail_SMTP, Gmail_attachment As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Set SendTo = ActiveWorkbook.Sheets("Settings").Range("B20")
Set SendCC = ActiveWorkbook.Sheets("Settings").Range("B21")
Set Holidex = ActiveWorkbook.Sheets("Settings").Range("B5")
Set Property = ActiveWorkbook.Sheets("Settings").Range("B4")
Set QCI_Mgr = ActiveWorkbook.Sheets("Settings").Range("B14")
Set Position = ActiveWorkbook.Sheets("Settings").Range("B15")
Gmail_SMTP = "smtp.gmail.com"
Gmail_ID = "user#gmail.com"
Gmail_PWD = "password"
'Copy the sheet to a new workbook
ActiveSheet.Copy Before:=Sheets(1)
With ActiveSheet
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
'.ShowAllData ' disable autofilters
.Cells.Copy
.Cells.PasteSpecial xlValues
End With
Application.CutCopyMode = False
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
'FileExtStr = ".pdf": FileFormatNum = 17
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in the worksheet to values if you want
'With Destwb.Sheets(1).Range("A1:I50")
' .Select
' .Copy
' .PasteSpecial xlPasteValues
'End With
'Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")
Set NewMail = CreateObject("CDO.Message")
' Define Gmail configuration
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True ' Enalbe SSL
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 ' SMTP Authentication ON
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Gmail_SMTP ' SMTP Server address
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 ' SMTP port
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' SMTP encryption
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Gmail_ID ' Gmail ID
NewMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Gmail_PWD ' Gmail PWD
NewMail.Configuration.Fields.Update ' Update all settings
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
.Close savechanges:=False
On Error Resume Next
Gmail_attachment = TempFilePath & TempFileName & FileExtStr
'Set All Email Properties
With NewMail
.From = Gmail_ID
.To = SendTo
.CC = SendCC
.BCC = ""
.Subject = Holidex & " System Login - " & ThisWorkbook.Name & " - " & Format(Now, "dd-mm-yyyy")
.textbody = "The following client has just logged in to this system:" & vbNewLine _
& "Date: " & Format(Now, "dd-mm-yyyy hh:ss") & vbNewLine _
& "System: F&B Feedback Card Summary" & vbNewLine _
& "Filename: " & ThisWorkbook.FullName
'.HTMLBody = "Write your complete HTML Page"
' For multiple Attachment you can add below lines as many times
.AddAttachment Gmail_attachment
End With
NewMail.Send ' or use .display
'MsgBox Gmail_attachment, vbOKOnly, "String"
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
' Delete the duplicated worksheet and turn off prompts
Application.DisplayAlerts = False
With ActiveWorkbook
.ActiveSheet.Select
.ActiveSheet.Delete
.Sheets("Summary").Select
End With
Application.DisplayAlerts = True
' Clean up
Set NewMail = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The problem is here in this section where one adds the .attachment "C:\file.xls" variable
'Set All Email Properties
With NewMail
.From = Gmail_ID
.To = SendTo
.CC = SendCC
.BCC = ""
.Subject = Holidex & " System Login - " & ThisWorkbook.Name & " - " & Format(Now, "dd-mm-yyyy")
.textbody = "The following client has just logged in to this system:" & vbNewLine _
& "Date: " & Format(Now, "dd-mm-yyyy hh:ss") & vbNewLine _
& "System: F&B Feedback Card Summary" & vbNewLine _
& "Filename: " & ThisWorkbook.FullName
'.HTMLBody = "Write your complete HTML Page"
' For multiple Attachment you can add below lines as many times
.AddAttachment Gmail_attachment
End With
The script does not support attaching open workbooks, hence I had to place .Close savechanges:=False right after the save dialog which solved the issue. Original post has been edited.

Need to send attachment in XLSX format using CDO mail

Hi Iam using follwing code as a sample to send a mail with attachment via SMTP, but the attachment what it send is in XLSM format i need that to be in XLSX (non macro) format. Kindly help me to fo this.
Option Explicit
'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()
'Working in 2000-2007
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") = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "This is a test"
.TextBody = "This is the body text"
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I think what you'll need to do, is have this code reside in an add-in. That way you aren't trying to send the existing file with code via email.
You are sending workbook which you are running code from so it must be .xlsm and so you send it.
You must either create a copy of your workbook without macros and then send this copy or move your macro to PERSONAL (assuming macro you posted is the only code contained in your workbook)

Resources