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
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 = "r...@debruin.nl"
.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
--
Regards Ron de Bruin
http://www.rondebruin.nl
"Alan Campbell" <acampb...@yahoo.com> wrote in message news:49a0f95f.04081...@posting.google.com...
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" <ronde...@kabelfoon.nl> wrote in message news:<embxxP7f...@tk2msftngp13.phx.gbl>...
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
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
"Ron de Bruin" <ronde...@kabelfoon.nl> wrote in message news:<u7#BTB#fEHA...@TK2MSFTNGP10.phx.gbl>...