我有一个excel文件，其中我注册了员工的行为。
这是以下设计： ID数据类型Typedatail元数据Regdata小时
3767 01/04/2018 SN VM 64 05/01/2018 4
3767 01/04/2018 SN NM 65 05/01/2018 4
3767 03/04/2018 SN VM 66 05/01/2018 4
3767 03/04/2018 SN NM 67 05/01/2018 4
3767 04/04/2018 SN VM 68 05/01/2018 4
3767 04/04/2018 SN NM 69 05/01/2018 4
3767 07/04/2018 CA 70 05/01/2018 8
3767 08/04/2018 CA 71 05/01/2018 8
3767 09/04/2018 CA 72 05/01/2018 8
3683 12/01/2018 OU- 73 05/01/2018 -8
我还需要将它们放入日历中以分发这些知识。 ！（https://ibb.co/hQmOxR）
但有时我需要编辑那些。 （更改或删除那些）
我发现以下作为基础 Search Appointments in excel with VBA
这最终会找到它们，但这会通过所有约会，这是不必要的，因为我知道约会的设定日期。
因此我想限制范围，但我犯了它的错误，我无法弄明白。
基础查找预约
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) 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
Dim strRestriction As String 'opmaak zoekbeperking
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 = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar) 'oNameSpace.Session.GetDefaultFolder(9).Folders(olFolderCalendar)
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 And InStr(oApptItem.Body, argTikNummer) Then
MsgBox oApptItem.Body
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 intTikNummer As Integer
Dim sbCheck As String
Sheets("blad1").Select
Dim i As Long
i = 2
Do Until Trim(Cells(i, 1).Value) = "" 'voorlopig test omgeving. Moet worden omgevormd tot een single entry test
dtCheck = Cells(i, 2) '+ TimeValue("09:00:00")
intTikNummer = Cells(i, 1)
If CheckAppointment(dtCheck, intTikNummer) Then
MsgBox "Appointment found", vbOKOnly + vbInformation 'dummy uitkomst verslag. Moet worden vervangen door een opdracht
Else
MsgBox "Appointment not found", vbOKOnly + vbExclamation 'dummy uitkomst verslag. Moet worden vervangen door een opdracht
End If
i = i + 1
Loop
End Sub
`
基本限制示例（展望） Sub FindAppts（）
Dim myStart As Date
Dim myEnd As Date
Dim oCalendar As Outlook.folder
Dim oItems As Outlook.items
Dim oItemsInDateRange As Outlook.items
Dim oFinalItems As Outlook.items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String
myStart = Date
myEnd = DateAdd("d", 30, myStart)
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
'Construct filter for the next 30-day date range
strRestriction = "[Start] >= '" &; _
Format$(myStart, "mm/dd/yyyy hh:mm AMPM") _
&; "' AND [End] <= '" &; _
Format$(myEnd, "mm/dd/yyyy hh:mm AMPM") &; "'"
'Check the restriction string
Debug.Print strRestriction
Set oCalendar = Application.session.GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.items
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
'Restrict the Items collection for the 30-day date range
Set oItemsInDateRange = oItems.Restrict(strRestriction)
'Construct filter for Subject containing 'team'
Const PropTag As String = "http://schemas.microsoft.com/mapi/proptag/"
strRestriction = "@SQL=" &; Chr(34) &; PropTag _
&; "0x0037001E" &; Chr(34) &; " like '%team%'"
'Restrict the last set of filtered items for the subject
Set oFinalItems = oItemsInDateRange.Restrict(strRestriction)
'Sort and Debug.Print final results
oFinalItems.Sort "[Start]"
For Each oAppt In oFinalItems
Debug.Print oAppt.Start, oAppt.Subject
Next
End Sub
`
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) 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 oFolderA As Object
Dim oFolderB As Object
Dim oMeetingoApptItem As Object
Dim oObject As Object
Dim myStart, myEnd As Date
Dim strRestriction As String 'opmaak zoekbeperking
'Construct filter for day date range
myStart = Format(argCheckDate, "dd/mm/yyyy") 'argcheckdate
myEnd = DateAdd("d", 1, myStart)
myEnd = Format(myEnd, "dd/mm/yyyy") 'Argcheckdate
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
strRestriction = "[Start] = '" & myStart & "' AND [End] = '" & myEnd & "'"
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 = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar) 'oNameSpace.Session.GetDefaultFolder(9).Folders(olFolderCalendar)
CheckAppointment = False
'Restrict the Items collection for the 30-day date range
Set oFolderA = oFolder.Restrict(strRestriction)
For Each oObject In oFolderA.Items
MsgBox oObject & " : " & oObject.Start & " : " & myStart & " - " & myEnd
If (oObject.Class = olAppointment) Then ' <== This is why you need to define it first
Set oApptItem = oObject
If oApptItem.Start = argCheckDate And InStr(oApptItem.Body, argTikNummer) Then
MsgBox oApptItem.Body
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 oFolderA = Nothing
Set oFolderB = Nothing
Set oObject = Nothing
End Function
我最终得到一个空oApptItem但如果oApptItem.Start = argCheckDate和InStr(oApptItem.Body, argTikNummer)触发为真，尽管约会不在列表中。
以上代码是用于编辑或删除约会的基础。
答案 0 :(得分：0)
过滤日历非常棘手，而且由于没有关闭On Error Resume Next而加剧了这一点。
Option Explicit
Private Sub CheckAppointment_test()
' Appointment date
Dim argCheckDate As String
argCheckDate = "2018-01-05"
' Text in body of appointment
Dim argTikNummer As Long
argTikNummer = 3767
Dim result As Boolean
MsgBox CheckAppointment(argCheckDate, argTikNummer) & vbCr & " Done."
End Sub
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argTikNummer As Integer) As Boolean
' Not required as Outlook must be referenced
' to use olFolderCalendar later
'Const olAppointment = 26
Dim oApp As Object
Dim oNameSpace As Object
Dim oApptItem As Object
Dim oFolder As Object
Dim oFolderA As Object
Dim oObject As Object
Dim myStart, myEnd As Date
Dim strRestriction As String
'Construct filter for day date range
'myStart = Format(argCheckDate, "dd/mm/yyyy") 'argcheckdate
myStart = Format(argCheckDate, "yyyy-mm-dd") 'argcheckdate
myEnd = DateAdd("d", 1, myStart)
'myEnd = Format(myEnd, "dd/mm/yyyy") 'Argcheckdate
myEnd = Format(myEnd, "yyyy-mm-dd") 'Argcheckdate
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
'strRestriction = "[Start] = '" & myStart & "' AND [End] = '" & myEnd & "'"
strRestriction = "[Start] <= '" & myEnd & "' AND [End] >= '" & myStart & "'"
Debug.Print strRestriction
' Misuse causes insurmountable problems as errors are hidden
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
' Mandatory with On Error Resume Next to stop bypassing errors
On Error GoTo 0
' Handle error bypassed above, if any
If oApp Is Nothing Then Set oApp = CreateObject("Outlook.Application")
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
CheckAppointment = False
' *******
Dim oFolderItems As Object
Set oFolderItems = oFolder.items
' Strange behaviour if this is not used
oFolderItems.IncludeRecurrences = True
oFolderItems.Sort "[Start]"
' *******
'Restrict the Items collection for the specified date range
Set oFolderA = oFolderItems.Restrict(strRestriction)
'For Each oObject In oFolderA.items
For Each oObject In oFolderA
Debug.Print oObject.Subject & " : " & oObject.Start
If (oObject.Class = olAppointment) Then
Set oApptItem = oObject
Debug.Print "oApptItem.Start: " & oApptItem.Start
Debug.Print "Formatted oApptItem.Start: " & Format(oApptItem.Start, "yyyy-mm-dd")
Debug.Print "argCheckDate: " & argCheckDate
' Not true unless oApptItem.Start is formatted to match format of argCheckDate
' Should not be necessary if the filter is working correctly
'If oApptItem.Start = argCheckDate Then
Debug.Print InStr(oApptItem.body, argTikNummer)
If InStr(oApptItem.body, argTikNummer) Then
MsgBox oApptItem.Subject & vbCr & oApptItem.body
CheckAppointment = True
' Do not exit if there can be multiple appointments
'Exit For
End If
'End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oFolderA = Nothing
Set oObject = Nothing
End Function