Re: Emails aus Outlook automatisch speichern
03.04.2003 23:58:46
jinx
Moin, Johannes,wenn Du unter automatisch verstehst, dass diese Aktion beim Eintreffen der Mail passieren soll, bist Du im falschen Forum - das muss dann in Outlook in dem Modul DieseOutlookSitzung hinterlegt werden.
' Excel mit CreateObject starten
Sub LaunchExcel01()
'!!!WICHTIG!!! Verweis auf Excel muss gesetzt sein !!!!
'
' Hier als normales Makro, dass von Outlook zur Überprüfung
' zuerst von Hand gestartet werden sollte
' Öffnet eine Instanz von Excel, öffnet die Mappe
' schreibt die Daten. speichert die Mappe und schließt Excel
'
' Bei Verlegung in DieseOutlookSitzung muss das Makro
' in Private Sub Application_NewMail() umbenannt werden
' Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim xlApp 'As Excel.Application ' Diese Anweisungen sollten beibehalten werden!
Dim xlSheet 'As Excel.Worksheet ' dto.
Set xlApp = CreateObject("Excel.Application")
If Err Then
MsgBox "Excel-Anwendung kann nicht erstellt werden", vbCritical
Exit Sub
End If
' Der Pfad und der Name der Arbeitsmappe sind anzupassen
xlApp.Workbooks.Open "C:\Temp\OutlookEingang.xls"
' Hier wird auf das erste Blatt der Arbeitsmappe zugegriffen
Set xlSheet = xlApp.Sheets(1)
' Excel wird zu Testzwecken in den Vordergrund gebracht
xlApp.Visible = True
intLastRow = Cells(Rows.Count, 1).End(xlUp).Row
If intLastRow <= 1 Then
' Überschriften
[A1].Value = "Betreff"
[B1].Value = "Datum Uhrzeit"
[C1].Value = "empfangen von"
[D1].Value = "gelesen"
[E1].Value = "Dateianhänge"
Rows(1).Font.Bold = True
End If
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' Hier wird jede neue Mail in die Liste aufgenommen
' es müßte dann eine If-Abfrage nach z.B. UCase(LEFT(.SenderName, 4)) = "JINX"
' statt .UnRead kommen
For Each objNewMail In objPosteingang.Items
With objNewMail
If .UnRead = True Then
intLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(intLastRow, 1).Value = .Subject
Cells(intLastRow, 2).Value = .ReceivedTime
Cells(intLastRow, 3).Value = .SenderName
Cells(intLastRow, 4).Value = Not .UnRead
Cells(intLastRow, 5).Value = .Attachments.Count
End If
End With
Next objNewMail
Columns("B:E").AutoFit
' Mappe wird gespeichert
ActiveWorkbook.Save
' Excel-Instanz wird geschlossen
xlApp.Application.Quit
' Freigabe
Set xlApp = Nothing
Set xlSheet = Nothing
End Sub
Code eingefügt mit Syntaxhighlighter 1.15
cu
jinx