Recherche dans outlook
Bonjour,
Je cherche à récupérer des infos d'outlook mais je suis incapable de faire cela
Pourriez-vous m'aider svp ?
Je souhaite récupérer dans outlook dans le calendrier qui se nomme "Calendrier1" les événement classer sous le nom "Loisirs" en vert et sous le nom "Important" en violet.
Je voudrais ensuite insérer ces événements (titre + heure début + heure fin) en commentaire sur la ligne 4 du fichier excel "test outlook.xlsm" dans la cellule comprenant la même date que l'événement.
Pensez vous que cette opération est possible ?
Si oui, je souhaiterais si possible que cette opération soit faite pou la période de j-7 à j+90 par exemple pour alléger la recherche (ou toute l'année si ce n'est pas trop lourd) et qu'à chaque appel de la procédure les commentaires soient effacés avant la l"opération pour supprimer d'éventuels événements supprimés ou modifiés sur outlook entre temps.
Je crains que cette demande soit impossible, et vous ?
Je vous remercie beaucoup de me lire et de votre aide.
Cordialement
Bonjour,
Pour un premier commencement et ne pas faire le job à ta place, je te propose de tester ce code, où tu dois ajouter dans l'IDE (Alt-F11) outils, référence, cocher : Microsoft Outlook......
et dans un module :
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
datedebut = "20/07/2019"
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
'
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
'
While TypeName(OutlAppointment) <> "Nothing"
MsgBox OutlAppointment.Subject
Set OutlAppointment = OutlItems.FindNext
Wend
End Sub
Bonjour,
J'ai coché dans référence Microsoft Outlook 16.0 Object library - Microsoft Outlook Social Provider extensibility - Microsoft Outlook View control
J'ai saisi votre code dans un module et tout fonctionne.
Comment faire s'il vous plait pour choisir le calendrier nommé "calendrier1" et filtrer que les événements de la catégorie nommée "Loisirs" et "Important"
J'ai testé ce code pour préciser la catégorie mais il cherche sans fin sans rien afficher, il plante :
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
datedebut = "02/09/2019"
datefin = datedebut + 15
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
'
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
'
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Categories = "Loisirs" Then
MsgBox OutlAppointment.Subject & " " & OutlAppointment.Start
Set OutlAppointment = OutlItems.FindNext
End If
Wend
End SubJe vous remercie beaucoup de votre aide
Cordialement
Autant pour moi , j'avais mal positionné endif
Le code recherche bien les informations dans le bon classeur malgré que ce n'est pas précisé dans le code
J'essaie de faire la recherche entre datedebut et datefin mais je n'arrive pas :
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'") and OutlItems.Find("[End] >= '" & datefin & "'")ou
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'" and "[end] <= '" & datefin & "'")Je voudrais ensuite insérer l'évenement dans la cellule de la feuille correspondant à la date de l'évenement sous forme de commentaire
Je vais essayer
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
datedebut = Range("a4")
datefin = Range("l4")
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
'
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
'
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Categories = "Loisirs" Then
MsgBox OutlAppointment.Subject & " " & OutlAppointment.Start & " " & OutlAppointment.Categories
End If
Set OutlAppointment = OutlItems.FindNext
Wend
End SubJ'ai testé ce code mais on m'indique une erreur sur
With Cells(4, col1)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
datedebut = Range("a4")
datefin = Range("l4")
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
'
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
'
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Categories = "Loisirs" Then
Set plage2 = ThisWorkbook.Worksheets("Feuil1").Range("a4:w4")
For Each Cell In plage2
If Cell.Value = CDate(OutlAppointment.Start) Then
col1 = Cell.Column
col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
MsgBox col1
End If
Next Cell
With Cells(4, col1)
.AddComment
.Comment.Text OutlAppointment.Subject
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = True
End With
MsgBox OutlAppointment.Subject & " " & OutlAppointment.Start & " " & OutlAppointment.Categories
End If
Set OutlAppointment = OutlItems.FindNext
Wend
End SubJ'ai avancé un peu
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
datedebut = Range("a4")
datefin = Range("l4")
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
'
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
'
Set plage2 = ThisWorkbook.Worksheets("Feuil1").Range("a4:ey4")
For Each Cell In plage2
Cell.ClearComments
Next Cell
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Categories = "Loisirs" Or OutlAppointment.Categories = "Médical" Then
ddd1 = Format(OutlAppointment.Start, "dd/mm/yyyy")
ddd2 = Format(OutlAppointment.Start, "hh:mm")
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
With Cells(4, col1)
.AddComment
.Comment.Text ddd1 & " - " & ddd2 & " : " & OutlAppointment.Subject & " " & OutlAppointment.Location
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = True
End With
MsgBox OutlAppointment.Subject & " " & OutlAppointment.Start & " " & OutlAppointment.Categories
End If
Set OutlAppointment = OutlItems.FindNext
Wend
End SubJe n'arrive toujours pas à faire une recherche entre datedébut et datefin
J'essaie d'ajouter une condition au cas ou il y ait plusieurs événement le même jour
dans ce cas ajouter le second évenement au commentaire existant en sautant une ligne
j'ai essayé
With Cells(4, col1)
if .comment.text = "" then
.AddComment
.Comment.Text OutlAppointment.Subject & " " & OutlAppointment.Location & " " & ddd1
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = True
else
.comment.text = .comment.text & OutlAppointment.Subject & chr(10) & OutlAppointment.Location
End Withmais ca ne fonctionne pas
Pourriez vous m'aider svp
Je vous remercie
Cordialement
J'ai bien avancé
Je pense avoir finit, reste à régler des détails et reporter ce code dans le fichier officiel
Qu'en pensez vous
Je recherche les évenements commencant par * sur une plage donnée et je les insère dans une cellule et dans un commentaire.
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
datedebut = Range("a4")
datefin = Range("ey4")
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
'
'
Set plage1 = ThisWorkbook.Worksheets("Feuil1").Range("a3:ey3")
For Each Cell In plage1
Cell.ClearContents
Next Cell
Set plage2 = ThisWorkbook.Worksheets("Feuil1").Range("a4:ey4")
For Each Cell In plage2
Cell.ClearComments
Next Cell
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Start < "20/12/2019" And OutlAppointment.Start > "22/07/2019" Then
S = Left(OutlAppointment.Subject, 1)
If S = "*" Then
ddd1 = Format(OutlAppointment.Start, "dd/mm/yyyy")
ddd2 = Format(OutlAppointment.Start, "hh:mm")
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
With Cells(3, col1)
If Cells(3, col1) = "" Then
Cells(3, col1) = OutlAppointment.Subject
Else
Cells(3, col1) = Cells(3, col1) & Chr(10) & "-" & Chr(10) & OutlAppointment.Subject
End If
Cells(4, col1).ClearComments
With Cells(4, col1)
.AddComment
.Comment.Text Cells(3, col1).Value
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = True
End With
End With
End If
End If
Set OutlAppointment = OutlItems.FindNext
Wend
End SubCordialement