PDA

View Full Version : [SLEEPER:] Sending email from excel based on cell value


essasmj
05-28-2019, 02:29 AM
Hi

this is my first thread in the forum
I am trying to build an excel sheet to track reports
the columns will be
Date report requested//who need to make the report(reporter)// reporter email// send email for the reporter

in the send email only three values are there
Send email1 "send email in the first 24 hour"
Send email2 "send reminder email after 48 hours"
Send email3 "send reminder email after 72 hour"

I need once I select "Send email1" to automatically open the outlook with the email of the reporter with htmlbody of table containing the report name, deadline, reason for the report

I tried different codes but eather they work with any change in the sheet or they are not wroking



Received Date
Send Emails


27/05/19 08:03:15 PM
Send Email1


27/05/19 08:04:44 PM
Send Email2


28/05/19 10:16:59 AM
Send Email3




the other challenge for me is that the code was sending to the email in the first row even I didn't change any thing in it


for your help please
macropod
05-28-2019, 04:38 AM
Cross-posted at: https://www.mrexcel.com/forum/general-excel-discussion-other-questions/1099108-sending-email-excel-based-cell-value.html
Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3
essasmj
05-28-2019, 06:59 AM
This the code which I was using but it is sending email for any change in any cell in the row


Private Sub Worksheet_Change(ByVal Target As Range)
'If value in G1 is edited to be "Send Email" then send the email....
If Range("G1") = "Send Email" Then
With CreateObject("Outlook.Application").createitem(0) '0 will create a new email item
On Error GoTo ErrorHandler
.to = Target.Offset(, -2)
.cc = Target.Offset(, -1)
.Subject = "Request for Medical Report " & Target.Offset(, -5)
.HTMLBody = "<HTML><BODY><span style=""color:#80BFFF"">Font Color</span style=""color:#80BFFF""> _
<br>the <b>bold text</b> here.</br> <br><u>New line with underline</u></br><br><p _
style='font-family:calibri;font-size:25'>Font size</br></p></BODY></HTML>"
.Display 'Change this to .Send
End With
End If
ErrorHandler:
End Sub
essasmj
05-29-2019, 12:59 AM
This is the code which I am using now
Still I need to include some cells in the body and to fill the table from other cells but I still cant figure out how



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)
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(, -3) _
& "<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>1539</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




is there any way to make offset to work with HTML body
How to fill the table from the excel cells
gmayor
05-29-2019, 06:18 AM
Frankly I think you are making things difficult for yourself.

You can access the WordEditor Inspector to access the message body directly and write to it as you would to a Word document using VBA, by setting ranges and formatting those ranges as required. Copy the Excel range that you want to include to the clipboard and paste it to the message body where shown below.
You will notice that I have used Set xOutApp = OutlookApp() to start Outlook. This calls a function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm which opens Outlook correctly whether it is already open or not and ensures that the code works as intended.

Not having seen your worksheet I have only included the code for creating the message (which keeps the default signature associated with the account).



Set xOutApp = OutlookApp() Set xMailItem = xOutApp.createitem(0)
With xMailItem
.To = Target.Offset(, -6)
.cc = Target.Offset(, -5)
.Subject = "Request for Medical Report " & Target.Offset(, -9)
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
.Display 'essential
oRng.collapse 1 'set a range to the start of the message
With oRng
.Text = "Dear " & vbCr & vbCr & Target.Offset(, -3)
.Font.Size = 12
.Font.Name = "Times New Roman"
.Font.Color = &H0
.collapse 0
.Text = "Greetings!" * vbCr & vbCr
.Font.Bold = True
.collapse 0
.Font.Bold = False
.Text = "Please be notified that the below-mentioned patient is requesting for a medical report;" & vbCr & vbCr
.collapse 0
'Copy the Excel range
.Paste 'and paste it into the message
.collapse 0
.Text = vbCr & vbCr & "Please feel free to contact me on "
.Font.Size = 12
.Font.Name = "Times New Roman"
.Font.Color = &H0
.collapse 0
.Text = "1539"
.Font.Bold = True
.collapse 0
.Text = " or "
.Font.Bold = False
.collapse 0
.Text = "0xxxxxxx"
.Font.Bold = True
.collapse 0
.Text = " for assistance." & vbCr & vbCr
.Font.Bold = False
.collapse 0
.Text = "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."
.Font.Name = "Calibri Light"
.Font.Size = 14
.Font.Color = &HFF
.Font.Bold = True
.collapse 0
.Text = vbCr & vbCr & "Best Regards,"
.Font.Name = "Times New Roman"
.Font.Bold = False
.Font.Size = 12
.Font.Color = &H0
End With
End With
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
essasmj
05-29-2019, 08:49 AM
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











24299

24300


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
essasmj
05-29-2019, 11:16 AM
dear gmayor

I used your code
it work perfect in keeping the signature
I couldn't figure out how to copy the table


