Discussion :

[ccghost57]

Bonjour,

Je sais que la question a déjà été posée plein de fois sur différents forums, mais je ne comprends pas les réponses, ou je n'arrive pas à les adapter, je ne sais pas, c'est pourquoi je sollicite votre aide...

J'ai fait un petit code qui permet d'enregistrer automatiquement des rendez-vous dans Outlook à partir d'une feuille Excel.

Cela fonctionne, mais les RDV sont toujours enregistrés dans mon calendrier personnel, et pas dans le calendrier que je partage avec mon équipe... Comment choisir un autre calendrier que celui par défaut ?......

Voilà mon code :

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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
Private Sub CommandButton1_Click()
 
    Dim oOutlook As Outlook.Application
    Dim oAppointment As Outlook.AppointmentItem
    Dim namespaceOutlook As Outlook.Namespace
    Dim DossierCalendrier As Outlook.MAPIFolder
    Dim Cell As Range
    Dim DateDebut As String
    Dim ol As New Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fdCalendar As Outlook.MAPIFolder
    Dim objItem As Object
    Dim objAppt As AppointmentItem
    Dim i, j, nCount As Integer
    Dim answer As Integer
    Dim strName As String
    Dim objRecip As Outlook.Recipient
    Dim objDummy As Outlook.MailItem
 
    ' ### name of person whose Calendar you want to use ###
    strName = "L&D"
 
    Set oOutlook = CreateObject("Outlook.Application")
    Set ns = ol.GetNamespace("MAPI") 'Reference the default Calendar folder
    Set objDummy = ol.CreateItem(olMailItem)
    'Set fdCalendar = ns.GetDefaultFolder(olFolderCalendar)
    Set objRecip = objDummy.Recipients.Add(strName)
    objRecip.Resolve
    If objRecip.Resolved Then
        On Error Resume Next
        Set fdCalendar = _
          ns.GetSharedDefaultFolder(objRecip, _
            olFolderCalendar)
    End If
    i = 1
    j = 0
    'nCount = fdCalendar.Items.Count
    nCount = 500
 
   Do While i < nCount
      Set objItem = fdCalendar.Items(i)
 
      If objItem.Class = olAppointment Then
          Set objAppt = objItem
          If (objAppt.Subject Like "TL profile reactivation*") Then
                objAppt.Delete
                j = j + 1
          End If
      End If
      i = i + 1
      Set objItem = Nothing
      Set objAppt = Nothing
    Loop
 
     MsgBox (j - 1 & " items have been deleted"), vbOKOnly
 
    Set fdCalendar = Nothing
    Set ns = Nothing
    Set ol = Nothing
 
 
   'on crée ensuite les objets
    Set oOutlook = CreateObject("Outlook.Application")
    Set namespaceOutlook = oOutlook.GetNamespace("MAPI")
 
   'plage de donnée
    For Each Cell In Sheets("Menu").Range("L2:L60")
 
    If Cell = "On leave-licence access" Then 'recherche dans la plage si il existe des données à inscrire
 
    'définit le dossier calendrier
    'GetDefaultFolder renvoit le calendrier du compte actif
    Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar)
 
    'on crée un nouveau rendez-vous
    Set oAppointment = DossierCalendrier.Items.Add
 
 
With oAppointment
    .MeetingStatus = olNonMeeting
    .Subject = "TL profile reactivation  for user " & Cell.Offset(0, -7) & " " & Cell.Offset(0, -6) & " " & Cell.Offset(0, -5)
    .Body = "Change Status - ""On leave - licence access"" to ""Active"""
    .Start = CDate(Cell.Offset(0, -2)) + 9 / 24
    .Duration = 30
    .Save
End With
 
 
MsgBox "Le rappel pour " & Cell.Offset(0, -7) & " " & Cell.Offset(0, -6) & " a été ajouté au calendrier"
 
End If
 
Next Cell
 
 
'Libération des variables.
    Set oAppointment = Nothing
    Set oOutlook = Nothing
 
 
 
 
 
Fin_Execution:
    Exit Sub
Err_Execution:
    MsgBox Err.Description, vbExclamation
    Resume Fin_Execution
End Sub

Je ne sais pas si le nom du calendrier n'est pas le bon, ni ce qu'il se passe...

