01.08.2018, 18:46
Hallo Zusammen,
um dieses Projekt abschliessen zu können, brauche ich aus dem Forum nochmal Unterstützung. Das Makro funktioniert soweit und die Emails werden nach Excel exportiert. Bisher ist der "Body" nach wie vor ohne Formatierung in Excel. Dazu habe ich bisher keine Lösung gefunden.
Die zweite mögliche Lösung wäre, den "Body" so in Excel zu belassen, aber das Makro zu erweitern.
Meine Frage ist: Kann der "gelb" markierte Text aus dem Email extra ausgelesen werden und eine zweite Spalte übertragen werden.
D.h. Makro sucht im Email nach dem Text der gelb markiert ist, kopiert diesen Text in eine Zelle in einer neuen Spalte.
Könntet ihr so nett sein und mir gleich die Marko Befehle an der richtigen Stelle einfügen sonst läuft das Makro wieder nicht und ich bin nicht fit genug den Fehler zu finden. Für zukünftige Interessierte ist dann auch die Lösung gut kopierbar.
Vielen herzlichen Dank.
Karin
um dieses Projekt abschliessen zu können, brauche ich aus dem Forum nochmal Unterstützung. Das Makro funktioniert soweit und die Emails werden nach Excel exportiert. Bisher ist der "Body" nach wie vor ohne Formatierung in Excel. Dazu habe ich bisher keine Lösung gefunden.
Die zweite mögliche Lösung wäre, den "Body" so in Excel zu belassen, aber das Makro zu erweitern.
Meine Frage ist: Kann der "gelb" markierte Text aus dem Email extra ausgelesen werden und eine zweite Spalte übertragen werden.
D.h. Makro sucht im Email nach dem Text der gelb markiert ist, kopiert diesen Text in eine Zelle in einer neuen Spalte.
Könntet ihr so nett sein und mir gleich die Marko Befehle an der richtigen Stelle einfügen sonst läuft das Makro wieder nicht und ich bin nicht fit genug den Fehler zu finden. Für zukünftige Interessierte ist dann auch die Lösung gut kopierbar.
Vielen herzlichen Dank.
Karin
Code:
Sub OutlookPosteingang()
'Variablendeklaration
Dim olApp As Outlook.Application
Dim olVerz As Outlook.MAPIFolder
Dim objMail As MailItem
Set olApp = CreateObject("Outlook.Application")
Set olVerz = olApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox).Folders("Test")
Dim AnzEintraege As Integer, i As Integer, Email As Integer
' Hier wird eine Tabelle hinzugefuegt
Sheets.Add
'Globale Fehlerbehandlung -> Excel soll automatisch weitermachen, egal welcher Fehler
'On Error Resume Next'
' Ueberschriften im neuen Blatt -> die erste Zeile von A1 - E1
[A1].Value = "Betreff"
[B1].Value = "Datum Uhrzeit"
[C1].Value = "empfangen von"
[D1].Value = "gesendet an"
[E1].Value = "Nachricht"
'Erste Zeile soll Fett formatiert werden
Rows(1).Font.Bold = True
'Setzen der Variable als Outlook Application; Zugriff auf Outlook
Set OLF = GetObject("", "Outlook.Application") _
.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox).Folders("Test")
'Setzen der Variable -> es sollen alle Nachrichten im Ordner 'Test (Folders) gezaehlt werden
AnzEintraege = OLF.Items.Count
'Setzen der Variablen auf '0'
i = 0: Email = 0
'Beginn Schleifendurchlauf (Schleife 1) -> die Variable 'i' laeuft solange, wie Anzahl der EMails vorhanden sind
While i < AnzEintraege
i = i + 1
'Anzeigen einer Nachricht in der Statuszeile
Application.StatusBar = "Lese Test" & _
Format(i / AnzEintraege, "0%")
'Was soll mit den Nachrichten geschehen? (Schleife 2)
With OLF.Items(i)
Email = Email + 1
'Zelle 1 mit dem Wert Betreff in der EMail
Cells(Email + 1, 1).Value = .Subject
'Zelle 2 mit dem Wert 'Empfangen am' in der EMail
Cells(Email + 1, 2).Value = .ReceivedTime
'Zelle 3 Absender
Cells(Email + 1, 3).Value = .SenderName
'Zelle 4 mit dem Wert
Cells(Email + 1, 4).Value = .CC
'Zelle 5 mit der eigentlichen Nachricht
Cells(Email + 1, 5).Value = .Body
'Ende der Schleife 2
End With
'Ende der Schleife 1
Wend
'Die Variable muss wieder auf Null gesetzt werden = nothing halt
Set OLF = Nothing
'Loeschen der Leerzeilen in Spalte E und Spaltenbreite aendern, gehe zum Anfang Zelle A1"
Columns("E:E").Select
Selection.ColumnWidth = 60
Cells.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Replace What:=Chr(10) & "" & Chr(10) & " " & Chr(10), Replacement:=Chr(10)
'Die Zelle 'A1' soll selektiert werden
[A1].Select
'Die Spalten sollen automatisch in der Breite angeglichen werden
Columns("A:F").AutoFit
'Die Exceldatei wird gespeichert
ActiveWorkbook.Saved = True
'Die Statuszeile wird wieder ausgeschaltet
Application.StatusBar = False
End With
End Sub