Dashboard Outlook

Bonjour

J'ai besoin de votre aide afin de créer un dashboard dans EXCEL pour outlook sous le format suivant

J'avais trouvé un code (ci-dessous) mais qu'il m'affiche les résultats dans un msgbox alors que j'en ai besoin dans excel lui même

Sub CountDatedEmails()

'Declare Outlook app and folder object variables.
Dim objOutlook As Object, objnSpace As Object
Dim objFolder As Object, objFolderA As Object, objFolderB As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

'Verify existence of MIS folder as direct subfolder of Personal Folders.
On Error Resume Next
Set objFolder = objnSpace.Folders("Account1").Folders("Sent Items")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder named MIS.", 48, "Cannot continue"
Exit Sub
End If

'Verify existence of Enquiries folder as direct subfolder #1 of Personal Folders.
On Error Resume Next
Set objFolderA = objnSpace.Folders("Account1").Folders("Inbox").Folders("Folder1")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder named Enquiries exists in the Inbox folder.", 48, "Cannot continue"
Exit Sub
End If

'Verify existence of Enquiries folder as direct subfolder #2 of Personal Folders.
On Error Resume Next
Set objFolderB = objnSpace.Folders("Account1").Folders("Inbox").Folders("Folder2")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder named Application exists in the Inbox folder.", 48, "Cannot continue"
Exit Sub
End If

'All folders are present, OK to continue.

'Declare and define the myDate variable to be yesterday's date.
Dim myDate As Date
myDate = DateSerial(Year(Date), Month(Date), Day(Date) - 1)

'Declare and define the count and date variables for all 3 folders.
Dim iCount As Integer
Dim EmailCountInbox As Integer, EmailCountEnquiries As Integer, EmailCountApplication As Integer
Dim DateCountInbox As Integer, DateCountEnquiries As Integer, DateCountApplication As Integer

'Count total and yesterday's received emails in the Inbox folder:
EmailCountInbox = objFolder.Items.Count: DateCountInbox = 0
For iCount = 1 To EmailCountInbox
With objFolder.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCountInbox = DateCountInbox + 1
End With
Next iCount

'Count total and yesterday's received emails in the Inbox > Enquiries folder:
EmailCountEnquiries = objFolderA.Items.Count: DateCountEnquiries = 0
For iCount = 1 To EmailCountEnquiries
With objFolderA.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCountEnquiries = DateCountEnquiries + 1
End With
Next iCount

'Count total and yesterday's received emails in the Inbox > Application folder:
EmailCountApplication = objFolderB.Items.Count: DateCountApplication = 0
For iCount = 1 To EmailCountApplication
With objFolderB.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCountApplication = DateCountApplication + 1
End With
Next iCount

'Advise the user of all counts for the three folders.
MsgBox _
"Inbox folder email count - -" & vbCrLf & _
"Total: " & vbTab & vbTab & EmailCountInbox & vbCrLf & _
"Yesterday: " & vbTab & DateCountInbox & vbCrLf & vbCrLf & _
"Inbox > Enquiries folder email count - -" & vbCrLf & _
"Total: " & vbTab & vbTab & EmailCountEnquiries & vbCrLf & _
"Yesterday: " & vbTab & DateCountEnquiries & vbCrLf & vbCrLf & _
"Inbox > Application folder email count - -" & vbCrLf & _
"Total: " & vbTab & vbTab & EmailCountApplication & vbCrLf & _
"Yesterday: " & vbTab & DateCountApplication, , "Email counts:"

'Release object variable memory
Set objFolder = Nothing
Set objFolderA = Nothing
Set objFolderB = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing

End Sub

autre problème que j'ai c'est que j'ai besoin que ces données soit actualisé chaque 2 minutes (genre refresh)

Merci infiniment pour votre aide

cdt

Soufiane

Bonjour,

avant d'automatiser le refresh, regarde si ceci fonctionne et peut te convenir

Sub CountDatedEmails()