J'ai recopié sans trop comprendre une petite procédure que j'avais trouvée sur le web pour choisir son calendrier, mais je ne sais pas appeler cette fonction

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 ListerRépertoires()
 
    Dim MyNameSpace, Folder, SubFolder
    Dim strTemp As String
 
    On Error GoTo Erreur
 
    Set objOutlook = New Outlook.Application
    Set MyNameSpace = objOutlook.GetNamespace("MAPI")
 
'Lister les répertoires principaux
    For Each Folder In MyNameSpace.Folders
        strTemp = strTemp & Folder.Name & vbCrLf
        strTemp = strTemp & GetSubFolder(Folder) 'recherche des sous-répertoires
    Next
    Set MyNameSpace = Nothing
    Set objOutlook = Nothing
    MsgBox strTemp
Exit Sub
 
Erreur:
    MsgBox Err.Description
 
End Sub
 
Function GetSubFolder(Folder) As String
 
    Dim strTemp As String
 
    Dim FolderTemp
 
 
 
    For Each FolderTemp In Folder.Folders
 
        If FolderTemp.DefaultItemType = olAppointmentItem Then  'type Calendrier
 
        strTemp = strTemp & vbTab & FolderTemp.Name & vbCrLf
 
        End If
 
    Next
 
 
 
    GetSubFolder = strTemp
 
End Function

Vraiment, un grand merci à qui pourra m'aider sur ce point !!!

[parmi]

Bonjour,

Ça ressemble pas mal à mon code...

