I currently have macros built that will execute when a cell value dips below a certain number. My issue, these are live prices, and that number will tick constantly, prompting the macro to run all day. Ideally this macro calls the email macro once a day, given the parameters are met.
This Excel file will sit on a computer that runs 24/7, so no issue in closing and re-opening.
Here is the code for both:
Private Sub Worksheet_Calculate()
If Range("C15").Value < 72 Then
Call Send_Email
End If
End Sub
Sub Send_Email()
Dim pApp As Object
Dim pMail As Object
Dim pBody As String
Dim rng As Range
Set rng = Range("B6:C16")
Set pApp = CreateObject("Outlook.Application")
Set pMail = pApp.CreateItem(0)
On Error Resume Next
With pMail
.To = "gmail.com"
.CC = ""
.BCC = ""
.Subject = "Account Action Price Notification"
.Body = "Hello, our recommended action price for BLANK of $72 has been hit." & vbNewLine & vbNewLine & _
"Thank you."
'Below displays the email and allows it to paste
.Display
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = pMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
'Copy the range in-place
rng.Copy
wdRange.Paste
'Below will auto send the email when apostrophe is removed
'.Send
End With
On Error GoTo 0
Set pMail = Nothing
Set pApp = Nothing
End Sub
I have tried working solutions from here: VBA Run Macro Once a Day
However, I am unable to get this to properly run.
Consider using a cell that logs/updates if the task has been done for the day. For example, populate the cell with a date and time after which the task may run. Then, as part of the code, include a validation if the time is past or not and escapes if it is not later. Once the time comes and the full code is permitted to run, use an additional line at the end to update the cell to the next date (and time, if desired).
Related
On W10. Been using VBA for 7/8 years now, but I am having a mind numbingly confusing question. Since I've been working with it, my colleagues and I have been sending out emaisl at around 06:00 so that when we get to work, 20/30 different sheets are kicked off and its using Application.OnTime. Now, I still see these getting kicked off, but on the very first sheet, whenever it goes to wEditor.Application.Selection.Paste it kicks off an error and says clipboard empty...
A couple of observations I noticed - this never happens in the day when I am online. My colleagues haven't experienced this. I can see the dashed box around the range which I am trying to copy?
Any suggestions would be greatly appreciated.
Sub EMAIL_PINEEHATempReserve()
On Error GoTo ErrorHandler
Dim mailApp, mail As Object
Dim olMailItem, wEditor, x, y As Variant
Dim ToEmailIDs, CCEmailIDs As String
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.CreateItem(olMailItem)
Dim wb As Workbook
Set wb = ThisWorkbook
wb.Activate
Sheets("Summary").Calculate
Sheets("Summary").Calculate
For Each x In Range("EmailListTO"): ToEmailIDs = ToEmailIDs & ";" & x.Value: Next x
For Each y In Range("EmailListCC"): CCEmailIDs = CCEmailIDs & ";" & y.Value: Next y
With mail
.To = ToEmailIDs
.CC = CCEmailIDs
.Subject = Range("Subject").Value
.Display
mailApp.ActiveInspector.WindowState = olMinimized
Set wEditor = mailApp.ActiveInspector.WordEditor
Range("ControlEmailRange").Copy
wEditor.Application.Selection.Paste
.Send
End With
Application.CutCopyMode = False
ErrorHandler:
ActiveWorkbook.Close False
End Sub
I'm trying to use VBA to paste a selected range from Excel to Outlook. I want to keep it under the same conversation with all the recipients.
I have seen some codes: Outlook Reply or ReplyAll to an Email
I am stuck with this code (Application.ActiveExplorer.Selection).
Any ideas how to do this?
This is the code I have when creating a new email instead of replying:
Sub a()
Dim r As Range
Set r = Range("B1:AC42")
r.Copy
'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
With outMail
.BodyFormat = olFormatHTML
.Display
'.HTMLBody = "write your email here" & "<br>" & .HTMLBody
.Subject = ""
.Attachments.Add ("path")
End With
'Paste picture
wordDoc.Range.Paste
For Each shp In wordDoc.InlineShapes
shp.ScaleHeight = 50 shp.ScaleWidth = 50
Next
End Sub
EDIT:
I noticed that your question was edited by another user and now the mention of your need for the email to be a reply-all email is gone. This was probably in order to make your question simpler, but now my answer won't make as much sense. My answer also assumes that you also already have the HTML code needed to insert the email. If that's not the case, you might want to have a look at this gist to get you started on converting a range to HTML code.
The question you are linking to was on Outlook VBA so you have to make sure that you declare your variables differently since in Excel VBA, Application will refer to the Excel application and not Outlook.
Here's how you could go about this:
Sub ReplyAllWithTable()
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' ReplyAll
Dim HtmlTable As String
HtmlTable = "<table><tr><td>Test</td><td>123</td></tr><tr><td>123</td><td>test</td></tr></table>"
For Each olItem In outlookApp.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
olReply.HTMLBody = "Here is the table: " & vbCrLf & HtmlTable & vbCrLf & olReply.HTMLBody
olReply.Display
'Uncomment next line when you're done with debugging
'olReply.Send
Next olItem
End Sub
About pasting range as a picture
If you take the approach in the code above, you won't be able to use the copy-paste method to insert your image. I personally prefer to set the HTML body of the email instead since it gives you more control. If you are ok with using the HTML method you could either:
convert your range to HTML code and insert it inside the email (similarly as how it was done in the code above); or
convert your range to an image, save it and insert it with HTML in the email body.
In order to achieve the 2nd option, you could run the following code:
Sub ReplyAllWithTableAsPicture()
'REFERENCE:
'- https://excel-macro.tutorialhorizon.com/excel-vba-send-mail-with-embedded-image-in-message-body-from-ms-outlook-using-excel/
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' ReplyAll
Dim fileName As String
Dim fileFullName As String
fileFullName = Environ("temp") & "\Temp.jpg" 'CUSTOMIZABLE (make sure this file can be overwritten at will)
fileName = Split(fileFullName, "\")(UBound(Split(fileFullName, "\")))
RangeToImage fileFullName:=fileFullName, rng:=ActiveSheet.Range("B1:AC42") 'CUSTOMIZABLE (choose the range to save as picture)
For Each olItem In outlookApp.ActiveExplorer.Selection 'if we have only one email, we could use: set olItem = outlookApp.ActiveExplorer.Selection(1)
Set olReply = olItem.ReplyAll
olReply.Attachments.Add fileFullName, olByValue, 0
olReply.HTMLBody = "Here is the table: " & "<br>" & "<img src='cid:" & fileName & "'>" & vbCrLf & olReply.HTMLBody
olReply.Display
'Uncomment this line when you're done with debugging
'olReply.Send
Next olItem
End Sub
And add the following sub procedure in the module as well:
Sub RangeToImage(ByVal fileFullName As String, ByRef rng As Range)
'REFERENCE:
'- https://analystcave.com/excel-image-vba-save-range-workbook-image/
Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
Dim pic As Variant
'Create temporary chart as canvas
Set sht = rng.Worksheet
rng.Copy
sht.Pictures.Paste.Select
Set sh = sht.Shapes(sht.Shapes.Count)
Set tmpChart = Charts.Add
tmpChart.ChartArea.Clear
tmpChart.Name = "PicChart" & (Rnd() * 10000)
Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
tmpChart.ChartArea.Width = sh.Width
tmpChart.ChartArea.Height = sh.Height
tmpChart.Parent.Border.LineStyle = 0
'Paste range as image to chart
sh.Copy
tmpChart.ChartArea.Select
tmpChart.Paste
'Save chart image to file
tmpChart.Export fileName:=fileFullName, FilterName:="jpg"
'Clean up
sht.Cells(1, 1).Activate
sht.ChartObjects(sht.ChartObjects.Count).Delete
sh.Delete
End Sub
Explanations:
In the ReplyAllWithTableAsPicture procedure, we are essentially doing the same thing as the first code, but we are now attaching an image to the email but keep it "hidden" so we can just include it in the body of the email without it being in the list of attachements when people receive the email. To include the image, we use the img tag with a source starting with "cid" allowing us to refer to the "hidden" attachment.
Since the image has to be a file, we use the RangeToImage procedure to generate the image file from the range that we supply. Currently, the file will be saved in the temporary directory always with the same name, which means that the file would be overwritten. Feel free to change the name or add the date to the name if you which to keep copies of these image files.
Instead of creating mail item, Work with Selection item
Example outlookApp.ActiveExplorer.Selection(1)
Your code
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Change to
Dim sel_Item As Outlook.MailItem
Set sel_Item = outlookApp.ActiveExplorer.Selection(1)
Dim outMail As Outlook.MailItem
'Get its Word editor
Set outMail = sel_Item.ReplyAll
I would like to ask you for a favour. I got a spreadsheet with code that sends an email if the cell (I3) contains a txt "YES".
Basically, if cell (J3) is empty then (I3) return the value "YES", then the code sends an email to addresses in cell (B3) once it's done it, the date appears to the cell (J3) and the value in (I3) changes to "NO". So on the next occasion the code knows that no emails needs to be send to to particular person.
I got this code of the internet. Done a little modification to the code to suit the sheet1. I'm very new to this, please be patient with me.
In cell (C3) I have the start date, cell (H3) the finish/due date. I would like my spreadsheet to send emails automatically without me opening the workbook.
I would like a time trigger that would send emails if particular task is due in 30 days and if an email could be generated each monday until it reaches 0 days and then one email for overdue - 5.
Not sure if the cell (I3) or (J3) could be still in use.
I hope I explained everything clearly.
Dim uRange
Dim lRange
Dim BCell As Range
Dim iBody As String
Dim iTo As String
Dim iSubject As String
Dim DaysOverdue
Public Sub SetEmailParams()
Set uRange = Sheet1.Range("I2")
Set lRange = Sheet1.Range("I" & Rows.Count).End(xlUp)
iBody = Empty
iSubject = Empty
iTo = Empty
For Each BCell In Range(uRange, lRange)
If BCell.Value = "YES" Then
If DateDiff("d", Format(Now(), "dd/mm/yyyy"), Format(Range("G3"),
"dd/mm/yyyy")) <= 0 Then
DaysOverdue = DateDiff("d", Format(BCell.Offset(0, -6)),
Format(BCell.Offset(0, -1)))
iTo = BCell.Offset(0, -7).Value
iSubject = "Reminder"
iBody = "The job assigned to you under this describtion - " &
BCell.Offset(0, -4) & " in the name of " & BCell.Offset(0, -3) & " for the
confirmation date of " & BCell.Offset(0, -1) & " is due " & DaysOverdue & "
days."
SendEmail
BCell.Offset(0, 1).Value = Now()
End If
End If
Next BCell
End Sub
Private Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = iTo
.CC = ""
.BCC = ""
.Subject = iSubject
.Body = iBody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Send to automatically send without displaying
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
For sending automatic mails you can use SendInBlue APIs or mail gun
For converting excel sheet use sheetjs
i hope it helps
You could create a BAT FILE, that open this workbooks and when the workbooks has open then run a Auto_Open macro that reads all cells content.
In ThisWorkbook write this code:
Private Sub Workbook_Open()
MsgBox "Welcome"
End Sub
This is a example of the BAT file i mentioned before:
1.- Open a notepad
2.- Write this:
start Excel.exe "C:\Temporal\TEST.xlsm"
3.- Save it as MyBat.bat
4.- Go to Panel Control --> Administrative tools --> Task Scheduler --> Create a Basic Task
5.- Set the time you want to execute this bat file!
I hope this works for you!
Cheers!
Referring to my comments an Example of using Mail.DeferredDeliveryTime is given below.
This sample sends every email with a certain subject the next Monday at 8 o'clock in the morning.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim Mail As Outlook.MailItem
If TypeOf Item Is Outlook.MailItem Then
Set Mail = Item
If Mail.Subject = "sample" Then
Mail.DeferredDeliveryTime = GetNextWeekday(vbMonday) & " 08:00 AM"
End If
End If
End Sub
Private Function GetNextWeekday(ByVal DayOfWeek As VbDayOfWeek) As Date
Dim diff As Long
diff = DayOfWeek - Weekday(Date, vbSunday)
If diff > 0 Then
GetNextWeekday = DateAdd("d", diff, Date)
Else
GetNextWeekday = DateAdd("d", 7 + diff, Date)
End If
End Function
I'm upgrading an Excel macro. I want to generate an email copying in a table that changes range daily.
Strbody populates the email but the timetable isn't attaching.
Sub Ops_button()
'Working in Office 2000-2010
Dim Outapp As Object
Dim Outmail As Object
Dim Strbody As String
Dim Timetable As String
'Auto Email Attachment Variables
Set Outapp = CreateObject("Outlook.Application")
Set Outmail = Outapp.createitem(0)
Timetable = Sheets("sheet1").Range("C2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Strbody = "body text."
On Error Resume Next
With Outmail
'Send email
.To = ""
.bcc = ""
.Subject = "Report" & " " & Format$(Date, "dd-mm-yyyy")
.body = Strbody & Timetable
On Error Resume Next
.Display
End With
On Error GoTo 0
Set Outmail = Nothing
Set Outapp = Nothing
End Sub
You can't do this the way you're trying to do it... Let's see why not :)
You've declared Timetable as a String type variable. In this statement, you're assigning its value as the return from the .Select method (which will return a value of True if there is no error).
Timetable = Sheets("sheet1").Range("C2").Select
So, you're in no way appending the Table's Range object to the string, in this statement:
.body = Strbody & Timetable
Instead, you really need to either convert the table to HTML or copy and paste the range directly from Excel to Word.
Use Ron de Bruin's function to convert the table to an HTML PublishObject and insert that to the email, or
.Display the MailItem and then get a handle on the MailItem's .Inspector object (which is really just a Word document)
For the solution 1, adapt the answer already given, here:
Paste specific excel range in outlook
For the solution 2, you'll need to use the method outlined here to get the Inspector (Word Document representing the Email item):
https://msdn.microsoft.com/en-us/library/office/ff868098.aspx
Then, Dim TimeTable as Range, and change code to:
Set Timetable = Sheets("sheet1").Range("C2").End(xlToRight).End(xlDown)
Then, copy the table:
Timetable.Copy
And then following the MSDN link above once you have a handle on the Inspector, get the destination range in Outlook (Word) and you can use the PasteAndFormat method of a Word.Range object:
Dim wdRange as Object 'Word.Range
OutMail.Display
Set wdRange = OutMail.getInspector().WordEditor.Range
wdRange.Text = strBody
wdRange.Expand (1)
wdRange.Characters.Last.PasteAndFormat 16 'wdFormatOriginalFormatting
Option 2 would be my preferred method. I'm on a computer that doesn't have outlook, so I'm winging this a little bit from memory and I can't test right now, but if you have any issues with it just leave a comment and I'll try to help out some more in the morning.
I'm running a report that gets distributed via email. In the email is a hyperlink to the report and a range of cells copied out of it as a snapshot of the report content. I'm trying to automate and found some VBA, but I'm not a programmer and can't modify it for my needs.
The VBA below gets me most of the way, but for 2 shortcomings:
1) I need the hyperlink to point to the specific file I'm referencing in the email, which changes daily (i.e. a unique workbook is created). The below uses a static hyperlink. I was trying to figure out a way to derive the hyperlink from a cell reference.
2) When copying the hyperlink and range of cells from excel into the email, I need the cells below the hyperlink. The below puts the range above the hyperlink.
I'd like to preserve the approach taken in the below VBA of referencing a worksheet to derive the email. It appears easy to deploy on other reports which get distributed.
Sub CreateMail()
Dim rngSubject As Range
Dim rngTo As Range
Dim rngCc As Range
Dim rngBody As Range
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("B1")
Set rngCc = .Range("B3")
Set rngSubject = .Range("B2")
Set rngBody = .Range("H6:K22")
End With
rngBody.Copy
With objMail
.Body = "Please click on the link below..." & vbCrLf & "rngBody.Paste" & vbCrLf & _
"file:\\dbd03\nccode\Router_Proc\04Routing.txt"
End With
With objMail
.To = rngTo
.Cc = rngCc
.Subject = rngSubject
.Display
End With
SendKeys "^({v})", True
Set objOutlook = Nothing
Set objMail = Nothing
1) To make the file link dynamic, you can just include the reference of the cell, containing the file name, in the file path.
"<file:\\dbd03\nccode\Router_Proc\" & _
ActiveSheet.Range(<cell address here>) & ">"
Note: You might want to also check to make sure the path exists (like this) before putting it in the email
2) To paste the cells below the hyperlink, you can use another SendKeys combination to simulate the pressing of Ctrl + End, which will place the cursor at the end of the email. Doing this before using SendKeys to simulate the Ctrl + V should paste the range of cells after your body text. Your updated code should be the following:
With objMail
.To = rngTo
.Cc = rngCc
.Subject = rngSubject
.Display
End With
SendKeys "^({END})", True '<--- Add this line HERE
SendKeys "^({v})", True
Another Note: Also, i don't think you need "rngBody.Paste" in your Body string, as this just pastes that exact text in your email body