'Declare Outlook app and folder object variables.
    Dim objOutlook As Object, objnSpace As Object
    Dim objFolder As Object, objFolderA As Object, objFolderB As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")
    For Each acc In objnSpace.Folders
        nacc = nacc + 1
        'Verify existence of MIS folder as direct subfolder of Personal Folders.
        On Error Resume Next
        Set objFolder = acc.Folders("Sent Items")
        If Err.Number <> 0 Then
            Err.Clear
            MsgBox "No such folder named MIS.", 48, "Cannot continue"
            Exit Sub
        End If

        'Verify existence of Enquiries folder as direct subfolder #1 of Personal Folders.
        On Error Resume Next
        Set objFolderA = acc.Folders("Inbox")
        If Err.Number <> 0 Then
            Err.Clear
            MsgBox "No such folder named Enquiries exists in the Inbox folder.", 48, "Cannot continue"
            Exit Sub
        End If

        'All folders are present, OK to continue.

        'Declare and define the myDate variable to be yesterday's date.
        Dim myDate As Date
        myDate = DateSerial(Year(Date), Month(Date), Day(Date) - 1)

        'Declare and define the count and date variables for all 3 folders.
        Dim iCount As Integer
        Dim EmailCountInbox As Integer, EmailCountEnquiries As Integer, EmailCountApplication As Integer
        Dim DateCountInbox As Integer, DateCountEnquiries As Integer, DateCountApplication As Integer

        'Count total nimber of mails received today
        EmailCountInbox = objFolderA.Items.Count: DateCountInbox = 0
        For iCount = 1 To EmailCountInbox
            With objFolder.Items(iCount)
                If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCountInbox = DateCountInbox + 1
            End With
        Next iCount

        'Count total number of mails sent today
        EmailCountEnquiries = objFolder.Items.Count: DateCountEnquiries = 0
        For iCount = 1 To EmailCountEnquiries
            With objFolderA.Items(iCount)
                If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCountEnquiries = DateCountEnquiries + 1
            End With
        Next iCount
        Cells(nacc, 1) = acc.Name
        Cells(nacc, 3) = DateCountEnquiries
        Cells(nacc, 2) = DateCountInbox
    Next acc
    'Release object variable memory
    Set objFolder = Nothing
    Set objFolderA = Nothing
    Set objFolderB = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing

End Sub

Merci inifniment pour l'aide

mais malheureusement sa ne fonctionne pas, il m'affiche l'erreur " MsgBox "No such folder named MIS."

il me donne le nom du compte dans A1 et le un nombre 2784dans B1 et 0 dans C1

alors que le chiffre 2784 n'existe sur aucun de mes repetoire

autre chose, il m'affiche un seul compte alors que j'ai 4

merci d'avance

bonjour,

je t'ai fait une nouvelle version, je suppose que tu as une version FR de outlook et que les noms de ses répertoires sont en français.

si c'est le cas dans le code ci-dessous tu devras changer les noms anglais par leur équivalent en français. (je pense que cela doit s'appeler "messages reçus" et "messages envoyés" mais je n'en suis pas sûr.

Sub CountDatedEmails()

'Declare Outlook app and folder object variables.
    Dim objOutlook As Object, objnSpace As Object
    Dim objFolder As Object, objFolderA As Object, objFolderB As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    nomfolders = Array("Inbox", "Sent Items") '<- changer nom des dossiers outlook ici

    Dim myDate As Date
    myDate = DateSerial(Year(Date), Month(Date), Day(Date))
    For Each acc In objnSpace.Folders
        ctrf = 1
        nacc = nacc + 1
        If nacc = 1 Then
            Cells(1, 1) = "compte"
            Cells(1, 2) = "Messages reçus"
            Cells(1, 3) = "Messages envoyés"
            nacc = nacc + 1
        End If
        For Each nomfolder In nomfolders
            ctrf = ctrf + 1
            On Error Resume Next
            Cells(nacc, 1) = acc.Name
            Set objFolder = acc.Folders(nomfolder)
            If Err.Number <> 0 Then
                Cells(nacc, ctrf) = "Non trouvé"
            Else
                EmailCount = objFolder.Items.Count: DateCount = 0
                For iCount = 1 To EmailCount
                    With objFolder.Items(iCount)
                        If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCount = DateCount + 1
                    End With
                Next iCount
                Cells(nacc, ctrf) = DateCount
            End If

        Next
    Next
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing

End Sub

Non j'ai un Office anglais

Bonjour,

as-tu essayé cette nouvelle version ?

il me donne un compte et il tourne en infini, il veut pas s'arreter :/

Bonjour,

combien as-tu de messages dans ta boite mail ? il lui faut le temps de tous les passeer en revue pour sélectionner ceux qui correspondent à la date du jour.

