VBA choix d'un calendrier outlook pour inserer des RDVS [Résolu]

jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 9 nov. 2006 à 13:33 - Dernière réponse :  Nicals
- 18 févr. 2014 à 16:57
Bonjour,

J'ai un bout de code qui me permet d'envoyer de Excel dans Outlook calendrier un paquet de rendez-vous, le probleme est qu'ils vont toujours dans le calendrier par defaut, j'aimerai offrir un choix d'un calendrier à l'utilisateur.

Si quelqu'un hyperdoué pouvait me passer une solution ce serait géant.
Dans cette attente

Avec mes remerciements anticipés

[mailto:jldancet.scrutas@wanadoo.fr jldancet.scrutas@wanadoo.fr]
Afficher la suite 

24 réponses

Répondre au sujet
Fianchetto 41 Messages postés dimanche 13 février 2005Date d'inscription 14 décembre 2006 Dernière intervention - 9 nov. 2006 à 13:55
+3
Utile
Tu as une fonction qui s'appelle getDefaultFolder, ptet il y en a aussi une te permettant de spécifier autre chose que les répertoires par défaut. En tout cas, ce petit lien vers la msdn pourrait peut-etre t'aider.

Ff8-g7
Cette réponse vous a-t-elle aidé ?  
Commenter la réponse de Fianchetto
cs_Bidou 5507 Messages postés dimanche 4 août 2002Date d'inscription 20 juin 2013 Dernière intervention - 9 nov. 2006 à 13:59
+3
Utile
Déplacé sur vbfrance.com (j'espère que c'est juste...)


















-Blog-
Cette réponse vous a-t-elle aidé ?  
Commenter la réponse de cs_Bidou
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 9 nov. 2006 à 15:41
+3
Utile
 Merci,
j'ai utilisé getdefaultfolder, mais en plus il faut lui mettre un nom quelque part si on veut aller vers un calendrier précis, je vais surement trouver dans le raccourci que tu m'as passé.
Avec mes salutations
JL
Cette réponse vous a-t-elle aidé ?  
Commenter la réponse de jldancet
cs_MPi 3863 Messages postés mardi 19 mars 2002Date d'inscription 13 mars 2018 Dernière intervention - 10 nov. 2006 à 11:19
+3
Utile
Voici une petite procédure que j'ai créée il n'y a pas longtemps et que je n'ai jamais vraiment  terminée.

L'idée était de lister tous les répertoires et sous-répertoires. Il me
manque la partie "récursive" pour rechercher les sous-sous-répertoires.

En ajoutant la section DefaultItemType, on peut chercher un type de répertoire, comme les calendriers.


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

MPi
Cette réponse vous a-t-elle aidé ?  
Commenter la réponse de cs_MPi
cs_MPi 3863 Messages postés mardi 19 mars 2002Date d'inscription 13 mars 2018 Dernière intervention - 29 nov. 2006 à 10:37
+3
Utile
Je ne connaissais pas ces méthodes, mais si en regardant dans l'aide, Il y a une condition avant cet appel

......
myRecipient.Resolve
If myRecipient.Resolved Then
    Set myCalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient,                     olFolderCalendar)
End If
......

J'imagine que cette condition est là pour éviter l'erreur.
Peut-être que le nom que tu utilises  "Geneve, User1"  n'est pas le bon ?
Peut-être manque-t-il un espace ou quelque chose comme ça, d'où l'erreur (?)
Peut-être que ce "user" est protégé et que tu n'as pas les droits d'y accéder (?)

J'avais fait des tests au bureau, mais je n'ai pas les mêmes conditions que toi... Il n'y a pas de calendrier partagé dans le réseau, seulement des tas de répertoires et sous-répertoires.

MPi
Cette réponse vous a-t-elle aidé ?  
Commenter la réponse de cs_MPi
cs_MPi 3863 Messages postés mardi 19 mars 2002Date d'inscription 13 mars 2018 Dernière intervention - 8 déc. 2006 à 23:30
+3
Utile
Bien content pour toi.
Il était temps parce que je n'avais plus beaucoup de ressources pour t'aider plus avant... ¦¬)

