Option Explicit
' Déclaration des variables utiles pour tout le module
Dim FlgErr As Boolean
Dim FolderPartage As Outlook.Folder
'---------------------------------------------------------------------------------------
' Création d'un RDV sur Agenda OUTLOOK
'---------------------------------------------------------------------------------------
Sub AjoutDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xDuree, xLieu, xBody, xCatégorie)
Dim xStart As String
Dim ObjRDV As Outlook.AppointmentItem
' Définir le FLAG d'erreur à FAUX
FlgErr = False
' Trouver et définir le calendrier sur lequel travailler
Call TrouveDefCal(xCalendrier)
' Si pas d'erreur rencontrée
If FlgErr = False Then
' Création du RDV
Set ObjRDV = FolderPartage.Items.Add
xStart = xDateDeb & " " & Deux(Hour(xHeurDeb)) & ":" & Deux(Minute(xHeurDeb)) & ":00"
With ObjRDV
.Subject = xTitre
.Body = xBody
.Start = xStart
.Duration = xDuree 'Valeur entière (exemple 30) exprimée en minutes
.Location = xLieu
.Categories = xCatégorie 'Exemple : Catégorie Bleu
.ReminderMinutesBeforeStart = 0
.ReminderSet = True
.Display 'Mettre en commentaire après mise au point
'.Save
End With
End If
End Sub
'---------------------------------------------------------------------------------------
' Supression d'un RDV sur Agenda OUTLOOK
'---------------------------------------------------------------------------------------
Sub SupprDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xCatégorie)
Dim oAppointment As Outlook.AppointmentItem
Dim CollectionAppointments As Outlook.Items
Dim xConcat As String, xConcatRDV As String, sFilter As String, xStart As String
Dim xTitRDV As String, xDebRDV As String, xFinRDV As String, xEmpRDV As String, xBodRDV As String, xCatRDV As String
' Définir le FLAG d'erreur à FAUX
FlgErr = False
' Trouver et définir le calendrier sur lequel travailler
Call TrouveDefCal(xCalendrier)
' Si pas d'erreur rencontrée
If FlgErr = False Then
'----------------------------------------------------------
' Récupération des données du tableau
'----------------------------------------------------------
xStart = xDateDeb & " " & Deux(Hour(xHeurDeb)) & ":" & Deux(Minute(xHeurDeb))
xConcat = xTitre & "-" & xStart & ":00-" & xCatégorie
'Définit les critères de filtre
sFilter = "[Start] = '" & xStart & "'"
Set CollectionAppointments = FolderPartage.Items.Restrict(sFilter)
'--------------------------------------------------------
' Boucle sur tous les rdv trouvés
'--------------------------------------------------------
For Each oAppointment In CollectionAppointments
xTitRDV = oAppointment.Subject 'Titre
xDebRDV = oAppointment.Start 'Date et Heure de début
xFinRDV = oAppointment.End 'Date et Heure de fin
xEmpRDV = oAppointment.Location 'Emplacement
xBodRDV = oAppointment.Body 'Corps
xCatRDV = oAppointment.Categories 'Catégorie (couleur)
xConcatRDV = xTitRDV & "-" & xDebRDV & "-" & xCatRDV
' RDV trouvé, le supprimer
If xConcatRDV = xConcat Then oAppointment.Delete
Next
End If
' Effacer les variables objet pour libérer de la mémoire
Set CollectionAppointments = Nothing
End Sub
Sub TrouveDefCal(xCalendrier)
Dim OLApp As Outlook.Application
Dim ObjNS As Outlook.Namespace
Dim ObjExpCal As Outlook.Explorer
Dim ObjNavCalPart As Outlook.NavigationFolders
Dim ObjNavFolder As Outlook.NavigationFolder
Dim ObjNavMod As Outlook.CalendarModule
Dim xNbrFamCal As Integer, xNbrSousCal As Integer
Dim xNomFamilleCal As String, xNomCalendrier As String
Dim xMess As String
Dim F As Integer, G As Integer
Dim xTrouve As Boolean
Set OLApp = CreateObject("outlook.application")
Set ObjNS = OLApp.Session
Set ObjExpCal = ObjNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set ObjNavMod = ObjExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
'--------------------------------------------------------------------------------------
' Parcours la liste des familles de calendrier et les calendriers de chaque famille
'--------------------------------------------------------------------------------------
xTrouve = False
xNbrFamCal = ObjNavMod.NavigationGroups.Count
For F = 1 To xNbrFamCal
xNbrSousCal = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Count
For G = 1 To xNbrSousCal
xNomFamilleCal = ObjNavMod.NavigationGroups.Item(F).Name ' Juste pour info
xNomCalendrier = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Item(G).DisplayName
' Si le calendrier trouvé = celui cherché
If xNomCalendrier = xCalendrier Then
On Error Resume Next
Set ObjNavCalPart = ObjNavMod.NavigationGroups.Item(xNomFamilleCal).NavigationFolders
Set ObjNavFolder = ObjNavCalPart(xCalendrier)
If Err Then
xTrouve = False
MsgBox "Calendrier : " & xCalendrier & " non accéssible !!!", vbCritical, "ERREUR"
Else
xTrouve = True
xMess = Empty
xMess = xMess & "FAMILLE = " & xNomFamilleCal & Chr(13) & Chr(13)
xMess = xMess & Space(10) & "CALENDRIER = " & xNomCalendrier
MsgBox xMess, vbInformation, "FAMILLE & CALENDRIER"
' Définir le dossier de travail
Set FolderPartage = ObjNavFolder.Folder
Exit For
End If
End If
Next G
If xTrouve Then Exit For
Next F
' FLAG d'erreur
FlgErr = Not xTrouve
' Petit message si non trouvé
If xTrouve = False Then
MsgBox "Calendrier : " & xCalendrier & " non trouvé !!!!", vbCritical, "CALENDRIER"
End If
' Effacer les variables objet pour libérer de la mémoire
Set OLApp = Nothing: Set ObjNS = Nothing
Set ObjExpCal = Nothing: Set ObjNavMod = Nothing
Set ObjNavCalPart = Nothing: Set ObjNavFolder = Nothing
End Sub