Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1320to1324
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Outlook inport

Outlook inport
16.07.2013 08:04:50
stefan
Hallo Zusammen,
habe folgenden Code für das Einlesen von E-Mails nach Excel gefunden.
Sub GrapText()
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As Object
Dim objMsg As Object
Dim intCounter As Integer, intCount As Integer, iRow As Integer
Dim sTxt As String
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.Folders("Postfach - Fries, Stefan").Folders("Inbox")
intCount = objFolder.Items.Count
If intCount > 0 Then
For intCounter = 1 To intCount
Set objMsg = objFolder.Items(intCounter)
Worksheets.Add after:=Worksheets(Worksheets.Count)
objMsg.SaveAs ThisWorkbook.Path & "\temp.txt", olTXT
Close
iRow = 0
Open ThisWorkbook.Path & "\temp.txt" For Input As #1
Do Until EOF(1)
iRow = iRow + 1
Line Input #1, sTxt
Cells(iRow, 1).Value = "'" & sTxt
Loop
Close
Next intCounter
Kill ThisWorkbook.Path & "\temp.txt"
End If
Set objnSpace = Nothing
Set objFolder = Nothing
Set objMsg = Nothing
Set objOutlook = Nothing
End Sub

Was muß ich machen, wenn ich nur die Mails einlesen will, die den Betreff haben, der
in meinem Tabellenblatt "Setup" in Zelle B1 steht?
Gruß
stefan

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Outlook inport
16.07.2013 08:39:27
GuentherH
Hallo stefan,
ungetestet:

For intCounter = 1 To intCount
Set objMsg = objFolder.Items(intCounter)
if objmsg.subject=sheets("Setup").range("B1").text then
Worksheets.Add after:=Worksheets(Worksheets.Count)
objMsg.SaveAs ThisWorkbook.Path & "\temp.txt", olTXT
Close
iRow = 0
Open ThisWorkbook.Path & "\temp.txt" For Input As #1
Do Until EOF(1)
iRow = iRow + 1
Line Input #1, sTxt
Cells(iRow, 1).Value = "'" & sTxt
Loop
Close
end if
Next intCounter
Gruß,
Günther

AW: Outlook inport
16.07.2013 09:15:26
stefan
Hallo Günther,
ja funktioniert !!
DANKE für die schnelle Hilfe
Gruß
Stefan

Anzeige
AW: Outlook inport
16.07.2013 09:10:43
fcs
Hallo Stefan,
hier dein Makro angepasst. Bezüglich Groß-Klein-Schreibung und Vergleich (Zellinhalt gleich Betreff oder in Betreff enthalten) muss du die paasenden Zeilen wählen.
Gruß
Franz
Sub GrapText()
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As Object
Dim objMsg As Object
Dim intCounter As Integer, intCount As Integer, iRow As Integer
Dim sTxt As String, strSubject As String                          'geändert
Application.ScreenUpdating = False
'   strSubject = ActiveWorkbook.Worksheets("Setup").Range("B1")       'neu-mit Groß _
Kleinschreibung
strSubject = LCase(ActiveWorkbook.Worksheets("Setup").Range("B1")) 'neu-ohne Groß _
Kleinschreibung
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.Folders("Postfach - Fries, Stefan").Folders("Inbox")
intCount = objFolder.Items.Count
If intCount > 0 Then
For intCounter = 1 To intCount
Set objMsg = objFolder.Items(intCounter)
'         If InStr(1, objMsg.Subject, strSubject) > 0 Then       'neu-mit GroßKleinschreibung
If InStr(1, LCase(objMsg.Subject), strSubject) > 0 Then 'neu-ohne GroßKleinschreibung
'         If objMsg.Subject = strSubject Then                    'neu-mit GroßKleinschreibung
'         If LCase(objMsg.Subject) = strSubject Then             'neu-ohne GroßKleinschreibung
Worksheets.Add after:=Worksheets(Worksheets.Count)
objMsg.SaveAs ThisWorkbook.Path & "\temp.txt", 0 '0 = olTXT  'geändert
Close
iRow = 0
Open ThisWorkbook.Path & "\temp.txt" For Input As #1
Do Until EOF(1)
iRow = iRow + 1
Line Input #1, sTxt
Cells(iRow, 1).Value = "'" & sTxt
Loop
Close
End If                                                       'neu
Next intCounter
If Dir(ThisWorkbook.Path & "\temp.txt")  "" Then              'neu
Kill ThisWorkbook.Path & "\temp.txt"
End If                                                          'neu
End If
Set objnSpace = Nothing
Set objFolder = Nothing
Set objMsg = Nothing
Set objOutlook = Nothing
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige