Transfer Hyperlinks in Excel Range to Outlook Email - excel

I am trying to create an email from excel ranges (rng 1 through 6) that have hyperlinks for each cell in Columns A and D. Here is an example of the code that creates the hyperlinks for these ranges. That all works just fine.
ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("A" & D2), _
Address:="some address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value
ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("D" & D2), _
Address:="some other address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value
I then have the below code that creates an email from the excel ranges (rng1 through 6). When the email is created the hyperlinks do not transfer to Outlook. The text is underlined as if there is a hyperlink but it is not clickable.
Sub Mail_Body()
Dim rng1 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim wb2 As Workbook
Dim MyDate, Weeknr, MyFileName, MyTime, MyMonth
Dim Mail1 As String
Dim Mail2 As String
Dim Subject As String
Dim Warr As String
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim Subject_email As String
Application.ScreenUpdating = False
Application.EnableEvents = False
nPath = Environ("temp") & "\" & ThisWorkbook.Sheets("Lists").Range("AA1").Value
Set wb2 = Workbooks.Open(nPath)
D2 = Sheets("Critical").Range("A1").Offset(Sheets("Critical").Rows.Count - 1, 0).End(xlUp).Row
D3 = Sheets("High").Range("A1").Offset(Sheets("High").Rows.Count - 1, 0).End(xlUp).Row
D4 = Sheets("Low").Range("A1").Offset(Sheets("Low").Rows.Count - 1, 0).End(xlUp).Row
D5 = Sheets("Other").Range("A1").Offset(Sheets("Other").Rows.Count - 1, 0).End(xlUp).Row
D6 = Sheets("Overdue").Range("A1").Offset(Sheets("Overdue").Rows.Count - 1, 0).End(xlUp).Row
Set rng = Nothing
Set rng1 = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set rng4 = Nothing
Set rng5 = Nothing
Set rng6 = Nothing
Set rng2 = Sheets("Critical").Range("A1:J" & D2).SpecialCells(xlCellTypeVisible)
Set rng3 = Sheets("High").Range("A1:J" & D3).SpecialCells(xlCellTypeVisible)
Set rng4 = Sheets("Low").Range("A1:J" & D4).SpecialCells(xlCellTypeVisible)
Set rng5 = Sheets("Other").Range("A1:J" & D5).SpecialCells(xlCellTypeVisible)
Set rng6 = Sheets("Overdue").Range("A1:L" & D6).SpecialCells(xlCellTypeVisible)
Set OutMail = Nothing
Set OutApp = Nothing
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
'MsgBox OutApp
Set OutMail = OutApp.CreateItem(0)
Dim Session As Object
Set Session = OutApp.GetNamespace("MAPI")
Session.Logon
Create email
With OutMail
.To = Mail1
.CC = Mail2
.BCC = ""
.Subject = Subject_email
.HTMLBody = "Overview:" & "<br>" & RangetoHTML(rng1) _
& "<br>" & "<u>Critical</u>" & "<br>" & RangetoHTML(rng2) & "<br>" & "<u>High</u>" _
& "<br>" & RangetoHTML(rng3) & "<br>" & "<u>Low</u>" & "<br>" & RangetoHTML(rng4) _
& "<br>" & "<u>Other</u>" & "<br>" & RangetoHTML(rng5) _
& "<br>" & "<u>Overdue</u>" & "<br>" & RangetoHTML(rng6)
.Attachments.Add nPath '.FullName
.Recipients.ResolveAll
.Display '.Send
End With
I'm unable to share the output of this code, but what happens, as explained above, is the hyperlinks from the Excel sheet do not transfer to the Outlook email. They are blue and underlined but there is no hyperlink.
How do I carry over the active hyperlinks from excel to outlook? I've been unable to find a pre-existing solution that fits my specific needs.

I found a solution to the issue: https://www.mrexcel.com/forum/excel-questions/560111-retain-hyperlinks-after-rangetohtml-paste-outlook.html
In the RangetoHTML function, change the .pastevalues to .pasteall and the hyperlinks will be copied over.
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
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 xlPasteAll, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).PasteSpecial xlPasteRowHeights
.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

Related

Only one message with HTML code in a loop is sent