une version qui te permet de voir par folder, le nombre de messages et de sous-folders, si tu pouvais me l'envoyer pour que je me fasse une idée de la structure de ta boite mail.

Sub CountDatedEmails()

'Declare Outlook app and folder object variables.
    Dim objOutlook As Object, objnSpace As Object
    Dim objFolder As Object, objFolderA As Object, objFolderB As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    nomfolders = Array("Inbox", "Sent Items")

    Dim myDate As Date
    myDate = DateSerial(Year(Date), Month(Date), Day(Date) - 1)
    For Each acc In objnSpace.Folders
        ctrf = 1
        nacc = nacc + 1
        If nacc = 1 Then
            Cells(1, 1) = "compte"
            Cells(1, 2) = "Messages reçus"
            Cells(1, 3) = "sous folders"
            nacc = nacc + 1
        End If
        For Each f In acc.Folders
         nomfolder = f.Name
        'For Each nomfolder In nomfolders
            'ctrf = ctrf + 1
            ctrf = 2
            nacc = nacc + 1
            On Error Resume Next
            Cells(nacc, 1) = acc.Name & " " & nomfolder
            Set objFolder = acc.Folders(nomfolder)
            If Err.Number <> 0 Then
                Cells(nacc, ctrf) = "Non trouvé"
            Else
                EmailCount = objFolder.Items.Count: DateCount = 0
                'For iCount = 1 To EmailCount
                '    With objFolder.Items(iCount)
                '        If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCount = DateCount + 1
                '    End With
                'Next iCount
                Cells(nacc, ctrf) = EmailCount
                Cells(nacc, ctrf + 1) = acc.Folders(nomfolder).Folders.Count
            End If

        Next
    Next
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing

End Sub

Merci inifniment

