Блог

Работает следующий код, который я немного адаптировал, однако я пытаюсь выполнить 2 заключительных шага, которые, похоже, не работают.

Я пытаюсь показать время начала и время окончания, но в конечном времени мне не нужна дата, так как я пытаюсь показать доступность и поэтому не нужно повторять дату. Таким образом, в настоящее время в окне печати отображается следующее»25/06/2021 14:45:34 25/06/2021 16:05:00″ Хотите удалить среднюю дату. Я пробовал маски, но просто ошибаюсь.

Также пытаюсь, когда появляется диалоговое окно, я хочу скопировать содержимое в буфер обмена?

 Dim CalFolder As Outlook.Folder
Dim nameFolder
Dim strKeyword As String
Dim strResults As String

' Run this macro
 Sub SearchinSharedCalendars()
 Dim objPane As Outlook.NavigationPane
 Dim objModule As Outlook.CalendarModule
 Dim objGroup As Outlook.NavigationGroup
 Dim objNavFolder As Outlook.NavigationFolder
 Dim objCalendar As Folder
 Dim objFolder As Folder

 Dim i As Integer
 Dim g As Integer
 On Error Resume Next

 Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)

 Set Application.ActiveExplorer.CurrentFolder = objCalendar
 DoEvents
 
strKeyword = InputBox("Search subject and body", "Search Shared Calendars")

 Set objPane = Application.ActiveExplorer.NavigationPane
 Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)

 With objModule.NavigationGroups

 For g = 1 To .Count

 Set objGroup = .Item(g)

 For i = 1 To objGroup.NavigationFolders.Count
 Set objNavFolder = objGroup.NavigationFolders.Item(i)

 If objNavFolder.IsSelected = True Then

 Set CalFolder = objNavFolder.Folder
 Set nameFolder = objNavFolder

 Dim NS As Outlook.NameSpace
 Dim objOwner As Outlook.Recipient
 Set NS = Application.GetNamespace("MAPI")
 Set objOwner = NS.CreateRecipient(nameFolder)
 objOwner.Resolve
 If objOwner.Resolved Then
 Set CalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
 End If

SearchSharedCalendar

txtSearchResults = strResults amp; vbCrLf amp; txtSearchResults
 
 End If
 Next i
 Next g
 End With
 
MsgBox txtSearchResults

 Set objPane = Nothing
 Set objModule = Nothing
 Set objGroup = Nothing
 Set objNavFolder = Nothing
 Set objCalendar = Nothing
 Set objFolder = Nothing
 End Sub

 Private Sub SearchSharedCalendar()

 Dim CalItems As Outlook.Items
 Dim ResItems As Outlook.Items
 Dim oFinalItems As Outlook.Items
 Dim sFilter As String
 Dim iNumRestricted As Integer
 Dim itm As Object
 Dim strAppt As String
 Dim endAppt As String
 Dim dStart1 As Date, dStart2 As Date

 
 Set CalItems = CalFolder.Items

 If CalFolder = printCal Then
 Exit Sub
 End If

 ' Sort all of the appointments based on the start time
 CalItems.Sort "[Start]"
 
 ' body key word doesn't work if including recurring
 CalItems.IncludeRecurrences = True

 On Error Resume Next
 ' if you arent search subfolders, you only need parent name
 strName = CalFolder.Parent.Name amp; " - " amp; CalFolder.Name

' set dates
dStart1 = Date
dStart2 = Date   30

' fileer by date first
sFilter = "[Start] >= '" amp; dStart1 amp; "'" amp; " And [Start] < '" amp; dStart2 amp; "'"
Debug.Print sFilter

'Restrict the Items collection for the 30-day date range
 Set ResItems = CalItems.Restrict(sFilter)

' Filter the results by keyword
' filter for Subject containing strKeyword '0x0037001E
' body is 0x1000001f
    Const PropTag  As String = "http://schemas.microsoft.com/mapi/proptag/"
    sFilter = "@SQL=(" amp; Chr(34) amp; PropTag _
        amp; "0x0037001E" amp; Chr(34) amp; " like '%" amp; strKeyword amp; "%' OR " amp; Chr(34) amp; PropTag _
        amp; "0x1000001f" amp; Chr(34) amp; " like '%" amp; strKeyword amp; "%')"
Debug.Print sFilter
'Restrict the last set of filtered items for the subject
Set oFinalItems = ResItems.Restrict(sFilter)

'Sort and collect final results
oFinalItems.Sort "[Start]"
 iNumRestricted = 0
For Each oAppt In oFinalItems
If oAppt.Start >= dStart1 And oAppt.Start <= dStart2 Then
 iNumRestricted = iNumRestricted   1
  strAppt = oAppt.Start amp; " " amp; endAppt
endAppt = oAppt.End

End If
Next
 
 strResults = iNumRestricted amp; " matching Appointment found in " amp; vbCrLf amp; strAppt amp; " " amp; endAppt

 Set itm = Nothing
 Set newAppt = Nothing
 Set ResItems = Nothing
 Set CalItems = Nothing
 Set CalFolder = Nothing

 End Sub
 

Во-первых, нет необходимости перебирать все элементы коллекции:

 For Each oAppt In oFinalItems
 

Вместо этого вы можете применить фильтр, используя методы Restrict или Find / FindNext Items класса, как вы делали это ранее в коде.

Чтобы отформатировать значения дат, вам нужно использовать функцию Форматирования, доступную в VBA:

 strAppt = oAppt.Start amp; " " amp; Format(endAppt, "hh:mm:ss")