XL 2016 Ajouter planning Outlook un rdv(sans activer de reference "Microsoft Outlook object library xx.x"

[fredl]

Bonjour à tous,
je viens faire appel à vos lumières suite à recherche infructueuse sur le forum.
dans la macro "AjoutRdvPlanningOutlook1" ci dessous, j'ajoute au calendrier Outlook un Rdv (Jour férié)
L'inconvénient pour cette dernière est l'obligation d'activer la ref "Microsoft Outlook object library xx.x" bloquante lorsque l'on a des utilisateurs avec des versions différentes d'outlook.

J'ai donc essayé de réécrire cette macro autrement pour s'en affranchir (elle marche bien pour la création d'emails).
Par contre, elle ne marche pas pour la création d'un Rdv.....->cela cree un Email(pas de date de debut et de fin necessaire à un rdv....

Je suis vivement intéressé par vos retours qui me dépatouilleraient bien.
Merci d'avance!
frédéric

Sub AjoutRdvPlanningOutlook1() 'marche
'mais oblige l'activation de la Reference "Microsoft Outlook object library xx.x", bloquant si les users ont des versions d'office différentes...
Dim olApp As Outlook.Application
Dim olApt As AppointmentItem
Set olApp = New Outlook.Application

''supprimer les messages d'alerte
Application.DisplayAlerts = False
Set olApt = olApp.CreateItem(olAppointmentItem)
On Error Resume Next
    With olApt
        .Start = "0:00 AM" & Format("01/01/2023")
        .End = .Start + 1
        .Subject = "Jour Férié"
        .Location = "" '"N/A"
        .Body = "Jour Férié du début de l'année"
        .BusyStatus = olOutOfOffice
        .ReminderMinutesBeforeStart = 960 '16h avant minuit=8h du mat la veille
        .ReminderSet = True
        .Display
        .Save
        .Close False
    End With
    Set olApt = Nothing
    Set olApp = Nothing
    Application.DisplayAlerts = True
End Sub

Sub AjoutRdvPlanningOutlook2() 'ne marche pas
'pas d'activation de reference particuliere(marche pour la creation d'emails)-> parfait pour toutes les versions d'outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then 'si outlook es fermé,ouvrir outlook
    Set olApp = CreateObject("Outlook.Application")
End If

''supprimer les messages d'alerte
Application.DisplayAlerts = False
Set olApt = olApp.CreateItem(olAppointmentItem)
On Error Resume Next
        With olApt
        .Start = "0:00 AM" & Format("01/01/2023")
        .End = .Start + 1
        .Subject = "Jour Férié"
        .Location = "" '"N/A"
        .Body = "Jour Férié du début de l'année"
        .BusyStatus = olOutOfOffice
        .ReminderMinutesBeforeStart = 960 '16h avant minuit=8h du mat la veille
        .ReminderSet = True
        .Display '->crée un Email(pas de date de debut et de fin)
        .Save
        .Close False
    End With
    Set olApt = Nothing
    Set olApp = Nothing
    Application.DisplayAlerts = True
End Sub

 

[fanch55]

Bonjour,
La constante olAppointmentItem n'est renseignée que si vous mettez la bib OUtlook en référence .
Sinon, c'est juste une variable propre à la sub où elle est codée avec 0 comme valeur par défaut .
Pour créer un mail, cela ne pose pas de problème car l'argument passé à CreateItem doit être = 0 .
Dans le cas d'un rdv, l 'argument doit être = 1 .
Il suffit donc de le renseigner dès le début de sub :

Sub AjoutRdvPlanningOutlook2()
    olAppointmentItem = 1

 

[fredl]

meerciiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii
trop fort !
Tu m'enlèves une sacrée épine du pied
Au plaisir!
Frederic