Excl vba - Ouvrir un calendrier partagé Outlook dans une nouvelle fenêtre à une certaine date

**goninph** · 11/10/2023, 22h09

Bonjour,

Le premier code fonctionne nickel pour mes besoins : Il ouvre un agenda partagé dans une nouvelle fenêtre
J'aimerais afficher la semaine de travail du 01.01.2024 par exemple

Le deuxième code le fait, mais il n'ouvre pas un calendrier partagé dans une nouvelle fenêtre

Comment mixer les deux ? Impossible de trouver une solution

Je vous remercie pour votre aide 😘

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Sub Ouvrir_Agenda_Oscar()
Dim Email As Object
Dim objNS As Object
Dim Messagerie As Object
Dim objRecip As Object
Dim objFolder As Object
Dim Nom_Calendrier As String
    Nom_Calendrier = "o.fernandes@zurbuchensa.ch"
    Set Messagerie = CreateObject("Outlook.Application")
    Set objNS = Messagerie.GetNamespace("MAPI")
    On Error Resume Next    'permet de passer à la ligne suivante pour traiter l'erreur si le calendrier n'est pas trouvé
    Set objRecip = objNS.CreateRecipient(Nom_Calendrier)
    objRecip.Resolve
    If objRecip.Resolved Then
        Set objFolder = objNS.GetSharedDefaultFolder(objRecip, 9) '9 = valeur du dossier calendrier
        Set Email = objFolder.Items.Add
        'Si le calendrier et trouvé mais en lecture seule (pas de modification possible)
        If Not Email Is Nothing Then
            objFolder.Display 'Ouvre le calendrier partagé qui s'affichera une fois le rendez-vous enregistré
        Else
            MsgBox "L'agenda : " & Nom_Calendrier & vbCrLf & vbCrLf & " n'est pas accessible pour la modification.", vbExclamation, "! Oups ! Action interrompue"
        End If
    Else
        MsgBox "L'agenda : " & Nom_Calendrier & vbCrLf & vbCrLf & " n'existe pas.", vbExclamation, "! Oups ! Action interrompue"
    End If
    Set Email = Nothing
    Set objNS = Nothing
    Set Messagerie = Nothing
    Set objRecip = Nothing
    Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Atteindre_Date_Calendrier()
Dim Messagerie As Outlook.Application
Dim objNS As Outlook.Namespace
Dim outCalendarView As Outlook.CalendarView
Dim objRecip As Outlook.Folder
Dim Nom_Calendrier As String
    Set Messagerie = Outlook.Application
    Set objNS = Messagerie.GetNamespace("MAPI")
    Set objRecip = objNS.GetDefaultFolder(olFolderCalendar)
    Set Messagerie.ActiveExplorer.CurrentFolder = objRecip
    Set outCalendarView = Messagerie.ActiveExplorer.CurrentView
    With outCalendarView
        .GoToDate "01/01/2024"
        .CalendarViewMode = olCalendarViewMonth
        .Save
    End With
End Sub

**goninph** · 27/10/2023, 13h46

Bonjour,

C'est tout bon, j'ai trouvé pour afficher la semaine de la date remontée

Je n'arrive toujours pas à ouvrir la fenêtre en grand (maximized)

Une idée ?

