Thanks a lot gmayor
excuse my naivety in VBA
I tried to include your code but I failed
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2017/9/12
Dim xRgSel As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim rng As Range
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng = Sheets("lists").Range("L8:P9").SpecialCells(xlCellTypeVisible)
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xRg = Range("k2:k10000")
Set xRgSel = Intersect(Target, xRg)
ActiveWorkbook.Save
If Not xRgSel Is Nothing Then
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.createitem(0)
'Copy and PasteSpecial a between worksheets
Worksheets("Sheet1").Range("A2").Copy
Worksheets("Sheet2").Range("A2").PasteSpecial Paste:=xlPasteFormulas
Target.Offset(, -10).Copy Worksheets("Lists").Range("L9")
Target.Offset(, -9).Copy Worksheets("Lists").Range("M9")
Target.Offset(, -8).Copy Worksheets("Lists").Range("N9")
Target.Offset(, -7).Copy Worksheets("Lists").Range("O9")
Target.Offset(, -4).Copy Worksheets("Lists").Range("P9")
Application.CutCopyMode = False
Sheets("Master").Activate
With xMailItem
.To = Target.Offset(, -6)
.cc = Target.Offset(, -5)
.Subject = "Request for Medical Report " & Target.Offset(, -9)
.HTMLBody = "<font size=""3"" face=""Times New Roman"" color=""Black"">" & "Dear " & Target.Offset(, -7) & "," _
& "<br>" _
& "<br>" _
& "<B>Greetings!</B>" _
& "<br>" _
& "<br>" _
& "Please be notified that the below-mentioned patient is requesting for a medical report;" & "</font>" _
& "<br>" _
& "<br>" _
& RangetoHTML(rng) _
& "<br>" _
& "<br>" _
& "Please feel free to contact me on " & "<B>1xxx</B>" & " or " & "<B>0xxxxxxx</B>" & " for assistance." _
& "<br>" _
& "<br>" _
& "<font size=""2"" face=""Calibri Light"" color=""red"">" & "<B> NOTE: PLEASE KEEP US INFORMED IF YOU ARE GOING ON LEAVE FOR MORE THAN 3 DAYS, SO THAT WE CAN AVOID ACCEPTING REQUESTS DURING THE SPAN.</B>" & "</font>" _
& "<br>" _
& "<br>" _
& "<B>Best Regards,</B>"
.Display
End With
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
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"
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
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
Capture1.JPG
Capture2.JPG
this the code I am using now and an image from the excel
its working perfectly
I have two issues in it
first the signature is not included
second the table when its displayed the lower lines are missing