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 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
| Sub TrouveCalendrierPartagé()
'---------------------------------------------------------------------------------------
' Procedure : ListeCalendrierPartagé
' Author : Oliv-
' Date : 19/02/2014
' Purpose : Liste les des "calendrier partagé" et le Dossier correpondant
'---------------------------------------------------------------------------------------
'
Dim objNS As Outlook.Namespace
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim objNavCalPart As Outlook.NavigationFolders
Dim i, objitem As Object
Nom = "planning technique"
Set OL = CreateObject("outlook.application")
Set objNS = OL.Session
Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objcalgr = objNavMod.NavigationGroups.Item("Tous les calendriers de groupe")
Set objNavCalPart = objNavMod.NavigationGroups.Item("Tous les calendriers de groupe").NavigationFolders
For i = 1 To objNavCalPart.Count
Debug.Print objNavCalPart(i).DisplayName
If InStr(1, objNavCalPart(i).DisplayName, Nom, vbTextCompare) > 0 Then
Set objitem = objNavCalPart(i)
On Error Resume Next
FoldName = objitem.Folder.Name & "-" & objitem.Folder.FullFolderPath
If Err Then FoldName = "Pas accessible"
Debug.Print objitem & "-->" & FoldName
Call ExportFolderAppointmentsToExcel(objitem.Folder)
Exit For
End If
Next i
End Sub
Sub ExportFolderAppointmentsToExcel(oFolder As Object)
'---------------------------------------------------------------------------------------
' Procedure : ExportFolderAppointmentsToExcel
' Author : OCTU
' Date : 10/09/2020
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim criteria
Dim oTable As Object
Dim i, oRow, R, arr
Const olFolderInbox = 6
Const olUserItems = 0
'Pour ne prendre que les EMAILS
'criteria = "[MessageClass]='IPM.Note' or [MessageClass]='IPM.Post'"
'Pour tous les éléments
criteria = "[MessageClass]<>'zzz'"
Set oTable = oFolder.GetTable(criteria, olUserItems)
MsgBox oTable.GetRowCount
On Error Resume Next
' With oTable.Columns
' .RemoveAll
' .Add ("Subject")
' .Add ("CreationTime")
' .Add ("LastModificationTime")
' .Add ("MessageClass")
' .Add ("ReceivedTime")
' .Add ("Senton")
' .Add ("Size")
' .Add ("To")
' .Add ("Cc")
' .Add ("Bcc")
' .Add ("Categories")
' .Add ("ConversationTopic")
' .Add ("ReceivedByName")
' .Add ("SenderName")
' .Add ("SenderEmailAddress")
' .Add ("Unread")
' .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B") 'PR_HASATTACH
' .Add ("ConversationIndex")
' .Add ("http://schemas.microsoft.com/mapi/proptag/0x66700102")
' .Add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F") '="Body"
' ''.Add ("Sent") 'KO
' ''.Add ("Duration") 'KO
' ''.Add ("Type") 'KO
'
' End With
'MsgBox oTable.GetRowCount
Dim AppExcel As Object
Dim Wk As Object, Ws As Object
If InStr(1, Application, "Excel", vbTextCompare) > 0 Then
Set AppExcel = Application
Else
Set AppExcel = CreateObject("Excel.application")
AppExcel.Visible = True
End If
Set Wk = AppExcel.Workbooks.Add
Set Ws = Wk.ActiveSheet
R = 2
'Enumerate the table using test for EndOfTable
For i = 1 To oTable.Columns.Count
Ws.Cells(1, i).Value = oTable.Columns.Item(i).Name
If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B" Then Ws.Cells(1, i).Value = "PR_HASATTACH"
If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x66700102" Then Ws.Cells(1, i).Value = "EntryIdLong"
If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x1000001F" Then Ws.Cells(1, i).Value = "Body"
Next i
Ws.Cells.NumberFormat = "@"
Ws.Range("C:H").NumberFormat = "General"
'GoTo parcourir
' one row spanning several columns
oTable.Sort "LastModificationTime", True
arr = oTable.GetArray(oTable.GetRowCount)
Dim Destination As Range
Set Destination = Ws.Range("a2")
Set Destination = Destination.Resize(UBound(arr, 1) + 1 - LBound(arr, 1), UBound(arr, 2) + 1 - LBound(arr, 2))
On Error Resume Next
Destination.Value = arr
If Err = 1004 Then GoTo parcourir
'quand cela ne marche pas cela vient du format de la colonne destination
On Error GoTo 0
GoTo mef
'AUTRE METHODE on ecrit en parcourant les enregistrement et les colonnes
parcourir:
'pour parcourir la table champs par champs
oTable.MoveToStart
Do Until (oTable.EndOfTable)
On Error Resume Next
Set oRow = oTable.GetNextRow()
For i = 1 To oTable.Columns.Count
Debug.Print oRow("Body")
AppExcel.Cells(R, i).Value = oRow(oTable.Columns(i).Name)
Next i
R = R + 1
Loop
GoTo mef
mef:
'mise en forme
With Ws.Cells
.AutoFilter
.EntireColumn.AutoFit
End With
With Ws.Rows("1:1").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
.Parent.Font.Bold = True
End With
Ws.Cells.WrapText = True
Ws.Cells.WrapText = False
Exit Sub
End Sub |
Partager