Hyperlink not working using Range to HTML function - html

Using some VBA to grab a table of information and paste to the body of an email using range to html. The problem seems to be with the hyperlink, since the function is just grabbing it as text and formatting it accordingly. The vba i'm using is:
Sub Archive_Send()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody1 As Range
Dim StrBody As String
Dim StrBody1 As String
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Posting").Range("B5:C55").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rngTo = Sheets("Email").Range("C5")
Set rngSubject = Sheets("Email").Range("C3")
Set rngBody1 = Sheets("Email").Range("C13")
On Error Resume Next
With OutMail
.To = rngTo.Value
.Subject = rngSubject.Value
.HTMLBody = .HTMLBody & rngBody1.Value & "" _
& RangetoHTML(rng) _
& "<br><br>Best Regards,<br><br></font></span>"
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.ReferenceStyle = xlA1
End Sub
Function RangetoHTML(rng As Range)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy") & ".htm"
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
On Error GoTo 0
End With
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
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=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

The code rangetohtml works for me with hyperlinks just after making little change shown below:
Use .Cells(1).PasteSpecial xlPasteAll, , False, False
instead of line .Cells(1).PasteSpecial xlPastevalues, , False, False
Function re-written with said changes as below:
Function RangetoHTML(rng As Range)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteAll, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
On Error GoTo 0
End With
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
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=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Let me know if this solves your concern. :)

Related

HTML/VBA Auto-Email at a Specific Time

I am trying to get my VBA/HTML to automatically send emails at a specific time, however as the time I have it set to test at comes and goes, nothing happens. When I go to activate it manually, the debugger highlights the time value and says "invalid outside procedure". I am new to VBA and was wondering if anyone could help?
Application.OnTime TimeValue("14:31:00"), Procedure = "RangetoHTML"
Function RangetoHTML(rng As Range)
' Working in Office 2000-2016
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 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
Sub AutoEmail()
' You need to use this module with the RangetoHTML subroutine.
' Working in Office 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Sheets("emailtest").Range("A10:E39").SpecialCells(xlCellTypeVisible) ' Change this
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("C6").Value ' Change this to the email addresses you want to send to
.CC = ""
.BCC = ""
.Subject = Date & " " & "Daily MCAPS Part Update" ' Add in a subject
.HTMLBody = Range("C5").Value
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Your function Function RangetoHTML(rng As Range) needs a parameter. So, it must be passed when it is called. But I do not have the knowledge to be possible to directly send an object like parameter and you must make a kind of trick. The function parameter must be declared As String and the range address will be sent and the range will be built inside the function. Something like this:
Function RangetoHTML(rngAdd As String)
Dim rng As Range
Set rng = Range(rngAdd)
'then use it like you need
End Function
And the function will be called in this way:
Application.OnTime TimeValue("14:31:00"), "'RangetoHTML """ & rng.address & "'"

Keep Excel format when exporting data into Outlook template using VBA [duplicate]

The function of this code is to copy particular range of cells, each cell (having codes like 1ML-234-1R) and place it in the body of outlook mail (taken from Ron de Bruin Excel Automation code).
I want instead that the cells data goes into the subject of mail separated by comma (,) and does not leave any spaces before or after any cell data.
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Sheet1").Range("D1:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "faizanfarooque#hotmail.com"
.CC = ""
.BCC = ""
.Subject = "Load Shed "
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 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
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I am new to VBA and have tried Subject = RangetoHTML(rng) but it showed me this in the subject html xmlns:o="urn:schemas-microsoft-com:office:office"
OK then:
'.....
.Subject = RangeToCSV(rng)
'.....
Function:
Function RangeToCSV(rng)
Dim s, sep, c As Range
For Each c In rng.Cells
If c.Value <> "" Then
s = s & sep & c.Value
sep = ","
End If
Next c
RangeToCSV = s
End Function

Range To HTML removing part of the string [duplicate]

