Clever-Excel-Forum

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

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

ngassanov

volti