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

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
871
Office Version
  1. 365
Platform
  1. Windows
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 :)

VBA Code:
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
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
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")
 
Upvote 0
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??

VBA Code:
 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
 
Upvote 0
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
 
Upvote 0
How about adding this to the output?

Code:
OutputRange.Cells(1).PasteSpecial xlPasteAll
 
Upvote 0
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.

 
Upvote 0

Forum statistics

Threads
1,213,560
Messages
6,114,306
Members
448,564
Latest member
ED38

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