This question already has answers here:
How to keep formats when I copy a range from Excel to outlook
(2 answers)
Closed 3 years ago.
All,
I have been using the below code to generate an email which compiles a range into an HTML body of an email.
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lastrow As Long
Dim sht As Worksheet
Dim StrBody As String
Set rng = Nothing
Sheets("HTML Loop").Activate 'Change
Set sht = ActiveSheet
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Range
On Error Resume Next
Set rng = sht.Range("A1:A" & lastrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If sht.Range("A1").Value = "" Then
Exit Sub
End If
StrBody = "All," & "<br>" & "<br>" & _
"The Robot has completed its daily check of the FX3 Site and has created " & lastrow & " new folder location(s)." & "<br>" & "<br>" & _
"*Please review the files located here:"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Sean.B#xxx.co.uk"
.CC = ""
.BCC = ""
.Subject = "Daily FX3 Notification Email " & Now()
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & "<br>" & "<br>" & "Thanks" & "<br>" & "<br>" & "Gary"
.Display
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutA
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 past 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
The issue I am having is when the email is generated, the strings within the range is cut at 9 Characters long.
The range consists of file paths like the below:
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Bristol\TEST TEST 108 EastCott Hill
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Exeter\TEST TEST 108 EastCott Hill
I would like to understand why the output is like the screenshot attached.
All, this is a duplicate question the answer I was looking for can be found here:
How to keep formats when I copy a range from Excel to outlook
Specific Code:
TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
'.Cells(1).PasteSpecial xlPasteValues, , False, False
'.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

MS Access 2016 can't find my function / module

I'm still new to VBA, but I'm having an issue trying to automate some function. Namely, I can't seem to be able to run it in immediate (Ctrl+G), and when I try to call it in a Macro, I get the can't find the named function error.
It works when I run the code with no variables, like emailPaste(), and this code is taken from here: http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
I tried leaving it as emailPaste() and then calling the function in immediate/macro RunCode but still the same issue.
I have named the Module: EmailWithPaste
Current code:
Option Compare Database
Sub emailPaste(exFile As String, exSheet As String, EmailSubject As String, _
To_Field As String, Optional CC_Field As String)
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim ApXL As Object
Set ApXL = CreateObject("Excel.Application")
ApXL.Workbooks.Open (exFile)
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets(exSheet).Range("A1:D12").SpecialCells(xlCellTypeVisible)
'If rng Is Nothing Then
'MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
'Exit Sub
'End If
With ApXL.Application
.EnableEvents = False
.ScreenUpdating = False
End With
Call OpenOutlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = To_Field
.CC = CC_Field
.Subject = EmailSubject
.HTMLBody = RangetoHTML(rng)
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
On Error GoTo 0
With ApXL.Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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 xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
TempWB.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
Subs are either called without parentheses, or with the deprecated Call keyword. Only functions are called with parentheses, hence the Expected function or variable.
Also, RunCode runs functions, not subs.
An easy workaround is to change the code to be a function, even though it returns nothing:
Public Function emailPaste(exFile As String, exSheet As String, EmailSubject As String, _
To_Field As String, Optional CC_Field As String)
'The code
End Function
And, because it returns nothing, it still should be called as a sub in the immediate window:
emailPaste "C:\Users\KF\Desktop\TestExcelExport.xlsx","Sheet2","Test","test","cc"

Adjust column width in RangetoHTML for Outlook

I send emails automatically from Excel.
Sometimes the third column ends up completely at the right, outside the mail-window of the receiver (while I autofit the cells before I use RangetoHTML).
It seems that the width of the second column is set much wider or that the third column is set wider and aligned right.
The thing is that it doesn't happen every time. Adjusting the row heights is easily done but not the column width.
How do I keep the width formatting constant in RangetoHTML?
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim R As Long
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 xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a html 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
Try this
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
Cells(1).Select
Cells(1).EntireRow.AutoFit
Cells(1).EntireColumn.AutoFit
Try
On Error GoTo 0
End With
TempWB.Sheets(1).UsedRange.Columns.AutoFit