I am trying to create a list on excel to track which of my selected sent outlook emails (moved to a particular sub folder, "Test") have been replied. For emails which have not been replied, I would like to send a reminder email after a few days. Would it be possible to create an outlook VBA macro to do this?
Currently, my VBA code is only able to pull selected email details in a tracking file.
I know that to track conversations, the PR_CONVERSATION_INDEX should be used, but am not sure how to incorporate it into my code below.
Sub List_Email_Info()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim i As Long ' Row tracker
Dim arrHeader As Variant
Dim olNS As NameSpace
Dim olSentFolder As MAPIFolder
Dim olItems As Items
Dim olMailItem As MailItem
Dim olRecipients As Outlook.Recipients
arrHeader = Array("Date Created", "Subject", "Recipient's Name")
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
Set olNS = GetNamespace("MAPI")
Set olSentFolder = olNS.GetDefaultFolder(olFolderSentMail).Folders("test")
Set olItems = olSentFolder.Items
i = 1
On Error Resume Next
xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
For Each olMailItem In olItems
xlWB.Worksheets(1).Cells(i + 1, "A").Value = olItems(i).CreationTime
xlWB.Worksheets(1).Cells(i + 1, "B").Value = olItems(i).Subject
xlWB.Worksheets(1).Cells(i + 1, "C").Value = olItems(i).To
i = i + 1
Next olMailItem
xlWB.Worksheets(1).Cells.EntireColumn.AutoFit
MsgBox "Export complete.", vbInformation
Set xlWB = Nothing
Set xlApp = Nothing
Set olItems = Nothing
Set olSentFolder = Nothing
Would appreciate any help on this!
==========================================================================
Current code is adapted from: https://learndataanalysis.org/pull-outlook-emails-detail-into-excel-using-vba/
As this is not a programming service where ready to run code is served, I'd suggest you do like this:
When an email is received and moved, you set a calendar appointment in VBA when to send the reminder if no reply has been received.
https://learn.microsoft.com/en-us/office/vba/outlook/how-to/items-folders-and-stores/create-an-appointment-as-a-meeting-on-the-calendar
You also set a trigger for it in VBA and let the action be to resend the email:
Use calendar appointment in outlook to trigger VBA macro
If a reply is received you delete that particular calendar time:
https://learn.microsoft.com/en-us/office/vba/api/outlook.appointmentitem.delete
Otherwise the calendar trigger will send the email reminder.
To do it this way uses built-in resources in Outlook so you don't have to write them yourself.
Related
I frequently have to send out emails to various contractors to check in on the statuses of the projects I have bid with them. Currently I have to enter the name of each Rep in reference cell and then execute the macro but I deal with dozens of reps. I would like to be able to send an bulk email blast out to all the reps whose projects are still "Open" with one macro instead of having to change the reps name each time. Also, I tried to use the automatic .send function but cannot get it to work and I would hope to not have to keep using the .display for this situation for obvious reasons.
Sub EmailGCs_1()
'Declare Outlook Variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector
'Declare Word Variables
Dim oWrdDoc As Word.Document
Dim oWrdRng As Word.Range
Dim oWrdTble As Word.Table
'Declare Excel Variables
Dim ExcTbl As ListObject
On Error Resume Next
'Get The Active instance of Outlook, if there is one.
Set oLookApp = GetObject(, "Outlook. Application")
'If ther is no active instance create one
If Err.Number = 429 Then
'Create a new instance
Set oLookApp = New Outlook.Application
End If
'Create a new Email
Set oLookItm = oLookApp.CreateItem(olMailItem)
'Create a refernce to the table
Set Exltbl = ActiveSheet.ListOjects(1)
With oLookItm
'Basic Info
.To = Range("D2").Value
.Subject = "Various Project Statuses"
'Display Email
.Display
'Get The Inspector
Set oLookIns = .GetInspector
'Get the Word Editor
Set oWrdDoc = oLookIns.WordEditor
'Filter Table to Distro
ActiveSheet.Range("Table1").AutoFilter field:=6, Criteria1:=Cells(1, 6).Value
'Hide Columns
Range("G:R").EntireColumn.Hidden = True
'Copy Items
Worksheets(1).ListObjects("Table1").Range.Copy
oWrdDoc.Range(1, 2).Paste
'Greeting Text
MsgText = Split(Range("F1").Value, " ")(0) & "," & vbNewLine & "Can you please let me know the statuses of the projects below." & vbNewLine
oWrdDoc.Range.InsertBefore Text:=MsgText
'Clearing out filter and selection
ActiveSheet.ListObjects(1).AutoFilter.ShowAllData
Application.CutCopyMode = False
Range("G:R").EntireColumn.Hidden = False
End With
Set oLookItm = Nothing
Set oLookApp = Nothing
Application.ScreenUpdating = True
End Sub
The Send method is not safe and the Outlook object model may trigger security prompts or give errors when Outlook is automated from an external application. Possible workarounds are listed below:
Create a COM add-in which deals with a safe Application instance which doesn't trigger security prompts.
Use a low-level code on which Outlook is built on and which doesn't have security riggers onboard. Or may also consider any other third-party wrappers around that API, for example, Redemption.
Use a third-party components for suppressing Outlook security warnings. See Security Manager for Microsoft Outlook for more information.
Use group policy objects for setting up machines.
Install any AV software with latest updates.
Here is one way to loop through a list.
Source: Sending Email to a List of Recipients Using Excel and Outlook
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub EmailGCs_2()
' Early binding requires reference to Microsoft Outlook XX.X Object Library
' Declare Outlook variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim iCounter As Long
'Application.ScreenUpdating = False
'There can only be one instance of Outlook
' GetObject is not needed.
' The problematic On Error Resume Next can be dropped
Set oLookApp = New Outlook.Application
'Subsequent errors would have been bypassed
' due to the missing On Error GoTo 0
'If there are any errors you can fix them now.
'Assumes a list of email addresses in column D starting at cell D2
' https://learn.microsoft.com/en-us/office/vba/excel/concepts/working-with-other-applications/sending-email-to-a-list-of-recipients-using-excel-and-outlook
'Debug.Print WorksheetFunction.CountA(Columns(4)) + 1
For iCounter = 2 To WorksheetFunction.CountA(Columns(4)) + 1
'Debug.Print iCounter
'Create a new Email
Set oLookItm = oLookApp.CreateItem(olMailItem)
With oLookItm
'Basic Info
.To = Cells(iCounter, 4).Value
.Subject = "Various Project Statuses"
'Display Email
.Display
End With
Set oLookItm = Nothing
Next
Set oLookItm = Nothing
Set oLookApp = Nothing
Application.ScreenUpdating = True
Debug.Print "Done."
End Sub
I am trying to write a simple program to automatically send emails from a list in excel, and it works, but outlook keeps opening pop ups asking for permission. How do you get outlook to not ask for permission anymore and just do what excel tells it without the pop ups
Heres the code I have so far:
Sub SendMessage()
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim recemail
Dim i As Integer
i = 1
recemail = Sheet1.Cells(i, 1)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(recemail)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "TEST!"
.Body = "DOES THIS WORK!?"
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
i = i + 1
End Sub
This is a manual operation that you need to do :
Run Outlook as Administrator
Go to Tools (Outlook 2007) or File, Options (Outlook 2010 and up)
Go to Trust Center
Change the Programmatic Access setting to : Never warn me about suspicious activity
You can now close Outlook and from now on, you'll have access every time without the popup!
BTW, to avoid opening a new instance of Outlook (if there is already one), use this :
'Create or Get the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set objOutlook = CreateObject("Outlook.Application")
On Error GoTo 0
I receive an automated email message (in Outlook) every time a room is reserved in a scheduling system but then have to go over and mirror that reservation in another system (which necessitates checking each reservation for specific information and searching through the inbox). I am trying to determine if there is a way to pull the information from the message section (I have found some code that pulls the date received, and subject line as well as read status, but cannot determine how to pull the message body information that I need)
The code that I am running is courtesy of Jie Jenn:
Sub ListOutlookEmailInfoinExcel()
Dim olNS As Outlook.NameSpace
Dim olTaskFolder As Outlook.MAPIFolder
Dim olTask As Outlook.TaskItem
Dim olItems As Outlook.Items
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim x As Long
Dim arrHeaders As Variant
Set olNS = GetNamespace("MAPI")
Set olTaskFolder = olNS.GetDefaultFolder(olFolderInbox)
Set olItems = olTaskFolder.Items
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
On Error Resume Next
x = 2
arrHeaders = Array("Date Created", "Date Recieved", "Subject", "Unread?")
xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeaders)).Value = ""
Do
With xlWB.Worksheets(1)
If Not (olItems(x).Subjects = "" And olItems(x).CreationTime = "") Then
.Range("A1").Resize(1, UBound(arrHeaders) + 1) = arrHeaders
.Cells(x, 1).Value = olItems(x).CreationTime
.Cells(x, 2).Value = olItems(x).ReceivedTime
.Cells(x, 3).Value = olItems(x).Subject
.Cells(x, 4).Value = olItems(x).UnRead
x = x + 1
End If
End With
Loop Until x >= olItems.Count + 1
Set olNS = Nothing
Set olTaskFolder = Nothing
Set olItems = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
End Sub
With the above code, I get a readout of the Subject line, the date created/received and whether or not it has been read. I am trying to see if I can, in addition, get some of the unique string data within the message itself. The format of the emails that I receive is as follows:
Message-ID: sample info
User: test
Content1: test
Content2: test
Content3: test
Please submit a service request if you are receiving this message in error.
-Notice of NEW Room Request
Sponsored By: My_example#Test.com
Event Type: Meeting
Event Title: Test
Date of Reservation: 2015-12-02
Room: 150
From: 13:00
To: 14:00
The information will vary with each request, but I was wondering if anyone had any idea on how to capture the unique strings that will come through so that I can keep a log of the requests that is much faster than the current manual entry and double-checks?
As requested in follow up, the following code splits the message body into individual lines of information. A couple of notes: I copied your message exactly from your post, then searched for "Notice of NEW Room Request". Needless to say, this string should always start the block of information that you need. If it varies, then we have to account for the type of messages that may come through. Also, you may have to test how your message body breaks up individual lines. When I copied and pasted your message into Excel, each line break was 2 line feeds (Chr(10) in VBA). In some cases, it may be only one line feed. Or it can be a Carriage Return (Chr(13)), or even both.
Without further ado, see the code below and let us know of questions.
Sub SplitBody()
Dim sBody As String
Dim sBodyLines() As String
sBody = Range("A1").Value
sBodyLines() = Split(Mid(sBody, InStr(sBody, "Notice of NEW Room Request"), Len(sBody)), Chr(10) & Chr(10))
For i = LBound(sBodyLines) To UBound(sBodyLines)
MsgBox (sBodyLines(i))
Next i
End Sub
Below is an example connecting to an Outlook session, navigating to the default Inbox, then looping through items and adding unread emails to the spreadsheet. See if you can modify the code to your needs, and post back if specific help is needed.
Sub LinkToOutlook()
Dim olApp As Object
Dim olNS As Object
Dim olFolderInbox As Object
Dim rOutput As Range
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.getNamespace("MAPI")
Set olFolderInbox = olNS.GetDefaultFolder(6) 'Gets the default inbox folder
Set rOutput = Sheet1.Range("A1")
For Each itm In olFolderInbox.items
If itm.unread = True Then 'check if it has already been read
rOutput.Value = itm.body
Set rOutput = rOutput.Offset(1)
End If
Next itm
End Sub
Alternatively, you can write code in Outlook directly that looks for new mail arrival, and from there, you can test if it meets your criteria, and if it does, it can write to Excel. Here's a link to get you started. Post back for added help.
Using VBA to read new Outlook Email?
I am trying to create three Outlook appointments in a specific (shared) calendar.
The events will be all-day events. I want the dates for the current row to be added to the calendar. All three dates will be in the same row on the spreadsheet.
The code creates the appointment but the for loop is not working. The only event that is created is the last date.
Sub Makeapt()
Set myOutlook = CreateObject("Outlook.Application")
Set myApt = myOutlook.createitem(1)
Dim i As Integer
For i = 3 To 5
myApt.Subject = Cells(ActiveCell.Row, 1).Value
myApt.Start = Cells(ActiveCell.Row, i).Value
myApt.Save
Next i
End Sub
I solved the problem. Appt still goes to the default calendar, but that is actually preferable.
Sub Makeapt()
Dim warning
warning = MsgBox("You are about to create Outlook appointments for subject #" & Cells(ActiveCell.Row, 3) & ". Is that right?", vbOKCancel)
If warning = vbCancel Then Exit Sub
Set myOutlook = CreateObject("Outlook.Application")
Set ID = Cells(ActiveCell.Row, 3)
Dim i As Integer
For i = 7 To 9
Set myApt = myOutlook.createitem(1)
myApt.Subject = "Subject #" & ID
myApt.Start = Cells(ActiveCell.Row, i).Value
myApt.Save
Next i
End Sub
Dmitry nailed it for how to create an appointment/meeting in a shared calendar from Excel. His post was a big help to me as it seems there are not any very good answers to how to create an appointment on a shared calendar. I looked all over numerous forums to get answers and came up with very little. Based on his answer, I was able to get it working. Below is an example script I put together. This is a somewhat stripped-down version of what I am using for my needs, but I did test this example and it works. Just make sure the Outlook library is selected in the Excel VBA editor's Tools->References menu item.
Sub SendInvitationAsUser()
Rcpts = "user#test.com; user2#test.com, etc#test.com" ' These can be in other formats that Outlook understands like display name.
Subject = "Meeting sent from shared calendar"
' Creates Outlook instance
Set OutApp = CreateObject("Outlook.Application")
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim objfolder As Outlook.Folder
Set myNamespace = OutApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Smith, John Q") 'The invite will come from this user's mailbox
myRecipient.Resolve
If myRecipient.Resolved Then
Set objfolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar) 'Sets folder where appt will be created
Else
ok = MsgBox("Unable to resolve the name of the sender.", vbCritical, "Error")
Exit Sub
End If
Set OutlookAppt = objfolder.Items.Add(olAppointmentItem) 'Creates appointment in shared calendar
' Edit Outlook appointment, convert to meeting invitation by adding recipients.
With OutlookAppt
.MeetingStatus = olMeeting
.Subject = Subject
.Start = #1/1/2018 8:00:00 AM#
.End = #1/1/2018 9:00:00 AM#
.Location = "Conference Room 1"
.RequiredAttendees = Rcpts
End With
'Use Word to do fancy formatting of body text. Example below is basic but a lot of formatting via VBA is possible.
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
Set DocSelection = WordApp.Selection
WordApp.Visible = True
WordDoc.Activate ' You want to see the window, right?
DocSelection.Font.Name = "Arial" ' Everything is Arial.
DocSelection.Font.Size = "10" ' Everything is size 10.
DocSelection.ParagraphFormat.SpaceAfter = "0" ' No line spacing.
DocSelection.ParagraphFormat.SpaceBefore = "0" ' No line spacing.
DocSelection.TypeText ("Please plan to attend my meeting.")
WordDoc.Content.Copy
OutlookAppt.Display
Set TargetApptDoc = OutlookAppt.GetInspector.WordEditor
TargetApptDoc.Range(0, 0).Paste
WordDoc.Close savechanges:=False
WordApp.Quit
End Sub
If you want a shared calendar, create a recipient object using Application.CreateRecipient, open the shared calendar using Application.Session.GetSharedDefaultFolder, create an appointment using MAPIFolder.Items.Add.
I would like to paste a range of formatted Excel cells into an Outlook message.
The following code (that I lifted from various sources), runs without error and sends an empty message.
Sub SendMessage(SubjectText As String, Importance As OlImportance)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim iAddr As Integer, Col As Integer, SendLink As Boolean
'Dim Doc As Word.Document, wdRn As Word.Range
Dim Doc As Object, wdRn As Object
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set Doc = objOutlookMsg.GetInspector.WordEditor
'Set Doc = objOutlookMsg.ActiveInspector.WordEditor
Set wdRn = Doc.Range
wdRn.Paste
Set objOutlookRecip = objOutlookMsg.Recipients.Add("MyAddress#MyDomain.com")
objOutlookRecip.Type = 1
objOutlookMsg.Subject = SubjectText
objOutlookMsg.Importance = Importance
With objOutlookMsg
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
' Set the Subject, Body, and Importance of the message.
'.Subject = "Coverage Requests"
'objDrafts.GetFromClipboard
Next
.Send
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
I think you need to call .Save on your Mail Item (objOutlookMsg) after you've made all the changes.
Put .Display before .Send,
Simple but Quick fix, your problem is the email is not refreshing with the pasted contents before it sends, forcing it to Display first gives it time...
Also make sure you have another macro which runs before this to Copy the Range into your clipboard...
There is a button in excel to do this, "Send to mail recipent" its not normally on the ribbon.
You can also use the simple mapi built into office using the MailEnvelope in VBA
.. a good article on what you are trying to do http://www.rondebruin.nl/mail/folder3/mail4.htm