-
Notifications
You must be signed in to change notification settings - Fork 2
/
RangetoHtml
74 lines (60 loc) · 2.44 KB
/
RangetoHtml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
'https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
Sub BodyVsHTMLBody()
Dim rng As Range
Dim ol As Outlook.Application
Dim olMail As Outlook.MailItem
Set ol = New Outlook.Application
Set olMail = ol.CreateItem(olMailItem)
With olMail
.To = "[email protected]"
.Subject = "Bonus letters"
'.Body = "Hello Sir," & vbNewLine & vbNewLine & "You have performed well in last quarter and you receive a hike of 100% as bonus." & vbNewLine & vbNewLine & "Regards," & vbNewLine & "Team HR"
'.HTMLBody = "<b>Hello Kamal,</b> <br/><br/>You have performed well in last quarter and you receive a hike of 100% as bonus. <br/> <table border=1> <tbody> <tr><th>FirstName</th><th>Last Name</th></tr> <tr><td>" & Cells(2, 1).Value & "</td><td>" & Cells(2, 2).Value & "</td></tr> </tbody> </table> <br/><br/>Regards,<br/>Team HR"
.HTMLBody = RangetoHTML(rng)
.Display
End With
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 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