Bon weekend

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Sub Ouvrir_Agenda_Poseur()
Dim Email As Object
Dim objNS As Object
Dim Messagerie As Object
Dim objRecip As Object
Dim objFolder As Object
Dim Calendar_View As Outlook.CalendarView
Dim LigneActive As String
Dim f As Variant
Dim Ma_Date As Date
    Agenda_Mail.Nom_Poseur 'Dénifir le nom du calendrier
    Set Messagerie = CreateObject("Outlook.Application")
    Set objNS = Messagerie.GetNamespace("MAPI")
    On Error Resume Next    'permet de passer à la ligne suivante pour traiter l'erreur si le calendrier n'est pas trouvé
    Set objRecip = objNS.CreateRecipient(Nom_Calendrier_poseur)
    objRecip.Resolve
    If objRecip.Resolved Then
        Set objFolder = objNS.GetSharedDefaultFolder(objRecip, 9) '9 = valeur du dossier calendrier
        Set Email = objFolder.Items.Add
        'Si le calendrier et trouvé mais en lecture seule (pas de modification possible)
        If Not Email Is Nothing Then
            Set f = ActiveSheet
            LigneActive = ActiveCell.Row
            If f.Cells(LigneActive, Range("TS_Suivi" & "[Intervention]").Column).Value = "" Then
                Ma_Date = Date
            Else
                Ma_Date = f.Cells(LigneActive, Range("TS_Suivi" & "[Intervention]").Column).Value
            End If
            objFolder.Display 'Ouvre le calendrier partagé
            Set Messagerie.ActiveExplorer.CurrentFolder = objFolder
            Set Calendar_View = Messagerie.ActiveExplorer.CurrentView
'            Messagerie.Application.ActiveWindow.WindowState = 2 ne fonctionne pas
            Calendar_View.GoToDate Ma_Date
'            Calendar_View.CalendarViewMode = olCalendarViewMonth 'Affiche le mois
'            Calendar_View.Save
        Else
            MsgBox "L'agenda : " & Nom_Calendrier_poseur & vbCrLf & vbCrLf & " n'est pas accessible pour la modification.", vbExclamation, "! Oups ! Action interrompue"
        End If
    Else
        MsgBox "L'agenda : " & Nom_Calendrier_poseur & vbCrLf & vbCrLf & " n'existe pas.", vbExclamation, "! Oups ! Action interrompue"
    End If
    Set Email = Nothing
    Set objNS = Nothing
    Set Messagerie = Nothing
    Set objRecip = Nothing
    Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub

**goninph** · 27/10/2023, 15h18

Enfin

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Sub Ouvrir_Agenda_Poseur()
Dim Email As Object
Dim objNS As Object
Dim Messagerie As Object
Dim objRecip As Object
Dim objFolder As Object
Dim Calendar_View As Outlook.CalendarView
Dim LigneActive As String
Dim f As Variant
Dim Ma_Date As Date
    Nom_Calendrier_poseur = "p.gonin@zurbuchensa.ch"
 
    Set Messagerie = CreateObject("Outlook.Application")
    Set objNS = Messagerie.GetNamespace("MAPI")
    On Error Resume Next    'permet de passer à la ligne suivante pour traiter l'erreur si le calendrier n'est pas trouvé
    Set objRecip = objNS.CreateRecipient(Nom_Calendrier_poseur)
    objRecip.Resolve
    If objRecip.Resolved Then
        Set objFolder = objNS.GetSharedDefaultFolder(objRecip, 9)
                                                    '(objRecip, 6) Mail
                                                    '(objRecip, 9) Calendrier
                                                    '(objRecip, 10) Contact
                                                    '(objRecip, 11) Journal
                                                    '(objRecip, 12) Notes
                                                    '(objRecip, 13) Tâches
        Set Email = objFolder.Items.Add
        'Si le calendrier et trouvé mais en lecture seule (pas de modification possible)
        If Not Email Is Nothing Then
            Set f = ActiveSheet
            LigneActive = ActiveCell.Row
            If f.Cells(LigneActive, Range("TS_Suivi" & "[Intervention]").Column).Value = "" Then
                Ma_Date = Date
            Else
                Ma_Date = f.Cells(LigneActive, Range("TS_Suivi" & "[Intervention]").Column).Value
            End If
            objFolder.Display 'Ouvre le calendrier partagé
            Set Messagerie.ActiveExplorer.CurrentFolder = objFolder
            Set Calendar_View = Messagerie.ActiveExplorer.CurrentView
'            Messagerie.Application.ActiveWindow.WindowState = 2 ne fonctionne pas
            Calendar_View.GoToDate "01.01.2024" 'Ma_Date
