VBA Macro to Send a Range from an Active Sheet in an Outlook Email Body from Active Workbook
Sub Mail_Selection_Range_Outlook_Body()
Dim Rng As Range
Dim OutlookApp As Object
Dim NewMail As Object
Set Rng = Nothing
On Error Resume Next
Set Rng = ActiveSheet.Range("MyRng")
'--You can also use a Fixed range if you want
'Set Rng = Sheets("YourSheet").Range("A1:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Rng Is Nothing Then
MsgBox "The Selection is not a Range or the Sheet is Protected" & _
vbNewLine & "Please Correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutlookApp = CreateObject("Outlook.Application")
Set NewMail = OutlookApp.CreateItem(olMailItem)
'Set NewMail = OutlookApp.CreateItem(0)
'--Inserting Signature in Email Body
'--Change only 'YourSignature.htm' to the name of your Signature
SigString = Environ("appdata") & "\Microsoft\Signatures\Tamatam.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
'--Selecting your desired Email Account for Sending From
'--If the account is not in your profile, Then you need to use SentOnBehalfOfName
For I = 1 To OutlookApp.Session.Accounts.Count
If OutlookApp.Session.Accounts.Item(I) = "MyEmailAccountAlias@Domain.Com" Then
MsgBox OutlookApp.Session.Accounts.Item(I) & " : This is account number " & I
Acn_No = I
Exit For
End If
Next I
'--Defining the Email Body Message
Strbody = "<H3><B>TEST MAIL via EXCEL MACRO</B></H3>" & _
"This is sample test mail by Macro<br>" & _
"Please donot repond to it<br>" & _
"<A href=""https://excelkingdom.blogspot.in/"">Excel Kingdom</A>"
On Error Resume Next
'--Opening a New Email to Send
With NewMail
.TO= "YourEmail@Domain.com" '--Your Email Id here
.CC = ""
.BCC = ""
.Subject = "Test Message" '--Your Email Subject here
'.Body = "This Your Email Boday ; '--You can use below one as well
.HTMLBody = Strbody & "<br>" & "<br>" & _
RangetoHTML(Rng) & "<br>" & "<br>" & _
"<B>Thank you</B>" & "<br>" & "<br>" & Signature
.SentOnBehalfOfName = OutlookApp.Session.Accounts.Item(Acn_No)
'--You can use below one as well
'.SentOnBehalfOfName = "MyEmailAccountAlias@Domain.Com"
'.SendUsingAccount = OutlookApp.Session.Accounts.Item(Acn_No)
.Display '--Use .Display to show you the Email before sending it.
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
-- This is will call to above Procedure to Copy the Range from Active sheet to a .htm file then to the Email Message Body
Function RangetoHTML(Rng As Range)
Dim FSO As Object
Dim TS As Object
Dim TempFile As String
Dim TempWB As Workbook
'--Creating a Temporary .htm file to Copy the Range from Active sheet.
'TempFile = Environ$("temp") & "\" & Format(Now, "dd-mmm-yyyy") & ".htm"
TempFile = Environ("UserProfile") & "\Desktop\Test\" & Format(Now, "dd-mmm-yyyy")
& ".htm"
'--Copy the range and Paste the data to newly created Workbook
'Rng.Select
Rng.Copy
Set TempWB = Workbooks.Add(xlWBATWorksheet)
'--Copy Pasting the Range from Active Sheet to a Temp Workbook Sheet
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8 'Paste with same Column Widths
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'--Publish the Sheet to a htm file from Temp Workbook Sheet
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'--Reading all data from the htm file into RangetoHTML variable
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TS = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = TS.readall
TS.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'--Closing the TempWB
TempWB.Close SaveChanges:=False
'--Delete the htm file we used in this Function
Kill TempFile
Set TS = Nothing
Set FSO = Nothing
Set TempWB = Nothing
End Function
-- This is will call to above Procedure to Copy the Signature to the Email Message Body
Function GetBoiler(ByVal SigFile As String) As String
Dim FSO As Object
Dim TS As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TS = FSO.GetFile(SigFile).OpenAsTextStream(1, -2)
GetBoiler = TS.readall
TS.Close
End Function
Sub Mail_Selection_Range_Outlook_Body()
Dim Rng As Range
Dim OutlookApp As Object
Dim NewMail As Object
Set Rng = Nothing
On Error Resume Next
Set Rng = ActiveSheet.Range("MyRng")
'--You can also use a Fixed range if you want
'Set Rng = Sheets("YourSheet").Range("A1:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Rng Is Nothing Then
MsgBox "The Selection is not a Range or the Sheet is Protected" & _
vbNewLine & "Please Correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutlookApp = CreateObject("Outlook.Application")
Set NewMail = OutlookApp.CreateItem(olMailItem)
'Set NewMail = OutlookApp.CreateItem(0)
'--Inserting Signature in Email Body
'--Change only 'YourSignature.htm' to the name of your Signature
SigString = Environ("appdata") & "\Microsoft\Signatures\Tamatam.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
'--Selecting your desired Email Account for Sending From
'--If the account is not in your profile, Then you need to use SentOnBehalfOfName
For I = 1 To OutlookApp.Session.Accounts.Count
If OutlookApp.Session.Accounts.Item(I) = "MyEmailAccountAlias@Domain.Com" Then
MsgBox OutlookApp.Session.Accounts.Item(I) & " : This is account number " & I
Acn_No = I
Exit For
End If
Next I
'--Defining the Email Body Message
Strbody = "<H3><B>TEST MAIL via EXCEL MACRO</B></H3>" & _
"This is sample test mail by Macro<br>" & _
"Please donot repond to it<br>" & _
"<A href=""https://excelkingdom.blogspot.in/"">Excel Kingdom</A>"
On Error Resume Next
'--Opening a New Email to Send
With NewMail
.TO= "YourEmail@Domain.com" '--Your Email Id here
.CC = ""
.BCC = ""
.Subject = "Test Message" '--Your Email Subject here
'.Body = "This Your Email Boday ; '--You can use below one as well
.HTMLBody = Strbody & "<br>" & "<br>" & _
RangetoHTML(Rng) & "<br>" & "<br>" & _
"<B>Thank you</B>" & "<br>" & "<br>" & Signature
.SentOnBehalfOfName = OutlookApp.Session.Accounts.Item(Acn_No)
'--You can use below one as well
'.SentOnBehalfOfName = "MyEmailAccountAlias@Domain.Com"
'.SendUsingAccount = OutlookApp.Session.Accounts.Item(Acn_No)
.Display '--Use .Display to show you the Email before sending it.
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
-- This is will call to above Procedure to Copy the Range from Active sheet to a .htm file then to the Email Message Body
Function RangetoHTML(Rng As Range)
Dim FSO As Object
Dim TS As Object
Dim TempFile As String
Dim TempWB As Workbook
'--Creating a Temporary .htm file to Copy the Range from Active sheet.
'TempFile = Environ$("temp") & "\" & Format(Now, "dd-mmm-yyyy") & ".htm"
TempFile = Environ("UserProfile") & "\Desktop\Test\" & Format(Now, "dd-mmm-yyyy")
& ".htm"
'--Copy the range and Paste the data to newly created Workbook
'Rng.Select
Rng.Copy
Set TempWB = Workbooks.Add(xlWBATWorksheet)
'--Copy Pasting the Range from Active Sheet to a Temp Workbook Sheet
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8 'Paste with same Column Widths
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'--Publish the Sheet to a htm file from Temp Workbook Sheet
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'--Reading all data from the htm file into RangetoHTML variable
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TS = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = TS.readall
TS.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'--Closing the TempWB
TempWB.Close SaveChanges:=False
'--Delete the htm file we used in this Function
Kill TempFile
Set TS = Nothing
Set FSO = Nothing
Set TempWB = Nothing
End Function
-- This is will call to above Procedure to Copy the Signature to the Email Message Body
Function GetBoiler(ByVal SigFile As String) As String
Dim FSO As Object
Dim TS As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TS = FSO.GetFile(SigFile).OpenAsTextStream(1, -2)
GetBoiler = TS.readall
TS.Close
End Function
--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------
No comments:
Post a Comment
Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.