Following Ron de Bruin's indications here, I created a VBA script to send each of my students an e-mail with their qualification. Each message contains text and a range with two rows and is composed in HTML format.
The routine seems to work using the .Display method of the Outmail object created in the script.
When I change .Display to .Send only the first message in the list is sent and, during tests, several times I had to close Outlook from the Task Manager because it is hung without closing. If I do this and run the script again, then the messages are sent and each receiver receives the message twice.
Here's a sample of the code:
Option Explicit
Sub GetLblAddress()
Dim wb As Workbook
Dim ws As Worksheet
Dim oLblRg As Range
On Error Resume Next
' Range C2:I2 contains labels of points earned in each exercise
Set oLblRg = Application.InputBox(Prompt:="Select labels in worksheet", _
Title:="SEND NOTES", _
Default:="C2:I2", _
Type:=8)
'Missing error trap yet!
Set ws = oLblRg.Parent
Set wb = ws.Parent
SendNotes wb, ws, oLblRg.Address
End Sub
Sub SendNotes(wb As Workbook, ws As Worksheet, sIniAd As String)
Const sSIGN As String = "<br><br>" & "Saludos" & "<br><br>" & "myname here"
Dim wsList As Worksheet
Dim rng As Range
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.mailitem
Dim OutAccount As Outlook.Account
Dim mailAd As String
Dim rw, lstRw, nCol, numSend As Long
Dim sAd, s As String
Dim sTo, sSubj, sBody As String
Dim bSend As Boolean
On Error GoTo CleanUp:
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'worksheet "Listado" contains e-mail addresses in column H
Set wsList = wb.Worksheets("Listado")
With ws
If .Range(sIniAd).Rows.Count <> 1 Or Left(.Range(sIniAd)(1, 1), 1) <> "P" Then
Err.Raise 1
End If
End With
lstRw = ws.Cells(Rows.Count, 1).End(xlUp).Row
'Here begins loop that runs through the range of qualifications
'and send the corresponding row to each student present in the exam
numSend = 0
Application.StatusBar = "Creando instancia de Outlook." 'Just to keep me informed
Set OutApp = CreateObject("Outlook.Application")
Set OutAccount = OutApp.Session.Accounts("MyAddress#gmail.com")
For rw = 3 To lstRw
bSend = False
With ws
nCol = .Range(sIniAd).Columns.Count + 2
sAd = sIniAd & "," & .Cells(rw, 3).Address & ":" & .Cells(rw, nCol).Address
'Range rng contains two rows: labels and marks
Set rng = .Range(sAd)
sTo = wsList.Cells(rw, 8) 'Mail address of the student
sSubj = "Notas del Examen"
sBody = "Hola." & "<br><br>" & "Tu calificación en el examen es:" & "<br><br>"
'Set boolean variable bSend to know wether send a message
bSend = IsNumeric(.Cells(rw, 3)) And UCase(.Cells(rw, 10).Value) = "NO" And sTo <> vbNullString
End With
'Here's the "meat"
If bSend Then
Set OutMail = OutApp.CreateItem(olmailitem)
With OutMail
.To = sTo
.Subject = sSubj
.HTMLBody = sBody & RangetoHTML(rng) & sSIGN
.SendUsingAccount = OutAccount
.Display 'or use .SEND
End With
numSend = numSend + 1
'Sets the "Send" state to Yes
ws.Cells(rw, 10) = "SI"
End If
'Report advance of script into the status bar
Application.StatusBar = "Procesando: " & rw - 2 & "/" & lstRw - 2 & " (" & Format((rw - 2) / (lstRw - 2), "0%") & ")."
Next rw
CleanUp:
Application.StatusBar = False
Application.CutCopyMode = False
Set OutMail = Nothing
Set OutApp = Nothing
Set ws = Nothing
Set wsList = Nothing
If Err.Number <> 0 Then
If Err.Number = 1 Then
MsgBox "Debe seleccionar sólo la fila de ETIQUETAS", vbExclamation, "SEND NOTES"
ElseIf rng Is Nothing Then
MsgBox "No hay un rango seleccionado o la hoja está protegida," & _
vbNewLine & "corregir e intentar nuevamente.", vbExclamation, "SEND NOTES"
Else
MsgBox Err.Description, vbExclamation, "SEND NOTES"
End If
ElseIf numSend = 0 Then
MsgBox "No se han enviado mensajes.", vbInformation, "SEND NOTES"
ElseIf numSend = 1 Then
MsgBox "Se ha enviado 1 mensaje.", vbInformation, "SEND NOTES"
Else
MsgBox "Se han enviado " & numSend & " mensajes.", vbInformation, "SEND NOTES"
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
'Extracted from http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
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).CurrentRegion.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
Alternative question: Is it possible to include HTML code in a message without using Outlook (something like what is suggested here)?

Reply the email in PST outlook that have same value in Excel file [ Same Value is Service Tag ]

