Hi

I am using the following code what I was able to use of from Ron de Bruin's
web site to email selected information on an Excel sheet.
The problem is, with the selected information there are a logo of our
company that should be on the mail as well but on the mail where the logo
should be is a box with a cross. I have tried to embed the picture, but in
Excel you are unable to embed a picture.
I have checked, when the .htm file are created the logo is still fine. It
looks like when the information is read into RangetoHTML the logo is replaced
with the box with cross marking. Can someone please give me advice or a code
that can help to fix this problem?

Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) _
As Long

Sub Mail_Selection_Outlook_Body()
Dim source As Range
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

Set source = Nothing
On Error Resume Next
Set source = Selection
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
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Collateral Calculation"
.HTMLBody = RangetoHTML
.Display
End With

Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

Public Function RangetoHTML()
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim Buffer As String * 100
Dim BuffLen As Long

BuffLen = 100
GetUserName Buffer, BuffLen
UserName = Left(Buffer, BuffLen - 1)

TempFile = "C:\WINNT\profiles\" & UserName & "\Local settings\Temp\" &
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
source:=Selection.Address, _
HtmlType:=xlHtmlStatic)
.Publish (False)
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

Thanks
Bob

Hi Bob

This is only possible when you use 2002 or 2003
See
http://support.microsoft.com/default...b;en-us;816644

--
Regards Ron De Bruin
http://www.rondebruin.nl



"Bob" wrote in message ...
Hi

I am using the following code what I was able to use of from Ron de Bruin's
web site to email selected information on an Excel sheet.
The problem is, with the selected information there are a logo of our
company that should be on the mail as well but on the mail where the logo
should be is a box with a cross. I have tried to embed the picture, but in
Excel you are unable to embed a picture.
I have checked, when the .htm file are created the logo is still fine. It
looks like when the information is read into RangetoHTML the logo is replaced
with the box with cross marking. Can someone please give me advice or a code
that can help to fix this problem?

Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) _
As Long

Sub Mail_Selection_Outlook_Body()
Dim source As Range
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

Set source = Nothing
On Error Resume Next
Set source = Selection
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
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Collateral Calculation"
.HTMLBody = RangetoHTML
.Display
End With

Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

Public Function RangetoHTML()
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim Buffer As String * 100
Dim BuffLen As Long

BuffLen = 100
GetUserName Buffer, BuffLen
UserName = Left(Buffer, BuffLen - 1)

TempFile = "C:\WINNT\profiles\" & UserName & "\Local settings\Temp\" &
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
source:=Selection.Address, _
HtmlType:=xlHtmlStatic)
.Publish (False)
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

Thanks
Bob