Я пытаюсь автоматически добавить собрания Zoom, которые мы получаем от Salesforce, в календарь нашей команды.
Благодаря https://www.slipstick.com/developer/copy-new-appointments-to-another-calendar-using-vba/ мне удалось подойти очень близко. Сценарий работает, если я создаю встречу в качестве теста, но не тогда, когда встреча отправляется мне, и я принимаю приглашение. (Мои настройки Outlook настроены на автоматический прием всех приглашений.)
При отладке выделяются .Start = Item.Start в curCal_ItemAdd:
Dim WithEvents curCal As Items
Dim newCalFolder As Outlook.Folder
Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
' calendar to watch for new items
Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items
' calendar moving copy to
Set objOwner = NS.CreateRecipient("Team Calendar")
objOwner.Resolve
If objOwner.Resolved Then
'MsgBox objOwner.Name
Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
Set NS = Nothing
End Sub
Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim moveCal As AppointmentItem
' On Error Resume Next
' copy only Zoom Meetings
' remove to make a copy of all items
If Item.Subject Like "Zoom Meeting Invitation*" Then
Set cAppt = Application.CreateItem(olAppointmentItem)
With cAppt
.Subject = Mid(Item.Subject, 28)
.Start = Item.Start ' ** highlighted text
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
End With
' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(newCalFolder)
moveCal.Categories = "Webex"
moveCal.Save
End If
End Sub
Public Function GetDATETIME() As String
GetDATETIME = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
End Function
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
После нажатия кнопки сброса в VBA В редакторе, если я открою приглашение и снова нажму «принять приглашение», оно будет работать так, как должно. При первом запуске оно не определяет время начала приглашения.
Я пытался ввести задержку, но ни одна из попыток сделать это не имела никакого значения. Насколько я знаю, я поставил задержку не в том месте.