Bravo et bonne continuation dans tes projets.

MPi
Cette réponse vous a-t-elle aidé ?  
Commenter la réponse de cs_MPi
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 10 nov. 2006 à 12:58
0
Utile
Merci pour le tuyau, je vais essayer
hyper sympa de ta part
JL
Commenter la réponse de jldancet
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 12 nov. 2006 à 18:39
0
Utile
Bonsoir
je reviens sur mon probleme de choix de calendrier, j'ai fait une modification pour modifier le "Calendrier_PR", apparement il e trouve mais ca termine en cata dans la ligne "SET MYITEM" en couleur.
Voici le code, il lit un tableau excel et cree des rendez-vous, si tu peux trouver ce qui manque, je pense que mes maux de  tete seront soulages-

D'avance merci

Jean-Louis

Sub SYNCHRO_PR()
On Error GoTo erreurapp
Call SupprimerRDVPR
'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim myOlApp As New Outlook.Application
Dim myItem As Outlook.AppointmentItem
Dim myCalendar As Outlook.Items


Dim Cell As Range
Dim deleg1
Dim D As Long
Dim premlivide As Long
Set myOlApp = CreateObject("outlook.application")
Set myCalendar = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Folders.Item("Calendrier_PR").Items




premlivide = 0
Sheets("SYNC_PR").Select
premlivide = Columns(1).Find("", [A65536], , , xlByRows, xlNext).Row




For D = 2 To premlivide
    If Cells(D, 1) = "" Then GoTo exisub
    If Cells(D, 2) = "KO" Then GoTo suite
    If Cells(D, 2) = "DB" Then GoTo suite
  
    Set myItem = myCalendar.CreateItem(olAppointmentItem) (ERREUR 438 Propriete ou methode non geree par cet objet¨)


    With myItem
        .MeetingStatus = olNonMeeting


        .AllDayEvent = True '"EX:AllDayEvent"


deleg1 = Cells(D, 9) & Chr(13)
For xx = 1 To 20If Cells(D + xx, 2) "DB" And Cells(D + xx, 3) Cells(D, 3) Then GoTo maj
GoTo yy
maj:
If Cells(D + xx, 9) = Cells(D + xx - 1, 9) Then GoTo yy1
deleg1 = deleg1 & "                " & Cells(D + xx, 9) & Chr(13)
yy1:
Next xx
yy:




.Body = "N° " & Cells(D, 1) & " " & "SAP PROJET : " & Cells(D, 3) & Chr(13) & Cells(D, 6) & Chr(13) & "Délégués : " + deleg1 & "Responsable : " + Cells(D, 33) '"EX:Body"


 


.Categories = "PR"


.Location = Cells(D, 7) '"EX:Location"


.ReminderSet = False
.ReminderSoundFile = False '"EX:ReminderSoundFile"


.Start = Cells(D, 4) '"EX:Start"
.Subject = Cells(D, 5) '"EX:Subject" prendre les 30 premieres positions


.Save


    End With


    
    Set myItem = Nothing
suite:
Next D
exisub:


Exit Sub


erreurapp:
MsgBox "Erreur Synchro Outlook (création) " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
Commenter la réponse de jldancet
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 13 nov. 2006 à 10:26
0
Utile
Bonsoir
je reviens sur mon probleme de choix de calendrier, j'ai fait une modification pour modifier le "Calendrier_PR", apparement il e trouve mais ca termine en cata dans la ligne "SET MYITEM" en couleur.
Voici le code, il lit un tableau excel et cree des rendez-vous, si tu peux trouver ce qui manque, je pense que mes maux de  tete seront soulages-

D'avance merci

Jean-Louis

Sub SYNCHRO_PR()
On Error GoTo erreurapp
Call SupprimerRDVPR
'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim myOlApp As New Outlook.Application
Dim myItem As Outlook.AppointmentItem
Dim myCalendar As Outlook.Items


