Excel 2010, Email from Excel, Pull cell from sheet and use in HTMLBody

[tberish]

This project uses a sheet called DATA and parses like email addresses, grabs columns, adds values, then sends an email to the email address of a table of those values. Additionally, it allows user inputs for custom commenting with in the email. The only problem is that there is no Refundee name at the top of the email and I cant figure out how to do it. I did not write it. I inherited it and I am not competent.

Here are the macros: (modules1)



Function Border()


Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Function


Function Sort(ShNm, St_Rg, Rg, odr)

Sheets(ShNm).Activate
ActiveWorkbook.Worksheets(ShNm).Sort.SortFields.Clear

If odr = "a" Then
ActiveWorkbook.Worksheets(ShNm).Sort.SortFields.Add Key:=Range(St_Rg), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Else
ActiveWorkbook.Worksheets(ShNm).Sort.SortFields.Add Key:=Range(St_Rg), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End If

With ActiveWorkbook.Worksheets(ShNm).Sort
.SetRange Range(Rg)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End Function


Function Mail_HTML_With_TABLE_Outlook(Email_Send_Id, k, Sh_Nm, Attch)

Email_Send_Subject = Sheets("SETTINGS").Cells(4, 3)
Attch = Sheets("SETTINGS").Cells(16, 3)
Email_Send_Text1 = Replace(Sheets("SETTINGS").Cells(6, 3), Chr(10), "<br>")
Email_Send_Text2 = Replace(Sheets("SETTINGS").Cells(10, 3), Chr(10), "<br>")

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Dim rng As Range
Set rng = Nothing
Set rng = Sheets(Sh_Nm).Range("A1:G" & k).SpecialCells(xlCellTypeVisible)

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Email_Send_Id
.CC = Sheets("SETTINGS").Cells(12, 3)
.BCC = Sheets("SETTINGS").Cells(14, 3)
.Subject = Email_Send_Subject
.HTMLBody = Email_Send_Text1 & "<br>" & RangetoHTML(rng) & "<br>" & Email_Send_Text2
.Attachments.Add Attch
.Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End Function

Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 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 workbook to receive the data.
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 an .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 the RangetoHTML subroutine.
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.
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function



Another macro: Module2][/I]

Sub Email_Merge()

Application.StatusBar = "Macro Running...Please Wait..."
Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each Sh In Worksheets
If Sh.Name = "Temp" Or Sh.Name = "Data Sheet" Then
Sh.Delete
End If
Next


Sheets.Add().Name = "Temp"
Sheets("DATA").Select
Cells.Copy
Sheets("Temp").Select
ActiveSheet.Paste
Rows("1:4").Delete Shift:=xlUp
Rc = Sheets("Temp").UsedRange.Rows.Count + 20
Call Sort("Temp", "J2", "A2:J" & Rc, "a")

For i = 2 To Rc

If Sheets("Temp").Cells(i, 10) <> "" Then

If Sheets("Temp").Cells(i, 10) <> Sheets("Temp").Cells(i - 1, 10) Then

Sheets.Add().Name = "Data Sheet"
Sheets("Data Sheet").Cells(1, 1) = "DATE"
Sheets("Data Sheet").Cells(1, 2) = "DOCKET #"
Sheets("Data Sheet").Cells(1, 3) = "CASE DESCRIPTION"
Sheets("Data Sheet").Cells(1, 4) = "REFUND"
Sheets("Data Sheet").Cells(1, 5) = "ESCROW"
Sheets("Data Sheet").Cells(1, 6) = "BOND"
Sheets("Data Sheet").Cells(1, 7) = "TOTAL"
k = 2
Tot = 0

Sheets("Data Sheet").Select
ActiveWindow.DisplayGridlines = False
Range("A1:G1").Select
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
Cells.Select
Cells.EntireColumn.AutoFit
Columns("D:G").NumberFormat = _
"_-[$$-409]* #,##0.00_ ;_-[$$-409]* -#,##0.00 ;_-[$$-409]* ""-""??_ ;_-@_ "
Columns("A:A").NumberFormat = "m/d/yyyy"

Columns("B:B").ColumnWidth = 12.43
Columns("A:A").ColumnWidth = 11.14
Columns("C:C").ColumnWidth = 55.86
Columns("D:G").ColumnWidth = 11.43
Columns("A:C").HorizontalAlignment = xlLeft


End If

