Using the RangeToHTML function from Ron de Bruin, I'm pasting a range into an outlook email. However, it seems that an extra blank row is being pasted into the email as seen below:
I've already confirmed that the Source:=TempWB.Sheets(1).UsedRange.Address line is correctly grabbing only the data itself and not an extra line. I've also confirmed that the input range to RangetoHTML() is also correct. My only guess is that the the .ReadAll method is somehow putting an extra line in the file, but I'm not sure how to debug that. Here's the RangetoHTML function I'm using for easy reference:
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Application.ScreenUpdating = False
Application.EnableEvents = False
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
If rng Is Nothing Then GoTo Skip
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1, 2).PasteSpecial Paste:=8
.Cells(1, 2).PasteSpecial xlPasteFormats
.Cells(1, 2).PasteSpecial xlPasteValues
.Cells.Font.Name = "Calibri"
.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
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
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close 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
Skip:
Application.ScreenUpdating = True
End Function
EDIT: Here's the portion of code where the email is being generated. The RangeToHTML(rng_Summary) is what inserts the range into the email:
'Construct the actual email in outlook
With OutMail
.to = "LastName, FirstName"
.CC = ""
.BCC = ""
.Subject = "LOB Break Status (As of " & Format(Now(), "m/d") & ")"
.HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>Here is the latest status for the breaks, by product, in the LOB:" & _
RangetoHTML(rng_Summary) & _
"<BODY style=font-size:9pt;font-family:Calibri>*allows are excluded from Avg. Age of Breaks calculation" & _
"<ul>" & _
"<li>" & _
"<BODY style=font-size:11pt;font-family:Calibri><u><b>Average Age of Breaks</u></b>" & Chr(150) & " " & avg_age_change & " from " & avg_break_age_prev & " to " & avg_break_age_curr & " due to ________" & _
"</li>" & _
"</ul>"
.Display 'CHANGE THIS to .Display/.Send if you want to test/send
End With
Workbook.PublishObjects includes an extra row to enforce column widths.
<![if supportMisalignedColumns]>
<tr height=0 style='display:none'>
<td width=64 style='width:48pt'></td>
<td width=64 style='width:48pt'></td>
</tr>
<![endif]>
Using the #EngineerToast's answer to Replace only last occurrence of match in a string in VBA we can hide the last row while preserving column widths.
Function getTrimRangetoHTML(rng As Range) As String
Const OldText = "display:none"
Const NewText = "visibility: hidden;"
Dim s As String
s = RangetoHTML(rng)
s = StrReverse(Replace(StrReverse(s), StrReverse(OldText), StrReverse(NewText), , 1))
getTrimRangetoHTML = s
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText s
.PutInClipboard
End With
End Function
Addendum
After reviewing RangetoHTML's output I noticed that the first row also enforces the column widths. Nonetheless, getTrimRangetoHTML will give the desired result of hidding the last row.
I've had this exact same thing happen to me, and I fixed it using some simple CSS.
tr:last-child {display:none;}
If you are not familiar CSS, that needs to be placed between style tags, like this:
<style> tr:last-child {display:none;} </style>
Placed here in your code:
RangetoHTML = "<style> tr:last-child {display:none;} </style>" & Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
Seems that you have to include the following code line before 'Close TempWB within the RangeToHTML procedure to avoid an additional line on top of HTML Body:
' >>> INSERTED CODE LINE:
RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]> <![endif]-->", "")
' Close TempWB
TempWB.Close savechanges:=False
' ....
' ....
Related
I have the following code and it creates the email almost perfectly. What it doesn't do is maintain the default signature that is visible before it pastes the RangetoHTML results.
How do I get my signature back?
This is almost entirely drawn from Ron de Bruin's code samples and as I said, it all works very well except for the signature bit. This is an Outlook created signature, so I do have an htm copy of it locally. I did experiment and found that nothing, not even additional text or another string, will appear after the ".body = Selection.Paste". No, changing that to ".HTMLbody = Selection.Paste", does not make it work.
Sub Mail_Reminder_Thursday()
'Emailing Script for Thursday Reminder
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim sendBCC As String
sendBCC = ""
Dim emailCell As Range
Dim Signature As String
With ActiveSheet
' Cycle through email addresses, from B3 to one before next blank cell in column
For Each emailCell In .Range("D2", .Range("D2").End(xlDown))
If .Cells(emailCell.Row, "C").Text = "YES" Then
sendBCC = sendBCC & "; " & emailCell.Text
End If
Next emailCell
End With
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Sheets("WEEKLY MATCHUPS").Range("T1:Z18").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 OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
OutMail.Display
On Error Resume Next
With OutMail
.BodyFormat = 2
.Display
.BCC = sendBCC
.Subject = "Week " & Sheets("WEEKLY MATCHUPS").Range("A1") & " - Thursday Reminder"
.HTMLBody = "This is just a friendly reminder that your pick for tonight's Thursday Night Football game is due by kickoff # " & Format(Sheets("WEEKLY MATCHUPS").Range("M3"), "medium time") & "<BR>" & "<BR>" & _
RangetoHTML(rng)
.Body = Selection.Paste
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to paste the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.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
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
'Read all data from the htm file into RangetoHTML
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=")
'Close 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
The trick here is that Outlook only adds the Signature when you .Display the email, and only if you haven't already made changes to .HTMLBody:
Dim DefaultSignature As String
.Display
DefaultSignature = .HTMLBody
.HTMLBody = "This is just a friendly reminder that your pick for tonight's Thursday Night Football game is due by kickoff # " & Format(ThisWorkbook.Worksheets("WEEKLY MATCHUPS").Range("M3").Value, "medium time") & "<BR>" & "<BR>" & _
RangetoHTML(rng) & DefaultSignature
I have compiled the following code in VBA to send out an email. I want to send a simple message with a Range of cells in a table format.
The code below works. But the output is flipped. I want the message text on top and the table on the bottom. (Please see image attached).
Any time I try to move anything around I get a "424 Object Required" error.
Please advise.
Sub SendEmail()
Dim msg As String
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.createitem(olMailItem)
msg = "Good Morning Team, " & "<br><br>" _
& "Here is this week's Coffee Talk groups. Enjoy!" & "<br><br>"
With mail
.To = "someone#gmail.com"
.Subject = "Coffee Talk " & Date
.HTMLBody = msg
End With
mail.display
Set wEditor = mailApp.ActiveInspector.wordEditor
ThisWorkbook.Sheets("Groups").Range("A1:E4").Copy
wEditor.Application.Selection.Paste
End Sub
There is a Range to HTML function made by Ron de Bruin that would help you with your issue. I have amended your code for his function to work:
Sub SendEmail()
Dim msg As String
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.createitem(olMailItem)
Dim rng As Range
msg = "Good Morning Team, " & "<br><br>" _
& "Here is this week's Coffee Talk groups. Enjoy!" & "<br>"
Set rng = Sheets("Groups").Range("A1:E4").SpecialCells(xlCellTypeVisible)
With mail
.To = "someone#gmail.com"
.Subject = "Coffee Talk " & Date
.HTMLBody = msg & "<br>" & RangetoHTML(rng)
.display
End With
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.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
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
'Read all data from the htm file into RangetoHTML
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=")
'Close 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
I am trying to send Automate mail from Excel via Outlook mail to users. Within that i have requirement to send some Excel tables and graphs to certain users. The excel table should be placed after some text provided/written by sender and should retain the same table format in the email.
I am not able to get this functionality automate (sending excel table and graph in the email body) and require your help in sorting this out.
PS: I am using excel/Outlook 2010 (win)
Below is my overall code written as of now:
Sub Mail_to_MgmtTeam()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
Dim x As Integer, y As Integer
Dim total_Resource As Integer
Application.ScreenUpdating = False
' Delete the Temp sheets, if any (just precautionary step)
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Temp").Delete
Application.DisplayAlerts = True
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
Sheets("Mail Details").Select
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Temp").Select
Range("A5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("J:J").EntireColumn.Delete
Columns("A:A").EntireColumn.Delete
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'' Below code not getting executed successfully
'Selection.Select
'Set rng = Sheets("Temp").Selection.SpecialCells(xlCellTypeVisible)
'rng.Copy
' NEED HELP Here : TO send this selected TABLE within the email BODY to someone...
' code for sending the mails form Excel
Sheets("Mail Details").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Dear " & Cells(x + 5, 3).Value & ", " & _
vbNewLine & vbNewLine & _
"Below Table provides the overall statue of Pending Lists." & _
vbNewLine & vbNewLine & vbNewLine & _
"Thank You " & vbNewLine & "XYZ..."
On Error Resume Next
With OutMail
.To = Sheets("Mail Details").Range("D6").Value
.CC = ""
.BCC = ""
.Subject = "Excel Table Attached"
.Body = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Mails have been sent", vbDefaultButton1, "Mail Sent!!!"
End Sub
Thanks in advance
Kunal...
I was able to complete the task for which i had posted. I am posting the final code below for anyone who may need help in future on the similar line...
PS:
I have segmented into different sets for easy of use. Please copy each code and paste it in in 'module' back to back
The sheet name should be "RawData" and "ReportData"
The Table should be placed in sheet "RawData" and Column header should be in Row 5
In sheet "RawData", in K Column, Mail ID is mentioned
Macro #1
Option Explicit
Dim folder_path As String
Dim chart_no As Integer
Dim file_path As String
Sub mail_2_IBUhead()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
Dim x As Integer, y As Integer
Dim total_Resource As Integer
Application.ScreenUpdating = False
Sheets("RawData").Select
Call export_chart
Call Send_Automate_Mail
Sheets("RawData").Select
Range("A1").Select
'Delete the htm file we used in this function
Kill file_path & "Chart_1.png"
MsgBox "Draft Mails have been generated", vbDefaultButton1, "Mail Drafted!!!"
End Sub
Macro #2:
Private Sub Send_Automate_Mail()
' This macro would only send the mail...
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody_1 As String, strbody_2 As String, strbody_3 As String
Dim Start_row As Integer, Start_column As Integer, End_row As Integer, End_Column As Integer
' selecting the entire table range in the sheet
Sheets("RawData").Select
Range("A5").Select
Start_row = Selection.Row
Start_column = Selection.Column
Selection.End(xlToRight).Select
End_Column = Selection.Column
Range("A5").End(xlDown).Select
End_row = Selection.Row
Range(Cells(Start_row, 1), Cells(End_row, End_Column)).Select
Set rng = Selection.SpecialCells(xlCellTypeVisible)
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 OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody_1 = "<BODY style=font-size:11pt;font-family:Calibri>Dear User,<p>" & _
" Below is the Graph.... <br> </BODY> "
strbody_2 = "<BODY style=font-size:11pt;font-family:Calibri>" & _
" Below is the Table... <br> </BODY> "
strbody_3 = "<BODY style=font-size:11pt;font-family:Calibri> This is an Automated mail. Please do not respond. <p> <p> " & _
" Regards, <br> Sender </BODY> "
file_path = folder_path & "\"
With OutMail
.To = Sheets("RawData").Range("k6").Value
.CC = ""
.BCC = ""
.Subject = "BE. RawData"
.Attachments.Add file_path & "Chart_1.png"
.htmlbody = strbody_1 & "<p>" & "<p>" & _
"<img src='cid:Chart_1.png'" & "width='1000' height='580'>" & "<br>" & "<p>" & _
strbody_2 & "<p>" & _
RangetoHTML(rng) & "<br>" & _
strbody_3
.Importance = 2
' display the e-mail message, change it to ".send" to send the mail on running the macro
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Macro #3:
Function RangetoHTML(rng As Range)
' this function is used in code "Send_Automate_Mail"
' do not change the code if you are new to coding :)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.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
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
'Read all data from the htm file into RangetoHTML
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=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Macro #4:
Private Sub export_chart()
' this code will export all the graphs present in the sheet
Dim objCht As ChartObject
Dim x As Integer
folder_path = Application.ActiveWorkbook.Path
' for each graph present in the sheet, it will get exported
Sheets("ReportData").Select
x = 1
For Each objCht In ActiveSheet.ChartObjects
objCht.Chart.Export folder_path & "\Chart_" & x & ".png", "PNG"
x = x + 1
Next objCht
End Sub
Thanks,
Kunal...
Hello I have these two macros in one module but when I run it only runs the first part where it deletes the rows but I would like it to also send the emails... I had some excellent help from #Simoco on the send part earlier but cant seem to figure out the combine part...
I tried to add the Call Sub... but no luck
Sorry about the length of the code...
Sub DeleteDuplicateRows()
Dim R As Long
Dim N As Long
Dim V As Variant
Dim rng As Range
Range("D2").Select
ActiveCell.FormulaR1C1 = "1"
Range("D2").Select
Selection.Copy
Range("A5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
Rows("1:3").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Columns("A:A").EntireColumn.AutoFit
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(rng.Row, "#,##0")
N = 0
For R = rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = rng.Cells(R, 1).Value
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(rng.Columns(1), vbNullString) > 1 Then
rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Else
If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
rng.Rows(R).EntireRow.Delete
N = N + 1
End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Dim lastrow As Long
Set OutApp = CreateObject("Outlook.Application")
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For Each cel In Range("C2:C" & lastrow)
strbody = "Hi there" & cel.Offset(, -1) & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
cel.Offset(, 3) & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutApp.CreateItem(0)
If cel.Value <> "" Then
.To = cel.Value
.CC = cel.Offset(0, 10).Value
.Body = strbody & vbNewLine & vbNewLine & Signature
Else
.To = cel.Offset(0, 10).Value
.Body = "Hello " & cel.Offset(, 9) & "! " & cel.Offset(, -1) & " is having this event" & vbNewLine & Signature
'.HTMLBody = strbody & vbNewLine & RangetoHTML(cel.Offset(, -2).Resize(, 4)) & vbNewLine & Signature
End If
'.BCC = ""
.Subject = "Choose your plan"
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.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
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
'Read all data from the htm file into RangetoHTML
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=")
'Close 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
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
If you execute a macro you call one procedure or one function. I assume you want to call Delete_Duplicate_Rows and Send_Email. To execute two procedures you can create one procedure that calls the other procedures
Sub Delete_And_Send()
Call Delete_Duplicate_Rows()
Call Send_Email()
End Sub
I'm totally new to Excel VBA. I am using Microsoft 2003 excel.
What my superior tasked me to do was to create a Leave Management System that tracks down an employee's amount of days left in terms of leave and from there, send an email down to her, her secretary and the employee regarding the status of approved or rejected.
I did try out some codes of VBA.. But I do not know how really the mail sending function works? Do i send the attachment out? Or when i entered some value in the code, it will auto send the whole attachment over? I'm really lost here, thank you!
Sub Mail_sheets()
Dim MyArr As Variant
Dim last As Long
Dim shname As Long
Dim a As Integer
Dim Arr() As String
Dim N As Integer
Dim strdate As String
For a = 1 To 253 Step 3
If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
Exit Sub
End
Application.ScreenUpdating = False
last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
a).End(xlUp).Row
N = 0
For shname = 1 To last
N = N + 1
ReDim Preserve Arr(1 To N)
Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
Next shname
ThisWorkbook.Sheets(Arr).Copy
strdate = Format(Date, "dd-mm-yy") & " " & _
Format(Time, "h-mm-ss")
ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
With ThisWorkbook.Sheets("mail")
MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
a + 1).End(xlUp))
End With
ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
Application.ScreenUpdating = True
Next a
End Sub
Here is an example on how to achieve what you want. Please amend it for your actual needs.
I did try out some codes of VBA.. But I do not know how really the mail sending function works? Do i send the attachment out?
You don't need to send the entire workbook as an attachment. You can send a simple email stating whether the leave is approved or rejected. If you need to support why you are rejecting or approving the leave then you can paste the relevant cells in the email. See this example.
I am assuming for a moment that you worksheet looks like this.
Now suppose the employee Siddharth wants to take a leave. As we can see in the snapshot, the employee has 0 leaves balance. So the request for leave will be declined and a mail will be shot to the relevant person/Dept
When you run the code, it will ask you to enter the employees name
and then sends the relevant email.
CODE
Option Explicit
'~~> To Field in Email
Const strTo As String = "aaa#aaa.com"
'~~> CC field in email. If you do not want to CC then change "bbb#bbb.com" to ""
Const strCC As String = "bbb#bbb.com"
'~~> This is what goes in the body
Const strBody1 As String = "Dear XYZ,"
Const strBody2 As String = "This is in reference to leave request for employee "
Const strBodyApp As String = "The employee has sufficient leave balance and can take the leave"
Const strBodyNotApp As String = "The employee doesn't have sufficient leave balance and hence cannot take the leave"
Const strByeBye As String = "Thanks and Regards"
Const sender As String = "ABC"
Sub Sample()
Dim ws As Worksheet
Dim aCell As Range
Dim Ret
Dim Bal As Long
Dim Rw As Long
Ret = Application.InputBox("Please enter the name of the employee who wants to take a leave")
If Ret = "" Then Exit Sub
Set ws = Sheets("Sheet3")
Set aCell = ws.Columns(2).Find(What:=Ret, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Bal = aCell.Offset(, 5).Value
Rw = aCell.Row
If Bal > 0 Then
Approved Ret, True, Rw
Else
Approved Ret, False, Rw
End If
Else
MsgBox "The employee " & Ret & " was not found"
End If
End Sub
Sub Approved(EmpName, app As Boolean, lRow As Long)
Dim msg As String
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
If app = True Then
msg = "<p class=MsoNormal>" & strBody1 & "<o:p></o:p></p>" & vbNewLine & _
"<p class=MsoNormal><o:p> </o:p></p>" & vbNewLine & _
"<p class=MsoNormal>" & strBody2 & EmpName & ". " & strBodyApp & _
"<span style='mso-fareast-font-family:""Times New Roman""'><o:p></o:p></span></p>"
Else
msg = "<p class=MsoNormal>" & strBody1 & "<o:p></o:p></p>" & vbNewLine & _
"<p class=MsoNormal><o:p> </o:p></p>" & vbNewLine & _
"<p class=MsoNormal>" & strBody2 & EmpName & ". " & strBodyNotApp & _
"<span style='mso-fareast-font-family:""Times New Roman""'><o:p></o:p></span></p>"
End If
Set rng = Sheets("Sheet3").Range("A1:F1" & ",A" & lRow & ":F" & lRow)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strTo
.CC = strCC
.BCC = ""
.Subject = "Leave Status"
.HTMLBody = msg & _
RangetoHTML(rng) & _
"<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'>" & strByeBye & "<o:p></o:p></span></p>" & _
"<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'><o:p> </o:p></span></p>" & _
"<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'>" & sender & "<o:p></o:p></span></p>"
.Display '.Send 'To send the email
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'~~> Taken from http://www.rondebruin.nl/mail/folder3/mail4.htm
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.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
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
'Read all data from the htm file into RangetoHTML
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=")
'Close 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
DISCLAIMER: Since the above code is a basic example, I have not
1) included Error handling (which you should)
2) used basic stuff as Application.ScreenUpdating
SAMPLE FILE: This link will be active for the next 7 days. I have uploaded a sample file for you to play with :)
http://wikisend.com/download/562482/Sample.xls
HTH