Code problem emailing range as html in Outlook body

[Alan Campbell]

I am at a loss as to why the code below crashes when it gets to the
".publish" line in the function. This code is a modification of
coding from Ron de Bruin's site (Thanks Ron!). I have inserted range
names, etc. as needed to fit the workbook I am coding. I will let you
all know that I am a "Novice" in every sense of the word, so I would
greatly appreciate any assistance in solving this problem. Please
ignore any debris in the middle of the code; I was trying ideas I
could find. Thanks in a advance.

Alan

Private Sub CommandButton2_Click()
'Sub Mail_Selection_Outlook_Body() 'You must add a reference to the
Microsoft outlook Library'Is not working in Office 97
Dim source As Range
Dim dest As Workbook
Dim myshape As Shape
Dim OutApp As Object
Dim OutMail As Object
'Dim OutApp As Outlook.Application
'Dim OutMail As Outlook.MailItem
Set source = Nothing
On Error Resume Next
Set source = ActiveWorkbook.ActiveSheet.Range("Print_Form") '
Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If source Is Nothing Then
MsgBox "The selection is not a range or the sheet is protect"
& _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
'If ActiveWindow.SelectedSheets.Count > 1 Or _
' Selection.Cells.Count = 1 Or _
' Selection.Areas.Count > 1 Then
' MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
' "You have more than one sheet selected." & vbNewLine &
_
' "You only selected one cell." & vbNewLine & _
' "You selected more than one area." & vbNewLine &
vbNewLine & _
' "Please correct and try again.", vbOKOnly
' Exit Sub
'End If
Application.ScreenUpdating = False
ActiveSheet.Copy
Set dest = ActiveWorkbook
For Each myshape In dest.Sheets(1).Shapes
myshape.Delete
Next
Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(olMailItem)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML() 'CreateWebPage()
'.Send 'or use
.Display
End With
'dest.Close = False
Set OutMail = Nothing
Set OutApp = Nothing
Set dest = Nothing
Application.ScreenUpdating = True
End Sub
Public Function RangetoHTML()
' You can't use this function in Excel 97
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim filename As String
'Dim sam As Object
Set wks = ActiveWorkbook.ActiveSheet
TempFile = Environ$("temp") & "vouch_tmp.htm"
'Dim filename As String, sam As Object
'Dim Rng As Range
'Set Rgn = "Print_Form"
'TempFile = "C:\Temp\" & "vouch_tmp.htm"
'Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects.Add( _
xlSourceRange, _
TempFile, _
wks.Name, _
"Print_Form", _
xlHtmlStatic)
.Publish True
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function

 

[Ron de Bruin]

Hi Alan

Try this

Sub Mail_Selection_Outlook_Body()
'Is not working in Office 97
Dim source As Range
Dim dest As Workbook
Dim myshape As Shape
Dim OutApp As Object
Dim OutMail As Object

Set source = Nothing
On Error Resume Next
Set source = Range("Print_Form").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If source Is Nothing Then
MsgBox "The selection is not a range or the sheet is protect" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

Application.ScreenUpdating = False
ActiveSheet.Copy
Set dest = ActiveWorkbook
For Each myshape In dest.Sheets(1).Shapes
myshape.Delete
Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML
.send 'or use .Display
End With
dest.Close False
Set OutMail = Nothing
Set OutApp = Nothing
Set dest = Nothing
Application.ScreenUpdating = True
End Sub


Function RangetoHTML()
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
source:=Range("Print_Form").Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function

 

[Alan Campbell]

Ron,

Worked like a charm. Thanks for your help. I looked over the
differences rather quickly. Was the problem in my "set source" line?
Thanks again.

Alan

 

[Ron de Bruin]

Hi Alan

The example on my site is for the selection
In the original function on my site I use
source:=Selection.Address

In your situation you are not sending the selection but
a named range.

I changed this to
Range("Print_Form").Address

 

[Alan Campbell]

Ron,

All is working well with the changes... generally. However, when the
document gets embedded in to the email body, some of the cell data and
formatting is missing. Any toughts?? Thanks again.

Alan