Private Sub Worksheet_Change(ByVal Target As Range)



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)


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)
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
.Display 'essential
oRng.collapse 1 'set a range to the start of the message

With oRng
.Text = "Dear " & Target.Offset(, -7) & "," & vbCr & vbCr
.Font.Size = 12
.Font.Name = "Times New Roman"
.Font.Color = &H0
.collapse 0
.Text = "Greetings!" & vbCr & vbCr
.Font.Bold = True
.collapse 0
.Font.Bold = False
.Text = "Please be notified that the below-mentioned patient is requesting for a medical report;" & vbCr & vbCr
.collapse 0
.Worksheets("Lists").Range("L8:P9").Copy
'Copy the Excel range
.Paste 'and paste it into the message
.collapse 0
.Text = vbCr & vbCr & "Please feel free to contact me on "
.Font.Size = 12
.Font.Name = "Times New Roman"
.Font.Color = &H0
.collapse 0
.Text = "1539"
.Font.Bold = True
.collapse 0
.Text = " or "
.Font.Bold = False
.collapse 0
.Text = "0xxxxxxx"
.Font.Bold = True
.collapse 0
.Text = " for assistance." & vbCr & vbCr
.Font.Bold = False
.collapse 0
.Text = "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."
.Font.Name = "Calibri Light"
.Font.Size = 12
.Font.Color = &HFF
.Font.Bold = True
.collapse 0
.Text = vbCr & vbCr & "Best Regards,"
.Font.Name = "Times New Roman"
.Font.Bold = False
.Font.Size = 12
.Font.Color = &H0

End With
End With

Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing

End If

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub




if you notice I used .Worksheets("Lists").Range("L8:P9").Copy
it didn't work

second observation that when I modified your code it works only if outlook is open and not if closed
gmayor
05-29-2019, 08:25 PM
Worksheets is not related to oRng so remove the period '.' from the start of the line

.Worksheets("Lists").Range("L8:P9").CopyBetter still copy the worksheet before the place where the message is created.
If it only works with Outlook running I would guess you didn't include the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm that the macro calls upon
essasmj
05-30-2019, 12:55 AM
Thanks a lot


It worked perfectly after removing '.'
also I added the code in rondebruin and now the outlook opens automatically
essasmj
05-30-2019, 12:56 AM
I need one more favor
I have two emails in my outlook the default that opens with the windows password and another one for reports
the one for reports is without password it appear in the right pane of outlook but not in the account setting (so I cant change it to be the default)
I used the code without benefit



Set .SendUsingAccount = OutApp.Session.Accounts.Item("email")
gmayor
05-30-2019, 04:40 AM
The following should work (though untested). Replace "Account Name" with the actual displayname of the account.


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range, xRG As Range
Dim xOutApp As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim xMailItem As Object
Dim oAccount 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
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
Set xOutApp = CreateObject("Outlook.Application")
For Each oAccount In xOutApp.Session.Accounts
If oAccount.DisplayName = "Account Name" Then
Set xMailItem = xOutApp.createitem(0)
With xMailItem
Set .SendUsingAccount = oAccount
.To = Target.Offset(, -6)
.cc = Target.Offset(, -5)
.Subject = "Request for Medical Report " & Target.Offset(, -9)
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
.Display 'essential
oRng.collapse 1 'set a range to the start of the message
With oRng
.Text = "Dear " & Target.Offset(, -7) & "," & vbCr & vbCr
.Font.Size = 12
.Font.Name = "Times New Roman"
.Font.Color = &H0
.collapse 0
.Text = "Greetings!" & vbCr & vbCr
.Font.Bold = True
.collapse 0
.Font.Bold = False
.Text = "Please be notified that the below-mentioned patient is requesting for a medical report;" & vbCr & vbCr
.collapse 0
Worksheets("Lists").Range("L8:P9").Copy
' Copy the Excel range
.Paste 'and paste it into the message
.collapse 0
.Text = vbCr & vbCr & "Please feel free to contact me on "
.Font.Size = 12
.Font.Name = "Times New Roman"
.Font.Color = &H0
.collapse 0
.Text = "1539"
.Font.Bold = True
.collapse 0
.Text = " or "
.Font.Bold = False
.collapse 0
.Text = "0xxxxxxx"
.Font.Bold = True
.collapse 0
.Text = " for assistance." & vbCr & vbCr
.Font.Bold = False
.collapse 0
.Text = "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."
.Font.Name = "Calibri Light"
.Font.Size = 12
.Font.Color = &HFF
.Font.Bold = True
.collapse 0
.Text = vbCr & vbCr & "Best Regards,"
.Font.Name = "Times New Roman"
.Font.Bold = False
.Font.Size = 12
.Font.Color = &H0
End With
End With
Exit For
End If
Next oAccount
End If
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
Set oAccount = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
essasmj
06-09-2019, 11:22 PM
Thanks gmayor for your continuous help
I tested it today, it didn't work
it still selects the main email

I couldn't figure out any solution