Discussion :

[ALEXM]

Bonjour,

j'ai une procédure qui est simple que j'ai récupéré qui positionne une rendez vous outlook .
je ne sais comment en gardant cette simplicité pouvoir positionner cette échéance sur un calendrier outlook d'un autre utilisateur (autre adresse Mail) qu'on peut récupérer
dans le formulaire via le nom de la personne concernée?
Quelqu'un pourrait m'aider.
Merci beaucoup !

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
Private Sub Thématique_du_Projet_Click()
If MsgBox("Bonjour,voulez-vous créer un rappel dans calendrier Outlook?", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
Else
 Dim outobj As Outlook.Application
     Dim outappt As Outlook.AppointmentItem
     Set outobj = CreateObject("outlook.application")
     Set outappt = outobj.CreateItem(olAppointmentItem)
 
     With outappt
             .Start = Me.Date_de_Debut
             .Duration = 15 ' En minute
             .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
             ../....
        End With
        Set outobj = Nothing
        End If
End Sub

[User]

Bonjour,

Quelque chose comme cela pour avoir le dossier principal du compte de messagerie :

Code VBA :

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

1
2
3
4
5
6
7
Set objApp = new Outlook.Application
 
' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")
 
' Référence au dossier principal du compte de messagerie
Set objCptFolder = objSpace.Folders("adresse_messagerie")

Après pour trouver le calendrier et ajouter le rendez-vous tu peux faire :

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
' Dans le dossier principal du compte de messagerie
   With objCptFolder
 
      ' On parcourt les dossiers contenus dans ce dossier parent
      For Each objFolder In .Folders
 
         If objFolder.Name = "monCalendrier" Then ' Si c'est le Calendrier de rendez-vous recherché
            'Tu ajoutes le rendez-vous dans ce calendrier ...
            Set oApointment = objFolder.Items.Add
 
            With oApointment
                 .Start = Me.Date_de_Debut
                 .Duration = 15 ' En minute
                 .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
                 ../....
            End With
         end if
 
      next   
   End With

A tester...

[ALEXM]

Bonjour,
Merci à USER pour le bout de code envoyé.
Le rendez vous s'inscrit bien dans mon doszsier [Calendrier], par contre pour l'autre dossier "Alexandre" créé pour test, il n'y pas d'écriture de rendez vous.
Quelqu'un pourrait m'aidre SVP?
Merci

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
rivate Sub Thématique_du_Projet_Click()
If MsgBox("Bonjour,voulez-vous créer un rappel dans calendrier Outlook?", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
Else
 
 Dim outobj As Outlook.Application
     Dim outappt As Outlook.AppointmentItem
     Set outobj = CreateObject("outlook.application")
     Set outappt = outobj.CreateItem(olAppointmentItem)
    Set objApp = New Outlook.Application
    ' Création de l'objet NameSpace d'Outlook
   Set objSpace = objApp.GetNamespace("MAPI")
 ' Référence au dossier principal du compte de messagerie
 'Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))
   Set objCptFolder = objSpace.Folders("prenom-nom@xxx.fr")
  'Dans le dossier principal du compte de messagerie
   With objCptFolder
       ' On parcourt les dossiers contenus dans ce dossier parent
      For Each objFolder In .Folders
          If objFolder.Name <> "Titi" Then ' Si c'est le Calendrier de rendez-vous recherché
            'Tu ajoutes le rendez-vous dans ce calendrier ...
            Set oApointment = objFolder.Items.Add
 
     With outappt
             .Start = Me.Date_de_Debut
             .Duration = 15 ' En minute
             .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
             .Body = " Attention date de fin de l'action à réaliser dans le cadre du projet " & Me.[Nom du Projet]
             .Location = "Rendez vous Microsoft Teams"
             .AllDayEvent = False
             .ReminderSet = True
            .End = Me.Date_de_fin
            .Save
 
     End With
         End If

[tee_grandbois]

bonjour,
je ne sais pas si c'est ça, mais, il y a une petite différence entre ton code et celui de User

Code User :

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

1
2
3
4
5
If objFolder.Name = "monCalendrier" Then ' Si c'est le Calendrier de rendez-vous recherché
    'Tu ajoutes le rendez-vous dans ce calendrier ...
    Set oApointment = objFolder.Items.Add
 
    With oApointment

Code ALEXM :

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

1
2
3
4
5
If objFolder.Name <> "Titi" Then ' Si c'est le Calendrier de rendez-vous recherché
    'Tu ajoutes le rendez-vous dans ce calendrier ...
    Set oApointment = objFolder.Items.Add
 
    With outappt

[ALEXM]

Bonsoir,

Oui mais quand je mets la syntaxe de USER

Code :

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

With oApointment

j'ai un plantage 438 :



On en est pas loin il doit y avoir un détail quelque part qui cloche....
Bonne soirée!
Et merci encore tee_grandbois

[User]

Bonsoir,

Peut-être faut-il préciser que tu ajoutes un élément de type olAppointmentItem :

Code :

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

Set oApointment = objFolder.Items.Add(olAppointmentItem)

Cdlt,

[ALEXM]

Bonjour,
Non cela ne change pas grand chose .
Je dois garder With outappt.

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
 For Each objFolder In .Folders
          If objFolder.Name <> "Titi" Then ' Si c'est le Calendrier de rendez-vous recherché
            'Tu ajoutes le rendez-vous dans ce calendrier ...
            Set oApointment = objFolder.Items.Add
 Set oApointment = objFolder.Items.Add(olAppointmentItem)
     With outappt
             .Start = Me.Date_de_Debut
             .Duration = 15 ' En minute
             .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
             .Body = " Attention date de fin de l'action à réaliser dans le cadre du projet " & Me.[Nom du Projet]
             .Location = "Rendez vous Microsoft Teams"
             .AllDayEvent = False
             .ReminderSet = True
           '  .End = Me.Date_de_fin
            .Save
 
      End With
         End If
       Next
   End With
  End If

Si je fais

Code :

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

1
2
 Set oApointment = objFolder.Items.Add(olAppointmentItem)
     With oApointment

Le'nregistrement dans outlokk est créé 25 fois, mais pas sur le calendrier Alexandre.

Bonne journée

[User]

Bonjour,

Pourquoi mets-tu <> "Titi", je ne comprends pas

Cdlt,

[ALEXM]

Bonjour,

je mets <> "Titi" pour voir si il trouve les folders autres que Titi.
Cela me permet de garder ce contrôle pour la sélection d'autres calendriers quand j'aurai plus de calendriers à gérer.
C'est tout!
Merci !

Bonne journée !

[User]

Rebonjour,

Pour être sûr, il faudrait voir à quel niveau se situe le calendrier "Alexandre", en affichant le noms des calendriers :

Code VBA :

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

1
2
For Each objFolder In .Folders
          debug.print(objFolder.Name)

Tu peux également lister les sous-répertoire :

Code VBA :

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

1
2
3
4
5
6
7
 
    For Each objFolder In .Folders
          debug.print(objFolder.Name)
        For Each subFolder In objFolder.Folders
                debug.print(subFolder.Name)
        next
    next

Pour tester si un dossier est un calendrier tu fais :

Code :

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

1
2
3
4
5
For Each objFolder In .Folders
    If objFolder.DefaultItemType = olAppointmentItem Then  'type Calendrier
        ....
    end if
next

Tu peux aussi consulter cette discussion :

https://www.developpez.net/forums/d2...espace-icloud/

Cdlt,

[ALEXM]

Oui ,
Merci je vais faire cela car je ne sais si réellement "Alexandre" est reconnu comme un dossier.
Je vais tester.
Merci beaucoup !

[ALEXM]

Bonjour,

Je n'arrive pas à afficher les répertoires et sous répertoires avec cette commande :
Mais cela m'est assez difficile de tester jusqu'au bout , car je n'ai pas de calendrier partagé à part "Alexandre" que j'ai créé .

Code :

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

1
2
3
4
5
6
 For Each objFolder In .Folders
          debug.print(objFolder.Name)
        For Each subFolder In objFolder.Folders
                debug.print(subFolder.Name)
        next
    next

La procédure que j'utilise marche pour mon calendrier uniquement , Rappel du 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
Private Sub Thématique_du_Projet_Click()
If MsgBox("Bonjour,voulez-vous créer un rappel dans calendrier Outlook?", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
Else
 Dim outobj As Outlook.Application
     Dim outappt As Outlook.AppointmentItem
     Set outobj = CreateObject("outlook.application")
     Set outappt = outobj.CreateItem(olAppointmentItem)
    Set objApp = New Outlook.Application
    ' Création de l'objet NameSpace d'Outlook
   Set objSpace = objApp.GetNamespace("MAPI")
 ' Référence au dossier principal du compte de messagerie
 'Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))
  Set objCptFolder = objSpace.Folders("prenom.Nom@xxxxxx.fr")
 
 
     With outappt
             .Start = Me.Date_de_Debut
             .Duration = 15 ' En minute
             .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
             .Body = " Attention date de fin de l'action à réaliser dans le cadre du projet " & Me.[Nom du Projet]
             .Location = "Rendez vous Microsoft Teams"
             .AllDayEvent = True
             .ReminderSet = True
           ' .End = Me.Date_de_fin
            .Save
 
        End With
        Set outobj = Nothing
        End If
End Sub

Le CODE que tu mentionnes dans ta réponse fonctionne sur le calendrier "Alexandre",
Mais on ne peut passer en paramètre les éléments de mon formulaire comme :

.Start = Me.Date_de_Debut
.Subject = " Action à éffectuer sur le projet : " & Me.[Nom du Projet]
Donc pour moi c'est compliqué.
En tout cas merci j, je vais voir si je trouve une solution...

BOnne soirée
ALEXM

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
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
    '...

[User]

Le CODE que tu mentionnes dans ta réponse fonctionne sur le calendrier "Alexandre",
Mais on ne peut passer en paramètre les éléments de mon formulaire comme :

.Start = Me.Date_de_Debut
.Subject = " Action à éffectuer sur le projet : " & Me.[Nom du Projet]
Donc pour moi c'est compliqué.
En tout cas merci j, je vais voir si je trouve une solution...

BOnne soirée
ALEXM

Oui, probablement parce que c'est une fonction générique copiée dans un module indépendant.
Dans ce cas il faut faire référence au formulaire dans lequel se trouve les contrôles.

Si ton formulaire se nomme "MonFormulaire", tu fais :

Code VBA :

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

1
2
3
4
'...
   .Start = Forms!MonFormulaire!Date_de_Debut
   .Subject = " Action à éffectuer sur le projet :  " & Forms!MonFormulaire![Nom du Projet]
'...

Cdlt,

[ALEXM]

Bonjour,
Oui merci USER pour ta rectification, à force de faire et refaire je n'ai pas fait attention à cela.
Je suis désolé mais je tourne en rond avec tous les codes que je teste et je n'arrive pas à avoir réellement ce que je veux.
Dans l'idéal, un utilisateur doit pouvoir choisir le ou les calendriers dans les quels il faut positionner le Rendez vous.
Je pense que je pourrai récupérer le calendrier avec l'adresse mail avec le code ci dessous pour ne pas figer l'adresse mail "en dur" :
Set objCptFolder = objSpace.Folders("prenom.Nom@xxxxxx.fr")
Par défaut c'est l'adresse Mail du Chef de Projet, j'ai une table dans laquelle ils y a les mails des User = Chef de Projet.
Mais j'en suis pas là encore.
Donc pour faire le point : j'ai un code qui fonctionne que sur le calendrier "Calendrier" :

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
Private Sub Thématique_du_Projet_Click()
If MsgBox("Bonjour,voulez-vous créer un rappel dans calendrier Outlook?", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
Else
 Dim outobj As Outlook.Application
     Dim outappt As Outlook.AppointmentItem
     Set outobj = CreateObject("outlook.application")
     Set outappt = outobj.CreateItem(olAppointmentItem)
    Set objApp = New Outlook.Application
    ' Création de l'objet NameSpace d'Outlook
   Set objSpace = objApp.GetNamespace("MAPI")
 ' Référence au dossier principal du compte de messagerie
 'Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))
  Set objCptFolder = objSpace.Folders("prenom.Nom@xxxxxx.fr")
 
 
     With outappt
             .Start = Me.Date_de_Debut
             .Duration = 15 ' En minute
             .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
             .Body = " Attention date de fin de l'action à réaliser dans le cadre du projet " & Me.[Nom du Projet]
             .Location = "Rendez vous Microsoft Teams"
             .AllDayEvent = True
             .ReminderSet = True
           ' .End = Me.Date_de_fin
            .Save
 
        End With
        Set outobj = Nothing
        End If
End Sub

J'ai un autre code qui fonctionne uniquement avec "Alexandre" , quand je précise un autre dossier : Erreur de compilation :

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
Private Sub Commande_14_Click()
 
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("Alexandre")
 
'on cree un nouveau rendez-vous
Set oApointment = DossierCalendrier.Items.Add
 
 
With oApointment
.Start = Forms!Projet!Date_de_Debut
.Subject = " Action à éffectuer sur le projet :  " & Forms!Projet![Nom du Projet]
.AllDayEvent = False
.End = Forms!Projet!Date_de_Debut
.Body = " Attention date de fin de l'action à réaliser dans le cadre du projet " & Me.[Nom du Projet]
.Location = "Rendez vous Microsoft Teams"
 .AllDayEvent = True
  .ReminderSet = True
.Save
.Close (olSave)
End With
 
Set oAppointment = Nothing
Set oOutlook = Nothing
 
End Sub

Je n'arrive pas à faire les 2 calendriers en même temps:

Quand j'envoie le code qui recherche les dossiers, sous dossiers OUTLOOK :

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
Private Sub HeureRappel_Click()
     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

Message renvoyé , que "Calendrier est trouvé" :


Ma messagerie Outlook se présente ainsi :


Merci si quelqu'un peut m'aider à y voir un plus calir.
Bonne journée

[User]

Bonjour,

Désolé pour le retard, j'étais très pris cette semaine

Une fois que tu as la référence au dossier principal du compte de messagerie objCptFolder, il te faut parcourir les dossiers et sous-dossiers contenu dans ce dossier principal pour rechercher celui d'Alexandre par exemple. Une fois que tu as la référence au dossier "Alexandre" grâce à la variable dossierCalendrier, tu peux créer un rendez-vous dans ce dossier.

Essaie ceci, en indiquant le nom du dossier que tu recherches au début dans la variable nomdossier :

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Private Sub Thématique_du_Projet_Click()
    Dim objapp As Outlook.Application
    Dim outappt As Outlook.AppointmentItem
    Dim objSpace as object
    Dim objFolder as Outlook.MAPIFolder
    Dim objSubFolder as Outlook.MAPIFolder
    Dim dossierCalendrier as Outlook.MAPIFolder
    Dim nomDossier as String
 
    nomDossier = "Alexandre"
 
    set objapp = CreateObject("outlook.application")
 
    ' Création de l'objet NameSpace d'Outlook
    Set objSpace = objapp.GetNamespace("MAPI")
 
    ' Référence au dossier principal du compte de messagerie
     Set objCptFolder = objSpace.Folders("prenom.Nom@xxxxxx.fr")
 
     For Each objFolder In objCptFolder ' on parcourt les dossiers
         If objFolder.Name Like nomDossier Then
             Set dossierCalendrier = objFolder ' dossier trouvé
             Exit For ' sortie du for
         end if
         For Each objSubFolder In objFolder ' on parcourt les sous-dossiers
              If objSubFolder.Name Like nomDossier Then
                  Set dossierCalendrier = objSubFolder ' dossier trouvé
                   Exit For ' sortie du for
              end if
         next
     next 
 
     set outappt = dossierCalendrier.Items.Add(olAppointmentItem) ' si un dossier a été trouvé, on créé le rendez-vous dans ce dossier
 
     With outappt
             .Start = Me.Date_de_Debut
             .Duration = 15 ' En minute
             .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
             .Body = " Attention date de fin de l'action à réaliser dans le cadre du projet " & Me.[Nom du Projet]
             .Location = "Rendez vous Microsoft Teams"
             .AllDayEvent = True
             .ReminderSet = True
           ' .End = Me.Date_de_fin
            .Save
 
        End With
 
      ' on libère les variables
      set outappt = nothing
      set dossierCalendrier = nothing
      set objSubFolder = nothing
      set objFolder = nothing
      set objSpace = nothing
      set  objapp = nothing          
 
End Sub

A tester...

Cdlt,

[ALEXM]

Bonjour USER,

Merci pour ta réponse.
J'ai une erreur de compilation 438, sur la ligne For each.....
j'ai regardé signification erreur 438, je ne vois pas comment Access n'accepte pas la commande For each.....
Dans le bout de code que j'ai récupéré qui liste les sous dossiers : Je n'ai pas de problèmes avec la commande For each et il m'affiche bien les informations (voir ci dessus)

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
Private Sub HeureRappel_Click()
     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

Merci pour toute votre aide !
ALEXM

[User]

Salut,

Désolé mais je ne suis pas très concentré en ce moment, j'avais oublié l'attribut folders du dossier objCptFolder. :

Code :

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

For Each objFolder In objCptFolder.Folders ' on parcourt les dossiers

Cdlt,

[ALEXM]

Oui ça marche très bien comme cela.
Juste un dernier petit point, si j'ai besoin de créer le rendez vous sur les calendriers de mes collaborateurs qui sont donc "en calendrier partagé avec moi, sans mettre la condition nomDossier = "Alexandre"
il faudrait que la ligne de commande

Code :

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

 [Set outappt = dossierCalendrier.Items.Add(olAppointmentItem) ' si un dossier a été trouvé, on créé le rendez-vous dans ce dossier,

s'applique à mes dossiers/sous dossiers?
Merci un fois de plus, après je ne vous embête plus.
Il faut garder et partager la procédure: Vous l'avez très bien écrite.
Alexm

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
 
Dim objapp As Outlook.Application
    Dim outappt As Outlook.AppointmentItem
    Dim objSpace As Object
    Dim objFolder As Outlook.MAPIFolder
    Dim objSubFolder As Outlook.MAPIFolder
    Dim dossierCalendrier As Outlook.MAPIFolder
    Dim nomDossier As String
    Dim strSqL As String
    nomDossier = "Alexandre"
 
    Set objapp = CreateObject("outlook.application")
 
    ' Création de l'objet NameSpace d'Outlook
    Set objSpace = objapp.GetNamespace("MAPI")
 
    ' Référence au dossier principal du compte de messagerie
    strSqL = "SELECT [Email] FROM [Agents]" _
     & " WHERE [Agent] ='" & Me.[Chef de Projet] & "'"
    Set rst = CurrentDb.OpenRecordset(strSqL, dbOpenSnapshot)
          Set objCptFolder = objSpace.Folders(rst("[Email]").Value)
    ' Set objCptFolder = objSpace.Folders("prenom.nom@pxxxxx.fr")
 
     For Each objFolder In objCptFolder.Folders ' on parcourt les dossiers
         If objFolder.Name Like nomDossier Then
             Set dossierCalendrier = objFolder ' dossier trouvé
             Exit For ' sortie du for
         End If
         For Each objSubFolder In objFolder.Folders ' on parcourt les sous-dossiers
              If objSubFolder.Name Like nomDossier Then
                  Set dossierCalendrier = objSubFolder ' dossier trouvé
                   Exit For ' sortie du for
              End If
         Next
     Next
 
     Set outappt = dossierCalendrier.Items.Add(olAppointmentItem) ' si un dossier a été trouvé, on créé le rendez-vous dans ce dossier
 
     With outappt
             .Start = Me.Date_de_Debut
             .Duration = 15 ' En minute
             .Subject = " Action à éffectuer sur le projet :  " & Me.[Nom du Projet]
             .Body = " Attention date de fin de l'action à réaliser dans le cadre du projet " & Me.[Nom du Projet]
             .Location = "Rendez vous Microsoft Teams"
             .AllDayEvent = True
             .ReminderSet = True
           ' .End = Me.Date_de_fin
            .Save
 
        End With
 
      ' on libère les variables
      Set outappt = Nothing
      Set dossierCalendrier = Nothing
      Set objSubFolder = Nothing
      Set objFolder = Nothing
      Set objSpace = Nothing
      Set objapp = Nothing
End Sub

[User]

Je ne suis pas sûr de comprendre.

Si par exemple la variable DossierCalendrier fait référence à ton dossier de calendrier, alors tu utilises le même principe pour parcourir ses dossiers et sous-dossiers :

Code VBA :

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

1
2
3
4
5
6
For Each objFolder In DossierCalendrier.Folders ' on parcourt les dossiers
         ' créer rendez-vous dans objFolder :  objFolder.Items.Add(olAppointmentItem)...
         For Each objSubFolder In objFolder.Folders ' on parcourt les sous-dossiers
              ' créer rendez-vous dans objSubFolder :  objSubFolder.Items.Add(olAppointmentItem)...
         Next
    Next

Cdlt,

[ALEXM]

Bonjour,

Merci beaucoup USER !
Bonne journée !