hier mit Filter von bis Datum...
28.03.2010 20:53:38
bis
Hallo,
in dieser Version brauchst du den Verweis 'Outlook Object Library' nicht zu setzen.
Option Explicit
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Public vonDatum As Date, bisDatum As Date
Sub MailsImportieren()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object, objItems As Object
Dim LRow As Long
Dim nCount As Integer
Dim myAr() As Variant
Dim HwndExel As Long
vonDatum = DateSerial(Year(Date) - 1, 1, 1) 'Filter von Datum
bisDatum = DateSerial(Year(Date) - 1, 12, 31) 'Filter bis Datum
HwndExel = GetForegroundWindow
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.PickFolder ''' Dialog
With Tabelle1 'Tabellennamen anpassen !!!!!!!
'Zellen leer machen für neue Daten
.Range("A2:B" & .Rows.Count).Clear
'Überschrift
.Cells(1, 1) = "Datum"
.Cells(1, 2) = "Betreff"
.Range("A1:B1").Font.Bold = True
With objFolder
If .Items.Count > 0 Then
Set objItems = .Items
Set objItems = objItems.Restrict("[SentOn] >= '" & Format(vonDatum, "dd.mm.yyyy hh:mm") & "'" & _
"AND [SentOn] <= '" & Format(bisDatum, "dd.mm.yyyy hh:mm") & "'")
'Array Dimensionieren
Redim myAr(1 To objItems.Count, 1 To 2)
'Mails aus Ordner lesen
On Error Resume Next
For nCount = 1 To objItems.Count
LRow = LRow + 1
myAr(LRow, 1) = objItems(nCount).SentOn 'Datum
myAr(LRow, 2) = .Items(nCount).Subject 'Betreff
Next nCount
End If
End With
If LRow > 0 Then
'Daten in Zellen schreiben
.Range("A2").Resize(LRow, 2) = myAr
'Breite der Spalten anpassen und Sort
With .Columns("A:B")
.EntireColumn.AutoFit
.Sort Key1:=.Cells(1, 1), Order1:=xlDescending, Header:=xlYes
End With
End If
End With
vonDatum = 0
bisDatum = 0
Set objOutlook = Nothing: Set objnSpace = Nothing
Set objFolder = Nothing: Set objItems = Nothing
SetForegroundWindow HwndExel
If LRow > 0 Then
MsgBox "Daten gelesen", vbInformation + vbMsgBoxSetForeground, LRow & " E-Mails gefunden"
Else
MsgBox "Daten gelesen", vbExclamation, "keine Daten gefunden"
End If
If Err.Number <> 0 Then
MsgBox "Es sind Fehler aufgetreten!" & vbCr & vbCr & Err.Description, vbCritical + vbMsgBoxSetForeground
End If
End Sub
Gruß Tino