Tellen ongelezen berichten in Outlook in specifieke mappen

[Anika001]

Hallo,

Middels een macro die ik elders heb gevonden (en iets heb aangepast) is het me gelukt om gedurende de dag een overzicht te tonen van het aantal ongelezen e-mails in Outlook-mappen. In een grafiek wordt vervolgens het resultaat van een drietal mappen getoond. Dit werkt goed, tot het moment dat er mappen worden toegevoegd/verwijderd. De grafiek verwijst namelijk naar bepaalde regels waar de gewenste mappen staan. Door mappen toe te voegen/te verwijderen komen die mappen echter op een andere regel te staan, waardoor de grafiek de verkeerde waarden toont.
Het liefst zou ik de macro zo aanpassen dat niet alle mappen worden doorlopen, maar slechts die mappen die ik nodig heb. Dan werkt mijn grafiek altijd. Ik heb wat pogingen ondernomen, echter zonder resultaat. Dit is de macro die ik gebruik:

Option Explicit
Public mdNextTime As Double
 
Dim ws As Worksheet
Dim iRow As Integer
Dim objNS As Outlook.Namespace

Const bTitles As Boolean = True ' do we want column titles?

Public Sub ListFolders()
   
  mdNextTime = Now + TimeValue("00:00:30")
  Application.OnTime mdNextTime, "ListFolders"
  Application.ScreenUpdating = False
  
  Set ws = ThisWorkbook.Sheets("Blad1")
  Set objNS = Outlook.Application.GetNamespace("MAPI")
  
  ws.UsedRange.ClearContents
  iRow = IIf(bTitles, 1, 0)
  If bTitles Then ws.Range("A1:D1") = Array("Folder Path & Name", "Items", "", "Indented List Of Folders")
  ws.Range("A1:D1").Font.Bold = bTitles
  
  ListFromFolder objNS, 1, ""
  
  ws.Cells(iRow + 1, 2) = "=SUM(B" & IIf(bTitles, "2", "1") & ":B" & CStr(iRow) & ")"
  ws.UsedRange.ColumnWidth = 4
  ws.Columns("A:B").AutoFit
  
  Set objNS = Nothing
  Set ws = Nothing
  
  Application.ScreenUpdating = True

End Sub
 
Private Sub ListFromFolder(objFolderRoot As Object, argLevel As Integer, argFullName As String)
 
  Dim objFolder As MAPIFolder
  
  For Each objFolder In objFolderRoot.Folders
    DoEvents
    iRow = iRow + 1
    ' full folder path in column A
    ws.Cells(iRow, 1) = argFullName & "\" & objFolder.Name
    ' count of items in folder in column B
    On Error Resume Next
    ws.Cells(iRow, 2) = objFolder.UnReadItemCount
    '.Count
    On Error GoTo 0
    ' indented folder list in column C onwards
    ws.Cells(iRow, argLevel + 3) = objFolder.Name
    If objFolder.Folders.Count > 0 Then
      ListFromFolder objFolder, argLevel + 1, argFullName & "\" & objFolder.Name
    End If
  Next objFolder
  
  Set objFolder = Nothing
 
End Sub

Deze code wordt aangeroepen op het moment dat de werkmap wordt geopend en wordt iedere 30 seconden herhaald. Heeft iemand een suggestie hoe ik alleen de gewenste mappen kan uitvragen?

Groet,

Anika

 

[edmoor]

Je kunt bekijken of objFolder.Name overeenkomt met de naam van een gewenste folder en deze overslaan als dat niet het geval is.

 

[Anika001]

Dat is inderdaad precies wat ik wil, maar ik heb geen idee welke code ik daarvoor moet gebruiken. Ik ben aardig goed in het hergebruiken van andermans code, maar als ik het zelf moet verzinnen, kom ik helaas niet zo ver. Ik heb er wel mee zitten knoeien, maar dus zonder het gewenste resultaat.

 

[edmoor]

Probeer deze eens als je ListFromFolder routine:

Private Sub ListFromFolder(objFolderRoot As Object, argLevel As Integer, argFullName As String)
 
  Dim objFolder As MAPIFolder

  Dim UseFolder As String
  UseFolder = "FOLDER1/FOLDER2/FOLDER3/FOLDER4"  

  For Each objFolder In objFolderRoot.Folders
    If Instr(UseFolder, Ucase(objFolder.Name)) > 0 Then
        DoEvents
        iRow = iRow + 1
        ' full folder path in column A
        ws.Cells(iRow, 1) = argFullName & "\" & objFolder.Name
        ' count of items in folder in column B
        On Error Resume Next
        ws.Cells(iRow, 2) = objFolder.UnReadItemCount
        '.Count
        On Error GoTo 0
        ' indented folder list in column C onwards
        ws.Cells(iRow, argLevel + 3) = objFolder.Name
        If objFolder.Folders.Count > 0 Then
            ListFromFolder objFolder, argLevel + 1, argFullName & "\" & objFolder.Name
        End If
    End If
  Next objFolder
  
  Set objFolder = Nothing
 