Essaie celui-ci
Place un TreeView sur un Userform (Style = 6) avec un bouton (je nomme le treeview TView et le bouton cmdOK
Le code du Userform

Code :

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

1
2
3
4
Private Sub cmdOK_Click()
    CheminOutlook = TView.SelectedItem.FullPath
    Unload me
End Sub

Le code dans une feuille ou un module
Ça va te lister tous les répertoires
À modifier si tu veux voir seulement les calendriers...

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
Sub ListerRépertoires()
    Dim MyNameSpace, Folder, SubFolder
    Dim strTemp As String, Idx As Integer, KeyID As String
 
    On Error GoTo Erreur
 
    Set objOutlook = CreateObject("Outlook.Application")     'New Outlook.Application
    Set MyNameSpace = objOutlook.GetNamespace("MAPI")
 
    For Each Folder In MyNameSpace.Folders
        If Folder.Name <> "Dossiers publics" Then
            KeyID = "N" & Idx
            strTemp = strTemp & Folder.Name & vbCrLf
            frmOutlook.TView.Nodes.Add , , KeyID, Folder.Name
            strTemp = strTemp & GetSubFolder(Folder, KeyID)
            Idx = Idx + 1
        End If
    Next
 
    Set MyNameSpace = Nothing
    Set objOutlook = Nothing
 
    frmOutlook.Show
 
Exit Sub
Erreur:
    MsgBox Err.Description
    'Stop    'facultatif
    'Resume    'facultatif
End Sub
 
Function GetSubFolder(Folder, Idx As String) As String
    Dim strTemp As String, KeyID As String
    Dim FolderTemp, Fold2
    Dim CurIdx As Integer
 
    For Each FolderTemp In Folder.Folders
        KeyID = Idx & "-" & CurIdx
            strTemp = strTemp & vbTab & FolderTemp.Name & vbCrLf
            frmOutlook.TView.Nodes.Add Idx, tvwChild, KeyID, FolderTemp.Name
            CurIdx = CurIdx + 1
            For Each Fold2 In FolderTemp.Folders
                 frmOutlook.TView.Nodes.Add KeyID, tvwChild, KeyID & "-" & CurIdx, Fold2.Name
                 CurIdx = CurIdx + 1
            Next
    Next
 
    GetSubFolder = strTemp
End Function

Il faut déclarer CheminOutlook en Public dans un module.
Une fois que tu as sélectionné le dossier dans le UserForm, il sera reconnu par d'autres Sub que tu utiliseras par la suite.

[ccghost57]

Bonjour Parmi,

Merci de ta réponse, et merci pour ton bout de code du coup !

La phrase "Met un Treview dans un UserForm" était un peu du chinois pour moi, mais en regardant un peu j'ai trouvé comment ajouter un Userform, en revanche je n'ai pas le bouton dans la Toolbox pour ajouter unTreeview (version trop vieille d'Excel?)

Ensuite, comment dois-je faire pour déclarer CheminOutlook en public ?

Enfin, je te promets que je ne fais pas exprès, mais je n'ai aucune idée de comment faire pour adapter ce code qui cherche des répertoires en code qui cherche les calendriers

J'aimerais bien attacher mon fichier si ça peut donner une idée plus précise du problème mais ça ne fonctionne pas, rien ne se passe quand je clique sur "Envoyer" grrrrrrr.....

Merci en tous cas !

[parmi]

Pour le TreeView, affiche ton Userform dans l'éditeur VBA.
Dans la boîte à outils, clique droit et sélectionne "Contrôles supplémentaires"
Dans la liste qui s'affiche, recherche Microsoft Treeview Control (version plus récente) et coche la boîte
Une nouvelle icône s'affichera dans tes outils.
Va dans ses propriétés et change le style pour le #6 pour avoir des +/- pour développer des éléments (sous-répertoires).
Si la fenêtre des propriétés n'est pas déjà affichée, tape F4

Pour la variable Public, insère un module (menu Insertion > Module)
Dans ce module, sous Option Explicit (si tu l'as) et en haut de toutes procédures, écris:

Code :

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

Public CheminOutlook As String

Pour afficher le Userform, crée une procédure avec

Code :

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

Userform1.Show

Avec le code que je t'ai mis, tu devrais voir tous les répertoires incluant les calendriers.
Tu sélectionnes celui que tu veux et tu cliques le bouton.
Le Userform va se fermer et tu vas pouvoir utiliser la variable CheminOutlook pour faire ce que tu veux dans ce répertoire...

[Oliv-]

Bonsoir,
pour obtenir le dossier d'un calendrier on peut simplement faire

Code :

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

1
2
3
Set oOutlook = CreateObject("Outlook.Application")
 Set namespaceOutlook = oOutlook.GetNamespace("MAPI")
Set DossierCalendrier = namespaceOutlook.folders("lenomdelaboite").folders("calendrier")

si c'est sous dossier :

Code :

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

Set DossierCalendrier = namespaceOutlook.folders("lenomdelaboite").folders("calendrier").folders("calendrier2")

ou comme cela

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
Sub test()
    Dim Fld As Outlook.MAPIFolder
    Set Fld = getDefaultFolderFromUser("user@toto.fr", olFolderCalendar)
    If Not Fld Is Nothing Then
        MsgBox Fld.Name & vbCr & Fld.FullFolderPath
    End If
End Sub
 
 
Function getDefaultFolderFromUser(user, dossier As Outlook.OlDefaultFolders) As Outlook.MAPIFolder
'---------------------------------------------------------------------------------------
' Procedure : getDefaultFolderFromUser
' Author    : OLIV-
' Date      : 22/12/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim OLApp As Outlook.Application
    If Application.Name = "Outlook" Then
        Set OLApp = Application
    Else
        Set OLApp = CreateObject("outlook.application")
    End If
    Dim nsOutlook As Outlook.NameSpace
    Dim oRecipient As Outlook.Recipient
    Dim Fld As Outlook.MAPIFolder
 
    Set nsOutlook = OLApp.GetNamespace("MAPI")
    Set oRecipient = nsOutlook.CreateRecipient(user)
    oRecipient.Resolve
 
    If oRecipient.Resolved Then
        On Error Resume Next
        Set Fld = nsOutlook.GetSharedDefaultFolder(oRecipient, dossier)
        Set getDefaultFolderFromUser = Fld
        If Err Then Set getDefaultFolderFromUser = Nothing
    Else
        MsgBox user & vbCr & "User inconnu", vbCritical, "Inconnu"
    End If
End Function

edit : POUR DES REPONSES A VOS PB DE MACRO OUTLOOK c'EST ICI

[sim140680]

Bonsoir,
ce code fonctionne parfaitement, par contre je ne parviens qu'à communiquer avec le calendrier de ma BAL outlook personnelle sur Exchange, même en utilisant "GetDefaultsharedFolder"

Malgré des séances de debug intensives, je ne parviens pas à trouver le moyen d'accéder aux calendriers partagés et aux calendriers de salles de réunions (partagés) et visibles/accessibles dans mon client Outlook.

Pourriez vous m'aider à y voir plus clair?!

Merci d'avance pour votre éclairage
Simon

[ciago]

Merci pour ce code.

En cette nouvelle air de télétravail, nous cherchons une méthode pour avoir un petit condenser des agenda outlook de l'équipe. J'ai trouvé différent code sur le forum pour y parvenir mais il me manque le petit nom à donner au calendrier partagé. C'est ce que j'espèrait trouver avec ce code. Mais au final il me liste les boite au lettres partagé mais pas du tout les calendriers.
Une astuce ?