1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
Private Sub Agenda_Salle(ByVal AdrMail As String, ByRef Fichier As Excel.Workbook, ByRef Ligne As Integer)
Dim objOutlook As New Outlook.Application
Dim objNS As Outlook.NameSpace
Dim Appt As Outlook.AppointmentItem 'Object
Dim objInboxItems As Outlook.Items
Dim objRecip As Outlook.Recipient
Dim Criteria As String
Dim OkDonnee As Boolean = False
objNS = objOutlook.GetNamespace("MAPI")
objRecip = objNS.CreateRecipient(AdrMail)
objInboxItems = objNS.GetSharedDefaultFolder(objRecip, Outlook.OlDefaultFolders.olFolderCalendar).Items 'Get all items in Calendar folder
Criteria = "[End] >= '" & Today & " 00:00' and [Start] <= '" & Today & " 23:59'" 'Format jj/dd/aa
objInboxItems.Sort("[Start]")
Appt = objInboxItems.Find(Criteria)
With Fichier.ActiveSheet
Do While Not (Appt Is Nothing)
'MsgBox(Appt.Organizer & " " & Appt.Start & " " & Appt.Body & " " & objRecip.Name)
'Insertion dans le fichier Excel
If OkDonnee = False Then 'Titre: nom de la salle
Fichier.ActiveSheet.cells(Ligne, 1) = objRecip.Name
'Fusion
.Range(.Cells(Ligne, 1), .Cells(Ligne, 3)).Merge()
'Fond jaune
.Range(.Cells(Ligne, 1), .Cells(Ligne, 3)).Interior.ColorIndex = 36
'En gras
.Range(.Cells(Ligne, 1), .Cells(Ligne, 3)).Font.Bold = True
'Centré
.Range(.Cells(Ligne, 1), .Cells(Ligne, 3)).HorizontalAlignment = Microsoft.Office.Interop.Excel.Constants.xlCenter
Ligne = Ligne + 1
End If
OkDonnee = True 'pour ne plus mettre le titre
IlYaDesDonnees = True
'ecriture de la réunion
MsgBox(Appt.Start.Date & " " & Appt.End.Date & " " & Appt.IsRecurring & " " & " " & Microsoft.VisualBasic.Right("00" & Appt.Start.Hour, 2) & ":" & Microsoft.VisualBasic.Right("00" & Appt.Start.Minute, 2))
If Appt.AllDayEvent = False Then 'Si on n'est pas sur une evenement toute la journée
.cells(Ligne, 1) = Microsoft.VisualBasic.Right("00" & Appt.Start.Hour, 2) & ":" & Microsoft.VisualBasic.Right("00" & Appt.Start.Minute, 2)
.cells(Ligne, 2) = Microsoft.VisualBasic.Right("00" & Appt.End.Hour, 2) & ":" & Microsoft.VisualBasic.Right("00" & Appt.End.Minute, 2)
Else
.cells(Ligne, 1) = "Journée."
.Range(.Cells(Ligne, 1), .Cells(Ligne, 2)).Merge()
End If
.cells(Ligne, 3) = Appt.Organizer & " - :" & Appt.ConversationTopic ' & " s:" & Appt.Subject
Ligne = Ligne + 1
Appt.Close(Outlook.OlInspectorClose.olDiscard)
Appt = objInboxItems.FindNext
Loop
End With
'On ajoute 2 lignes vierges:
If OkDonnee Then Ligne = Ligne + 2
objNS.Logoff()
objOutlook.Quit() 'Pour pas avoir message d'erreur: nb d'éléments maxi ouverts dans Outlook.
Appt = Nothing
objInboxItems = Nothing
objNS = Nothing
objOutlook = Nothing
End Sub |
