Email Body & HTMLBody From Excel

[Darrell Lankford]

I have setup an excel workbook that inserts a range into an HTML format
email (Thanks to Ron de Bruin's:
http://www.rondebruin.nl/mail/folder3/mail4.htm). The problem I'm
having is what code to insert a text at the begining before the range
inserted in the email such as...
*********************************
To whom it may concern,

See the following:

Thank you
*********************************
Does anyone know what code to put in that puts text before the cells
inserted in the email when using the .HTMLBody format?

Darrell

 

[Ron de Bruin]

You can try this

.HTMLBody = "To whom it may concern,<br><br>" & _
"See the following:<br><br>" & _
"Thank you <br>" & RangetoHTML(sh, rng)

 

[Darrell Lankford]

When I use this:

.HTMLBody = "To whom it may concern,<br><br>" & _
"See the following:<br><br>" & _
"Thank you <br>" & RangetoHTML(sh, rng)

I get my signature, but no text or the range.

When I use this:
..HTMLBody = RangetoHTML(sh, rng)

I get the Range and no text. I tryed setting up the text as strbody
(setting up strbody as a string) & try this:
..HTMLBody = strbody & RangetoHTML(sh, rng)

and again, I get the range in the email & no text.

any other ideas?

Thanks,
Darrell

 

[Ron de Bruin]

Hi Darrell

Working OK here

Post the complete macro you use now

 

[Ron de Bruin]

Hi Darrell

I see that my suggestion only work in Excel 2003
Will look for a solution for Excel 2002

 

[Darrell Lankford]

Ron,
I really appreciate the help. I am using Excel 2003.
Thanks, Darrell


Sub E_Desc_file()

'EMAIL "A" SHEET ONLY WITH NO BUTTONS AND FORMULAS

Dim objOL As New Outlook.Application
Dim objMail As MailItem
Set objOL = New Outlook.Application
Set objMail = objOL.CreateItem(olMailItem)
Dim msg As String


i = Range("Discrepancies_Title").Text
j = Range("ShipName").Text
UN = Application.UserName


Sheets("discrepancies").Select
ActiveWindow.DisplayHeadings = False

Sheets(Array("Snapshot", "discrepancies")).Copy
ActiveWorkbook.SaveAs Filename:="M:\Stuff\" & i & ".xls",
FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False,
_
CreateBackup:=False


'DELETE OBJECTS
Application.DisplayAlerts = False
Sheets("discrepancies").Select
ActiveSheet.Shapes("Button 1").Select
Selection.Delete

Application.CommandBars("Control Toolbox").Visible = False
Application.CommandBars("Formatting").Visible = False
Application.CommandBars("Standard").Visible = False
Application.CommandBars("Forms").Visible = False
Application.DisplayStatusBar = False
ActiveWindow.DisplayHeadings = False

'PASTE DATA WITOUT FORMULAS
Application.Goto Reference:="Print_Area"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

'DELETE REQUIRED COLUMNS & ROWS & FILTER BLANKS
Sheets("discrepancies").Select
Selection.AutoFilter Field:=1, Criteria1:="="
Columns("D").Select
Selection.Delete Shift:=xlToLeft
Columns("F:G").Select
Selection.Delete Shift:=xlToLeft
Range("B4").Select


Dim sh As Worksheet
Dim rng As Range
Set sh = Sheets("discrepancies")
Set rng = sh.Range("Discrepancies")


'DELETE RANGE NAMES
For Each R In ActiveWorkbook.Names
R.Delete
Next R
Application.DisplayAlerts = False


ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1


ActiveWorkbook.Save
'ActiveWorkbook.Close

msg = "<H3><B>Dear Customer</B></H3>" & _
"Please visit this website to download the new
version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/"">Ron's Excel
Page</A>" & _
"<br><br><B>Thank you</B>"


'msg = "To whom it may concern:" & Chr(13) & Chr(13)
'msg = msg & "The following discrepancies have been noted in the CSSR
file for " & j & ". Please make any corrections to CostPoint or the
sequence log "
'msg = msg & "as necessary. Please acknowledge corrections or intended
corrections to discrepancies in your cognizance within 24 hours. Your
prompt attention to "
'msg = msg & "these issues is appreciated." & Chr(13)
'msg = msg & "Thanks," & Chr(13) & Chr(13)


Select Case UN
Case "DarrellL"
msg = msg & "Darrell"
Case "WillyM"
msg = msg & "Willy"
Case "AlanM"
msg = msg & "Allan"
Case Default
msg = msg & ""
End Select


addee = "CVN 65"
CC = "(e-mail address removed);[email protected];[email protected]"


With objMail
.To = addee
.CC = CC
.Subject = i
.Attachments.Add "M:\Stuff\" & i & ".xls"
'.Body = msg
.HTMLBody = msg & RangetoHTML(sh, rng)
.Display

ActiveWorkbook.Close


End With
Set objMail = Nothing
Set objOL = Nothing

Kill "M:\Stuff\" & i & ".xls"



End Sub


Public Function RangetoHTML(sh As Worksheet, rng As Range)
'Changed by Ron de Bruin 13-Sept-2006
' You can't use this function in Excel 97
Dim TempFile As String
Dim Nwb As Workbook
Dim fso As Object
Dim ts As Object

sh.Copy
Set Nwb = ActiveWorkbook



With Nwb.Sheets(1)
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

With Nwb.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=sh.Name, _
Source:=rng.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

Nwb.Close False

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
'PublishObjects align center so we change it to left
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=",
"align=left xublishsource=")

Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile
End Function

 

[acampbell012]

Darrell,

Not sure if your problem is solved. Here is some code I use to insert
text on either end of the range insertion. This has works in Excel 2000
and above.

.HTMLBody = "<br>" & "Text above Range insertion" & "<br><br>"
& _
RangetoHTML & "<br><br><br><br>" &
Application.Text(Range("Acct_1"), "###########") & _
"<br><br>" & Application.Text(Range("Acct_2"), "###########") &
"<br><br>" & _
"Text Below Range Insertion."


Hope this Helps.


Alan

 

[Ron de Bruin]

Strange it is working for me in 2003.

Normal I always copy the range/selection to another sheet below the info I want to send and
send this sheet in the bosy

Is this not a option
Easier to change the text and formatting

 

[Darrell Lankford]

Ron,

I think the problem is somewhere between the way I'm using your code
with some of my code to make the file move and change the sheets the
way I need it before it attaches it to the email.

I got it so I'm getting the text before the range, but it's not in the
code. I'm sure it would be better to put it in the code, but it works.
I inserted extra rows at the top of the range in the worksheet and
entered my text there. I then extended the range up to include the
text. I hide the rows with the email text and unhide the rows in the
code, so that the text is included in the email.

I really appreciate the assistance.
Thanks again,
Darrell

 

[Trefor]

Ron,

I am having a similar problem. I would like to add an HTM file PLUS an HTM
signature. Is this possible? I seem to just get the signature or nothing.


If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

With OutMail
.To = ETo
.CC = Ecc
.BCC = EBcc
.Subject = ESubject
If BodyFile = "" Then
.Body = EMsg
Else
.HTMLBody = GetBoiler(AppPath & "\" & BodyFile) & "<br><br>" &
Signature
End If
.Attachments.Add EAttach1
.Display
End With