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
66
67
68
69
70
71
72
| Private Sub Agenda_Salle(ByVal AdrMail As String, ByRef Fichier As Excel.Workbook, ByRef Ligne As Integer)
'MsgBox(AdrMail)
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("206peugeot-ch846xv@macon-habitat.com")
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
'If AdrMail = "SalleRouge@macon-habitat.com" Then
objInboxItems.Sort("[Start]")
Appt = objInboxItems.Find(Criteria)
With Fichier.ActiveSheet
Do While Not (Appt Is Nothing)
' *********************************************************
MsgBox(Appt.Start.Date & " " & Appt.End.Date & " " & Appt.IsRecurring & " " & Appt.ConversationTopic & " " & Microsoft.VisualBasic.Right("00" & Appt.Start.Hour, 2) & ":" & Microsoft.VisualBasic.Right("00" & Appt.Start.Minute, 2))
' *********************************************************
If Appt.Start.Date <= Today And Appt.End.Date >= Today Then
'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
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
MsgBox(Appt.Sensitivity)
Ligne = Ligne + 1
End If
Appt.Close(Outlook.OlInspectorClose.olDiscard)
Appt = objInboxItems.FindNext
Loop
End With
'On ajoute 2 lignes vierges:
If OkDonnee Then Ligne = Ligne + 2
'End If
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 |
