Блог

Главная - Вопросы по программированию - Добавить встречу в чужой общий календарь Outlook с помощью VBA в MS Access

Добавить встречу в чужой общий календарь Outlook с помощью VBA в MS Access

#vba #ms-access #outlook

#vba #ms-access #outlook

Вопрос:

У меня возникли трудности с добавлением встречи в календарь коллег, которым они поделились со мной. Проблема, похоже, в ссылке на календарь. Мои встречи продолжают добавляться в их основной календарь по умолчанию, пока я пытаюсь добавить их в отдельный общий календарь с именем «Расписание занятий». Я использую Office 365.

     Dim olApp                 As Outlook.Application
    Dim olappt                As Outlook.AppointmentItem
    Dim bAppOpened            As Boolean
    Dim myNamespace           As Outlook.NameSpace
    Dim objRecip              As Outlook.Recipient
    Dim strName               As String
    Dim myFolder              As Outlook.Folder
 

    Const olAppointmentItem = 1
            
            On Error Resume Next
            Set olApp = GetObject(, "Outlook.Application")
            If Err.Number <> 0 Then
            Err.Clear
            Set olApp = CreateObject("Outlook.Application")
            bAppOpened = False  ' Outlook was not already running, started it
            Else
                bAppOpened = True   ' Outlook was already running
            End If
           ' On Error GoTo Error_Handler
            
            ' Get Study Schedule Folder Location
            Set myNamespace = olApp.GetNamespace("MAPI")
            Set objRecip = myNamespace.CreateRecipient("John Doe")
                objRecip.Resolve
    ' I believe the problem is in the two lines of code below as I try to reference non default folder (shared from john doe)            
                Set myFolder = myNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)
                Set myFolder = myFolder.Folders("Study Schedule") 
                myFolder.Display
                Set olappt = myFolder.Items.Add
                'Set olappt = myNewFolder.Items.Add
                With olappt
                            .AllDayEvent = True
                            .Start = ScheduledDate
                            .Subject = StudyName
                            .Body = "Study has been scheduled." amp; vbCr amp; _
                                vbCr amp; _
                                "Calendar Assigned: " amp; myFolder amp; vbCr amp; _
                                "Schedule Entry ID: " amp; ScheduleEntryID amp; vbCr amp; _
                                "Study Name: " amp; StudyName amp; vbCr amp; _
                                "Scheduled Date: " amp; ScheduledDate amp; vbCr amp; _
                                vbCr amp; _
                                "Principle Investigator: " amp; PrincipleInvestigator amp; vbCr amp; _
                                "Order Placed By: " amp; OrderPlacedBy amp; vbCr amp; _
                                vbCr amp; _
                                "Species: " amp; Spec

ies amp; vbCr amp; _
                            "Strain: " amp; Strain amp; vbCr amp; _
                            "Sex " amp; Sex amp; vbCr amp; _
                            "Age: " amp; Age amp; vbCr amp; _
                            "Weight: " amp; Weight amp; " Kg" amp; vbCr amp; _
                            "Quantity : " amp; Quantity amp; vbCr amp; _
                            vbCr amp; _
                            "Study Information: " amp; StudyDescription amp; vbCr amp; _
                            vbCr amp; _
                            "This Event was auto generated from the Scheduling Assistant and In-Vivo Database."
                        .Location = ""
                        .Display
               '         .Save
                   '    .Send
            End With

    ... Rest of Code

Любая помощь приветствуется!

Комментарии:

1. Считайте Option Explicit , что надпись вверху обязательна.

2. Считайте On Error GoTo 0 обязательным вернуться к обычной обработке ошибок как можно скорее после On Error Resume Next . Поместите, On Error GoTo 0 где у вас теперь есть комментарий On Error GoTo Error_Handler . Если вы не можете устранить какие-либо ошибки, теперь они видны, отредактируйте вопрос, добавив дополнительную информацию.

3. Вы проверяли разрешения в общем календаре? Приостановите выполнение после первого назначения myfolder и проверьте содержимое MyFolder. Папки.

4. Здравствуйте, они указали меня как владельца календаря и предоставили мне полные права на чтение / запись / удаление. Я добавил msgbox после myfolder и myfolder.folders. Оба ссылаются на свой «Календарь — John Doe» по умолчанию. Я пытаюсь сослаться на «Расписание занятий Джона Доу»

5. Вы ссылаетесь на папку с именем «Календарь — Джон Доу». Вы обходите ошибку, ссылающуюся на календарь «Расписание занятий». Обход ошибки означает, что ссылка на MyFolder остается прежней. Незнание того, как использовать, не приносит пользы On Error Resume Next .

Ответ №1:

Вероятно, общий календарь находится на том же уровне, что и календарь по умолчанию.

 ' For a folder at the same level as the default calendar
'  navigate up then back down
Set myFolder = myNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)
Set myFolder = myFolder.Parent.Folders("Study Schedule")

Ответ №2:

Я нашел обходной путь. Код, с которым я закончил, размещен ниже. Спасибо всем за быстрые ответы! Я действительно оценил помощь.

  Dim olApp                 As Outlook.Application
        Dim olappt                As Outlook.AppointmentItem
        Dim bAppOpened            As Boolean
        Dim myNamespace As Outlook.NameSpace
        Dim myFolder As Outlook.Folder
        Dim objPane As Outlook.NavigationPane
        Dim objModule As Outlook.CalendarModule
        Dim CalFolder As Outlook.Folder
        
        Const olAppointmentItem = 1
        
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If Err.Number <> 0 Then
        Err.Clear
        Set olApp = CreateObject("Outlook.Application")
        bAppOpened = False  ' Outlook was not already running, started it
        Else
            bAppOpened = True   ' Outlook was already running
        End If
       ' On Error GoTo Error_Handler
        On Error GoTo 0
      
        Set objPane = Outlook.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 = "Study Schedule" Or objNavFolder = "John Doe - Study Schedule" Then
        Set CalFolder = objNavFolder.Folder
        
        MsgBox CalFolder
        End If
        Next
        Next
        End With
        
        Set olappt = CalFolder.Items.Add
        
        With olappt
                    .Display
                    .AllDayEvent = True
                    .Start = ScheduledDate
                    .Subject = StudyName
                    .Body = "Study has been scheduled." amp; vbCr amp; _
                        vbCr amp; _
                        "Schedule Entry ID: " amp; ScheduleEntryID amp; vbCr amp; _
                        "Study Name: " amp; StudyName amp; vbCr amp; _
                        "Scheduled Date: " amp; ScheduledDate amp; vbCr amp; _
                        vbCr amp; _
                        "Principle Investigator: " amp; PrincipleInvestigator amp; vbCr amp; _
                        "Order Placed By: " amp; OrderPlacedBy amp; vbCr amp; _
                        vbCr amp; _
                        "Species: " amp; Species amp; vbCr amp; _
                        "Strain: " amp; Strain amp; vbCr amp; _
                        "Sex " amp; Sex amp; vbCr amp; _
                        "Age: " amp; Age amp; vbCr amp; _
                        "Weight: " amp; Weight amp; " Kg" amp; vbCr amp; _
                        "Quantity : " amp; Quantity amp; vbCr amp; _
                        vbCr amp; _
                        "Study Information: " amp; StudyDescription amp; vbCr amp; _
                        vbCr amp; _
                        "This Event was auto generated from the Scheduling Assistant and In-Vivo Database."
                    .Location = ""
                    .Display
           '         .Save
               '    .Send
        End With