I receive an email report twice every workday. Sometimes the machine that sends these reports crashes and no emails are sent out. What I am wanting to do is use some Outlook VBA to check if an email hasnt arrived at 12:15 and 17:05.
Finding an email that is there is fairly easy, but finding one that isnt is making me scratch my head a bit. I have a class module set up right now (I assume that would be the way to go) and have the code for what I want to do if no email has been received, but cannot figure out how to go about checking for the email at those times. It might be something simple, but have not really scripted in Outlook VBA before, so am not sure where to start.
The method pointed out in a comment.
Outlook VBA - Run a code every half an hour
Outlook VBA - Run a code every half an hour with outlook 2010 64 bits
A possibly simpler alternative. Set a recurring task with a reminder.
In ThisOutlookSession
Private Sub Application_Reminder(ByVal Item As Object)
If Item.Class = olTask Then
If InStr(Item.Subject, "subject") > 0 Then
ReminderUnreceivedMail
End If
End If
End Sub
Sub ReminderUnreceivedMail()
Dim Itms As Items
Dim srchSender As String
Dim srchSubject As String
Set Itms = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
srchSender = "sender"
srchSubject = "subject"
Set Itms = Itms.Restrict("[SenderName] = 'sender' And [Subject] = 'subject' And [SentOn] > '" & Format(Date, "yyyy-mm-dd") & "'")
If Itms.count = 0 Then
MsgBox "No " & srchSubject & " email on " & Format(Date, "yyyy-mm-dd")
End If
Set Itms = Nothing
End Sub
Related
I have a problem, the macro below checks if there is a mail title from the sender. The problem is that in outlook, I have 2 accounts: IMAP and Exchange. Makro always chooses exchange. Where's the reason?
Sub srchmail()
Dim Itms As Items
Dim srchSender As String
Dim srchSubject As String
Dim strFilterBuild As String
Dim ItmsBuild As Items
Dim strFilter As String
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set sub_olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set sub_olFolder = sub_olFolder.Folders("SUBFOLDER")
Set Itms = sub_olFolder.Items
Dim i As Long
For i = 1 To Itms.Count
Next
srchSender = "SENDERMAIL"
srchSubject = "SUBJECTMAIL"
strFilter = "[SenderName] = '" & srchSender & "' And [Subject] = '" & srchSubject & "' And [SentOn] > '" & Format(Date, "dd-mm-yyyy") & "'"
Set Itms = Itms.Restrict(strFilter)
If Itms.Count = 0 Then
MsgBox "dont mail in " & sub_olFolder & " with sub:'" & srchSubject & "' on " & Format(Date, "dd-mm-yyyy")
Else
MsgBox "found mail in " & sub_olFolder & " with sub: '" & srchSubject & "' on " & Format(Date, "dd-mm-yyyy")
End If
ExitRoutine:
Set Itms = Nothing
End Sub
Your problem is:
Set sub_olFolder = objNS.GetDefaultFolder(olFolderInbox)
You can only have one default Inbox. Your default Inbox is clearly in the Exchange account. You will need to explicitly name the IMAP store to access its Inbox.
When you look at your folder pane, you will see something like this:
Xxxxxxxxxxx
Drafts
Deleted Items
Inbox
: :
Yyyyyyyyy
Drafts
Deleted Items
Inbox
SUBFOLDER
: :
Xxxxxxxxxxx and Yyyyyyyyy are the names of stores. Stores are the files in which Outlook saves all your emails, calendar items, tasks and so on. As I understand it, you MUST have one store per account. You can also have as many extra stores as you wish. I have stores named for my two accounts, “Archive”, “Test” and many more.
Try:
Set sub_olFolder = objNS.Folders("Yyyyyyyyy").Folders("Inbox")
Where “Yyyyyyyyy” is the name of the store (as it appears in the folder pane) containing the sub folder you wish to access.
I should perhaps add that I would have written:
Set Itms = Session.Folders("Yyyyyyyyy").Folders("Inbox").Folders("SUBFOLDER").Items
“Session” and “NameSpace” are supposed to be identical. I use Session because it avoids the need to create a namespace and because a long time ago I had a failure with NameSpace that I could not diagnose.
Unless you need to access the store or Inbox or SUBFOLDER in some other way, you do not need variables for them. Starting with the ultimate parent (Session) you can string the names of children, grandchildren and so on to any depth.
Be careful stringing properties together like this. (1) It can take a little time to get the string correct. (2) I have seen example of property strings where it is really difficult to determine what it being accessed. If you return to this macro in 12 months, will you remember what this string means? If someone else has to maintain your macro, will they understand what you have done? If in doubt, keep it simple.
Added because of error in original answer
It is not possible for me to test my answer. Try the following as a way for you to test my suggestion.
Replace "Yyyyyyyyy" in the following by the name of your IMAP store and then type it in your Immediate Window.
? Session.Folders("Yyyyyyyyy").Name
The interpreter should respond with the name of the IMAP store. If that works, try:
? Session.Folders("Yyyyyyyyy").Folders("Inbox").Name
The interpreter should respond Inbox. If that works, try:
? Session.Folders("Yyyyyyyyy").Folders("Inbox").Folders("SUBFOLDER").Name
The interpreter should respond SUBFOLDER. If that works, try:
? Session.Folders("Yyyyyyyyy").Folders("Inbox").Folders("SUBFOLDER").Items(1).ReceivedTime
The interpreter should respond with the date and time of the older email in the subfolder. If that works, my answer should work. If any of the above doesn't work, please respond with a detailed explanation of what failed
It looks like your Exchange account is set as default, so
when you get sub_olFolder, you are working with subfolder of Inbox of the message store that linked with Exchange account.
I have a macro set up that will automatically send out emails to dozens of managers. Sometimes they're away and I have to check the away message and manually forward it to the person covering for them.
I try to find a solution before I seek help so have mercy on me! I found a similar question but it wasn't a lot of help, I couldn't find a lot of info on extracting an auto response from a recipient in a draft.
So far this is what I've got:
Sub CheckAutoReply()
Dim OL As Outlook.Application
Dim EM As Outlook.MailItem
Dim R As Outlook.Recipient
Set OL = New Outlook.Application
Set EM = CreateItem(olMailItem)
With EM
.display
.To = "John.Doe#Stackoverflow.com" 'This is a recipient I know has an autoresponse. Fictitious of course.
End With
Set R = EM.Recipients(1) 'on hover it pops up with "EM.Recipients(1) = "John.Doe#Stackoverflow.com""
Debug.Print R.Name 'this returns "John.Doe#Stackoverflow.com"
Debug.Print R.AutoResponse 'this returns nothing
Set OL = Nothing
Set EM = Nothing
End Sub
This is not a proper answer but an attempt to get you started.
Your code suggests your knowledge of Outlook VBA is limited. If this is true, I doubt that any of the approaches in “a similar question” will be appropriate. Are you familiar with Visual Studio, C++, Delphi or Redemption? Even if you managed to access PR_OOF_STATE, you would not have the alternative email address.
I would start by attempting to extract the email address from the out-of-office reply. Looking for “#” and extracting the text back to and forward to the next space might be enough.
Copy the code below to an Outlook VBA module. Select one of the out-of-office replies and run macro DemoExplorer. The objective of this macro is to show you what the text and Html bodies of the email look like. Try this macro on other replies. Are the bodies consistent? Can you see how to extract the alternative email address?
Public Sub DemoExplorer()
Dim Exp As Outlook.Explorer
Dim ItemCrnt As MailItem
Dim NumSelected As Long
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemCrnt In Exp.Selection
With ItemCrnt
Debug.Print "From " & .SenderName & " Subject " & .Subject
Debug.Print "Text " & Replace(Replace(Replace(.Body, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
Debug.Print "Html " & Replace(Replace(Replace(.HTMLBody, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
End With
Next
End If
End Sub
The answer to the similar question you found (Remove recipients from Outlook email if automatic reply is activated) still stands. What were you having problem with?
The only additional possibility (and this is what Outlook uses when it displays an OOF banner for a recipient you are about to send to) is to use EWS and the GetMailTips operation (see https://msdn.microsoft.com/en-us/library/office/dd877060(v=exchg.150).aspx).
My excel spreadsheet has email a number of email addresses in column B that the email is to be sent to and addresses in column E that the email is to be cc to. in A1 I have today's date (which updates) and in B1 I have the date the email needs to be sent and in C1 I have another date 6 months later the email needs to be sent.
Here is my code:
Private Sub workbook_Open()
Dim Subject, Send_From, Send_To, cc, body As String
Dim Email_Range, cl, cc_Range, cx As Range
Dim Due_Date, Today_Date, Send_Date As Date
Today_Date = Range ("A1").Text
Due_Date = Today_Date + 7
Send_Date = Range ("B1").Text
Dim Mail_Object, Mail_Single As Variant
Set Email_Range = Range("B3:B14")
For Each cl In Email_Range
Sent_To = Send_To & ";" & cl.Value
Next
Send_To = Mid(Send_To, 2)
Set cc_Range = Range("E3:E14")
For Each cx In cc_Range
cc = cc & ";" & cx.Value
Next
cc = Mid(cc, 2)
Subject="subject"
Send_From="me#example.com"
Body="Please respond by" & "Due_Date" & "Thank You"
On Error GoTo debugs
Set Mai_Object = Create Object ("Outlook Application")
Set Mail_Single - Mail_Object, Create Item(0)
With Mail_Single
.Subject=Subject
.To=Send_To
.cc=cc
.Body=Body
.Send
End With
debugs:
If Err.Description c>"" Then Msg Box
Err.Description
End Sub
The program will send an email when I run it, but I need the program to send an email on the send date automatically (when due date=send date) and then when someone responds, take them off the email list. Repeat this until everyone has responded and then do it all again the next send date (different cell).
I have no idea where to start as I am pretty knew at this. Does anyone have any ideas?
There is a solution using Excel and Outlook utilising Outlook's task reminders, but it will send emails at the precise time only if your Outlook software is actively running at the moment a reminder event occurs. If you start Outlook and have 'missed' one or more scheduled events (because Outlook was turned off at the time), then emails corresponding with those missed scheduled events will occur shortly after Outlook starts. I'm assuming you have Outlook available as you are using Excel.
Excel Component Solution
I've created a spreadsheet that is slightly different to yours, but you can adapt as necessary. The spreadsheet has two separate sheets named "Recipients" and "Emails". The "Recipients" sheet contains a list of each email recipient along with three dates on which they should receive emails if they have not yet responded.
The "Emails" sheet contains content that is to be placed in each email:
Within the ThisWorkbook code for the spreadsheet, I added the following procedures. These are responsible for creating tasks within Outlook for which reminders will fire at particular times in the future. Each task will contain sufficient information to generate an email to a nominated recipient.
Sub CreateOutlookTask(name As String, destination As String, emailNum As Integer, sendDate As Date)
With CreateObject("Outlook.Application").CreateItem(3)
.Subject = Worksheets("Emails").Cells((emailNum + 1), "A").Value
.Role = destination
.StartDate = sendDate
.DueDate = sendDate
.ReminderTime = sendDate
.ReminderSet = True
.Body = Trim(Worksheets("Emails").Cells((emailNum + 1), "B").Value) + _
" " + name + "," + vbLf + vbLf + _
Worksheets("Emails").Cells(emailNum + 1, "C").Value + _
vbLf + vbLf + _
"This email was sent to " + destination + _
" by XYZ Corporation [add reason]."
.Categories = "AutoSend"
.Save
End With
End Sub
Sub ProcessRecipients()
Dim rowNum As Integer
Dim lastRowIdx As Integer
lastRowIdx = Worksheets("Recipients").Cells(Rows.Count, "B").End(xlUp).Row
For rowNum = 2 To lastRowIdx
With Worksheets("Recipients")
Call CreateOutlookTask(.Cells(rowNum, "A"), .Cells(rowNum, "B"), 1, .Cells(rowNum, "C"))
Call CreateOutlookTask(.Cells(rowNum, "A"), .Cells(rowNum, "B"), 2, .Cells(rowNum, "D"))
Call CreateOutlookTask(.Cells(rowNum, "A"), .Cells(rowNum, "B"), 3, .Cells(rowNum, "E"))
End With
Next
End Sub
Running the ProcessRecipients() macro within the Excel workbook will create three tasks in Outlook for each recipient listed on the "Recipients" sheet. However, the email magic won't happen until the following section is complete.
Outlook Component Solution
Two separate actions need to occur within Outlook. The first is the actual sending of emails at nominated times, and the second is looking for and processing the responses.
Automatically processing received emails is made more complicated by the fact the email address of the responder may not be the same as the email address of the originally intended recipient. By placing the intended recipient's email address within the body of the original email, it is highly likely that any response will include the original email and thus include a reference to the originally intended recipient. The automatic processing of emails looks known text within the subject heading string as well as a reference to an originally intended recipient's email address in the received email body.
The following VBA code needs to be placed in a (new) module within Outlook's VbaProject.OTM file. This code will become a rule that will be run whenever an email is received by the Outlook client.
' Create a rule that calls this macro each time an email is received.
' All tasks that are flagged with the 'AutoSend' category will be searched
' and the email destination for that task extracted from the task's 'role'
' field. If the received email explicitly refers to that email address, then
' the task will be deleted.
'
' It cannot be assumed that the sender of a response email will be the same
' email address as the email used to send the original email (i.e. it could
' have been forwarded, or simply be an alias for the actual recipient. We
' must therefore search the body of the response to look for a reference to
' the originally intended recipient email address.
'
Sub ProcessAutoEmailResponses(email As MailItem)
Dim task As Outlook.TaskItem
Dim items As Outlook.items
Dim folder As Outlook.MAPIFolder
Dim deletedTasks As String
Dim autoProcess As Boolean
autoProcess = False
Set folder = Application.Session.GetDefaultFolder(olFolderTasks)
Set items = folder.items
' If the incoming email subject contains any of the strings defined
' by an 'AutoReceive' task category subject
Set task = items.Find("[Categories] ='AutoReceive'")
Do While (Not task Is Nothing) And (autoProcess = False)
If (InStr(1, email.Subject, task.Subject) > 0) Then
autoProcess = True
End If
Set task = items.FindNext
Loop
If (autoProcess = True) Then
deletedTasks = "AutoSend Processing Triggered"
' loop through all AutoEmail categorised tasks
Set task = items.Find("[Categories] ='AutoSend'")
Do While (Not task Is Nothing)
' if the email contains a reference to the task's destination email address
If (InStr(1, email.Body, task.Role) > 0) Then
deletedTasks = deletedTasks & ", Deleted Reminder " & task.DueDate & " (" & task.Subject & ")"
' delete the task
task.Delete
End If
Set task = items.FindNext
Loop
' Insert note to indicate tasks have been deleted
email.Body = deletedTasks + vbLf + email.Body
email.Subject = "[AUTOSEND PROCESSED] " + email.Subject
email.Save
End If
End Sub
A second block of code needs to be placed in the ThisOutlookSession area of the VbaProject.OTM codebase. This code is executed whenever a reminder fires.
Note there are several ways to do this, and although I ended up not 'cancelling' the reminder window via this event handler, the BeforeReminderShow event handler is (I believe) the only way to control whether the reminder window is actually made visible as a result of a reminder firing. It might be something you wish to play with further.
Private WithEvents olRemind As Outlook.Reminders
Private Sub Application_Reminder(ByVal item As Object)
Set olRemind = Outlook.Reminders
End Sub
'
' Auto-dismiss/cancel reminders that would otherwise
' be displayed for "AutoSend" categorised items
'
Private Sub olRemind_BeforeReminderShow(Cancel As Boolean)
Dim reminderObj As Reminder
Dim item As TaskItem
For Each reminderObj In olRemind
If (reminderObj.IsVisible = True) Then
If (TypeName(reminderObj.item) = "TaskItem") Then
If reminderObj.item.Categories = "AutoSend" Then
Dim email As MailItem
Set email = Application.CreateItem(olMailItem)
email.To = reminderObj.item.Role
email.Subject = reminderObj.item.Subject
email.Body = reminderObj.item.Body
email.Send
reminderObj.item.ReminderSet = False
reminderObj.item.Save
reminderObj.Dismiss
End If
End If
End If
Next
End Sub
Important: Outlook macros are usually prohibited under the default Outlook configuration. It is best to sign your code and permit the execution of signed macros. Once your code is run once, you can nominate to 'always allow' that code to run, thereby eliminating permission problems.
This blog provides instructions for 'self-signing' your VBA project: http://www.remkoweijnen.nl/blog/2011/01/12/self-signing-word-macros/.
Final Steps
Create one or more 'tasks' within outlook (no date necessary) that contain the email subject headings as their titles and tag them with a category called 'AutoReceive'. These will control which emails are automatically processed based on the content of their email subject.
You'll now need to set-up a rule within Outlook to run the ProcessAutoEmailResponses(MailItem) method by going to Tools->Manage Rules and Alerts (or similar, depending on your Outlook version) and creating a rule that runs the method whenever a new email arrives.
As previously stated in a comment by Matt Rowland, Excel is not really the proper choice to do something like that. The easiest way to accomplish that would be probably using an SQL Server (or any other DB-Server) with the ability to send out emails.
The main problem is that you want Excel to run on a particular date / time. Yet, Excel is not running day and night on your computer. So, if Excel is not open / running on the particular date / time you want it to, then Excel cannot send out the requested emails.
Still, if the task has to be accomplish using Excel this is possible. First, you will have to make sure that you have a computer running day and night so that the computer is really on and running on the requested dates. Second, you need to setup the Windows Task (https://en.wikipedia.org/wiki/Windows_Task_Scheduler) to open Excel with the file you setup for that purpose (with the above code). To be really specific, you can even use the VBA function Application.OnTime (https://msdn.microsoft.com/en-gb/en-en/library/office/ff196165.aspx) to run your above procedure at a particular time.
I need to add a progress bar for exporting all appointments to a database in outlook with a Macro.
Here is my VBA code:
For Each appointment In objFolder.Items
If appointment.BusyStatus = olOutOfOffice Then
total = total + 1
End If
Next
With this code, total stays at 0 so I cant get a percentage.
I don't know how to use the debugger. I would like to see what the variable is when it is executing.
First of all, take a look at the Getting Started with VBA in Outlook 2010 article.
Instead of iterating over all items in the folder you can use the Restrict or Find/FindNext methods of the Items class. They will allow to find only those items that correspond to your condition.
You did not provide enough code to see what the problem could be. Perhaps you are not pointing to a calendar. Following the pattern of your code, without attempting to make it more efficient...
Option Explicit
Sub countAp()
Dim objfolder As folder
Dim Appointment As AppointmentItem
Dim totalAll As Long
Dim total As Long
Set objfolder = Application.GetNamespace("mapi").GetDefaultFolder(olFolderCalendar)
For Each Appointment In objfolder.Items
If Appointment.BusyStatus = olOutOfOffice Then
totalAll = totalAll + 1
End If
Next
Debug.Print "All Appointment.BusyStatus = olOutOfOffice: " & totalAll
Debug.Print "Processing..."
For Each Appointment In objfolder.Items
If Appointment.BusyStatus = olOutOfOffice Then
' do something here
Debug.Print Appointment.Subject
total = total + 1
Debug.Print " current total: " & Format(total, "000") & _
" Percentage Complete: " & Format(total / totalAll * 100, "##0.00")
End If
Next
Debug.Print "Done"
End Sub
You will find this helpful Debugging VBA Code
So far I have the first referral open-up the Outlook and retrieving the right email address with an automatic customized message. Now, I'm trying to add a second referral, Referral_To_ID_2 as an optional, meaning don't raise error if it isn't selected. Below is the form and the code I have so far, but I'm not quite sure if I'm doing it right by assigning a reference to my second object, Referral_To_ID_2 as well as the If statement. Now it's actually giving me an error if I don't select anything in Referral_To_ID_2 Can anyone explain me the best way to add a second object as an optional? Many thanks!
Private Sub cmdReferralEmail_Click()
Dim emailAddresses As Collection, newEmail As Email
Dim emailAddresses2 As Collection, newEmail2 As Email
Set emailAddresses = GetEmails(referralId:=Referral_To_ID)
Set emailAddresses2 = GetEmails(referralId:=Referral_To_ID_2)
If emailAddresses Is Nothing Then 'User cancelled
ElseIf emailAddresses2 Is Nothing Then 'User cancelled
GoTo ExitHandler
ElseIf emailAddresses.count = 0 Then
MsgBox "No email addresses were selected for this client.", vbExclamation
Else
Set newEmail = New Email
Set newEmail2 = New Email
With newEmail
.HtmlBody = _
"<p>We referred a potential client to you, " & _
Nz(First_Name & " ", "") & Nz(Last_Name, "") & _
", who needs help with an employment matter in " & Nz(State, "your state") & _
". Thank you for any assistance you might be able to provide.</p>"
Set .MailTo = emailAddresses
Set .MailTo = emailAddresses2
.Cc.Add "kjghkjgh#ihiu.com"
.Subject = "Potential"
.Send
End With
End If End Sub
My program reads through a list of people, if they are marked for a Maintenance for example it pulls a query and sets a recordset to that query with:
strSQL = "SELECT Email FROM Employees WHERE '" & department & "' = Department"
Debug.Print strSQL 'I do this so I can see what my query is in the immediate window
Set myR = CurrentDb.OpenRecordset(strSQL)
Then when the recordset has been made, I loop through each record that matched the criteria in the query and add the to the olTo of the email.
Do While Not myR.EOF
Debug.Print myR!Email 'print the email of the record I'm on
Set appOutlookRec = .Recipients.Add(myR!Email)
appOutlookRec.Type = olTo
myR.MoveNext
Loop
But to answer your question more specifically, I would add two IF statements checking first if Referral_To_ID_2 is null.
If Referral_To_ID_2 = Null Then 'or if its a string then If Len(Me.Notes & vbNullString) = 0
'do nothing
Else
Set emailAddresses2 = GetEmails(referralId:=Referral_To_ID_2)
End if
then put the second if down where you Set .MailTo
If emailAddresses2 = Nothing then 'I think that's how that would go, not 100%
'do nothing
Else
Set .MailTo = emailAddresses2
End if
No please know that I'm no guru. I've tried to piece this together with my knowledge I've picked up on so if anyone reads this and can modify it better then have at it. Let me know how it goes.
Because I needed it to open two separate Outlook windows I had to basically copy and paste the code I had for the second referral from the first referral and for the second referral not show error when isn't selected, here is what I came up with and it's working:
If IsNull(Referral_To_ID_2) Then
On Error Resume Next
Else
Set emailAddresses2 = GetEmails(referralId:=Referral_To_ID_2)
End If
Thanks all for your input!