Dim Cell As Range
Dim deleg1
Dim D As Long
Dim premlivide As Long
Set myOlApp = CreateObject("outlook.application")
Set myCalendar = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Folders.Item("Calendrier_PR").Items




premlivide = 0
Sheets("SYNC_PR").Select
premlivide = Columns(1).Find("", [A65536], , , xlByRows, xlNext).Row




For D = 2 To premlivide
    If Cells(D, 1) = "" Then GoTo exisub
    If Cells(D, 2) = "KO" Then GoTo suite
    If Cells(D, 2) = "DB" Then GoTo suite
  
    Set myItem = myCalendar.CreateItem(olAppointmentItem) (ERREUR 438 Propriete ou methode non geree par cet objet¨)


    With myItem
        .MeetingStatus = olNonMeeting


        .AllDayEvent = True '"EX:AllDayEvent"


deleg1 = Cells(D, 9) & Chr(13)
For xx = 1 To 20If Cells(D + xx, 2) "DB" And Cells(D + xx, 3) Cells(D, 3) Then GoTo maj
GoTo yy
maj:
If Cells(D + xx, 9) = Cells(D + xx - 1, 9) Then GoTo yy1
deleg1 = deleg1 & "                " & Cells(D + xx, 9) & Chr(13)
yy1:
Next xx
yy:




.Body = "N° " & Cells(D, 1) & " " & "SAP PROJET : " & Cells(D, 3) & Chr(13) & Cells(D, 6) & Chr(13) & "Délégués : " + deleg1 & "Responsable : " + Cells(D, 33) '"EX:Body"


 


.Categories = "PR"


.Location = Cells(D, 7) '"EX:Location"


.ReminderSet = False
.ReminderSoundFile = False '"EX:ReminderSoundFile"


.Start = Cells(D, 4) '"EX:Start"
.Subject = Cells(D, 5) '"EX:Subject" prendre les 30 premieres positions


.Save


    End With


    
    Set myItem = Nothing
suite:
Next D
exisub:


Exit Sub


erreurapp:
MsgBox "Erreur Synchro Outlook (création) " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
Commenter la réponse de jldancet
cs_MPi 3863 Messages postés mardi 19 mars 2002Date d'inscription 13 mars 2018 Dernière intervention - 13 nov. 2006 à 11:00
0
Utile
As-tu essayé avec
Set MyItem = MyCalendar.Add

CreateItem ne fait pas partie des choix ou possibilités de MyCalendar...

MPi
Commenter la réponse de cs_MPi
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 13 nov. 2006 à 11:41
0
Utile
je te dirai trois mots
BRAVO, BRAVO et BRAVO
encore merci
Commenter la réponse de jldancet
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 16 nov. 2006 à 13:12
0
Utile
Bonjour, je reviens avec mes problemes outlook, avec ce que tu m'as donné tout marche OK en monoposte, maintenant le probleme est que je n'arrive pas à atteindre des calendriers partagés sur un réseau, il y a 2 rubriques : mes calendriers (je peux tous les atteindre) et autres calendriers qui sont des calendriers partagés sur une machine réseau, as-tu une idée stp.
Merci d'avance

Jean-Louis
Commenter la réponse de jldancet
cs_MPi 3863 Messages postés mardi 19 mars 2002Date d'inscription 13 mars 2018 Dernière intervention - 16 nov. 2006 à 19:11
0
Utile
Aucune idée pour l'instant.
Il faudrait que je fasse des tests au bureau demain si j'y vais, sinon la semaine prochaine...

MPi
Commenter la réponse de cs_MPi
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 16 nov. 2006 à 20:50
0
Utile
Sympa de ta part, j'ai aussi recherché sur msdn, mais pas trouvé la réponse.
encore merci et à la semaine prochaine
jean-Louis
Commenter la réponse de jldancet
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 29 nov. 2006 à 07:21
0
Utile
Bonjour