Est-ce que je peux avoir le même truc qui me compte les emails dans ceratin repertoire (je peux déplacer les message des jours qui m'interesse pas et comme ça le resultas sera rapide.

merci encore une fois

compte Messages reçus sous folders

Compte1 Deleted Items 0 0

Compte1 Inbox 3607 24

Compte1 Outbox 0 0

Compte1 Sent Items 807 0

Compte1 Calendar 13 0

Compte1 Contacts 4 0

Compte1 Conversation Action Settings 0 0

Compte1 Drafts 13 0

Compte1 Journal 0 0

Compte1 Junk E-Mail 0 0

Compte1 Notes 0 0

Compte1 Tasks 1 0

Compte1 Sync Issues 1 3

Compte1 RSS Feeds 0 0

Compte1 Quick Step Settings 0 0

Compte1 Conversation History 2 0

Public Folders - Compte1 Favorites 0 0

Public Folders - Compte1 All Public Folders 0 7

Compte1 Deleted Items 0 0

Compte1 Inbox 3607 24

Compte1 Outbox 0 0

Compte1 Sent Items 807 0

Compte1 Calendar 13 0

Compte1 Contacts 4 0

Compte1 Conversation Action Settings 0 0

Compte1 Drafts 13 0

Compte1 Journal 0 0

Compte1 Junk E-Mail 0 0

Compte1 Notes 0 0

Compte1 Tasks 1 0

Compte1 Sync Issues 1 3

Compte1 RSS Feeds 0 0

Compte1 Quick Step Settings 0 0

Compte1 Conversation History 2 0

Compte2 Deleted Items 7 4

Compte2 Inbox 2 23

Compte2 Outbox 0 0

Compte2 Sent Items 135747 0

Compte2 Calendar 3 0

Compte2 Contacts 7 0

Compte2 Conversation Action Settings 0 0

Compte2 Conversation History 0 0

Compte2 Drafts 0 0

Compte2 Journal 0 0

Compte2 Junk E-Mail 5 0

Compte2 Mail Delivery failed 0 0

Compte2 News Feed 0 0

Compte2 Notes 0 0

Compte2 Quick Step Settings 0 0

Compte2 RSS Subscriptions 0 0

Compte2 Suggested Contacts 0 0

Compte2 Sync Issues 0 4

Compte2 Tasks 0 0

Public Folders - Compte2 Favorites 0 0

Public Folders - Compte2 All Public Folders 0 7

re-bonjour,

regarde si ceci peut te convenir.

Sub CountDatedEmailsv1()
    Dim objOutlook As Object, objnSpace As Object
    Dim objFolder As Object, objFolderA As Object, objFolderB As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    nomfolders = Array("Inbox", "Sent Items") '<- mettre ici la liste des folders à prendre en compte

    Dim myDate As Date
    myDate = DateSerial(Year(Date), Month(Date), Day(Date) - 1)
    lig = 0
    For Each acc In objnSpace.Folders
        browsefolder acc, nomfolders, 1, lig
    Next
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing

End Sub
Sub browsefolder(folder, nomfolders, n, ByRef lig)
    lig = lig + 1
    Cells(lig, n) = folder.Name & "(" & folder.items.Count & ")"
    For Each f In folder.Folders

            For Each tod In nomfolders
                If tod = f.Name Then
                    browsefolder f, nomfolders, n + 1, lig
                    Exit For
                End If
            Next

    Next
End Sub

Le resultats il est TOP tu es un génie!!!

serai t'il possible que le resultats soit affiché comme dans la solution d'avant ? au fait le dernier code s'affiche comme suit

dans le colonne B j'ai :

Inbox(3630)

Sent Items(811)

Inbox(3630)

Sent Items(811)

Inbox(2)

Sent Items(135860)

serait-il possible d'avoir dans "B" le nom des repertoire et dans "C" le count sans parenthèses.?

aussi comme je peux le faire un refresh chaque 2 minutes ?

merci infiniment

bonsoir,

voici les adaptations demandées

attention tu ne pourras pas travailler en excel tant que cette application est ouverte.

Sub CountDatedEmailsv1()
    Dim objOutlook As Object, objnSpace As Object
    Dim objFolder As Object, objFolderA As Object, objFolderB As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    nomfolders = Array("Inbox", "Sent Items") '<- mettre ici la liste des folders à prendre en compte

    Dim myDate As Date
    myDate = DateSerial(Year(Date), Month(Date), Day(Date) - 1)
    lig = 0
    For Each acc In objnSpace.Folders
        browsefolder acc, nomfolders, 1, lig
    Next
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
    nr = Now() + TimeValue("00:02:00") 'refresh toutes les 2 minutes
    Cells(lig + 1, 1) = "next refresh at " & Format(nr, "hh:mm:ss")
    Application.OnTime nr, "CountDatedEmailsv1"

End Sub
Sub browsefolder(folder, nomfolders, n, ByRef lig)
    lig = lig + 1
    Cells(lig, n) = folder.Name
    If n > 1 Then Cells(lig, n + 1) = folder.items.Count
    For Each f In folder.Folders

            For Each tod In nomfolders
                If tod = f.Name Then
                    browsefolder f, nomfolders, n + 1, lig
                    Exit For
                End If
            Next

    Next
End Sub

Sa fonctionne a merveille; derniere aide si c'est possible;

l'objectif c'est d'afficher que les chiffre que je veux dans sheet 2 alors que sheet 1 où les données s'exécutent reste invisible malgré la réactualisation comme ca j'aurai un Dashboard avec les couleurs et le design que je veux dans le sheet 2

est-ce possible ?

merci ennormement d'avance

bonjour,

voici

Sub CountDatedEmailsv1()
    Dim objOutlook As Object, objnSpace As Object
    Dim objFolder As Object, objFolderA As Object, objFolderB As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")
    Set ws = Worksheets("sheet1")
    nomfolders = Array("Inbox", "Sent Items")    '<- mettre ici la liste des folders à prendre en compte

    Dim myDate As Date
    myDate = DateSerial(Year(Date), Month(Date), Day(Date) - 1)
    lig = 0
    For Each acc In objnSpace.Folders
        browsefolder acc, nomfolders, 1, lig, ws
    Next
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
    nr = Now() + TimeValue("00:02:00")    'refresh toutes les 2 minutes
    ws.Cells(lig + 1, 1) = "next refresh at " & Format(nr, "hh:mm:ss")
    Application.OnTime nr, "CountDatedEmailsv1"

End Sub
Sub browsefolder(folder, nomfolders, n, ByRef lig, ws)
    lig = lig + 1
    ws.Cells(lig, n) = folder.Name
    If n > 1 Then ws.Cells(lig, n + 1) = folder.items.Count
    For Each f In folder.Folders
        For Each tod In nomfolders
            If tod = f.Name Then
                browsefolder f, nomfolders, n + 1, lig, ws
                Exit For
            End If
        Next
    Next
End Sub

Ohhhh sa fonctionne à merveille

merci bcp pour ton aide