Macro stat Sento/Receivedtime

**alexmirage** · 10/11/2017, 08h29

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Oliv-** · 10/11/2017, 11h12

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

**alexmirage** · 10/11/2017, 11h58

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

**Oliv-** · 10/11/2017, 13h15

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**alexmirage** · 10/11/2017, 14h09

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

**Oliv-** · 10/11/2017, 17h07

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Macro stat Sento/Receivedtime

VBA Outlook

Discussions similaires

Partager

Partager