'            Calendar_View.CalendarViewMode = olCalendarViewMonth 'Affiche le mois
'            Calendar_View.Save
        Else
            MsgBox "L'agenda : " & Nom_Calendrier_poseur & vbCrLf & vbCrLf & " n'est pas accessible pour la modification.", vbExclamation, "! Oups ! Action interrompue"
        End If
    Else
        MsgBox "L'agenda : " & Nom_Calendrier_poseur & vbCrLf & vbCrLf & " n'existe pas.", vbExclamation, "! Oups ! Action interrompue"
    End If
    Set Email = Nothing
    Set objNS = Nothing
    Set Messagerie = Nothing
    Set objRecip = Nothing
    Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub

**goninph** · 07/07/2024, 12h01

Bonjour,

Tout fonctionne nickel, mais un message Outlook apparait avec Impossible de lire le calendrier alors que tout est ouvert à la bonne date.

C'est imconpréhensible

Meilleures salutations

**goninph** · 07/07/2024, 12h58

Il faut ajouter un temps d'arrêt et plus de message

Application.Wait (Now + TimeValue("0:00:01")) 'Pour éviter le message Outlook : Impossible de lire le calendrier

Juste avant : Calendar_View.GoToDate Ma_Date

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Sub Ouvrir_Agenda_Poseur()
Dim Email As Object
Dim objNS As Object
Dim Messagerie As Object
Dim objRecip As Object
Dim objFolder As Object
Dim Calendar_View As Outlook.CalendarView
Dim f As Variant
Dim Ma_Date As Date
Application.ScreenUpdating = False
    Set Messagerie = CreateObject("Outlook.Application")
    Set objNS = Messagerie.GetNamespace("MAPI")
    On Error Resume Next    'permet de passer à la ligne suivante pour traiter l'erreur si le calendrier n'est pas trouvé
    Set objRecip = objNS.CreateRecipient(Adresse_Mail_Poseur)
    objRecip.Resolve
    If objRecip.Resolved Then
        Set objFolder = objNS.GetSharedDefaultFolder(objRecip, 9)
                                                    '(objRecip, 6) Mail
                                                    '(objRecip, 9) Calendrier
                                                    '(objRecip, 10) Contact
                                                    '(objRecip, 11) Journal
                                                    '(objRecip, 12) Notes
                                                    '(objRecip, 13) Tâches
        Set Email = objFolder.Items.Add
        'Si le calendrier et trouvé mais en lecture seule (pas de modification possible)
        If Not Email Is Nothing Then
            Set f = Sheets("Suivi")
            If f.Cells(ActiveCell.Row, f.Range("TS_Suivi" & "[Intervention]").Column).value = "" Then
                Ma_Date = Date
            Else
                Ma_Date = f.Cells(ActiveCell.Row, f.Range("TS_Suivi" & "[Intervention]").Column).value
            End If
            objFolder.Display 'Ouvre le calendrier partagé
            Messagerie.ActiveWindow.WindowState = olNormalWindow  'olMaximized olNormalWindow olMinimized
            Set Messagerie.ActiveExplorer.CurrentFolder = objFolder
            Set Calendar_View = Messagerie.ActiveExplorer.CurrentView
            Application.Wait (Now + TimeValue("0:00:01")) 'Pour éviter le message Outlook : Impossible de lire le calendrier
            Calendar_View.GoToDate Ma_Date
        Else
            MsgBox "L'agenda : " & Adresse_Mail_Poseur & vbCrLf & vbCrLf & " n'est pas accessible pour la modification.", vbExclamation, "! Oups ! Action interrompue"
        End If
    Else
        MsgBox "L'agenda : " & Adresse_Mail_Poseur & vbCrLf & vbCrLf & " n'existe pas.", vbExclamation, "! Oups ! Action interrompue"
    End If
    Set Email = Nothing
    Set objNS = Nothing
    Set Messagerie = Nothing
    Set objRecip = Nothing
    Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub

Excl vba - Ouvrir un calendrier partagé Outlook dans une nouvelle fenêtre à une certaine date [XL-365]

Macros et VBA Excel

Discussions similaires

Partager

Partager