Outlook temps tâches outlook

DJARNAUD

XLDnaute Occasionnel
Bonjour à tous,

Dans outlook j'ai une liste de tâche auxquels j'attribue un temps de travail (via la colonne travail total). Je souhaiterai savoir s'il y a un moyen rapide d'avoir la somme de tous ces temps de travail?

J'y arrive en faisant un copié collé dans excel et en déroulant une formule mais pas très pratique.

Merci d'avance

Cordialement
 
Solution
Rebonjour,

Voici le code mis à jour :
VB:
Sub AfficherTempsTotaux()
Dim l_l_i As Long
Dim l_l_nbItems As Long
Dim l_o_selection As Outlook.Selection
Dim l_l_totalWorkSum As Long
Dim l_l_actualWorkSum As Long
Dim l_l_totalWork As Long
Dim l_l_actualWork As Long
Dim l_s_text As String
Dim l_o_dicoTotalWorkValues As Object   'Scripting.Dictionary
Dim l_o_dicoActualWorkValues As Object  'Scripting.Dictionary

    Set l_o_selection = Application.ActiveExplorer.Selection
    If l_o_selection.Count >= 0 Then
        Set l_o_dicoTotalWorkValues = CreateObject("Scripting.Dictionary")
        Set l_o_dicoActualWorkValues = CreateObject("Scripting.Dictionary")
        For l_l_i = 1 To l_o_selection.Count
            l_l_totalWork = 0...

mromain

XLDnaute Barbatruc
Bonjour,

Je n'ai pas réussi à reproduire le problème.
Chez mois, lorsque je sélectionne une tâche qui a une durée de 2 semaines, cela m'affiche bien 4800 minutes : 60 minutes x 8 heures x 5 jours x 2 semaines.

Qu'est-ce qui ne marche pas chez toi ?

A+
 

mromain

XLDnaute Barbatruc
Rebonjour,

