Microsoft Excel

Herbers Excel/VBA-Archiv

E-Mails in Excel für bestimmten Zeitraum auslesen


Betrifft: E-Mails in Excel für bestimmten Zeitraum auslesen
von: ElTobi
Geschrieben am: 02.12.2018 13:31:26

Hallo zusammen,

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 <= .ReceivedTime And .ReceivedTime < BisDatum Then
             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" & olItemsCount + letzteZeile).Value = olHFolder. _
Name & "->" & 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

  

Betrifft: Crossposting
von: SF
Geschrieben am: 03.12.2018 07:46:09

Hola,

hat das einen bestimmten Grund dass du auf einmal ein zweites Forum ohne das im anderen Forum mitzuteilen?

http://www.vba-forum.de/forum/View.aspx?ziel=48460-E-Mails_in_Excel_f%C3%BCr_bestimmten_Zeitraum_auslesen_

Gruß,
steve1da


  

Betrifft: AW: Crossposting
von: ElTobi
Geschrieben am: 03.12.2018 09:28:00

Hatte relativ zeitnah gepostet, kenn mich nicht aus welche Foren hier wie aktiv sind.
Sollte dies nicht erlaubt sein, dann sorry