E-Mails in Excel für bestimmten Zeitraum auslesen
02.12.2018 13:31:26
ElTobi
meine eingebaute Datumsabfrage funktionier, allerdings werden nur die E-Mails des jeweiligen Zeitintervalls ausgelesen:
Jetzt bestehen zwei weitere Probleme:
- Es wird nur der erste Unterordner ausgelesen, vor dem 2. wird gestoppt
- und in der Tabelle werden Zeilen freigelassen wenn diese nicht dem Zeitintervall entsprechen.
Weiß jemand einen Rat?
Viele Grüße
Option Explicit
Public Sub ReadMailItems()
Dim olapp As Object
Dim olName As Object
Dim olHFolder As Object
Dim olUFolder As Object
Dim olUFolder2 As Object
Dim strAttCount As String
Dim olItemsCount As Long
Dim olItemsCount2 As Long
Dim lngAttCount As Long
Dim letzteZeile As Long
Dim VonDatum As Date, BisDatum As Date
On Error Resume Next
Set olapp = CreateObject("Outlook.Application")
Set olName = olapp.GetNamespace("MAPI")
Set olHFolder = olName.Session.Folders("Funktionspostfach")
Set olUFolder = olHFolder.Folders("Posteingang")
Set olUFolder2 = olHFolder.Folders("1.01 in Bearbeitung")
[A1].Value = "E-Mail-Ordner"
[B1].Value = "MailFrom"
[C1].Value = "Exchange ID"
[D1].Value = "Datum//Uhrzeit"
[E1].Value = "Betreff"
[F1].Value = "Text"
[G1].Value = "Anzahl Datei-Anhang"
[H1].Value = "Datei-Anhang"
[I1].Value = "Datei-Größe"
[J1].Value = "CC"
[K1].Value = "Empfänger"
Rows(1).Font.Bold = True
VonDatum = CDate(InputBox("Bitte Datum des ersten zu betrachtenden Tages eingeben:", " _
Datumseingabe", Format(Now - 1, "DD.MM.YYYY")))
BisDatum = CDate(InputBox("Bitte Datum des letzten zu betrachtenden Tages eingeben:", " _
Datumseingabe", Format(Now, "DD.MM.YYYY")))
VonDatum = DateSerial(Year(VonDatum), Month(VonDatum), Day(VonDatum))
BisDatum = DateSerial(Year(BisDatum), Month(BisDatum), Day(BisDatum) + 1)
letzteZeile = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
For olItemsCount = 1 To olUFolder.Items.Count
With olUFolder.Items.Item(olItemsCount)
If VonDatum " & olUFolder.Name
Sheets("Master").Range("B" & olItemsCount + letzteZeile).Value = .Sender
Sheets("Master").Range("C" & olItemsCount + letzteZeile).Value = . _
SenderEmailAddress
Sheets("Master").Range("D" & olItemsCount + letzteZeile).Value = .ReceivedTime
Sheets("Master").Range("E" & olItemsCount + letzteZeile).Value = .Subject
Sheets("Master").Range("F" & olItemsCount + letzteZeile).Value = .body
Sheets("Master").Range("G" & olItemsCount + letzteZeile).Value = .Attachments. _
_
Count
Sheets("Master").Range("H" & olItemsCount + letzteZeile).Value = strAttCount
Sheets("Master").Range("I" & olItemsCount + letzteZeile).Value = .Size
Sheets("Master").Range("J" & olItemsCount + letzteZeile).Value = .cc
Sheets("Master").Range("K" & olItemsCount + letzteZeile).Value = .To
strAttCount = ""
For olItemsCount2 = 1 To olUFolder2.Items.Count
letzteZeile = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
With olUFolder2.Items.Item(olItemsCount2)
For lngAttCount = 1 To .Attachments.Count
If strAttCount = "" Then
strAttCount = .Attachments.Item(lngAttCount).Filename
Else
strAttCount = strAttCount & vbCrLf & .Attachments.Item(lngAttCount). _
_
Filename
End If
Next lngAttCount
Sheets("Master").Range("A" & olItemsCount2 + letzteZeile).Value = olHFolder. _
Name & "->" & olUFolder2.Name
Sheets("Master").Range("B" & olItemsCount2 + letzteZeile).Value = .Sender
Sheets("Master").Range("C" & olItemsCount2 + letzteZeile).Value = . _
SenderEmailAddress
Sheets("Master").Range("D" & olItemsCount2 + letzteZeile).Value = . _
ReceivedTime
Sheets("Master").Range("E" & olItemsCount2 + letzteZeile).Value = .Subject
Sheets("Master").Range("F" & olItemsCount2 + letzteZeile).Value = .body
Sheets("Master").Range("G" & olItemsCount2 + letzteZeile).Value = .Attachments. _
_
Count
Sheets("Master").Range("H" & olItemsCount2 + letzteZeile).Value = strAttCount
Sheets("Master").Range("I" & olItemsCount2 + letzteZeile).Value = .Size
Sheets("Master").Range("J" & olItemsCount2 + letzteZeile).Value = .cc
Sheets("Master").Range("K" & olItemsCount2 + letzteZeile).Value = .To
strAttCount = ""
End With
Next
On Error GoTo 0
End If
End With
Next
End Sub