I want to create automail that will reply the email in Outlook where located in PST file that have same subject in Excel.
Below is my excel file. I want to search email with same service tag #Column D
And reply with custom HTML body.
my problem now I cannot display my desired email and reply it.
Hope you all can help me.
Here is my code that I try.
Sub AutoMail()
'Find OOW_Request
Dim OOW As Workbook
Dim s As Workbook
For Each s In Workbooks
If Left(s.Name, 11) = "OOW Request" Then
Set OOW = Workbooks(s.Name)
End If
Next s
Dim rng As Range
Dim rngTilte As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim eBodyLast As String
Dim olNs As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim olReply As Object ' Reply
Dim olRecip As Recipient ' Add Recipient
OOW.Sheets("OOW_REQUEST").Select
lRow = OOW.Sheets("OOW_REQUEST").Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
If OOW.Sheets("OOW_REQUEST").Range("L" & i) = "" Then
Set rng = Nothing
Set rngTilte = Nothing
On Error Resume Next
Set rngTilte = OOW.Sheets("OOW_REQUEST").Range("D1:M1").SpecialCells(xlCellTypeVisible)
Set rng = OOW.Sheets("OOW_REQUEST").Range("D" & i & ":" & "M" & i). _
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 olNs = OutApp.GetNamespace("MAPI")
olNs.AddStore ("C:\Users\Ruzaini_Subri\Documents\Outlook Files\OOW.pst")
Set myTasks = olNs.Session.Folders.Item(2).items
For Each olMail In myTasks
If (InStr(1, olMail.Subject, "Cells(i, 4)", vbTextCompare) > 0) Then
' toList = Cells(i, 8)
' eSubject = "yOOW part requestz|| Part: " & Cells(i, 5) & " || TAG: " & Cells(i, 4)
eBody = "<BODY style=font-size:10pt;font-family:Arial><p>Hi " & Cells(i, 8) & "</p>" & _
"Please advise if you can support this OOW request by replying this email." & "<br><br></BODY>"
eBodyLast = "<BODY style=font-size:9pt;font-family:Arial><br><br>" & "<p>Thank You.</p>" & _
"<strong>---------------------------------------------------------------------</strong><br>" & _
"<span style=""color: #333399;""><strong>Ruzaini Subri</strong></span></BODY>"
On Error Resume Next
Set olReply = olMail.ReplyAll
Set olRecip = olReply.Recipients.Add("& Cells(i, 8) &") ' Recipient Address
olRecip.Type = olTo
olReply.HTMLBody = eBody & RangetoHTML(rngTilte) & RangetoHTML(rng) & eBodyLast & vbCrLf & olReply.HTMLBody
olReply.Display
'olReply.Send
On Error GoTo 0
End If
Next olMail
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set olMail = Nothing
Set OutApp = Nothing
Cells(i, 12) = "TBU"
End If
Next i
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=")
RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]> <![endif]-->", "")
'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
I solve this problem after search in internet
You can mapping Outlook folder ID in excel and refer it to find desired email.
Find Folder ID in Outlook
Sub Test()
Dim app As Outlook.Application
Dim nms As Outlook.Namespace
Dim fld As Outlook.Folder
Set app = GetObject(, "Outlook.Application")
Set nms = app.GetNamespace("MAPI")
Set fld = nms.PickFolder
Debug.Print "StoreID: " & fld.StoreID
Debug.Print "EntryID: " & fld.EntryID
Sheets("MACRO").Range("N10") = fld.StoreID
Sheets("MACRO").Range("N11") = fld.EntryID
Call MessageBoxTimer
End Sub
Use it in your code
Dim StoreID As Variant
Dim EntryID As Variant
StoreID = ws.Range("N1").Value
EntryID = ws.Range("N2").Value
For i = 2 To lRow
If OOW.Sheets("WORKING FILE").Range("W" & i) = "YES" And _
OOW.Sheets("WORKING FILE").Range("B" & i) = "Ruz" And _
OOW.Sheets("WORKING FILE").Range("Y" & i) = "" Then
Set rng = Nothing
Set rngTilte = Nothing
On Error Resume Next
Set rngTilte = OOW.Sheets("WORKING FILE").Range("D1:X1").SpecialCells(xlCellTypeVisible)
Set rng = OOW.Sheets("WORKING FILE").Range("D" & i & ":" & "X" & i). _
SpecialCells(xlCellTypeVisible)
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set olNs = OutApp.GetNamespace("MAPI")
Set Fldr = olNs.GetFolderFromID(EntryID, StoreID)
Set myTasks = Fldr.items

VBA - Copy Cell from Sheet into Outlook email

