VBA choix d'un calendrier outlook pour inserer des RDVSRésolu

Question

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]

Fianchetto · Accepted Answer

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

cs_Bidou · Answer

Déplacé sur vbfrance.com (j'espère que c'est juste...)














 



-Blog-

jldancet · Answer

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

cs_MPi · Answer

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

jldancet · Answer

Merci pour le tuyau, je vais essayer
hyper sympa de ta part
JL

jldancet · Answer

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

jldancet · Answer

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

cs_MPi · Answer

As-tu essayé avec 
Set MyItem = MyCalendar.Add

CreateItem ne fait pas partie des choix ou possibilités de MyCalendar...

MPi

jldancet · Answer

je te dirai trois mots
BRAVO, BRAVO et BRAVO
encore merci

jldancet · Answer

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

cs_MPi · Answer

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

jldancet · Answer

Sympa de ta part, j'ai aussi recherché sur msdn, mais pas trouvé la réponse.
encore merci et à la semaine prochaine
jean-Louis

jldancet · Answer

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

cs_MPi · Answer

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

jldancet · Answer

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

cs_MPi · Answer

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

jldancet · Answer

Un tout grand merci, j'ai piqué ton programme et ajouté ma sauce ca fonctionne super bien, encore merci
amicalement
Jean-Louis

jldancet · Answer

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

cs_MPi · Answer

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

cs_MPi · Answer

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

VBA choix d'un calendrier outlook pour inserer des RDVS

24 réponses

Votre réponse

Discussions similaires