Ältestes Datum via Excel in Outlook auslesen
17.07.2025 12:41:40
Marc
ich nutze derzeit einen Code zum auslesen der Anzahl von Mails aus verschiedenen Outlook Ordnern. Diesen habe ich vor Jahren hier von einer netten Person erhalten.
Dieser sieht wie folgt aus:
Sub test()
Dim lngIndex As Long, lngCur As Long, lngCount As Long, lngRow As Long
Dim olApp As Outlook.Application, olVerz As Outlook.MAPIFolder
Dim olSubL1User As Outlook.MAPIFolder 'user-Ebene
Dim olSubL2Post As Outlook.MAPIFolder 'user-Ebene
Dim olSubL3Gru1 As Outlook.MAPIFolder
Dim olSubL3Gru2 As Outlook.MAPIFolder
Dim olSubL3Gru3 As Outlook.MAPIFolder
Dim olSubL4MA01 As Outlook.MAPIFolder
Dim olSubL4MA02 As Outlook.MAPIFolder
Dim olSubL4MA03 As Outlook.MAPIFolder
Dim olSubL4MA04 As Outlook.MAPIFolder
Dim olSubL4MA05 As Outlook.MAPIFolder
Dim olSubL4MA06 As Outlook.MAPIFolder
Dim olSubL4MA07 As Outlook.MAPIFolder
Dim olSubL4MA08 As Outlook.MAPIFolder
Dim olSubL4MA09 As Outlook.MAPIFolder
Dim olSubL4MA10 As Outlook.MAPIFolder
Dim olSubL4MA11 As Outlook.MAPIFolder
Dim olSubL4MA12 As Outlook.MAPIFolder
Dim olSubL4MA13 As Outlook.MAPIFolder
Tabelle2.Select
Dim OutlookUser As String, xMA As Long, xMaMAX As Long
OutlookUser = "test@test.com"
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
'===========================================================================================
' Level-1 behandeln (User)
'===========================================================================================
For Each olVerz In olApp.GetNamespace("Mapi").Folders
If olVerz.Name = OutlookUser Then
Set olSubL1User = olVerz 'user gefunden
Exit For
End If
Next olVerz
If olSubL1User Is Nothing Then
MsgBox "Fehler-01_test_b: Der User " & OutlookUser & " wurde nicht gefunden - Abbruch."
Exit Sub
End If
'===========================================================================================
' Level-2 behandeln (Posteingang)
'===========================================================================================
If Not olSubL1User Is Nothing Then
For Each olVerz In olSubL1User.Folders
If olVerz.Name = "Posteingang" Then
Set olSubL2Post = olVerz
Exit For
End If
Next olVerz
If olSubL2Post Is Nothing Then
MsgBox "Fehler-02_testB: Posteingang wurde nicht gefunden - Abbruch."
Exit Sub
End If
End If
'===========================================================================================
' Level-3 behandeln (Gruppen)
'===========================================================================================
If Not olSubL2Post Is Nothing Then
For Each olVerz In olSubL2Post.Folders
If olVerz.Name = "test5B" Then Set olSubL3Gru1 = olVerz
If olVerz.Name = "test6B" Then Set olSubL3Gru2 = olVerz
If olVerz.Name = "Top" Then Set olSubL3Gru3 = olVerz
If olVerz.Name = "parken" Then Set olSubL3Gru3 = olVerz
Next olVerz
If olSubL3Gru1 Is Nothing Or olSubL3Gru2 Is Nothing Or olSubL3Gru3 Is Nothing Then
MsgBox "Fehler-03_test5B: Eine Gruppe wurde nicht gefunden - Abbruch."
Exit Sub
End If
End If
'===========================================================================================
' Level-4 behandeln (Mitarbeiter prüfen), Gruppen sind bereits auf Existenz geprüft.
'===========================================================================================
xMA = 0
xMaMAX = 3
For Each olVerz In olSubL3Gru1.Folders
If olVerz.Name = Range("B5") Then xMA = xMA + 1
If olVerz.Name = Range("B6") Then xMA = xMA + 1
If olVerz.Name = Range("B7") Then xMA = xMA + 1
If olVerz.Name = Range("B8") Then xMA = xMA + 1
If olVerz.Name = Range("B9") Then xMA = xMA + 1
If olVerz.Name = Range("B10") Then xMA = xMA + 1
If olVerz.Name = Range("B11") Then xMA = xMA + 1
If olVerz.Name = Range("B12") Then xMA = xMA + 1
If olVerz.Name = Range("B13") Then xMA = xMA + 1
If olVerz.Name = Range("B14") Then xMA = xMA + 1
If olVerz.Name = Range("B15") Then xMA = xMA + 1
If olVerz.Name = Range("B16") Then xMA = xMA + 1
If olVerz.Name = Range("B19") Then xMA = xMA + 1
If olVerz.Name = Range("B18") Then xMA = xMA + 1
Next olVerz
If xMA xMaMAX Then
MsgBox "Fehler-04_test5B: Mindestens einer von " & xMaMAX & " Mitarbeitern wurde nicht gefunden - Abbruch."
Exit Sub
End If
'===========================================================================================
' Level-4 behandeln (Mitarbeiter ok => auslesen), Gruppen sind bereits auf Existenz geprüft.
' MsgBox "kein Postfach bzw. Postfach-Ordner gefunden!", vbCritical Or vbSystemModal
'===========================================================================================
For Each olVerz In olSubL2Post.Folders
If olVerz.Name = "test5b" Then
Set olSubL2Post = olVerz
Range("C4").Value = olSubL2Post.Items.Count 'Anzahl Emails des MAnn
End If
If olVerz.Name = "Top" Then
Set olSubL2Post = olVerz
Range("C19").Value = olSubL2Post.Items.Count 'Anzahl Emails des MAnn
End If
If olVerz.Name = "parken" Then
Set olSubL2Post = olVerz
Range("C18").Value = olSubL2Post.Items.Count 'Anzahl Emails des MAnn
End If
Next olVerz
For Each olVerz In olSubL3Gru1.Folders
If olVerz.Name = Range("B5") Then
Set olSubL4MA01 = olVerz
Range("C5").Value = olSubL4MA01.Items.Count 'Anzahl Emails des MAnn
End If
....
next olVerz
end subIch benötige nun noch das älteste Datum aus dem jeweilig angesprochenen Ordner. Dies würde ja nur hier sinn machen, wo die einzelnen Ordner abgefragt werden:
For Each olVerz In olSubL3Gru1.Folders
If olVerz.Name = Range("B5") Then
Set olSubL4MA01 = olVerz
Range("C5").Value = olSubL4MA01.Items.Count 'Anzahl Emails des MAnn
End If
....
next olVerzIch probiere es jetzt schon seit ein paar Tagen. Ich bekomme aber immer nur das älteste Datum aus meinem persönlichen Postfach und nicht wie gewünscht aus dem angesprochenen.
Hat jemand eine Idee oder einen Lösungsansatz?
Danke und viele Grüße,
Marc
Anzeige