Je reviens avec mes soucis de calendrier partagé.
J'ai pu piocher des trucs interessants dans MSDN, la sub permet l'affichage du calendrier partagé et ca marche, par contre pour ce qui est de l'enregistrement d'appointmentsitem c'est une autre histoire, il manque toujours un objet ou un type n'est pas accepté.
ci-dessous, la sub qui affiche, suivie de ma sub (derivée de la premiere) qui essaye d'enregistrer un rendezvous.

Je te remercie d'avance de ton précieux concours

Amicalement

¨Jean-Louis

Sub ResolveName()
 Dim myOlApp As Outlook.Application
 Dim myNamespace As Outlook.NameSpace
 Dim myRecipient As Outlook.Recipient
 Dim CalendarFolder As Outlook.MAPIFolder
 Set myOlApp = CreateObject("Outlook.Application")
 Set myNamespace = myOlApp.GetNamespace("MAPI")
 Set myRecipient = myNamespace.CreateRecipient("Dan Wilson")
 myRecipient.Resolve
 If myRecipient.Resolved Then
  Call ShowCalendar(myNamespace, myRecipient)
 End If
End Sub


Sub ShowCalendar(myNamespace, myRecipient)
 Dim CalendarFolder As MAPIFolder
 Set CalendarFolder = _
        myNamespace.GetSharedDefaultFolder _
        (myRecipient, olFolderCalendar)
 CalendarFolder.Display
End Sub




sub Mon_code()



Dim myOlApp As New Outlook.Application
Dim myItem As Outlook.AppointmentItem
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myCalendar As Outlook.Items
Dim myCalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("outlook.application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Geneve, User1")
myRecipient.Resolve




Set myCalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar) <---- plante ici



Set myItem = myCalendarFolder.Add(olAppointmentItem)


With myItem
        .MeetingStatus = olNonMeeting
        .AllDayEvent = True
        .Categories = "TEST"
        .Location = "TEST LOCATION"
        .ReminderSet = False
        .ReminderSoundFile = False 
        .Start = "01.01.2007"
        .Subject = "Sujet test"
        .Save
End With    
Set myItem = Nothing
end sub
Commenter la réponse de jldancet
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 29 nov. 2006 à 10:51
0
Utile
Je te remercie pour ta réaction rapide.


Le nom est OK, et les droits aussi, je voulais juste voir avec toi s'il y avait une grosse bourde bien visible dans mon code, apparement je vais aller sur ce site et faire des essais jusqu'à ce que réussite s'en suive, je ne manquerai pas de te communiquer les resultats surtout si ils sont positifs.

Avec mes remerciements


Jean-Louis
Commenter la réponse de jldancet
cs_MPi 3863 Messages postés mardi 19 mars 2002Date d'inscription 13 mars 2018 Dernière intervention - 29 nov. 2006 à 12:05
0
Utile
Tiens, un exemple que je viens de trouver:

Sub CreateOtherUserAppointment()
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim objDummy As Outlook.MailItem
    Dim objRecip As Outlook.Recipient
    Dim objAppt As Outlook.AppointmentItem
    Dim strMsg As String
    Dim strName As String
    On Error Resume Next
   
    ' ### name of person whose Calendar you want to use ###
    strName = "FlaviusJ"
   
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set objDummy = objApp.CreateItem(olMailItem)
    Set objRecip = objDummy.Recipients.Add(strName)
    objRecip.Resolve
    If objRecip.Resolved Then
        On Error Resume Next
        Set objFolder = _
          objNS.GetSharedDefaultFolder(objRecip, _
            olFolderCalendar)
        If Not objFolder Is Nothing Then
            Set objAppt = objFolder.Items.Add
            If Not objAppt Is Nothing Then
                With objAppt
                    .Subject = "Test Appointment"
                    .Start = Date + 14
                    .AllDayEvent = True
                    .Save
                End With
            End If
        End If
    Else
        MsgBox "Could not find " & Chr(34) & strName & Chr(34), , _
               "User not found"
    End If

    Set objApp = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    Set objDummy = Nothing
    Set objRecip = Nothing
    Set objAppt = Nothing
End Sub