End Sub

Vervang de namen in "FOLDER1/FOLDER2/FOLDER3/FOLDER4" door de namen van de gewenste folders gescheiden door een / teken.
Wel hoofdletters gebruiken. Het aantal maakt niet uit, die 4 hier is maaar een voorbeeld.
Ik heb het niet kunnen testen dus ik hoor het graag.

 

[Anika001]

Hallo edmoor,

Dank voor je reactie. Helaas werkt het niet. Mijn hele sheet blijft nu leeg, op de kolomkoppen na.

Groet,

Anika

 

[edmoor]

Laat die routine eens zien zoals je hem nu hebt.

Aanvulling:
Ik heb het kunnen testen hier en bij mij werkt de routine goed.
Je moet uiteraard wel de foldernamen aanpassen zoals ik zei.

 

[cow18]

zie bijlage
in de 1e kolom van die tabel hou je enkel die mappen over die je wenst.
De application.ontime moet je er nog even bij verzinnen.

 

[edmoor]

Een heel andere benadering maar werkt prima

 

[cow18]

ik heb de mosterd hier gevonden
http://snb-vba.eu/VBA_Outlook_external.html#H1

 

[Anika001]

Hallo cow18,

Het werkt en doet precies wat ik wil! Heel erg bedankt. Het heeft me nog wel wat moeite gekost om het helemaal te krijgen zoals ik wilde. Dat komt ook doordat ik nog niet helemaal begrijp wat er nu gebeurt, maar daar ga ik me nu maar eens over buigen.

Dit heb ik aangepast (mocht iemand naar iets dergelijks op zoek zijn):

Bij het openen van de werkmap wordt de macro gestart en bij het afsluiten gesloten:

Private Sub Workbook_Open()
    Mappen_Outlookmappenstruktuur
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  
    Application.OnTime mdNextTime, "Mappen_Outlookmappenstruktuur", schedule:=False
End Sub

In de module staat vervolgens de code van cow18 met een aanvulling om de macro constant te laten draaien tot het bestand gesloten wordt:

Option Explicit
Public mdNextTime As Double
Dim rGewensteMappen As Range

Sub Mappen_Outlookmappenstruktuur()
    Dim fld As MAPIFolder, fld1 As MAPIFolder, fld2 As MAPIFolder, fld3 As MAPIFolder, splits
    'Herhalen macro tot het bestand gesloten wordt
    mdNextTime = Now + TimeValue("00:00:30")
    Application.OnTime mdNextTime, "Mappen_Outlookmappenstruktuur"
    
    Set rGewensteMappen = Range("TabelOutlookMappen").ListObject.DataBodyRange.Columns(1)
    rGewensteMappen.Offset(, 1).ClearContents
    
    Application.ScreenUpdating = False
    For Each fld In CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
        splits = Split(NogVerderZoeken(fld.Name), "/")
        If splits(0) = 0 Then Exit For
        If splits(1) <> "0" Then rGewensteMappen.Cells(splits(1), 2).Value = fld.UnReadItemCount
        
        For Each fld1 In fld.Folders
            splits = Split(NogVerderZoeken(fld.Name & "/" & fld1.Name), "/")
            If splits(0) = 0 Then Exit For
            If splits(1) <> 0 Then rGewensteMappen.Cells(splits(1), 2).Value = fld1.UnReadItemCount
            
            For Each fld2 In fld1.Folders
                splits = Split(NogVerderZoeken(fld.Name & "/" & fld1.Name & "/" & fld2.Name), "/")
                If splits(0) = 0 Then Exit For
                If splits(1) <> 0 Then rGewensteMappen.Cells(splits(1), 2).Value = fld2.UnReadItemCount
                
                For Each fld3 In fld2.Folders
                    splits = Split(NogVerderZoeken(fld.Name & "/" & fld1.Name & "/" & fld2.Name & "/" & fld3.Name), "/")
                    If splits(0) = 0 Then Exit For
                    If splits(1) <> 0 Then rGewensteMappen.Cells(splits(1), 2).Value = fld3.UnReadItemCount
                Next
            Next
        Next
    Next
    Application.ScreenUpdating = True
End Sub

Function NogVerderZoeken(naam)
  Dim i1 As Integer, i2 As Integer, splits
  On Error Resume Next
  splits = Split(naam, "/")
  MsgBox Left(naam, Len(naam) - Len(splits(UBound(splits)) - 1))
  i1 = 1: If UBound(splits) > 0 Then i1 = WorksheetFunction.CountIf(rGewensteMappen, Left(naam, Len(naam) - Len(splits(UBound(splits)) - 1)) & "*")
  i2 = WorksheetFunction.Match(naam, rGewensteMappen, 0)
  NogVerderZoeken = i1 & "/" & i2
End Function

Nogmaals bedankt voor alle suggesties!