Voici le code mis à jour :
VB:
Sub AfficherTempsTotaux()
Dim l_l_i As Long
Dim l_l_nbItems As Long
Dim l_o_selection As Outlook.Selection
Dim l_l_totalWorkSum As Long
Dim l_l_actualWorkSum As Long
Dim l_l_totalWork As Long
Dim l_l_actualWork As Long
Dim l_s_text As String
Dim l_o_dicoTotalWorkValues As Object   'Scripting.Dictionary
Dim l_o_dicoActualWorkValues As Object  'Scripting.Dictionary

    Set l_o_selection = Application.ActiveExplorer.Selection
    If l_o_selection.Count >= 0 Then
        Set l_o_dicoTotalWorkValues = CreateObject("Scripting.Dictionary")
        Set l_o_dicoActualWorkValues = CreateObject("Scripting.Dictionary")
        For l_l_i = 1 To l_o_selection.Count
            l_l_totalWork = 0
            l_l_actualWork = 0
            On Error Resume Next
             l_l_totalWork = l_o_selection.Item(l_l_i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81110003")
             l_l_actualWork = l_o_selection.Item(l_l_i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81100003")
            On Error GoTo 0
            If (l_l_actualWork + l_l_totalWork) > 0 Then
                l_l_nbItems = l_l_nbItems + 1
                l_l_totalWorkSum = l_l_totalWorkSum + l_l_totalWork
                l_l_actualWorkSum = l_l_actualWorkSum + l_l_actualWork
                l_o_dicoTotalWorkValues.Add l_o_dicoTotalWorkValues.Count, l_l_totalWork
                l_o_dicoActualWorkValues.Add l_o_dicoActualWorkValues.Count, l_l_actualWork
            End If
        Next l_l_i
        If l_l_nbItems = 0 Then
            MsgBox "Aucun élément sélectionné n'a de temps de travail défini."
        Else
            l_s_text = l_l_nbItems & " élément(s) sélectionné(s) a/ont des temps de travail définis :"
            l_s_text = l_s_text & vbNewLine & "  - Temps total : " & l_l_totalWorkSum & "  - médiane = " & CalculateMedian(l_o_dicoTotalWorkValues.Items())
            l_s_text = l_s_text & vbNewLine & "  - Temps réel : " & l_l_actualWorkSum & "  - médiane = " & CalculateMedian(l_o_dicoActualWorkValues.Items())
            MsgBox l_s_text
        End If
    Else
        MsgBox "Aucun élément sélectionné."
    End If
    Set l_o_selection = Nothing
End Sub

'https://www.piger-lesmaths.fr/comment-calculer-la-mediane/
Private Function CalculateMedian(l_av_numValues) As Double
Dim l_l_i As Long
Dim l_l_j As Long
Dim l_l_nbValues As Long
Dim l_ad_sortedValues() As Double
Dim l_d_tmpVal As Double
   
    'copier les valeurs
    ReDim sortedValues(LBound(l_av_numValues) To UBound(l_av_numValues))
    For l_l_i = LBound(l_av_numValues) To UBound(l_av_numValues)
        l_ad_sortedValues(l_l_i) = CDbl(l_av_numValues(l_l_i))
    Next l_l_i
   
    'trier les valeurs
    For l_l_i = LBound(l_ad_sortedValues) To UBound(l_ad_sortedValues) - 1: For l_l_j = l_l_i + 1 To UBound(l_ad_sortedValues)
        If l_ad_sortedValues(l_l_j) < l_ad_sortedValues(l_l_i) Then
            l_d_tmpVal = l_ad_sortedValues(l_l_j)
            l_ad_sortedValues(l_l_j) = l_ad_sortedValues(l_l_i)
            l_ad_sortedValues(l_l_i) = l_d_tmpVal
        End If
    Next l_l_j, l_l_i
   
    'calculer la médiane
    l_l_nbValues = UBound(l_ad_sortedValues) - LBound(l_ad_sortedValues) + 1
    If (l_l_nbValues Mod 2) = 0 Then
        CalculateMedian = (l_ad_sortedValues(LBound(l_ad_sortedValues) + l_l_nbValues / 2 - 1) + l_ad_sortedValues(LBound(l_ad_sortedValues) + l_l_nbValues / 2)) / 2
    Else
        CalculateMedian = l_ad_sortedValues(LBound(l_ad_sortedValues) + (l_l_nbValues - 1) / 2)
    End If
End Function

La procedure AfficherTempsTotaux a été mise à jour. Je ne l'ai par contre pas testée.
La fonction CalculateMedian a été ajoutée (et testée, elle). C'est un essai d'implémentation de la méthode décrite dans cette page.

A+
 

mromain

XLDnaute Barbatruc
Bonjour DJARNAUD, le forum,

J'ai bien réussi à reproduire le bug. C'était une petite coquille...
Ci-dessous le code corrigé :
Code:
Sub AfficherTempsTotaux()
Dim l_l_i As Long
Dim l_l_nbItems As Long
Dim l_o_selection As Outlook.Selection
Dim l_l_totalWorkSum As Long
Dim l_l_actualWorkSum As Long
Dim l_l_totalWork As Long
Dim l_l_actualWork As Long
Dim l_s_text As String
Dim l_o_dicoTotalWorkValues As Object   'Scripting.Dictionary
Dim l_o_dicoActualWorkValues As Object  'Scripting.Dictionary

    Set l_o_selection = Application.ActiveExplorer.Selection
    If l_o_selection.Count >= 0 Then
        Set l_o_dicoTotalWorkValues = CreateObject("Scripting.Dictionary")
        Set l_o_dicoActualWorkValues = CreateObject("Scripting.Dictionary")
        For l_l_i = 1 To l_o_selection.Count
            l_l_totalWork = 0
            l_l_actualWork = 0
            On Error Resume Next
             l_l_totalWork = l_o_selection.Item(l_l_i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81110003")
             l_l_actualWork = l_o_selection.Item(l_l_i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81100003")
            On Error GoTo 0
            If (l_l_actualWork + l_l_totalWork) > 0 Then
                l_l_nbItems = l_l_nbItems + 1
                l_l_totalWorkSum = l_l_totalWorkSum + l_l_totalWork
                l_l_actualWorkSum = l_l_actualWorkSum + l_l_actualWork
                l_o_dicoTotalWorkValues.Add l_o_dicoTotalWorkValues.Count, l_l_totalWork
                l_o_dicoActualWorkValues.Add l_o_dicoActualWorkValues.Count, l_l_actualWork
            End If
        Next l_l_i
        If l_l_nbItems = 0 Then
            MsgBox "Aucun élément sélectionné n'a de temps de travail défini.", vbInformation, "Détail des tâches"
        Else
            l_s_text = l_l_nbItems & " élément(s) sélectionné(s) a/ont des temps de travail définis :"
            l_s_text = l_s_text & vbNewLine & "  - Temps total : " & l_l_totalWorkSum & "  - médiane = " & CalculateMedian(l_o_dicoTotalWorkValues.Items())
            l_s_text = l_s_text & vbNewLine & "  - Temps réel : " & l_l_actualWorkSum & "  - médiane = " & CalculateMedian(l_o_dicoActualWorkValues.Items())
            MsgBox l_s_text, vbInformation, "Détail des tâches"
        End If
    Else
        MsgBox "Aucun élément sélectionné.", vbExclamation, "Détail des tâches"
    End If
    Set l_o_selection = Nothing
End Sub

'https://www.piger-lesmaths.fr/comment-calculer-la-mediane/
Private Function CalculateMedian(l_av_numValues) As Double
Dim l_l_i As Long
Dim l_l_j As Long
Dim l_l_nbValues As Long
Dim l_ad_sortedValues() As Double
Dim l_d_tmpVal As Double
    
    'copier les valeurs
    ReDim l_ad_sortedValues(LBound(l_av_numValues) To UBound(l_av_numValues))
    For l_l_i = LBound(l_av_numValues) To UBound(l_av_numValues)
        l_ad_sortedValues(l_l_i) = CDbl(l_av_numValues(l_l_i))
    Next l_l_i
    
    'trier les valeurs
    For l_l_i = LBound(l_ad_sortedValues) To UBound(l_ad_sortedValues) - 1: For l_l_j = l_l_i + 1 To UBound(l_ad_sortedValues)
        If l_ad_sortedValues(l_l_j) < l_ad_sortedValues(l_l_i) Then
            l_d_tmpVal = l_ad_sortedValues(l_l_j)
            l_ad_sortedValues(l_l_j) = l_ad_sortedValues(l_l_i)
            l_ad_sortedValues(l_l_i) = l_d_tmpVal
        End If
    Next l_l_j, l_l_i
    
    'calculer la médiane
    l_l_nbValues = UBound(l_ad_sortedValues) - LBound(l_ad_sortedValues) + 1
    If (l_l_nbValues Mod 2) = 0 Then
        CalculateMedian = (l_ad_sortedValues(LBound(l_ad_sortedValues) + l_l_nbValues / 2 - 1) + l_ad_sortedValues(LBound(l_ad_sortedValues) + l_l_nbValues / 2)) / 2
    Else
        CalculateMedian = l_ad_sortedValues(LBound(l_ad_sortedValues) + (l_l_nbValues - 1) / 2)
    End If
End Function

A+
 

DJARNAUD

XLDnaute Occasionnel
Bonjour DJARNAUD, le forum,

J'ai bien réussi à reproduire le bug. C'était une petite coquille...
Ci-dessous le code corrigé :
Code:
Sub AfficherTempsTotaux()
Dim l_l_i As Long
Dim l_l_nbItems As Long
Dim l_o_selection As Outlook.Selection
Dim l_l_totalWorkSum As Long
Dim l_l_actualWorkSum As Long
Dim l_l_totalWork As Long
Dim l_l_actualWork As Long
Dim l_s_text As String
Dim l_o_dicoTotalWorkValues As Object   'Scripting.Dictionary
Dim l_o_dicoActualWorkValues As Object  'Scripting.Dictionary

    Set l_o_selection = Application.ActiveExplorer.Selection
    If l_o_selection.Count >= 0 Then
        Set l_o_dicoTotalWorkValues = CreateObject("Scripting.Dictionary")
        Set l_o_dicoActualWorkValues = CreateObject("Scripting.Dictionary")
        For l_l_i = 1 To l_o_selection.Count
            l_l_totalWork = 0
            l_l_actualWork = 0
            On Error Resume Next
             l_l_totalWork = l_o_selection.Item(l_l_i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81110003")
             l_l_actualWork = l_o_selection.Item(l_l_i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81100003")
            On Error GoTo 0
            If (l_l_actualWork + l_l_totalWork) > 0 Then
                l_l_nbItems = l_l_nbItems + 1
                l_l_totalWorkSum = l_l_totalWorkSum + l_l_totalWork
                l_l_actualWorkSum = l_l_actualWorkSum + l_l_actualWork
                l_o_dicoTotalWorkValues.Add l_o_dicoTotalWorkValues.Count, l_l_totalWork
                l_o_dicoActualWorkValues.Add l_o_dicoActualWorkValues.Count, l_l_actualWork
            End If
        Next l_l_i
        If l_l_nbItems = 0 Then
            MsgBox "Aucun élément sélectionné n'a de temps de travail défini.", vbInformation, "Détail des tâches"
        Else
            l_s_text = l_l_nbItems & " élément(s) sélectionné(s) a/ont des temps de travail définis :"
            l_s_text = l_s_text & vbNewLine & "  - Temps total : " & l_l_totalWorkSum & "  - médiane = " & CalculateMedian(l_o_dicoTotalWorkValues.Items())
            l_s_text = l_s_text & vbNewLine & "  - Temps réel : " & l_l_actualWorkSum & "  - médiane = " & CalculateMedian(l_o_dicoActualWorkValues.Items())
            MsgBox l_s_text, vbInformation, "Détail des tâches"
        End If
    Else
        MsgBox "Aucun élément sélectionné.", vbExclamation, "Détail des tâches"
    End If
    Set l_o_selection = Nothing
End Sub

'https://www.piger-lesmaths.fr/comment-calculer-la-mediane/
Private Function CalculateMedian(l_av_numValues) As Double
Dim l_l_i As Long
Dim l_l_j As Long
Dim l_l_nbValues As Long
Dim l_ad_sortedValues() As Double
Dim l_d_tmpVal As Double
   
    'copier les valeurs
    ReDim l_ad_sortedValues(LBound(l_av_numValues) To UBound(l_av_numValues))
    For l_l_i = LBound(l_av_numValues) To UBound(l_av_numValues)
        l_ad_sortedValues(l_l_i) = CDbl(l_av_numValues(l_l_i))
    Next l_l_i
   
    'trier les valeurs
    For l_l_i = LBound(l_ad_sortedValues) To UBound(l_ad_sortedValues) - 1: For l_l_j = l_l_i + 1 To UBound(l_ad_sortedValues)
        If l_ad_sortedValues(l_l_j) < l_ad_sortedValues(l_l_i) Then
            l_d_tmpVal = l_ad_sortedValues(l_l_j)
            l_ad_sortedValues(l_l_j) = l_ad_sortedValues(l_l_i)
            l_ad_sortedValues(l_l_i) = l_d_tmpVal
        End If
    Next l_l_j, l_l_i
   
    'calculer la médiane
    l_l_nbValues = UBound(l_ad_sortedValues) - LBound(l_ad_sortedValues) + 1
    If (l_l_nbValues Mod 2) = 0 Then
        CalculateMedian = (l_ad_sortedValues(LBound(l_ad_sortedValues) + l_l_nbValues / 2 - 1) + l_ad_sortedValues(LBound(l_ad_sortedValues) + l_l_nbValues / 2)) / 2
    Else
        CalculateMedian = l_ad_sortedValues(LBound(l_ad_sortedValues) + (l_l_nbValues - 1) / 2)
    End If
End Function

A+
ça marche parfaitement!!! merci beaucoup!!!!
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 015
Membres
101 870
dernier inscrit
Dethomas