Sheets("Data Sheet").Cells(k, 1) = Sheets("Temp").Cells(i, 2)
Sheets("Data Sheet").Cells(k, 2) = Sheets("Temp").Cells(i, 3)
Sheets("Data Sheet").Cells(k, 3) = Sheets("Temp").Cells(i, 4)
Sheets("Data Sheet").Cells(k, 4) = Sheets("Temp").Cells(i, 5)
Sheets("Data Sheet").Cells(k, 5) = Sheets("Temp").Cells(i, 6)
Sheets("Data Sheet").Cells(k, 6) = Sheets("Temp").Cells(i, 7)
Sheets("Data Sheet").Cells(k, 7) = Sheets("Temp").Cells(i, 5) + Sheets("Temp").Cells(i, 6) + Sheets("Temp").Cells(i, 7)
Tot = Tot + Sheets("Data Sheet").Cells(k, 7)
k = k + 1

If Sheets("Temp").Cells(i, 10) <> Sheets("Temp").Cells(i + 1, 10) Then

Sheets("Data Sheet").Select
Range("A1:G" & k).Select
Call Border

Sheets("Data Sheet").Cells(k, 1) = "Total"
Sheets("Data Sheet").Cells(k, 7) = Tot
Rows(k & ":" & k).Font.Bold = True
Range("A1").Select

Email_Send_Id = Sheets("Temp").Cells(i, 10)
If Email_Send_Id <> "" Then
Call Mail_HTML_With_TABLE_Outlook(Email_Send_Id, k, "Data Sheet", Attch)
End If

Sheets("Data Sheet").Delete

End If
End If

Next
Application.StatusBar = ""
MsgBox "Execution Completed"

End Sub

Sub Select_Attachment()

Dim lngCount As Long
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
For lngCount = 1 To .SelectedItems.Count
filePath = .SelectedItems(lngCount)

Next lngCount
End With

Sheets("SETTINGS").Cells(16, 3) = filePath

End Sub


Here is a short list of data:

MONTHLY ALLOCATED FEES
REFUND


ID DATE DOCKET # CASE DESCRIPTION REFUND ESCROW BOND REFUNDEE EMAIL ADDRESS
266 9/22/2006 CT-001752-05 HOWARD JOHNSON INTL VS MABRA HOLYFIELD $138.50 WILLIAM SCHWARZSCHILD III tberish@live.com
901 03062012 CT-002965-11 HSBC BANK NEVADA NA VS CHARLES WALKER $107.75 RON CUNNINGHAM tberish@fedex.com
901 03152012 CT-003007-10 PORTFOLIO RECOVERY ASSOC VS CHARLISE RUTHERFORD $98.25 RON CUNNINGHAM tberish@fedex.com
901 12172012 CT-001568-11 GMAC INC VS ROBERT RAIFORD $308.50 RON CUNNINGHAM tberish@fedex.com
901 CT-001876-10 HSBC MORTGAGE SERVICES INC VS STEPHEN MILLER $37.00 RON CUNNINGHAM tberish@fedex.com
2000 01312012 CT-002403-09 BRENDA GREENE VS KAZ USA INC $61.50 SIDNEY GILREATH tberish@live.com
2542 10222012 CT-001605-09 ROBERT FABIAN VS FULMER HELMETS $286.50 JAMES STRANCH III t_berish@hotmail.com
2777 11022012 CT-002046-12 SYLVAN PEURSUM VS PHILIP BOLLHEIMER JR $286.50 BART DURHAM tberishjr@yahoo.com
4166 04022012 CT-005339-09 JANIE SCRUGGS VS ST FRANCES HOSPITAL $136.25 DAVID WADE tberish@gmail.com
4166 08212012 CT-005282-09 MELISSA OAKS VS ROBERT SEGAL M.D. $286.50 DAVID WADE tberish@gmail.com

Here is the output email

Please find the details below.

DATE DOCKET # CASE DESCRIPTION REFUND ESCROW BOND TOTAL
3/6/2012 CT-002965-11 HSBC BANK NEVADA NA VS CHARLES WALKER $ 107.75 $ 107.75
3/15/2012 CT-003007-10 PORTFOLIO RECOVERY ASSOC VS CHARLISE RUTHERFORD $ 98.25 $ 98.25
12/17/2012 CT-001568-11 GMAC INC VS ROBERT RAIFORD $ 308.50 $ 308.50
CT-001876-10 HSBC MORTGAGE SERVICES INC VS STEPHEN MILLER $ 37.00 $ 37.00
Total $ 551.50


Regards
Thomas


What I want is to include the Refundee at the top of the email (httpbody)