heutige Emails auslesen im Posteingang

[ngassanov]

Hallo Zusammen,

ich habe einen Code geschrieben, der bestimmte Emails im Posteingang lesen soll. Die Ausführung des Codes bringt zwar keinen Fehler, allerdings er liefert auch kein Ergebnis.

Meine Web-Suche brachte auch keine Lösung.

Nun der Code

 

Code:

Sub CommandButton1_Click()
    On Error GoTo ErrHandler
   
    ' Set Outlook application object.
    Dim ws As Worksheet
    Dim objOutlook As Outlook.Application
    Set objOutlook = New Outlook.Application
    Set ws = ThisWorkbook.Worksheets("Tabelle2")
   
    Dim objNSpace As Outlook.Namespace    ' Create and Set a NameSpace OBJECT.
    ' The GetNameSpace() method will represent a specified Namespace.
    Set objNSpace = objOutlook.GetNamespace("MAPI")
   
    Dim myFolder As Outlook.MAPIFolder  ' Create a folder object.
    Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox)
   
    Dim objItem As Object
    Dim iRows As Integer
    Dim x As Date
    iRows = 2
    x = Date
   
    ' Loop through each item in the folder.
    For Each objItem In myFolder.Items
        If objItem.Class = olMail Then
       
        If InStr(objItem.ReceivedTime, x) > 0 Then
               
            ws.Cells(iRows, 1) = objItem.SenderEmailAddress
            ws.Cells(iRows, 2) = objItem.To
            ws.Cells(iRows, 3) = objItem.Subject
            ws.Cells(iRows, 4) = objItem.ReceivedTime
            ws.Range(Cells(iRows, 5), Cells(iRows + 4, 9)) = objItem.Body
       
        End If
        End If
      iRows = iRows + 1
    Next
   
    Set objMail = Nothing
 
    ' Release.
    Set objOutlook = Nothing
    Set objNSpace = Nothing
    Set myFolder = Nothing
ErrHandler:
    Debug.Print Err.Description
   
End Sub

Bereits jetzt vielen Dank für die mögliche Hilfe.

LG

[volti]

Hallo,

wenn Du es von Excel aus machen möchtest, hilft Dir dieses hier vielleicht als Anregung...

Code:

Sub GetAllMyMails()
' Sub liest die Mails des Posteingangs ein und listet die einzelnen Komponenten im Register Mails _
 auf
  Dim i As Integer, j As Integer, n As Integer, sMails() As String, iAnz As Integer
  Dim sAbsender As String

  sAbsender = "Face*"
  With ThisWorkbook.Sheets("Mails")
      .Cells.ClearContents
' Überschrift im MailRegister schreiben
      .Cells(1, 1).Resize(1, 10) = _
      Split("Absender Betreff gesendet Anz.Anl Mail-Text Wichtig gelesen Kopie-Empfänger Blindkopie-Empfänger Anlagen") _
                      

' Mails aus dem Posteinagng holen und verarbeiten
      With CreateObject("Outlook.Application").GetNamespace("MAPI")
          With .Folders("Volti@web.de").Folders("Posteingang")
              iAnz = .Items.Count
              ReDim sMails(iAnz, 9)
              For i = 0 To iAnz - 1
                  With .Items(i + 1)
                      If Left$(.ReceivedTime, 10) = (Date) Then
'      If .SenderName Like sAbsender Or sAbsender = "" Then
                         sMails(n, 0) = .SenderName
                         sMails(n, 1) = .Subject
                         sMails(n, 2) = .SentOn
                         sMails(n, 3) = .Attachments.Count
                         sMails(n, 4) = .body
                         sMails(n, 5) = IIf(.Importance = 0, "nein", "ja")
                         sMails(n, 6) = IIf(.unread = 0, "nein", "ja")
                         sMails(n, 7) = .Cc
                         sMails(n, 8) = .Bcc
Rem    sMails(n,7) = .ReminderSet    'Erinnerung

' Anlagen ermitteln
                         With .Attachments
                             For j = 1 To .Count
                                 sMails(i, 9) = sMails(n, 9) & .Item(j).FileName & vbLf
                                 '  .Item(1).SaveAsFile "c:\test.xls"
                             Next j
                         End With
                         n = n + 1
                      End If
                  End With
              Next i
          End With
      End With
      .Cells(2, "A").Resize(n, 10) = sMails()
  End With
  MsgBox "Habe " & n & " Mails abgeholt!", vbInformation, "Mails importieren"
End Sub

_________
viele Grüße
Karl-Heinz