![](/img/trans.png)
[英]How to get outlook appointments via Excel VBA without listingrecurring appointments
[英]Search Appointments in excel with VBA
我正在尝试编写一个脚本,以读取我的Excel工作表,并将日期与Outlook中的约会日期进行比较。
我不知道为什么我的代码没有找到任何OLAppointment项来将其日期与工作表上的dte进行比较...
见下面的代码
Public Function CheckAppointment(ByVal argCheckDate As Date) As Boolean
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oMeetingoApptItem As Object
Dim oObject As Object
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.Session.GetDefaultFolder(9).Folders("aa")
CheckAppointment = False
For Each oObject In oFolder.Items
MsgBox oObject
If (oObject.Class = OLAppointment) Then
Set oApptItem = oObject
If oApptItem.Start = argCheckDate Then
CheckAppointment = True
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function
Public Sub Driver()
Dim dtCheck As Date
Dim sbCheck As String
dtCheck = DateValue("23/11/2013") + TimeValue("09:00:00")
If CheckAppointment(dtCheck) Then
MsgBox "Appointment found", vbOKOnly + vbInformation
Else
MsgBox "Appointment not found", vbOKOnly + vbExclamation
End If
End Sub
我在2013年11月23日的日历“ aa”上创建了一个约会,但是当我尝试使用宏对其进行搜索时,总是给我“未找到约会”。 我还尝试用“ Msgbox”显示通过以下方式找到的约会的属性:
Set oFolder = oNameSpace.Session.GetDefaultFolder(9).Folders("aa")
CheckAppointment = False
For Each oObject In oFolder.Items
MsgBox oObject.Subject
但无论如何都不要走:\\
抱歉我的英语不好。
问题是您没有定义什么是OLAppointment
。 由于这是Excel中的宏,因此您需要定义Outlook内部常量。
Public Function CheckAppointment(ByVal argCheckDate As Date) As Boolean
Const olAppointment = 26 ' <== Added this line and your code worked.
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oMeetingoApptItem As Object
Dim oObject As Object
On Error Resume Next ' No appointment was found since you have this line and olAppointmnet wasn't defined.
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.Session.GetDefaultFolder(9).Folders("aa")
CheckAppointment = False
For Each oObject In oFolder.Items
MsgBox oObject
If (oObject.Class = olAppointment) Then ' <== This is why you need to define it first
Set oApptItem = oObject
If oApptItem.Start = argCheckDate Then
CheckAppointment = True
Exit For ' <== Added this exit for loop to improve performance
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function
Public Sub Driver()
Dim dtCheck As Date
Dim sbCheck As String
dtCheck = DateValue("4/11/2013") + TimeValue("09:00:00")
If CheckAppointment(dtCheck) Then
MsgBox "Appointment found", vbOKOnly + vbInformation
Else
MsgBox "Appointment not found", vbOKOnly + vbExclamation
End If
End Sub
您的代码可以正常工作,并使用默认Calendar
下名为aa
的Calendar
进行测试。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.