1. #1
    Nouveau membre du Club
    Profil pro
    Inscrit en
    février 2008
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : Belgique

    Informations forums :
    Inscription : février 2008
    Messages : 19
    Points : 27
    Points
    27

    Par défaut Macro stat Sento/Receivedtime

    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

  2. #2
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 080
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 46
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 080
    Points : 5 362
    Points
    5 362
    Billets dans le blog
    14

    Par défaut

    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

  3. #3
    Nouveau membre du Club
    Profil pro
    Inscrit en
    février 2008
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : Belgique

    Informations forums :
    Inscription : février 2008
    Messages : 19
    Points : 27
    Points
    27

    Par défaut

    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

  4. #4
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 080
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 46
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 080
    Points : 5 362
    Points
    5 362
    Billets dans le blog
    14

    Par défaut

    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

  5. #5
    Nouveau membre du Club
    Profil pro
    Inscrit en
    février 2008
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : Belgique

    Informations forums :
    Inscription : février 2008
    Messages : 19
    Points : 27
    Points
    27

    Par défaut

    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

  6. #6
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 080
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 46
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 080
    Points : 5 362
    Points
    5 362
    Billets dans le blog
    14

    Par défaut

    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 & "'"

Discussions similaires

  1. [XL-2013] macro industrialisation stat mensuelle
    Par tomnacer dans le forum Macros et VBA Excel
    Réponses: 0
    Dernier message: 23/05/2017, 19h30
  2. Macro / système de pilotage Stat !
    Par FreddyNB dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 27/12/2007, 06h27
  3. [VBA-E] [Excel] Lancer une macro à une heure donnée
    Par Lysis dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 16/10/2002, 13h15
  4. Qu'est-ce qu'une macro ?
    Par karli dans le forum Assembleur
    Réponses: 2
    Dernier message: 01/09/2002, 04h38
  5. Réponses: 2
    Dernier message: 22/07/2002, 13h13

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo