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

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
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

G
  • Question
Email from Excel query
Replies
0
Views
168
gmazza76
G
C
  • Question
VBA - Email specific range and attach Sheet1
Replies
4
Views
495
Clermont
C
A
  • Question
Ron de Bruin VBA
Replies
2
Views
986
Alexfoots
A
J
  • Question
Kill Temp File
Replies
1
Views
335
ExcelToDAX
E
J
  • Question
Outlook Hypperlink of fila in email body will not open
Replies
1
Views
434
josros60
J

Forum statistics

Threads
1,215,006
Messages
6,122,666
Members
449,091
Latest member
peppernaut

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