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
Related
I am trying to extract future calendar events from Outlook using the Items.Restrict method.
If the filter is not applied, it returns more than 70 results, older and future events.
When the filter for future events is applied, it returns around 20 results, most of them, future events, but also some old ones.
The Restrict filter is partially working, but I cannot understand why is not filtering those few old events.
Dim oOutlook As Object
Dim oMAPI As Object
Dim oAppointments As Object
Dim oFilteredAppointments As Object
Dim oAppointmentItem As Object
Dim sFilter As String
Const olFolderCalendar = 9
Set oOutlook = GetObject(, "Outlook.Application")
Set oMAPI = oOutlook.GetNamespace("MAPI")
Set oAppointments = oMAPI.GetDefaultFolder(olFolderCalendar)
sFilter = "[Start]>'" & Date & "'"
Debug.Print sFilter
Set oFilteredAppointments = oAppointments.Items.Restrict(sFilter)
For Each oAppointmentItem In oFilteredAppointments
Debug.Print oAppointmentItem.Start
Next
To show some evidence of the filter and the results I'm getting:
Calendars are trickier than normal folders. I had to combine the two filters as was suggested in Restrict Outlook Items by Date.
Note: oAppointmentItems rather than oAppointments.Items.
Option Explicit
Private Sub calApptsInSpecifiedRange()
Dim oCalendarFolder As Folder
Dim oAppointmentItems As Items
Dim oFilteredAppointments As Items
Dim oAppointmentItem As Object
Dim sFilter As String
Set oCalendarFolder = Session.GetDefaultFolder(olFolderCalendar)
Set oAppointmentItems = oCalendarFolder.Items
oAppointmentItems.Sort "[Start]", False
oAppointmentItems.IncludeRecurrences = True
sFilter = "[Start] > '" & Date & "'" & " AND [Start] < " & "'" & Date + 30 & "'"
Debug.Print sFilter
Set oFilteredAppointments = oAppointmentItems.Restrict(sFilter)
For Each oAppointmentItem In oFilteredAppointments
Debug.Print oAppointmentItem.Start, oAppointmentItem.Subject
Next
Debug.Print "Done."
End Sub
To retrieve all Outlook appointment items from the folder that meets the predefined condition, you need to sort the items in ascending order and set the IncludeRecurrences to true. You will not catch recurrent appointments if you don’t do this before using the Restrict method. Read more about that in the How To: Use Restrict method in Outlook to get calendar items article.
Also you may find the How To: Retrieve Outlook calendar items using Find and FindNext methods article helpful.
Dates and times are typically stored with a Date format, the Find and Restrict methods require that the date and time be converted to a string representation. To make sure that the date is formatted as Microsoft Outlook expects, use the Format function. The following example creates a filter to find all contacts that have been modified after January 15, 2022 at 3:30 P.M.
sFilter = "[LastModificationTime] > '" & Format("1/15/2022 3:30pm", "ddddd h:nn AMPM") & "'"
MS Word 2010 has a bug in its ability to correctly maintain (of all things) the documents collection (link to earliest report found - social.msdn.microsoft.com).
As far as I can tell this bug only impacts Word 2010. Although the documents collection is not maintained, it turns out that the Application.Windows collection is. Hence, for Word 2010 the following code based on the original reporters investigation (see below) and this question on answers.microsoft.com seem to provide a good alternative to the buggy documents collection:
' PURPOSE:
' Return a document collection, work-around for Word 2010 bug
Public Function docCollection() As VBA.Collection
Dim indexOfAvailableAppWindows As Long
Dim resultDoc As VBA.Collection
Dim foundDoc As Word.Document
Set resultDoc = New Collection
For indexOfAvailableAppWindows = 1 To Application.Windows.Count
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
Set foundDoc = Application.Windows(indexOfAvailableAppWindows).Document
resultDoc.Add foundDoc, foundDoc.FullName ' Can NOT use 'name' - fails to be unique
End If
Next indexOfAvailableAppWindows
Set docCollection = resultDoc
Set resultDoc = Nothing
End Function
However, and here's my question, the above code some times fails with error 457 This key is already associated with an element of this collection on line resultDoc.Add foundDoc, foundDoc.FullName. What circumstances could possibly lead to such a failure?
So far the code has only failed on 1 PC running Word 2016. I don't have access to the PC. I did discover that the original version used Document.Name as the key (which was not always unique, so this was changed to Document.Full name)
Assumptions:
Document.FullName will always be unique
Things I've ruled out:
use of Split Window
opening downloaded documents (protected window documents are not counted)
Code that can be used to demonstrate the issue in Word 2010 (adapted from the original report).
' Function Credit Bas258 (https://social.msdn.microsoft.com/profile/bas258)
Function test01() As Boolean
'Adapted to VBA from original: 03-11-2012 1.0 Visual Studio 2008 VB code
Dim oDoc As Word.Document
Dim oDoc0 As Word.Document
Dim oDoc1 As Word.Document
Dim oDoc2 As Word.Document
Dim oDoc3 As Word.Document
Dim oDoc4 As Word.Document
Dim n As Integer
Set WDapp = Application
With WDapp
Debug.Print (Format(Now(), "dd-MM-yyyy") & " MS Office " & .Application.Version)
Set oDoc0 = .Documents.Add: Debug.Print ("add " & oDoc0.Name)
Set oDoc1 = .Documents.Add: Debug.Print ("add " & oDoc1.Name)
Set oDoc2 = .Documents.Add: Debug.Print ("add " & oDoc2.Name)
Set oDoc3 = .Documents.Add: Debug.Print ("add " & oDoc3.Name)
Set oDoc4 = .Documents.Add: Debug.Print ("add " & oDoc4.Name)
For n = 1 To .Documents.Count
Debug.Print ("count " & n & " " & .Documents(n).Name)
Next n
Debug.Print ("close " & oDoc4.Name)
oDoc4.Close
Set oDoc4 = Nothing
Debug.Print ("close " & oDoc3.Name)
oDoc3.Close
Set oDoc3 = Nothing
For n = 1 To .Documents.Count
Debug.Print ("count " & n & " " & .Documents(n).Name)
Next n
n = 0
For Each oDoc In .Documents
n = n + 1
Debug.Print ("doc " & n & " " & oDoc.Name)
Next oDoc
n = 0
For Each oWin In .Windows
n = n + 1
Debug.Print ("win " & n & " " & oWin.Document.Name)
Next oWin
Debug.Print ("close " & oDoc2.Name)
oDoc2.Close
Set oDoc2 = Nothing
Debug.Print ("close " & oDoc1.Name)
oDoc1.Close
Set oDoc1 = Nothing
Debug.Print ("close " & oDoc0.Name)
oDoc0.Close
Set oDoc0 = Nothing
End With
Set WDapp = Nothing
End Function
This is NOT going to be the accepted answer. Although it does answer the broader question (what could cause this code to crash) it not address the specific crash that I am trying to isolate. Either way there appears to be another bug in MS Word which seemed to be worth capturing for the common good.
This time the bug is with the Windows Collection; and joy of joys, I've confirmed it for both Word 2010 and Word 2016 - both 64 bit apps.
Steps to reproduce the bug are as follows:
In windows explorer enable the Preview Pane
Select a word document FILE so that it is 'previewed'
Open the same document (without losing the 'preview view')
Run the code from the OP, it will crash on this line:
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
It turns out that when a word file is being previewed the Application.Windows.Count property is incremented by the preview; however any attempt to get a property of that window results in Error 5097 - Word has encountered a problem.
So, an improvement to the original code would therefore be:
' PURPOSE:
' Returns a healthy document collection
' - work-around for Word 2010 bug
' - excludes hits from Windows Explorer Preview Pane
Public Function docCollection() As VBA.Collection
On Error GoTo docCollectionError
Dim indexOfAvailableAppWindows As Long
Dim resultDoc As VBA.Collection
Dim foundDoc As Word.Document
Set resultDoc = New Collection
' Use index instead of Each to avoid For Loop Not initialised error, preview pane
For indexOfAvailableAppWindows = 1 To Application.Windows.Count
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
Set foundDoc = Application.Windows(indexOfAvailableAppWindows).Document
resultDoc.Add foundDoc, foundDoc.FullName ' Key must NOT be 'name' - fails to be unique see BUG: 1315
End If
lblSkipThisDoc:
Next indexOfAvailableAppWindows
Set docCollection = resultDoc
Set resultDoc = Nothing
Exit:
Exit Function
docCollectionError:
If Err.Number = 5097 Then ' An open document is also open in the Windows Explorer Preview Pane
Err.Clear
Resume lblSkipThisDoc ' - skip this window
End If
If Err.Number = 457 Then ' Key is already used, but HOW? Unknown cause of error
Err.Clear
Stop 'Resume lblSkipThisDoc ' Is it safe to skip this document, why is there a duplicate?
End If
End Function
There is a setting in MS Word that enables 1 document to be viewed in 2 windows. In Word 2010 it is under the View (Tab): Window > New Window
The new window is counted separately in Application.Windows.Count and returns the same document object, hence the key exists.
For indexOfAvailableAppWindows = 1 To Application.Windows.Count ' <<< New Windows is counted
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
Set foundDoc = Application.Windows(indexOfAvailableAppWindows).Document
resultDoc.Add foundDoc, foundDoc.FullName ' <<< fails to add 2nd instance of document
End If
So... the solution would likely involve checking the caption of the document:
IMMEDIATE WINDOW:
?foundDoc.Windows(1).Caption
Document2:1
Can someone point out what I am missing here. Every time I run this it says that an object is required.
I apologize I feel like this is a very easy fix but I have been wrecking my brain for a while.
Basically what I am trying to accomplish is count how many emails are mark as high importance.
Again I feel like this is such a simple error but I am still learning this.
Sub CheckForImportance()
Dim myNs As Outlook.NameSpace
Dim infldr As Outlook.Folder
Dim impMail As Outlook.MailItem
Dim ttlcount As Integer
Set myNs = Application.GetNamespace("MAPI")
Set infldr = myNs.GetDefaultFolder(olFolderInbox)
Set impMail = infldr.Items
Set ttlcount = 0
If impMail.Importance = olImportanceHigh Then ttlImp = ttlImp + 1
MsgBox ("count:" & ttlImp)
End Sub
Outlook stores mail items, calendar items, tasks and so on in files it calls Stores. Sometimes people say mail items and so on are stored in PST files which is usually true. However, all PST files are stores but not all stores are PST files.
I remember when the default was for messages sent to any of your email addresses to be loaded to the same store. In that situation, Set infldr = myNs.GetDefaultFolder(olFolderInbox)was useful since the default Inbox was in that one store.
With Outlook 2016, and perhaps some other recent versions, the default is to have a separate store for each email address. Each of these stores is named for the email address, for example: “JohnDoe#hotmail.com” or “DoeJ#gmail.com”.
Copy this macro to an Outlook module and run it:
Sub DsplUsernameOfDefaultStore()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)
Debug.Print DefaultInboxFldr.Parent.Name
End Sub
On my system, this macro outputs “Outlook Data File”. This was the default store that came with Outlook but none of my emails are loaded to it.
You will need something like:
Set infldr = Session.Folders("Xxxx").Folders("Inbox")
where Xxxx is the name of the store containing the Inbox you wish to interrogate.
Below I have three alternative macros that count the number of high importance emails in an Inbox. Points of particular note:
Version 1 uses a For Each loop as I suggested in my comment. Version 2 uses a For IndexVariable loop. To my knowledge, neither type of For has an advantage over the other. I use whichever seems more convenient for the task at hand. Version 3 uses a filter. I have not found a use for the Outlook filter often enough to have become expert in its use so I normally use a For loop. olImportanceHigh is a constant with a value of 2. It appears you cannot use a constant within a Restrict string which is why it says [Importance] = 2.
I find Debug.Print much more convenient than MsgBox during development.
Come back with questions about my code as necessary.
Option Explicit
Sub CountHighImportanceEmails1()
Dim FldrInbox As Folder
Dim MailItemCrnt As MailItem
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
For Each MailItemCrnt In FldrInbox.Items
If MailItemCrnt.Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails2()
Dim FldrInbox As Folder
Dim InxMi As Long
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
With FldrInbox
For InxMi = 1 To .Items.Count
If .Items(InxMi).Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
End With
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails3()
Dim FldrInbox As Folder
Dim MailItemsHighImport As Items
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
Set MailItemsHighImport = FldrInbox.Items.Restrict("[Importance] = 2")
Debug.Print "Number of high importance emails=" & MailItemsHighImport.Count
End Sub
Example would be
Option Explicit
Public Sub Example()
Dim Inbox As Outlook.folder
Set Inbox = Application.Session.GetDefaultFolder( _
olFolderInbox)
Dim Filter As String
Filter = "[Importance] = 2"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Debug.Print Items.Count
MsgBox Items.Count & " High importance Items are in " & Inbox.Name
End Sub
My company uses a single email address for customers to send requests and orders to. we created an Access database that import emails into a table. The table creates it's own unique identifier for each email imported but is not supposed to import an email twice. The system was working as we were only concerned with emails coming into the inbox and didn't need anything more than that.
However we now need to know the "flow", "traffic" and "workload" of the email pool that this account is. The email that comes into the inbox is categorized and then moved to a folder called "my_tasks" and a subfolder the folder named as 1 of the four CSRs to be worked on by a manager. This email is then dealt with and the CSR moves it to a subfolder under another folder called "Completed".
So email comes into Inbox, gets moved to my_tasks\joeblow is dealt with and gets moved to Completed\Canada.
Currently I have code that iterates through the folders and finds each email, grabs the fields we want to store and then inserts them into the table. All of this is done in Access through VBA code.
Private Sub ImportEmailItem(objMailItem As Outlook.MailItem)
On Error GoTo ImportEmailItem_Error
' Set up DAO objects
Dim rstMB As DAO.Recordset
Dim dskippedFolderMailCount As Double
Dim strSQLrMB As String
strSQLrMB = "SELECT * FROM tblMailBox WHERE OLID='" & objMailItem.EntryID & "'"
Set rstMB = CurrentDb.OpenRecordset(strSQLrMB)
With rstMB
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
If .Updatable Then
.Edit
rstMB!Subject = objMailItem.Subject
rstMB!Body = objMailItem.Body
Call subCategory(objMailItem)
rstMB!CSR = IIf(Len(objMailItem.Categories) = 0, "Unassigned", objMailItem.Categories)
rstMB!Importance = objMailItem.Importance
rstMB!Region = objMailItem.Parent
rstMB!DateModified = objMailItem.LastModificationTime
rstMB!FlagCompleted = objMailItem.FlagRequest
rstMB!folder = objMailItem.Parent
rstMB!Path = objMailItem
.Update
End If
.MoveNext
Wend
Else
rstMB.AddNew
rstMB!olid = objMailItem.EntryID
rstMB!ConversationIndex = objMailItem.ConversationIndex
rstMB!ConversationID = objMailItem.ConversationID
rstMB!Conversation = objMailItem.ConversationTopic
rstMB!To = Left(objMailItem.To, 250)
rstMB!CC = Left(objMailItem.CC, 250)
rstMB!Subject = objMailItem.Subject
rstMB!Body = objMailItem.Body
Call subCategory(objMailItem)
rstMB!CSR = IIf(Len(objMailItem.Categories) = 0, "Unassigned", objMailItem.Categories)
rstMB!Importance = objMailItem.Importance
rstMB!From = objMailItem.SenderEmailAddress
rstMB!Region = objMailItem.Parent
rstMB!DateReceived = objMailItem.ReceivedTime
rstMB!DateSent = objMailItem.SentOn
rstMB!DateCreated = objMailItem.CreationTime
rstMB!DateModified = objMailItem.LastModificationTime
rstMB!FlagCompleted = objMailItem.FlagRequest
rstMB!folder = objMailItem.Parent
rstMB.Update
End If
.Close
End With
ImportEmailItem_Exit:
Set rstMB = Nothing
Exit Sub
ImportEmailItem_Error:
Debug.Print Err.Number & " " & Err.Description
Select Case Err.Number
Case 91
Resume Next
Case 3022
Resume Next
Case -2147221233
MsgBox "Customer Care Account Name is incorrect, please enter the Mail box name as seen in your outlook client.", vbOKOnly, "Mail Folder Name Error"
Me.txtMailAccountName.SetFocus
Exit Sub
Case Else
MsgBox "Error #: " & Err.Number & " " & Err.Description '& Chr(13) + Chr(10) & IIf(mail.Subject Is Null, "", mail.Subject) & " " & IIf(mail.ReceivedTime Is Null, "", mail.ReceivedTime)
' DoCmd.RunSQL "INSERT INTO tblImportReport(ImportDate,ImportFolder,ImportResult,ImportEmailCount) VALUES (#" & Now() & "#,'" & mailFolder & "', 'Error " & Err.Number & "', " & dMailCount & ")"
Resume Next 'cmdImportEmail_Exit
End Select
End Sub
Is there a way to uniquely identify an email with a single field no matter whether it has been moved or not?
I have an idea of what I could do to make sure I have the right email and get the original entry in my database. If there was no other way I could concatenate fields together to form a unique field and then get the database table's primary key field value.
You can use the PR_SEARCH_KEY property (DASL name http://schemas.microsoft.com/mapi/proptag/0x300B0102) - it does not change when a message is moved. It can be accessed through MailItem.PropertyAccessor.GetProperty, but unfortunately you cannot use PT_BINARY properties in Items.Find/Restrict.
You can also set your own named property using MailItem.UserProperties.
UPDATE:
For PR_SEARCH_KEY, see https://msdn.microsoft.com/en-us/library/office/cc815908.aspx.
MaillItem.UserProperties can be used from anywhere - Outlook Object Model is Outlook Object Model whether it is used from inside Outlook or externally from Excel. Keep in mind that setting a user property and saving the item will change its last modified date.
If you want to stick to PR_SEARCH_KEY, to be be able to sort on it, you might want to look at Redemption (I am its author) - its RDOFolder.Items.Find / Restrict methods allow PT_BINARY properties in its queries, e.g. "http://schemas.microsoft.com/mapi/proptag/0x300B0102" = '89F75D48972B384EB2C50266D1541099'
Here is VBA code tested in MS Access 2013 to extract the PR_SEARCH_KEY from an Outlook.MailItem and convert to a string:
Public Function strGetMailItemUniqueId( _
olMailItem As Outlook.MailItem _
) As String
Dim PR_SEARCH_KEY As String
PR_SEARCH_KEY = "http://schemas.microsoft.com/mapi/proptag/0x300B0102"
Dim olPA As Outlook.PropertyAccessor
Set olPA = olMailItem.PropertyAccessor
Dim vBinary As Variant
vBinary = olPA.GetProperty(PR_SEARCH_KEY)
strGetMailItemUniqueId = olPA.BinaryToString(vBinary)
End Function
In Microsoft Outlook versions like 2007, 2010, Office 365 etc. there is a property Message-ID in the headers section of the email.
You can use this property to uniquely identify an email.
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