J'ai des difficultés à ajouter un rendez-vous à un calendrier de collègues qu'ils ont partagé avec moi. Le problème semble être dans la référence du calendrier. Mes rendez-vous continuent à s'ajouter à leur calendrier principal par défaut pendant que j'essaie de les ajouter à un calendrier partagé distinct nommé «Calendrier d'étude». J'exécute 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." & vbCr & _
                                vbCr & _
                                "Calendar Assigned: " & myFolder & vbCr & _
                                "Schedule Entry ID: " & ScheduleEntryID & vbCr & _
                                "Study Name: " & StudyName & vbCr & _
                                "Scheduled Date: " & ScheduledDate & vbCr & _
                                vbCr & _
                                "Principle Investigator: " & PrincipleInvestigator & vbCr & _
                                "Order Placed By: " & OrderPlacedBy & vbCr & _
                                vbCr & _
                                "Species: " & Spec

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

    ... Rest of Code

Toute aide est grandement appréciée!

0
Steven K 26 août 2020 à 00:40

2 réponses

Meilleure réponse

J'ai trouvé un travail. Le code que j'ai fini par utiliser est affiché ci-dessous. Merci à tous pour les réponses rapides! J'ai vraiment apprécié l'aide.

 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." & vbCr & _
                        vbCr & _
                        "Schedule Entry ID: " & ScheduleEntryID & vbCr & _
                        "Study Name: " & StudyName & vbCr & _
                        "Scheduled Date: " & ScheduledDate & vbCr & _
                        vbCr & _
                        "Principle Investigator: " & PrincipleInvestigator & vbCr & _
                        "Order Placed By: " & OrderPlacedBy & vbCr & _
                        vbCr & _
                        "Species: " & Species & vbCr & _
                        "Strain: " & Strain & vbCr & _
                        "Sex " & Sex & vbCr & _
                        "Age: " & Age & vbCr & _
                        "Weight: " & Weight & " Kg" & vbCr & _
                        "Quantity : " & Quantity & vbCr & _
                        vbCr & _
                        "Study Information: " & StudyDescription & vbCr & _
                        vbCr & _
                        "This Event was auto generated from the Scheduling Assistant and In-Vivo Database."
                    .Location = ""
                    .Display
           '         .Save
               '    .Send
        End With
0
Steven K 2 sept. 2020 à 18:31

Il est probable que le calendrier partagé soit au même niveau que le calendrier par défaut.

' 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")
0
niton 26 août 2020 à 22:46