MPi
Commenter la réponse de cs_MPi
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 29 nov. 2006 à 21:31
0
Utile
Un tout grand merci, j'ai piqué ton programme et ajouté ma sauce ca fonctionne super bien, encore merci
amicalement
Jean-Louis
Commenter la réponse de jldancet
jldancet 21 Messages postés lundi 14 août 2006Date d'inscription 17 février 2007 Dernière intervention - 1 déc. 2006 à 08:06
0
Utile
Bonjour,

je me heurte à un nouveau probleme : celui de supprimmer des appointmentsitems dans un calendrier partagé, voici mon code
le calendrier est trouvé mais je n'arrive pas à atteindre les items :

Sub supprimerRDVPR_SHR()
Application.ScreenUpdating = False


    Dim objApp As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objDummy As Outlook.MailItem
    Dim objRecip As Outlook.Recipient
    Dim objAppt As Outlook.AppointmentItem
    Dim objMyCalendar As Outlook.Items
    Dim strMsg As String
    Dim strName As String
    Dim calendrier
    Dim categorie
    Dim partage
    Dim dele
    dele = 0
    On Error Resume Next
    Sheets("MACRO").Select                                                        'feuille XLS contenant les parametres
    calendrier = [d90]                                                                    ' nom du calendrier partagé
    categorie = [e90]                                                                     ' categorie a supprimer
    partage = [A90]                                                                       ' calendrier partage oui ou non
    strName = calendrier
       
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set objDummy = objApp.CreateItem(olMailItem)
    Set objRecip = objNS.CreateRecipient(strName)
    objRecip.Resolve
    If objRecip.Resolved Then
        On Error Resume Next
        Set objFolder = _
          objNS.GetSharedDefaultFolder(objRecip, _
            olFolderCalendar)
                Set objMyCalendar = objApp.GetNamespace("MAPI").objFolder.Folders.Item(calendrier).Items


        If Not objFolder Is Nothing Then
        
            Set objAppt = objMyCalendar.Items ' ------> à l'execution donne : NOTHING alors qu'il y a 900 lignes.
            
            If Not objAppt Is Nothing Then
            For Each objAppt In objFolder
                With objAppt
                If Categories <> categorie Then GoTo suite
                      .Delete
                      dele = dele + 1                                              'comptage des enregistrements supprimés
suite:
               End With
               Set objAppt = Nothing
             Next objAppt
             If dele = 0 Then GoTo fin                                     'si dans cette boucle je n'ai rien supprime c'est terminé
             Call supprimerRDVPR_SHR                                'j'ai supprime des enregistrements je vais voir s'il y en a d'autres
fin:
                   
                
            End If
        End If
    Else
        MsgBox "Could not find " & Chr(34) & strName & Chr(34), , _
               "User not found"
    End If


    Set objApp = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    Set objDummy = Nothing
    Set objRecip = Nothing
    Set objAppt = Nothing
End Sub

J'espere que tu vas trouver un gros truc qui va te faire mal aux yeux.
Avec mes remerciements anticipés
Jean-Louis
Commenter la réponse de jldancet
cs_MPi 3863 Messages postés mardi 19 mars 2002Date d'inscription 13 mars 2018 Dernière intervention - 1 déc. 2006 à 11:21
0
Utile
Aucune idée lumineuse et aucune façon pour moi de tester parce que je n'ai pas ce genre de configuration Outlook ici...

Par contre, je me demande ce qu'est Categories...

If Categories <> categorie Then GoTo suite
Que valent ces 2 variables avant le goto suite ?

Quand j'utilise ce genre de collection d'objets, j'utilise  la fenêtre "Espions" qui me permet de voir quels sont les objets disponibles, si je passe par le bon objet pour me rendre à un autre... En mettant un point d'arrêt juste avant ou après la ligne en rouge, tu pourrais voir ce que contient
objMyCalendar
objFolder
objFolder.Folders
objFolder.Folders.Item(calendrier)
... etc

MPi
Commenter la réponse de cs_MPi

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

VBA choix d'un calendrier outlook pour inserer des RDVS - page 2