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 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
|
Sub SallesReunionToExcel()
Const SCRIPT_NAME = "Exporter le Planning des salles dans excel"
' nom du groupe calendrier
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim objGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objSalle As Folder
Dim objFolder As Folder
' compteur de boucle
Dim i As Integer
Dim j As Integer
'Objet outlook
Dim olkFld As Object
Dim olkGr As Object
Dim olkGrp As Object
Dim olkSel As Object
Dim olkLst As Object
Dim olkApt As Object
Dim olkpattern As Object
Dim olkRecurType As Object
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim lngRow As Long
Dim intCnt As Integer
Dim Periodique As String
Dim strfilename As String
Set olkFld = Application.ActiveExplorer.CurrentFolder
If olkFld.DefaultItemType <> olAppointmentItem Then
MsgBox ("Erreur, la selection actuelle n'est pas de type calendrier")
Else
'Préparation du fichier excel
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.Worksheets(1)
'Créer les entêtes de colonnes Excel
With excWks
.cells(1, 1) = "Emplacement"
.cells(1, 2) = "Objet"
.cells(1, 3) = "Organisateur"
.cells(1, 4) = "Créé"
.cells(1, 5) = "Début"
.cells(1, 6) = "Fin"
.cells(1, 7) = "Categories"
.cells(1, 8) = "Périodique ?"
.cells(1, 9) = "Critere de Périodicité"
.cells(1, 10) = "Jours par semaine"
.cells(1, 11) = "Mois Par année"
.cells(1, 12) = "Instance"
.cells(1, 13) = "Periodicité"
.cells(1, 14) = "durée"
.cells(1, 15) = "Periodicité date de début"
.cells(1, 16) = "Périodicité date de fin"
.cells(1, 17) = "RecurrenceState"
End With
'Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set objPane = Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
'navigation des groupes de calendriers
lngRow = 2
For i = 1 To .Count
Set objGroup = .Item(i)
'on ne parcours pas le groupe Mes calendriers
If objGroup <> "Mes calendriers" Then
'parcours les salles de reunions du groupe en cours
For j = 1 To objGroup.NavigationFolders.Count
If objGroup.NavigationFolders.Item(j).IsSelected = True Then
Set olkLst = objGroup.NavigationFolders.Item(j).Folder.Items
olkLst.Sort "[Start]"
olkLst.IncludeRecurrences = True
For Each olkApt In olkLst
'Exporte seulement les réunions (rendez vous)
If olkApt.Class = olAppointment Then
'Ajoute les colonnes pour chaque champs
excWks.cells(lngRow, 1) = olkApt.Location
excWks.cells(lngRow, 2) = olkApt.Subject
excWks.cells(lngRow, 3) = olkApt.Organizer
excWks.cells(lngRow, 4) = olkApt.CreationTime
excWks.cells(lngRow, 5) = olkApt.Start
excWks.cells(lngRow, 6) = olkApt.End
excWks.cells(lngRow, 7) = olkApt.Categories
excWks.cells(lngRow, 17) = olkApt.RecurrenceState
Periodique = ""
If olkApt.IsRecurring = True Then
Periodique = "X"
Set olkpattern = olkApt.GetRecurrencePattern()
'Set olkRecurType = olkApt.GetRecurrencePattern.RecurrenceType
With olkpattern
excWks.cells(lngRow, 8) = Periodique
excWks.cells(lngRow, 9) = .RecurrenceType
excWks.cells(lngRow, 10) = .DayOfWeekMask
excWks.cells(lngRow, 11) = .MonthOfYear
excWks.cells(lngRow, 12) = .Instance
excWks.cells(lngRow, 13) = .Occurrences
excWks.cells(lngRow, 14) = .Duration
excWks.cells(lngRow, 15) = .PatternStartDate
excWks.cells(lngRow, 16) = .PatternEndDate
End With
Set olkpattern = Nothing
End If
lngRow = lngRow + 1
intCnt = intCnt + 1
End If
Next
'excWkb.Close
End If
Next
End If
Next
If intCnt = 0 Then
MsgBox ("Il y a aucune réunion à exporter")
excApp.Close
Else
strfilename = InputBox("Entrer le nom du fichier Excel (Chemin)pour exporter le planning des salles", SCRIPT_NAME, "c:\temp\" & Format(Now, "dd-mm-yyyy--hh-nn-ss-") & "fichier.xlsx")
If strfilename <> "" Then
excWks.Columns("A:Z").AutoFit
excWkb.SaveAs strfilename
MsgBox "Opération terminée -> un total de " & intCnt & " réunions a été exporté .", vbInformation + vbOKOnly, SCRIPT_NAME
excApp.Visible = True
End If
End If
End With
End If
Set objPane = Nothing
Set objModule = Nothing
Set objGroup = Nothing
Set objNavFolder = Nothing
Set objSalle = Nothing
Set objFolder = Nothing
Set olkFld = Nothing
Set olkGr = Nothing
Set olkGrp = Nothing
Set olkSel = Nothing
Set olkLst = Nothing
Set olkApt = Nothing
Set olkpattern = Nothing
Set olkRecurType = Nothing
Set excApp = Nothing
Set excWkb = Nothing
Set excWks = Nothing
End Sub |
Partager