I want to display Outlook Calendar appointments from a given date in a MessageBox. Unfortunately the code I am using does not show any appointments for today. If i change my code to sfilter = "[Start] >= '" & startDate & "' "
then i get todays appointments with all future appointments for other dates. I want to only show appointments for the specified date.
The date selection is from a UserForm
called cmDates.srtDate.Value
sFilter
is the variable I am using the hold the date filter throughout the code
Code
Public Function getOutlookAppointments() As String
Dim oOutlook As Object
Dim oNS As Object
Dim oAppointments As Object
Dim oFilterAppointments As Object
Dim oAppointmentItem As Object
Dim bOutlookOpened As Boolean
' Dim rslt As String
Dim sfilter As String
Dim startDate As Date
Dim displayText As String
Dim start As Date
Const olFolderCalendar = 9
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance of Outlook, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
bOutlookOpened = False 'Outlook was not already running, we had to start it
Else
bOutlookOpened = True 'Outlook was already running
End If
On Error GoTo Error_Handler
DoEvents
Set oNS = oOutlook.GetNamespace("MAPI")
Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
startDate = cmDates.srtDate.value
'Apply a filter so we don't waste our time going through old stuff if we don't need to.
sfilter = "[Start] = '" & startDate & "' "
Set oFilterAppointments = oAppointments.Items.Restrict(sfilter)
For Each oAppointmentItem In oFilterAppointments
getOutlookAppointments = getOutlookAppointments & oFilterAppointments.Count & " appointment(s) found" & vbCrLf & vbCrLf & oAppointmentItem.Subject & vbCrLf & oAppointmentItem.start & vbCrLf & oAppointmentItem.End & vbCrLf & vbCrLf
'displayText = displayText & oAppointmentItem.Subject
Next
MsgBox prompt:=getOutlookAppointments, _
Title:="Appointments for"
If bOutlookOpened = False Then 'Since we started Outlook, we should close it now that we're done
oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
End If
Error_Handler_Exit:
On Error Resume Next
Set oAppointmentItem = Nothing
Set oFilterAppointments = Nothing
Set oAppointments = Nothing
Set oNS = Nothing
Set oOutlook = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetFutureOutlookEvents" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
outlookDates = False
End Function
Your restriction should have two parts - Start > today's midnight
, and Start < tomorrow's midnight
. You only have the first part.
Also keep in mind that if you want instances of the recurring activities (and not just the master appointments), you need to use the Items.IncludeRecurrences
property - see https://docs.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences
There are several aspects:
Restrict
method!IncludeRecurrences
property. The Count
property may return unexpected results and cause an infinite loop. 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 available in VBA. So, you must specify the date in the format which Outlook understand. Format(youDate, "ddddd h:nn AMPM")
For example, here is a sample VB.NET code:
Imports System.Text
Imports System.Diagnostics
' ...
Private Sub RestrictCalendarItems(folder As Outlook.MAPIFolder)
Dim dtEnd As DateTime = New DateTime(DateTime.Now.Year, DateTime.Now.Month, _
DateTime.Now.Day, 23, 59, 0, 0)
Dim restrictCriteria As String = "[Start]<=""" + dtEnd.ToString("g") + """" + _
" AND [End]>=""" + DateTime.Now.ToString("g") + """"
Dim strBuilder As StringBuilder = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItems As Outlook.Items = Nothing
Dim appItem As Outlook._AppointmentItem = Nothing
Dim counter As Integer = 0
Dim item As Object = Nothing
Try
strBuilder = New StringBuilder()
folderItems = folder.Items
folderItems.IncludeRecurrences = True
folderItems.Sort("[Start]")
resultItems = folderItems.Restrict(restrictCriteria)
item = resultItems.GetFirst()
Do
If Not IsNothing(item) Then
If (TypeOf (item) Is Outlook._AppointmentItem) Then
counter = counter + 1
appItem = item
strBuilder.AppendLine("#" + counter.ToString() + _
" Start: " + appItem.Start.ToString() + _
" Subject: " + appItem.Subject + _
" Location: " + appItem.Location)
End If
Marshal.ReleaseComObject(item)
item = resultItems.GetNext()
End If
Loop Until IsNothing(item)
If (strBuilder.Length > 0) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " _
+ folder.Name + " folder.")
End If
catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
If Not IsNothing(resultItems) Then Marshal.ReleaseComObject(resultItems)
End Try
End Sub
You may find the following articles helpful:
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.