I am new to VBA and have created the following code that sends an email.
My question is how do i copy some cells from my excel sheet that I am currently using to be pasted inside the excel file?
Thanks,
Sub CIR_Save_Email()
Dim objoutlook As Object
Set objoutlook = CreateObject("outlook.application")
Dim objemail As Object
Set objemail = objoutlook.createitem(olmailitem)
Const olFormatHTML As Long = 2
emailbodymessage = "<HTML><BODY>Hi Team," & _
"<br><br>Attached is the Display's CIR for today<br><br>" & _
"<b>Brief overview of CIR</b><br><br>" & _
"<b>Purpose:</b> To get a snapshot of what your current inventory levels by SKU are every day." & _
"<ul style=""list-style-type:circle"">" & _
"<li><b>Unrestricted QTY</b> The total inventory at that DC (i.e.Deliveries Created + Available Qty)</li>" & _
"<li><b>Deliveries Created:</b> Orders that are being processing at that DC (i.e. they will NOT be included in Available Inventory)</li>" & _
"<li><b>Available:</b> How many cases are available to use at that DC </li>" & _
"<li><b>Avail DOS:</b> How many DOS the available cases equate to</li>" & _
"<li><b>IT QTY:</b> How man cases are in transit</li>" & _
"<li><b>Avail +IT DOS:</b> How many DOS the available cases equate to</li>" & _
"</ul> </body> </html>"
emailbodymessage2 = "<html><body><ul style=""list-style-type:circle"">" & _
"<li><b>Future Available:</b> The total DOS of cases Avail + IT</li>" & _
"<li><b>QI QTY:</b> How many cases are on Qualitiy (ie Non-Conformance)</li>" & _
"<li><b>Blocked QTY:</b> How many cases are blocked from ordering due to damages, short dating, expired, etc." & _
"<li><b>CM- months:</b> The forecasts of the months past (CM-1=July)</li>" & _
"<li><b>% to Fcst:</b> How much of your projected forecast has shipped this month</li>" & _
"<li><b>Current SNAP Fcst:</b> This month's projected forecast</li>" & _
"<li><b>CM+ months:</b> The forecasts of the months moving forward (CM+1= September)</li>" & _
"</ul> </body></html>"
With objemail
.To = emaillist
.cc = ""
.Subject = "Display's CIR " & Date
.BodyFormat = olFormatHTML '// 2
.HTMLBody = emailbodymessage & emailbodymessage2
.display
End With
End Sub
You can use the following function (internally uses exporting range into HTML) to convert excel range into html. Then resultant HTML should be included into your generated HTML body.
The function is exporting Range into HTML temporary created file and then strips content to only div (without surrounding HTML tags).
However, I'm not sure if formatting and other details will fit your requirements. Other solution is to construct HTML from cells manually, but it is much more work.
Usage: str = GetHtml("Sheet1","D4:E6")
Public Function GetHtml(ByVal sheetName As String, ByVal rangeName As String) As String
Dim fso As FileSystemObject
Dim fileName As String
Dim txtStream As TextStream
Dim html As String
Dim line As String
Dim readLines As Boolean
Set fso = New FileSystemObject
Dim rng As range
fileName = fso.GetSpecialFolder(2) & "\" & Replace(fso.GetTempName, ".tmp", ".html")
If fso.FileExists(fileName) Then
fso.DeleteFile fileName
End If
Set rng = Sheets(sheetName).range(rangeName)
ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, fileName:=fileName, Sheet:=rng.Worksheet.Name, Source:=rng.Address, HtmlType:=xlHtmlStatic).Publish
Set txtStream = fso.OpenTextFile(fileName, ForReading, False)
readLines = False
html = ""
Do While Not txtStream.AtEndOfStream
line = txtStream.ReadLine
If InStr(line, "<!--START OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then
readLines = True
End If
If readLines Then
html = html & vbCrLf & line
End If
If readLines And InStr(line, "<!--END OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then
readLines = False
End If
Loop
txtStream.Close
Set txtStream = Nothing
If fso.FileExists(fileName) Then
fso.DeleteFile fileName
End If
Set fso = Nothing
GetHtml = html
End Function
You said you want to 'copy some cells from my excel sheet that I am currently using to be pasted inside the excel file'. I think you man copy from Excel and paste into the body of an Email, right.
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("YourSheet").Range("D4: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 = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.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
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Comparing the Dates and Sending an Email

I want to send an automatic mail if two conditions are met
The user input date in Cell (17,2) is > than today's date in
Cell(22,2)'
When the value in Cell (B3) = "Operation_Support"
When the above two conditions are met then I want an automatic mail to shoot up.
Can this be done?
The code is given below..
Sub datesexcelvba()
Dim OutApp As Object
Dim OutMail As Object
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim rng As Range
Dim StrBody As String
StrBody = "This is line " & "<br>" & _
"This is line " & "<br>" & _
"This is line " & "<br><br><br>"
mydate1 = Cells(17, 2).Value
mydate2 = mydate1
datetoday1 = Cells(22, 2).Value
datetoday2 = datetoday1
If mydate2 > datetoday2 & Range("B3").Value = "Operation_Support" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With mymail
.To = "x"
'& ";" & "x"
.CC = ""
.BCC = ""
.Subject = "Test Mail"
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
End With
End If
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
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
tested your code and encountered some minor issues. Assuming your Function
RangetoHTML()
works fine, you need to change the following to lines
If mydate2 > datetoday2 & Range("B3").Value = "Operation_Support" Then
...
With mymail
...
The changes are the following: Replace the '&' with 'And' and 'mymail' with the Object you set above (in your case it is OutMail).
So your Sub would be:
Sub datesexcelvba()
Dim OutApp As Object
Dim OutMail As Object
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim rng As Range
Dim StrBody As String
StrBody = "This is line " & "<br>" & _
"This is line " & "<br>" & _
"This is line " & "<br><br><br>"
mydate1 = Cells(17, 2).Value
mydate2 = mydate1
datetoday1 = Cells(22, 2).Value
datetoday2 = datetoday1
If mydate2 > datetoday2 And Range("B3").Value = "Operation_Support" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "test#testing.com"
'& ";" & "x"
.CC = ""
.BCC = ""
.Subject = "Test Mail"
.HTMLBody = StrBody
'.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
End With
End If
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

VBA-Trouble with attaching cells into body of email(Outlook)

I am using excel 2003 and I am having trouble attaching cells onto the body of an email. I got some of the code off http://www.rondebruin.nl/mail/folder3/mail4.htm but it does not work for me. What happens to me is that a spreadsheet would pop up that has Not Peer Review on it and an error message saying "runtime error '1004' PasteSpecial method of Range class failed". Please provide assistance.
Below is the code (the code in bold is the error):
'' Creates Email
Sub Email_Click()
Dim sDate As Date
sDate = ThisWorkbook.Sheets("SheetA").Range("H4").Value
Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim tmp
Set olApp = New Outlook.Application
'' Location of email template
Set olMail = olApp.CreateItem(olMailItem)
ThisWorkbook.Worksheets("SheetB").Activate
Application.ActiveSheet.Columns("A:E").AutoFit
Dim totalRows As Integer
totalRows = Application.ActiveSheet.UsedRange.Rows.count
With olMail
'' Subject
.Subject = "Email"
.BodyFormat = olFormatHTML
.To = "emailsheet#gmail.com"
'' Body
.HTMLBody = RangetoHTML(Application.ActiveSheet.Range("A1:E" & totalRows))
.Display
End With
Set olMail = Nothing
Set olApp = Nothing
ThisWorkbook.Worksheets("Base Sheet").Activate
End Sub
Function RangetoHTML(rng As Range)
'' Changed by Ron de Bruin 28-Oct-2006
'' Working in Office 2000-2007
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
Replace the erronous line
.Cells(1).PasteSpecial Paste:=8
with
.Cells(1).PasteSpecial xlPasteColumnWidths, xlPasteSpecialOperationNone, False, False
Another possibility would be to write your own code generating the html, it's quite easy:
Public Sub
Dim crtRow as Integer
Dim crtCol as Integer
Dim tempBody as String
tempBody = "<table>" & vbNewline
For crtRow = 0 To maxRow
tempBody = tempBody & " <tr>" & vbNewline
For crtCol = 0 To maxCol
tempBody = tempBody & " <td>" & yourWorksheet.Cells(maxRow, maxCol).Value & "</td>" & vbNewline
Next crtCol
tempBody = tempBody & " </tr>" & vbNewline
Next crtRow
tempBody = "</table>" & vbNewline
yourEmail.HTMLBody = tempBody
End Sub
Sure, the format isn't copied this way. You would have to add it yourself though. And the rest of your email-message needs to be constructed as well.
hope that helps a bit out
regards
How about:
s = RangetoHTML(Application.ActiveSheet.Name & "$" & "A1:E" & totalRows)
Function RangetoHTML(rng As String)
''Reference: Microsoft ActiveX Data Objects x.x Library
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
strFile = Workbooks(1).FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
cn.Open strCon
rs.Open "SELECT * FROM [" & rng & "]", cn
s = "<table border=""1"" width=""100%""><tr><td>"
s = s & rs.GetString(, , "</td><td>", "</td></tr><tr><td>", " ")
s = s & "</td></tr></table>"
RangetoHTML = s
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Function

Resources