Retain hyperlinks after rangetohtml paste Outlook?

H

Human_doing

Board Regular
Joined
Feb 16, 2011
Messages
137
Hi all,

Can anyone help with an amendment to the below code to retain hyperlinks in an email generated using VBA, namely the RangetoHTML function? I am able to get the necessary range to paste to an email but the column with hyperlinks is lost (they still show up as blue text but can't be clicked on).

Thanks

Code: 
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
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
.Cells(1).PasteSpecial xlValues
.Cells(1).PasteSpecial xlFormats
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
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 x:publishsource=", _
"align=left x:publishsource=")
 
'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
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Hi all,

can anyone please help with this issue, I'm looking to retain the hyperlink formatting of an Excel 2003 cell after it is placed in an Outlook 2003 email as part of rangetohtml function. I understand the issue may have to do with the following:

.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlValues
.Cells(1).PasteSpecial xlFormats

but am not sure how to resolve? It would make my code seem much more professional if the generated emails maintained the hyperlink format for the benefit of the users,

Many thanks



Code: 
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
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
.Cells(1).PasteSpecial xlValues
.Cells(1).PasteSpecial xlFormats
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
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 x:publishsource=", _
"align=left x:publishsource=")
 
'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
 
Upvote 0
Hi all,

I'm just giving this thread a bump in case anyone is able to help, as noted previously I'm trying to retain the hyperlinks in an email generated using the rangetohtml function, can anyone please assist? I am hoping it might only need literally one or two words changed in the code?

Thanks
 
Upvote 0
Hi,
I had the same problem and was searching for a solution. After having been searching high and low, I solved it myself and just want to share the solution to anyone alse having this problem:

In the RangeToHTML code add the following Dim statement:

Dim Hlink As Hyperlink

Further, add this code just before the publish code:

'Copy hyperlinks as well

For Each Hlink In rng.Hyperlinks
TempWB.Sheets(1).Hyperlinks.Add _
Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
Address:=Hlink.Address, _
TextToDisplay:=Hlink.TextToDisplay
​
Next Hlink

This works for me.

BR
 
Upvote 0
KDY said:
Hi,
I had the same problem and was searching for a solution. After having been searching high and low, I solved it myself and just want to share the solution to anyone alse having this problem:

In the RangeToHTML code add the following Dim statement:

Dim Hlink As Hyperlink

Further, add this code just before the publish code:

'Copy hyperlinks as well

For Each Hlink In rng.Hyperlinks
TempWB.Sheets(1).Hyperlinks.Add _
Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
Address:=Hlink.Address, _
TextToDisplay:=Hlink.TextToDisplay
​
Next Hlink

This works for me.

BR
Click to expand...


This works great the only modification I did is that I made the range relative.. here is my snippet of the code.
I shifted the row by 2 and the column by 2. This code works fine for me..

Code: 
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim Hlink As Hyperlink


    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'Copy hyperlinks as well
    For Each Hlink In rng.Hyperlinks
        'relativeRange = TempWB.Sheets(1).Range(Hlink.Range.Address)
        
        TempWB.Sheets(1).Hyperlinks.Add _
            Anchor:=Cells(Hlink.Range.Row - 2, Hlink.Range.Column - 2), _
            Address:=Hlink.Address, _
            TextToDisplay:=Hlink.TextToDisplay
    Next Hlink
 
    ' Publish the sheet to an .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 the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Upvote 0
I realise this is 4 years old but this was exactly what I was looking for !!@ My code generates a table layout with info and a links to other sites and stores it in the Clipboard for pasting as HTML into Mail Chimp newsletter and Wordpress blog.

I too had to make it relative as I had an offset of 1 column x 13 rows, Thank you both!

I had been using Ron's RangetoHTML code for ages, pasting info into emails etc so was familiar with it but couldn't get it to work with URL links! Thank you Pratikabu!!

Boris !



pratikabu said:
This works great the only modification I did is that I made the range relative.. here is my snippet of the code.
I shifted the row by 2 and the column by 2. This code works fine for me..

Code: 
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim Hlink As Hyperlink


    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'Copy hyperlinks as well
    For Each Hlink In rng.Hyperlinks
        'relativeRange = TempWB.Sheets(1).Range(Hlink.Range.Address)
        
        TempWB.Sheets(1).Hyperlinks.Add _
            Anchor:=Cells(Hlink.Range.Row - 2, Hlink.Range.Column - 2), _
            Address:=Hlink.Address, _
            TextToDisplay:=Hlink.TextToDisplay
    Next Hlink
 
    ' Publish the sheet to an .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 the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Compose Email VBA Help
Replies
1
Views
117
Logit
Logit
earthworm
  • Question Question
Autofit table in Outlook upon copying from Excel sheet using Macro
Replies
1
Views
210
KOKOSEK
KOKOSEK
D
  • Solved
VBA to paste table into Outlook
Replies
5
Views
816
Dani_LobP
D
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
726
Domenic
D
M
  • Question Question
Email file VBA - change attachment from excel to PDF?
Replies
2
Views
341
MOB
M

Forum statistics

Threads
1,224,522
Messages
6,179,292
Members
452,902
Latest member
Knuddeluff

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top