Betreff von neuen Mails automatisch in Excel
05.09.2019 10:02:54
neuen
Ich möchte den Betreff einer Mail auslesen und den Betreff dann in eine Exceltabelle schreiben. Das unten stehende Macro habe Ich in Outlook in einem Modul. Das MAcro soll automatisch laufen, wenn eine neue Mail rein kommt.
Ich habe eine regel erstellt, die dieses Script bei neuer Mail ausführen soll.
Nun die Probleme:
1. Es wird immer nur die Vorletzte Mail mit der Regel bearbeitet.
- Kommt also die erste Mail rein, apssiert nichts. Erst wenn noch eine Zweite rein kommt funktioniert das.
1b. Ich würde das Macro gerne automatisch über den vba code starten anstatt üpber die regel, da dies nur mit der registry veränderung funktioneirt.
2. Excel soll sich nach abspeichern schließen, weiß nicht wie das geht. "Application.Quit" gibt mir nen fehler raus.
Wenn nur eine Mail drin ist und ich die Regel Manuell starte, geht es.
Vielleicht hat ja einer ne Ahnung.
Danke!
[code]
Sub extractgenehmigung(Item As Outlook.MailItem)
Dim fMails As Folder, mail As MailItem, txtContent As String, arrContent As Variant, objExcel _
As Object, wb As Object, sheet As Object, rngStart As Object, rngCurrent As Object, fErledigt As Object
'Pfad zur Excel-Datei
Const EXCELFILE = "PFADZUMEXCELFILE"
'Ordner in Outlook referenzieren
Set fMails = Application.Session.Stores("Email_des_Postfaches").GetDefaultFolder( _
olFolderInbox).Items
'Unterordner referenzieren in den die Mails verschoben werden wenn sie bearbeitet wurden
Set fErledigt = fMails.Folders("erledigt")
If fMails.Items.Count > 0 Then
'Excel Objekt erzeugen
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = False
'Excelfile öffnen
Set wb = objExcel.Workbooks.Open(EXCELFILE)
'Daten kommen in Worksheet
Set sheet = wb.Worksheets("Genehmigung")
'Startzelle in Spalte A ermitteln
Set rngStart = sheet.Cells(sheet.Rows.Count, 1).End(-4162).Offset(1, 0)
Set rngCurrent = rngStart
While fMails.Items.Count > 0
'aktuelle Mail
Set mail = fMails.Items(1)
'betreff extrahieren
txtContent = mail.Subject
'Setze Werte im Sheet
With rngCurrent
.Value = txtContent
End With
'Excel Zeile eins nach unten verschieben
Set rngCurrent = rngCurrent.Offset(1, 0)
' Mail in den 'Erledigt' Ordner verschieben
mail.Move fErledigt
Wend
'Workbook speichern
wb.Save
'Excel anzeigen
objExcel.Visible = False
objExcel.DisplayAlerts = False
End If
Set objExcel = Nothing
Set wb = Nothing
Set sheet = Nothing
Set mail = Nothing
End Sub
[/code]