Help with VBA code - email data from Excel but keep hyperlinks

[willow1985]

I am using the below code to automatically e-mail data to select employee's
What this code does is copy the data from Sheet "Automatic Emails" columns A: I and put that data in an e-mail
column J is the e-mail addresses for all the recipiants, Q1 is the Subject and Q2 the message that accompanies the data in A:I etc

In order to keep the formats correct a Function is used to create a temp file.

Now the data in Column A contains hyperlinks. Is there a way to keep the hyperlinks in the e-mail?

Thank you to anyone who can help

Sub sendmail()
  Dim OutlookApp As Object, MItem As Object, cad As String
  Dim i As Long, sh As Worksheet, rng As Range, lr As Long
 
  Set sh = Sheets("Automatic Emails")
  lr = sh.Range("A" & Rows.Count).End(xlUp).Row
  Set rng = sh.Range("A1:I" & lr)
  For i = 2 To lr
    cad = cad & sh.Range("J" & i).Value & "; "
  Next
  Set OutlookApp = CreateObject("Outlook.Application")
  Set MItem = OutlookApp.CreateItem(0)
  With MItem
    .to = cad
    .Subject = sh.Range("Q1").Value
    .htmlBody = sh.Range("Q2").Value & RangetoHTML(rng) & _
      "<br>[This is an Automated Message - Do not reply]<br>" & _
      "CAPA Log"
    .Display
    .Send
  End With
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 paste the data in
    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

    '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

 

[Bobjg]

Have you tried adding something like this to your code:
ActiveSheet.PasteSpecial xlPasteAll

I found an example of a similar request and this solution seemed to work. You would have to adjust the basics:
Sheets("Sheet1").Range("J19:K100").SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Sheet2").Range("C5")

 

[willow1985]

I am not too sure what you mean? I got this code from a Member on this site and I think what has to be modified is in the Function but am not sure....

Possibly in this section??

 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

 

[willow1985]

I found a work around. I added a column that references the hyperlink as text and replaces blanks with %20 so it is recognized as a link.

I still am curious of a possible modification but if not it is ok as I found a solution.

Thank you

Carla

 

[Bobjg]

How about adding this to the output?

Code:
OutputRange.Cells(1).PasteSpecial xlPasteAll

 

[daverunt]

Hi,

there's a modification the Ron De Bruins RangetoHTML from that preserves hyperlinks posted by KDY on this board.
Might do what you want.

Retain hyperlinks after rangetohtml paste Outlook?

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...

www.mrexcel.com