Discussion :

[barbiturix]

Bonjour,
Je cherche à créer un RDV sur le calendrier “Sport" qui est partagé sur mon PC et mon smartPhone par iCloud
Mon bout de code fonctionne sur les calendriers de mon espace professionnel « MonJob » mais pas avec le Calendrier “Sport" qui est sur « iCLoud » Les 2 espaces « iCloud » et « MonJob » sont présents dans les calendriers Outlook sur mon PC
Autodidacte en VBA, après plusieurs recherches, je n’arrive pas à écrire le bon code.
Merci de votre aide

Ci-dessous je colle le code que j'utilise

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
Sub RDVSport()
 
 
Dim oOutlook As Outlook.Application
Dim oAppointment As Outlook.AppointmentItem
Dim namespaceOutlook As Outlook.Namespace
Dim DossierCalendrier As Outlook.MAPIFolder
 
 
'creation des objets
Set oOutlook = CreateObject("Outlook.Application")
Set namespaceOutlook = oOutlook.GetNamespace("MAPI")
 
 
'definit le dossier calendrier
Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar).Folders.Item("Sport")
 
'on cree un nouveau rendez-vous
Set oApointment = DossierCalendrier.Items.Add
 
 
With oApointment
.Start = "17/9/2021"
.AllDayEvent = True
.End = "19/9/2021"
.Subject = "essai RDV SPORT"
.Save
.Close (olSave)
End With
 
Set oAppointment = Nothing
Set oOutlook = Nothing
End Sub

Voici une capture des calendriers d'Outlook

[barbiturix]

Bonjour,
Dans mes recherches j’ai trouvé un code qui permet de retrouver les dossiers et sous dossiers de calendrier dont ceux d’iCloud et "Sport". Par contre comment utiliser cette information pour générer un RDV, je bloque, …


Voici le 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
 
 
Sub ListerRepertoires()
    Dim myNamespace, Folder, SubFolder
    Dim strTemp As String
    On Error GoTo Erreur
    Set objOutlook = New Outlook.Application
    Set myNamespace = objOutlook.GetNamespace("MAPI")
'Lister les repertoires principaux
    For Each Folder In myNamespace.Folders
        strTemp = strTemp & Folder.Name & vbCrLf
        strTemp = strTemp & GetSubFolder(Folder) 'recherche des sous-repertoires
    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

En résultat j'obtiens un message du type:

[User]

Bonsoir,

Vous pouvez utiliser ce type de fonction :

Code VBA :

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
Function FindInFolders(TheFolders As Outlook.Folders, FolderName As String)
  Dim SubFolder As Outlook.MAPIFolder
 
  On Error Resume Next ' peut être inutile
 
  Set FindInFolders = Nothing
 
  For Each SubFolder In TheFolders ' on parcourt les dossiers
    If LCase(SubFolder.Name) Like LCase(Name) Then
      Set FindInFolders = SubFolder ' dossier trouvé
      Exit For ' sortie de la fonction
    Else ' sinon
      Set FindInFolders = FindInFolders(SubFolder.Folders, FolderName) ' appel récursif dans les sous dossiers
      If Not FindInFolders Is Nothing Then Exit For ' si folder trouvé, on sort
    End If
  Next
End Function

exemple de code pour ajouter u rdv :

Code VBA :

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
    Dim nomDossier As String
    Dim oOutlook As Outlook.Application
    Dim oAppointment As Outlook.AppointmentItem
    Dim namespaceOutlook As Outlook.Namespace
    Dim DossierCalendrier As Outlook.MAPIFolder
 
    Set oOutlook = New Outlook.Application
 
    nomDossier = "Sport" ' on définit le nom du dossier recherché
 
    Set DossierCalendrier = FindInFolders(oOutlook.ActiveExplorer.Session.Folders, nomDossier)
 
    If Not DossierCalendrier Is Nothing Then ' si le dossier a été trouvé
 
        'on crée un nouveau rendez-vous
        Set oApointment = DossierCalendrier.Items.Add
 
        With oApointment
            .Start = "17/9/2021"
            .AllDayEvent = True
            .End = "19/9/2021"
            .Subject = "essai RDV SPORT"
            .Save
            .Close (olSave)
        End With
 
        Set oAppointment = Nothing
 
    Else
        MsgBox "Pas trouvé !", vbInformation
    End If
 
    Set oOutlook = Nothing
    '...

Tout ceci a adapter, car je n'ai pas testé..

Cdlt,