Recupérer données d'un calendrier outlook
Bonjour,
J'ai une procédure me permettant de récupérer les événements d'un calendrier outlook (commencant par *) pour être inséré dans un tableau excel et dans des userform.
Je lance cette procédure à l'ouverture de la feuille concernée ou en cliquant sur un bouton pour mettre à jour les valeurs.
Par contre cette procédure est très longue. (2 à 4 minutes environ)
Serait t-il possible d'accélérer cette procédure svp ?
peut-être en insérant dans un premier temps les données du calendrier dans un tableau et ensuite utiliser le tableau pour insérer les infos dans la feuille et l'userform ? (je maîtrise pas la gestion des tableaux)
Qu'en pensez vous ? Pourriez vous m'aider svp ?
Voici mon code :
Sub testcaloutlook()
Dim OutlApp As New Outlook.Application
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
'
Dim datedebut As String
Dim datefin As String
Dim S As String
Dim comb As String
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.DisplayAlerts = False
' informe de la date de début et de fin des événemets du calendrier à rechercher
datedebut = Date - 10
datefin = Date + 90
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
' efface les valeurs des cellules de la ligne 54 comprise entre la date de début et de la la date de fin de la ligne 55
Set plage2 = ThisWorkbook.Worksheets("Stats repas").Range("f55:oi55")
For Each Cell In plage2
col1 = Cell.Column
col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
If Cell.Value > CDate(datedebut) And Cell.Value < CDate(datefin) Then
Cell.ClearComments
Cells(54, col).ClearContents
End If
Next Cell
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Start > datedebut And OutlAppointment.Start < datefin Then
S = Left(OutlAppointment.Subject, 1)
' recherche événements du calendrier commencant par *
If S = "*" Then
ddd1 = Format(OutlAppointment.Start, "dd/mm/yyyy")
ddd2 = Format(OutlAppointment.Start, "hh:mm")
' recherche colonne de la date
For Each Cell In plage2
If Cell.Value = CDate(ddd1) Then
col1 = Cell.Column
col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
End If
Next Cell
' copie valeurs de l evenement du calendrier dans la cellule
If Cells(54, col1) = "" Then
Cells(54, col1) = OutlAppointment.Subject
Cells(54, col1).ShrinkToFit = True
Cells(52, col1) = OutlAppointment.Subject & " " & OutlAppointment.Location
Else
Cells(54, col1) = Cells(54, col1) & Chr(10) & OutlAppointment.Subject
Cells(52, col1) = Cells(52, col1) & Chr(10) & OutlAppointment.Subject & " " & OutlAppointment.Location
End If
End If
End If
Set OutlAppointment = OutlItems.FindNext
Wend
Application.ScreenUpdating = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Je vous remercie beaucoup de votre aide
Cordialement
Bonjour,
A priori tu as pratiquement fait le maximum ...
Tu pourrais ajouter en début et en fin de macro
Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic
En espèrant que cela améliore les choses ...
Merci beaucoup
Maintenant ca prend que quelques secondes, trop cool
Encore MERCI
Ravi que cela t'aide ...
Merci pour tes remerciements
Autre petite question
J'avais fait des corrections il y a quelques temps sur mon classeur
et depuis au démarrage j'ai le message :
"Pour l'instant nous ne parvenons pas à mettre à jour certaines des liaisons de votre classeur
Vous pouvez continuer sans mettre à jour leurs valeurs ou modifier les liaisons qui semblent incorrectes
CONTINUER - MODIFIER LIAISONS"
quand je clique sur MODIFIER LIAISONS mes 2 liaisons ont un état OK
Pourquoi donc avoir ce message si mes liaisons sont ok ?
Avez vous une explication svp ?
J'ai essayé d'aller dans rechercher, noter .xl ou [ dans rechercher et regarder dans formules mais il ne trouve aucune formule ???
Je vous remercie de votre aide
Cordialement
Re,
A priori il s'agit simplement d'une configuration de sécurité ... que tu peux modifier en allant dans les Options d'Excel ...
Autant pour moi
J'ai trouvé l'erreur
J'avais dans "gestionnaires de noms" des noms avec des références inconnues, je les ai supprimés et le message a disparu
Bonne journée