XL 2021 Période d'un calendrier outlook vers Excel

[combory]

Bonjour à tous,

J'ai retrouvé une macro de maitre BOISGONTIER (coucou là-haut) qui répond à mon besoin d'intégrer mon calendrier Outlook 2021 dans Excel 2021.
Cependant, je n'arrive pas limiter le nombre de données.
Je souhaiterais récupérer tous les RDV qui sont entre "Now()" et "Now() + 5".
Je précise que je prends "Now()" pour avoir les rendez-vous restant de la journée en cours, et donc pas ceux de ce matin...
J'ai essayé d'intégrer une boucle IF après le For Each, mais ça ne marche pas.

Merci d'avance à tous.

 

[combory]

Bonjour,

J'ai un peu avancé sur mon problème en modifiant le code comme suit :

Sub ListeCalendrier()
'Range("Tableau3[[Libéllé]:[Calendrier]]").Select
'Selection.ClearContents

Set oOlApp = CreateObject("Outlook.Application")
Set oNameSpace = oOlApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(9)

With Worksheets("LitCalendrier")
ligne = 2
For Each i In oFolder.Items
On Error Resume Next
For t = Date To Date + 10
If i.Start = t Then
.Cells(ligne, 1).Value = i.Subject
.Cells(ligne, 2).Value = i.Start
.Cells(ligne, 3).Value = i.End
.Cells(ligne, 4).Value = oFolder.Name
ligne = ligne + 1
End If
Next t
Next i
End With
MsgBox "C'est fini"
End Sub

Le problème c'est que je ne récupère que les rendez-vous pour les journées entières (de J à J+10) et pas ceux qui sont dans la journée (ex : de 09:00 à 11:00 de la journée du 13/10/2023) .
J'ai essayé de remplacer Date par Now() mais ça ne marche pas.
J'ai essayé de mettre DateAdd pour donner un cycle de 1 seconde, pas de résultats non plus.

Une idée ??

 

[zebanx]

Bonjour Combory, le forum

Regardez peut-être ce fil

Download Outlook Calendar VBA Example

I built this example due to frustration. Check out my example for downloading your Outlook Calendar with VBA.

rtmccormick.com

ou celui là

Outlook - importation outlook dans excel

bonjour, j'explique mon probleme : tous les vendredi j'envoie un avis de RDV outlook aux memes personnes elles ont jusqu'au jeudi soir pour repondre : accepté , refusée ... Je souhaiterais le vendredi, lancer une macro afin de recuperer sous forme de tableau excel 1 colonne pour les noms des...

excel-downloads.com

Bonne journée
zebanx

PS : votre fichier a fait apparaitre une détection de mon anti-virus (!)

 

[combory]

Bonjour,

Merci pour cette proposition.
J'ai finalement modifié le code que je mets ci-dessous, à toutes fins utiles.

Sub LireCalendriersOutlookAvecSousCalendriers(ByVal Folder As Object, ByVal DateDebut As Date, ByVal DateFin As Date)
Dim OutlookFolder As Object
Dim OutlookAppointment As Object
Dim i As Integer


With Worksheets("LitCalendrier")
Ligne = Cells(Rows.Count, 6).End(xlUp).Row + 1
' Boucle à travers les rendez-vous du calendrier actuel
For i = 1 To Folder.Items.Count
Set OutlookAppointment = Folder.Items(i)

' Vérifie si la date de début du rendez-vous est dans la plage spécifiée
If OutlookAppointment.Start >= DateDebut And OutlookAppointment.Start <= DateFin Then
On Error Resume Next
' Affiche les détails du rendez-vous dans la fenêtre de l'éditeur VBA (Fenêtre Immediate)
.Cells(Ligne, 1).Value = OutlookAppointment.Subject
.Cells(Ligne, 2).Value = OutlookAppointment.Location
.Cells(Ligne, 3).Value = OutlookAppointment.Start
.Cells(Ligne, 4).Value = OutlookAppointment.End
.Cells(Ligne, 5).Value = ConvertMinToDay(OutlookAppointment.Duration)
.Cells(Ligne, 6).Value = Folder.Name
Ligne = Ligne + 1
End If
Next i

' Récursivement parcourir les sous-calendriers
If Folder.Folders.Count > 0 Then
For Each OutlookFolder In Folder.Folders
LireCalendriersOutlookAvecSousCalendriers OutlookFolder, DateDebut, DateFin
Next OutlookFolder
End If
End With

End Sub

Sub LireCalendriersOutlook()
'on vide le tableau
' Range("Tableau3[[Sujet]:[Calendrier]]").Select
' Selection.Delete
Dim OutlookApp As Object
Dim OutlookNamespace As Object

' Définir la date de début comme étant la date actuelle
Dim DateDebut As Date
DateDebut = Date

' Définir la date de fin comme étant la date actuelle + 10 jours
Dim DateFin As Date
DateFin = Date + 10

' Crée une instance d'Outlook
Set OutlookApp = CreateObject("Outlook.Application")
' Accède au namespace (espace de noms) Outlook
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

' Appeler la fonction de lecture pour le dossier racine (calendrier principal)
LireCalendriersOutlookAvecSousCalendriers OutlookNamespace.GetDefaultFolder(9), DateDebut, DateFin
' Libère les objets Outlook
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub

Function ConvertMinToDay(lngTime As Integer) As String
ConvertMinToDay = lngTime \ 1440 & "j " & _
(lngTime Mod 1440) \ 60 & ":" & (lngTime Mod 1440) Mod 60
End Function