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

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
738
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

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

Bobjg

New Member
Joined
Dec 11, 2019
Messages
24
Office Version
  1. 365
Platform
  1. Windows
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

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

willow1985

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

New Member
Joined
Dec 11, 2019
Messages
24
Office Version
  1. 365
Platform
  1. Windows
How about adding this to the output?

Code:
OutputRange.Cells(1).PasteSpecial xlPasteAll
 

daverunt

Well-known Member
Joined
Jul 9, 2009
Messages
1,894
Office Version
  1. 2013
Platform
  1. Windows
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.

 

Forum statistics

Threads
1,143,839
Messages
5,721,093
Members
422,339
Latest member
SHIVATVM

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
Top