【发布时间】：2018-01-09 11:04:46
【问题描述】：
我有一个 Excel 文件，我在其中记录了员工的行为。
这是以下设计： ID 数据类型 Typedatail 元数据 Regdata hours
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
`
基本限制示例（展望） 子 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) 触发 true，尽管约会不在列表中。
上面的代码是用来编辑或删除约会的基础。
【问题讨论】：
标签： vba excel outlook automation appointment