VBA Macro to Send Active Sheet as an Outlook Email Attachment from Active Workbook
The following Macro will copy the Active sheet data from the This/Active Workbook to a New Workbook with single sheet and Save that with Active sheet name, then it will send via Outlook as an Email Attachment, from a specified Email Account/Alias to the defined Users.
Sub Email_ActiveSheet_WB()
Dim OutlookApp As Object
Dim NewMail As Object
Dim ActShtName As String
Dim FileFullPath As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Copying the Active Sheet data
ActiveSheet.Cells.Copy
ActShtName = ActiveSheet.Name
'Saving the Active sheet data into a new workbook with Active Sheet name_Today date
Workbooks.Add (xlWBATWorksheet)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("A1").Select
ActiveSheet.Name = ActShtName
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Environ("UserProfile") & "\Desktop\Test\" & ActShtName & "_" & Format(Now, "dd-mmm-yyyy") & ".xlsx"
'Storing the Saved file(which we used for attachment later) path into a Variable
FileFullPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWorkbook.Close True
Application.DisplayAlerts = True
'Setting up the objects of Outlook Application and New Email
Set OutlookApp = CreateObject("Outlook.Application")
Set NewMail = OutlookApp.CreateItem(olMailItem)
'Set NewMail = OutlookApp.CreateItem(0)
'Inserting Signature in Email Boday ; 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 Account
'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 Email 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>" & "<B>Thank you</B>" & "<br>" & Signature
.Attachments.Add FileFullPath '-- Full Path of the Attachment where it is saved.
.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 ErrMsg:
' Since mail has been sent with the attachment.You can kill the Source file if not required
Kill FileFullPath
' Set nothing to the objects created.
Set NewMail = Nothing
Set OutlookApp = Nothing
' Now set the application properties back to true.
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Activesheet as Email Attchment Sent Successfully", vbOKOnly, "Job Done"
Exit Sub
ErrMsg:
MsgBox Err.Description
End Sub
'The Function to Look and Get the Email Signature; Calls into above Macro
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
---------------------------------------------------------------------------------------------------------------------
Note : Please note that You have to define both the Sub Procedure and Function in the same Module, to call Signature into your Email body.
---------------------------------------------------------------------------------------------------------------------
The following Macro will copy the Active sheet data from the This/Active Workbook to a New Workbook with single sheet and Save that with Active sheet name, then it will send via Outlook as an Email Attachment, from a specified Email Account/Alias to the defined Users.
Sub Email_ActiveSheet_WB()
Dim OutlookApp As Object
Dim NewMail As Object
Dim ActShtName As String
Dim FileFullPath As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Copying the Active Sheet data
ActiveSheet.Cells.Copy
ActShtName = ActiveSheet.Name
'Saving the Active sheet data into a new workbook with Active Sheet name_Today date
Workbooks.Add (xlWBATWorksheet)
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("A1").Select
ActiveSheet.Name = ActShtName
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Environ("UserProfile") & "\Desktop\Test\" & ActShtName & "_" & Format(Now, "dd-mmm-yyyy") & ".xlsx"
'Storing the Saved file(which we used for attachment later) path into a Variable
FileFullPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWorkbook.Close True
Application.DisplayAlerts = True
'Setting up the objects of Outlook Application and New Email
Set OutlookApp = CreateObject("Outlook.Application")
Set NewMail = OutlookApp.CreateItem(olMailItem)
'Set NewMail = OutlookApp.CreateItem(0)
'Inserting Signature in Email Boday ; 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 Account
'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 Email 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>" & "<B>Thank you</B>" & "<br>" & Signature
.Attachments.Add FileFullPath '-- Full Path of the Attachment where it is saved.
.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 ErrMsg:
' Since mail has been sent with the attachment.You can kill the Source file if not required
Kill FileFullPath
' Set nothing to the objects created.
Set NewMail = Nothing
Set OutlookApp = Nothing
' Now set the application properties back to true.
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Activesheet as Email Attchment Sent Successfully", vbOKOnly, "Job Done"
Exit Sub
ErrMsg:
MsgBox Err.Description
End Sub
'The Function to Look and Get the Email Signature; Calls into above Macro
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
---------------------------------------------------------------------------------------------------------------------
Note : Please note that You have to define both the Sub Procedure and Function in the same Module, to call Signature into your Email body.
---------------------------------------------------------------------------------------------------------------------
--------------------------------------------------------------------------------------------------------
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.