emailing htmlbody and range of cells (as html)

[flik1018]

Hello Experts,

I have searched through the threads existing about emailing ranges, and have adapted the code from the Ron de Bruin site, but can't seem to find a solution to my challenge.

I need to create an email that is a blend of a generated email (with hyperlinks) and data from an excel range (which changes in size each time). I have the code written to build the html email, and then include the RangetoHTML function. However, the email is created with just the output of the RangetoHTML function.

Any insight would be of great help.

Thanks!

Here is my code:

Sub ProcessDeploymentCommunication()
'
'Application.ScreenUpdating = False

Workbooks("LaborOpsToolbox.xls").Sheets("Deployment").Select
Range("A3:J2000").Select
Selection.ClearContents

Rows("3:3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Interior.ColorIndex = xlNone

Range("A3").Select


Dim cn As ADODB.Connection, rs As ADODB.Recordset
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=\\wdw\data\studios\data\Labor Office\Reports\LaborOpsToolbox\Databases" & "\" & "LaborOpsToolboxSource.mdb"

Dim l As Long
l = frmDeploymentCommunication.ListBox1.ListCount

Dim x As Variant
Dim i As Long

For i = 0 To l - 1
If frmDeploymentCommunication.ListBox1.Selected(i) = True Then
x = frmDeploymentCommunication.ListBox1.List(i)

'Create the SQL-statement.
stSQL = "SELECT * FROM [tblDeploymentCommunication] Where [nameProp]=""" & frmDeploymentCommunication.ComboBox1.Value & """ AND [nameArea] = """ & x & """"

' open a recordset
Set rs = New ADODB.Recordset

With rs
.Open stSQL, cn, adOpenKeyset, adLockOptimistic
End With
ActiveCell.CopyFromRecordset rs


rs.Close
Set rs = Nothing

LR = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
Range("A" & LR).Select

End If
Next i

cn.Close
Set cn = Nothing


Dim cell As Variant
Dim cadd As Variant
Dim cellrange As Range
Dim ChkDeploy As String

Dim r As Long

Set cellrange = ActiveSheet.Range("A3:A" & LR)

For Each cell In cellrange
cadd = cell.Address

r = Range(cadd).Row

ChkDeploy = Range(cadd).Offset(0, 7).Value

If ChkDeploy = "Yes" Then
Range("A" & r & ":J" & r).Select
Selection.Interior.ColorIndex = 36
End If

Next cell

'dropping in date

Range("A1").Select

Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=\\wdw\data\studios\data\Labor Office\Reports\LaborOpsToolbox\Databases" & "\" & "LaborOpsToolboxSource.mdb"

'Create the SQL-statement.
stSQL = "SELECT * FROM [Deployment -- Date]"

' open a recordset
Set rs = New ADODB.Recordset

With rs
.Open stSQL, cn, adOpenKeyset, adLockOptimistic
End With
ActiveCell.CopyFromRecordset rs


rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

'creating email
Dim JobGroup As String
Dim Property As String
Dim WkDate As Date


Property = frmDeploymentCommunication.ComboBox1.Value
JobGroup = frmDeploymentCommunication.ComboBox2.Value
WkDate = Workbooks("LaborOpsToolbox.xls").Sheets("Deployment").Range("A1").Value


dear = "<font face="" Times New Roman"">Hello,</font>"
strbody1 = "<font face=""Times New Roman""> <br><br>Please be advised that the Cast Members listed below from your area are scheduled to be deployed during week ending " & WkDate & "."
strbody2 = "<font face=""Times New Roman""> <br><br>Please ensure that a Leader in your area meets with these Cast Members to give them an overview of Deployment and share the various resources that are available to them on The Hub." & _
"<br><br>If the cast member line is highlighted in yellow below, this is their first deployment experience. Please ensure that they have the proper resources available.<br><br>" & _
"Below are some helpful links to assist in this conversation:<br><br>"
Link = "<A HREF=""http://tink.corp.disney.com/?i=32w"">First Time Cast Deployment - Leader Spiel</a></font>"
Link2 = "<br><br><A HREF=""http://tink.corp.disney.com/?i=32x"">Resort Welcome Letters</a></font>"
Link3 = "<br><br><A HREF=""http://tink.corp.disney.com/?i=32y"">Resort Virtual Property Tours</a></font>"
Link4 = "<br><br><A HREF=""http://tink.corp.disney.com/?i=32z"">Transportation Assistance</a></font>"
strbody3 = "<font face=""Times New Roman""> <br><br>Please be advised that Cast Members can also easily access Deployment Resources from the Cast Link module on The Hub." & _
"<br><br>Thank you in advance for preparing our Cast Members for a positive Deployment experience.<br><br>"



Dim rng As Range
Dim olApp As Outlook.Application
Dim olMail As MailItem


Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Deployment").Range("A1:J" & LR).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


Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)

With olMail
.To = Environ("UserName")
.CC = ""
.BCC = ""
.Subject = "Deployment Communication for " & JobGroup & " at " & Property & " for week ending " & WkDate
.HTMLBody = dear & strbody1 & strbody2 & Link & Link2 & Link3 & Link4 & strbody3
.Save
End With


On Error GoTo 0


Set olMail = Nothing
Set olApp = Nothing



'Application.ScreenUpdating = True



MsgBox ("e-Mail Draft created")

Unload frmDeploymentCommunication



End Sub


Function RangetoHTML(rng As Range)
' Working in Office 2000-2007
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 xlPasteFormulas
.Cells(1).PasteSpecial xlPasteFormats
.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 xublishsource=", _
"align=left xublishsource=")

'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

 

[flik1018]

I should have stated that this is the code that is working for creating the html email portion with the links.

When I change the line:
.HTMLBody = dear & strbody1 & strbody2 & Link & Link2 & Link3 & Link4 & strbody3

to:
.HTMLBody = dear & strbody1 & strbody2 & Link & Link2 & Link3 & Link4 & strbody3 & RangetoHTML(rng)

-this is where it only creates the html email with only the portion that is the range.

Still stumped...