Macro stat Sento/Receivedtime

Version imprimable

Bonjour,

Dans le but de pouvoir avoir certaines statistiques quand au queuing de notre server exchange mais celui ci etant délocalisé et sous traité, j'aimerais pouvoir produire des stats par rapport à la date d'envoi(heure) et la date de reception (heure). Toutes les demi heures par exemples sur base des 10 derniers mails de ma boite mail,j'aimerais faire une soustraction de ces 2 données(mailItem.senton et MailItem.ReceivedTime) et générer un graphique. Pour connaitre la latence entre l'envoi et la réception du message.
N'étant pas un gran doué en scripting vba voici ce que j'ai pu réaliser jusqu'ici
Code:

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 Sub Outlookexport() Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim rCount As Long Dim bXStarted As Boolean Dim enviro As String Dim strPath As String Dim currentExplorer As Explorer Dim Selection As Selection Dim olItem As Outlook.MailItem Dim obj As Object Dim strColA, strColB As String On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Application.StatusBar = "Please wait while Excel source is opened ... " Set xlApp = CreateObject("Excel.Application") bXStarted = True End If On Error GoTo 0 Set xlWB = xlApp.Workbooks.Add Set xlSheet = xlWB.Sheets("Sheet1") xlSheet.Range("A1") = "Recieved Time" xlSheet.Range("B1") = "Sent On" xlSheet.Range("C1") = "Time on Queue" On Error Resume Next rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row rCount = rCount + 1 Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection For Each obj In Selection Set olItem = obj strColA = olItem.ReceivedTime strColB = olItem.SentOn xlSheet.Range("A" & rCount) = strColA xlSheet.Range("B" & rCount) = strColB rCount = rCount + 1 xlSheet.Columns("A:F").EntireColumn.AutoFit xlSheet.Range("A2").Select xlSheet.Columns("A:B").NumberFormat = "HH:MM:SS;@" Next xlApp.Visible = True Set olItem = Nothing Set obj = Nothing Set currentExplorer = Nothing Set xlSheet = Nothing Set xlWB = Nothing Set xlApp = Nothing End Sub
Ma question est est ce que quelqu'un peut gentillement me guider sur comment séléctionner automiquement les x premiers mails de ma boite(actuellement sélection manuelle), comment faire la boucle de soustraction entre mes 2 colonnes (senton et receivedtime) tout en mettant la différence dans la colonne C.

Merci d'avance pour votre aide .

bonne journée

Alex

10/11/2017, 11h12
Oliv-

Bonjour,
Je ne suis pas sûr que cela réponde à ton besoin. le délais entre les 2 n'est pas forcément du à ton serveur EXCHANGE ! il peux venir du serveur d'envoi , des relais ou d'un décallage d'horloge entre le serveur d'envoi et celui de réception
10/11/2017, 11h58
alexmirage

Merci de ta réponse Oliv-

Mais j'ai été un peu trop vite , il s'agit en fait de détecter une latence anormale sur l'envoi reception d'un mail et ainsi y réagir le plus rapidement possible. Car cela peut venir des exchange servers, des ADs servers, des relays,smtp, des firewals, d'un décalage horaire.

Dans l'absolu je ne suis pas convaincu que la solution sera efficace , c'est plus pour avoir une vue statistique dessus.

Alex

Ok, tu auras sans doute trop d'infos mais c'est rapide.

Tu peux mettre tout le code directement dans EXCEL

si tu veux limiter le nombre de lignes renvoyées il faut utiliser la méthode PARCOURIR et la modifier pour les X premiers

Code:

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
Option Explicit
 
Sub ExportFolderItemsToExcel()
'---------------------------------------------------------------------------------------
' Procedure : ExportFolderItemsToExcel
' Author    : Oliv
' Date      : 10/11/2017
' Purpose   : export des informations d'Emails de la boite de reception vers excel
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Object
    Dim criteria
    Dim oTable As Object
    Dim i, oRow, R, arr
 
    Const olFolderInbox = 6
    Const olUserItems = 0
 
    Dim OL As Object
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    'Si on connait le nom
    Set oFolder = OL.Session.GetDefaultFolder(olFolderInbox)
 
    'si on veut choisir
 
    'Set oFolder = OL.Session.PickFolder
    criteria = "[MessageClass]='IPM.Note' or [MessageClass]='IPM.Post'"
    'criteria = "[MessageClass]='IPM.Activity'"
 
    Set oTable = oFolder.GetTable(criteria, olUserItems)
    On Error Resume Next
    With oTable.Columns
        ''.Add ("Duration") 'KO
        ''.Add ("Type") 'KO
        .Add ("ReceivedTime")
        .Add ("Senton")
        .Add ("Size")
        .Add ("To")
        .Add ("Cc")
        .Add ("Bcc")
        .Add ("Categories")
        .Add ("ConversationTopic")
        .Add ("ReceivedByName")
        .Add ("SenderName")
        ''.Add ("Sent") 'KO
        .Add ("SenderEmailAddress")
        .Add ("Unread")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B")    'PR_HASATTACH
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x0E13000D") 'PR_MESSAGE_ATTACHMENTS
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x37010102") 'PR_ATTACH_DATA_BIN
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x0EA5001E") 'PR_SEARCH_ATTACHMENTS
        '.add ("http://schemas.microsoft.com/mapi/proptag/0x0E12000D") 'PR_MESSAGE_RECIPIENTS
        '"http://schemas.microsoft.com/mapi/proptag/0x0E13000D"
        '.add ("BodyFormat") KO
        '.add ("HTMLBody")KO
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F")    '="Body"
        '' .add (" http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8596001E") 'attach name
 
 
    End With
    MsgBox oTable.GetRowCount
 
    Dim AppExcel As Object
    Dim Wk As Object, Ws As Object
    Set AppExcel = CreateObject("Excel.application")
    AppExcel.Visible = True
    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/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

10/11/2017, 14h09
alexmirage

Merci pour ta contribution ,

J'ai un peu regardé a ce que tu as fait en effet cela représente énormément de data surtout que j ai plus de 13000 mails dans mon inbox ...

Mais je vais continuer a chercher pour essayer de ne selectionner que les 20 premiers et ne rappeler que les datas concernant le senton et receivedtime

Bien à toi,

Alex
10/11/2017, 17h07
Oliv-

Change la ligne criteria....
par celle ci ca devrait ne renvoyer que les Email du jour

Code:

criteria = "[MessageClass]='IPM.Note' and [LastModificationTime] > '" & Date & "'"