Copying text and hyperlinks from XL to Outlook

[Stef5063]

I am using Excel 2007 and Windows 7.

I wish to copy a range in excel, containing stock codes and hyperlinks, to the body of a message in Outlook 2007. I have code that works most of the time (see below), but the SendKeys command is unreliable. It sometimes takes several attempts to work. Is there VBA code that does the same job without using the SendKeys command?

My current prodedure is as follows:

Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem

Set OutlookApp = New Outlook.Application
Set MItem = OutlookApp.CreateItem(olMailItem)

Range("A1:A10").Copy ' copy range of stock codes and hyperlinks

With MItem
.display
Application.Wait Now + TimeValue("00:00:01")
Application.SendKeys "{TAB 4}", Wait:=True 'tab down to body in email
Application.Wait Now + TimeValue("00:00:01")
Application.SendKeys ("^v")
End With



Many thanks!
Stefan

 

[Andrew Poulsom]

Look here:

http://www.rondebruin.nl/mail/folder3/mail4.htm

 

[Stef5063]

Great! Thanks it works now. I had to modify the code a little i.e. replace the pastespecials with just paste, but here is the finished code for anyone who's interested:

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
Set rng = Sheets("Sheet1").Range("A1:A10").SpecialCells(xlCellTypeVisible)

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.display
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = RangetoHTML(rng)
.display ' or send
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub



Function RangetoHTML(rng As Range)

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 new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
ActiveSheet.Paste
Application.CutCopyMode = False
End With

'Publish the sheet to a 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 RangetoHTML
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 we used in this function
Kill TempFile

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