Der Hinweis von sigma ist ausgezeichnet.
Ich hab Dir das Zählen mal mit eingebaut.
Option Explicit
Sub OutlookPosteingang()
'Variablendeklaration
Dim OLF As Outlook.MAPIFolder
Dim AnzEintraege As Long, i As Long, Email As Long
Dim lngLaufZahl As Long, lngAnzahlZeichen As Long
Dim strINHALT As String
' Hier wird eine Tabelle hinzugefügt
Sheets.Add
'Globale Fehlerbehandlung -> Excel soll automatisch weitermachen, egal welcher Fehler
On Error Resume Next
' Überschriften im neuen Blatt -> die erste Zeile von A1 - F1
[A1].Value = "Betreff"
[B1].Value = "Datum Uhrzeit"
[C1].Value = "empfangen von"
[D1].Value = "gelesen"
[E1].Value = "Nachricht"
[F1].Value = "Dateianhänge"
'Erste Zeile soll Fett formatiert werden
Rows(1).Font.Bold = True
'Setzen der Variable als Outlook Application; Zugriff auf Outlook
Set OLF = GetObject("", "Outlook.Application") _
.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'Setzen der Variable -> es sollen alle Nachrichten im Ordner 'Posteingang (olFolderInbox) gezählt werden
AnzEintraege = OLF.Items.Count
'Setzen der Variablen auf '0'
i = 0: Email = 0
'Beginn Schleifendurchlauf (Schleife 1) -> die Variable 'i' läuft solange, wie Anzahl der EMails vorhanden sind
While i < AnzEintraege
i = i + 1
'Anzeigen einer Nachricht in der Statuszeile
Application.StatusBar = "Lese Posteingang " & _
Format(i / AnzEintraege, "0%")
'Was soll mit den Nachrichten geschehen? (Schleife 2)
With OLF.Items(i)
Email = Email + 1
'Zelle 1 mit dem Wert Betreff in der EMail
Cells(Email + 1, 1).Value = .Subject
'Zelle 2 mit dem Wert 'Empfangen am' in der EMail
Cells(Email + 1, 2).Value = .ReceivedTime
'Zelle 3 Absender
Cells(Email + 1, 3).Value = .SenderName
'Zelle 4 der gelesenen Nachrichten
Cells(Email + 1, 4).Value = Not .UnRead
'Zelle 5 mit der eigentlichen Nachricht
Cells(Email + 1, 5).Value = .Body
'Zelle 6 -> Anzahl der Anhänge in der EMail
Cells(Email + 1, 6).Value = .Attachments.Count
'Beginn der Zählung (Schleife 3)
strINHALT = .Body
lngAnzahlZeichen = 0
For lngLaufZahl = 1 To Len(strINHALT)
If Mid(strINHALT, lngLaufZahl, 1) = "!" Then
lngAnzahlZeichen = lngAnzahlZeichen + 1
End If
Next lngLaufZahl
Cells(Email + 1, 7).Value = lngAnzahlZeichen
'Ende Zählung (Schleife 3)
'Ende der Schleife 2
End With
'Ende der Schleife 1
Wend
'Die Variable muss wieder freigegeben werden:
Set OLF = Nothing
'Die Spalten sollen automatisch in der Breite angeglichen werden
Columns("A:G").AutoFit
'Die Zelle 'A2' soll selektiert werden
[A2].Select
'Die Exceldatei wird als gespeichert deklariert
ActiveWorkbook.Saved = True
'Die Statuszeile wird wieder ausgeschaltet
Application.StatusBar = False
End Sub
|