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 |
macro Prise rdv outlook depuis outlook + export calendrier outlook vers excel
Répondre avec citation
Envoyé par Wavy84
Oliv'
Partager