Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1240to1244
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

@ Sepp: Kennst Du

@ Sepp: Kennst Du
Claudia
Dich mit Outlook? Ich hoffe Du kannst mir auch dieses Mal helfen.
Ich bin auf der Suche nach einem Excel-Makro, was sämtliche Ordner in Outlook "auswertet" und in Excel einstellt.
Pro Outlook-Ordner soll ein Excel-Blatt angelegt werden. Hier sollen dann die Mails mit dem entsprechenden Betreff aufgelistet werden. Zusätzlich angereichert um die Größe und wenn möglich Sender und Empfänger.
Wäre sowas machbar?
Liebe Grüße
Claudia

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: @ Sepp: Kennst Du
15.12.2011 21:26:06
Josef

Hallo Claudia,
anbei mal ein Versuch.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Dim objSh As Worksheet
Dim lngRow As Long

Sub ListOutlookMails()
  Dim olApp As Object, objFolder As Object
  
  Set olApp = CreateObject("outlook.application")
  Set objFolder = olApp.GetNameSpace("MAPI") '.GetDefaultFolder(6)
  
  
  getInfo objFolder
  
  
  Set objFolder = Nothing
  Set olApp = Nothing
End Sub



Sub getInfo(objFolder As Object)
  Dim objItem As Object, objFo As Object
  
  On Error Resume Next
  
  For Each objItem In objFolder.Items
    If Not objItem Is Nothing Then
      If Clng(objItem.Class) = 43 Then
        If Not objSh Is Nothing Then
          If objSh.Name <> objFolder.Name Then Set objSh = Nothing
        End If
        If objSh Is Nothing Then
          If Not SheetExist(objFolder.Name) Then
            Set objSh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            With objSh
              .Name = objFolder.Name
              .Range("A1:E1") = Array("Datum", "Betreff", "Absender", "Empfänger", "Größe (kb)")
              .Range("A1:E1").Font.Bold = True
              .Range("A1:E1").ColumnWidth = 13
              .Columns(2).ColumnWidth = 70
              .Columns(3).ColumnWidth = 20
              .Columns(4).ColumnWidth = 20
            End With
          Else
            Set objSh = Sheets(objFolder.Name)
          End If
        End If
        lngRow = Application.Max(2, objSh.Cells(objSh.Rows.Count, 1).End(xlUp).Row + 1)
        objSh.Cells(lngRow, 1) = CDate(Clng(objItem.ReceivedTime))
        objSh.Cells(lngRow, 2) = objItem.Subject
        objSh.Cells(lngRow, 3) = objItem.SenderEmailAddress
        objSh.Cells(lngRow, 4) = objItem.To
        objSh.Cells(lngRow, 5) = Round(objItem.Size / 1024, 2)
      End If
    End If
  Next
  
  For Each objFo In objFolder.Folders
    getInfo objFo
  Next
  
  On Error GoTo 0
  
  Set objItem = Nothing
  Set objFo = Nothing
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function



« Gruß Sepp »

Anzeige
AW: @ Sepp: Kennst Du
15.12.2011 21:40:08
Claudia
Hallo Sepp,
mal wieder genial.
Allerdings stelle ich fest, dass das auslesen aller Ordner keinen Sinn macht, da wir auf der Arbeit auch öffentliche Ordner haben, mit denen ich aber gar nichts zu tun habe. Das Makro greift hierbei nur auf die öffentlichen Ordner zu.
Kann man irgendwo festlegen, welche Ordner ausgelesen werden sollen? Also ich habe beispielsweise mein Postfach und darunter hängen meine persönlichen Ordner. Wenn das klappen würde, dann wäre das super.
Liebe Grüße
Claudia
AW: @ Sepp: Kennst Du
15.12.2011 21:57:45
Josef

Hallo Claudia,
mach das Hochkomma (') vor .GetDefaultFolder(6) weg und probiere es dann noch einmal.

« Gruß Sepp »

Anzeige
AW: @ Sepp: Kennst Du
16.12.2011 16:39:48
Claudia
Hallo Sepp,
konnte ich erst gerade ausprobieren. Habe Spätdienst.
Mit der Änderung wird mir nun nur mein Posteingang ausgelesen, meine eigenen Ordner leider nicht.
Ich denke, dass liegt an den tollen Einstellungen meines AG. Hast Du noch eine Idee?
Auf alle Fälle vielen vielen Dank jetzt schon für Deine Hilfe!
Liebe Grüße
Claudia
AW: @ Sepp: Kennst Du
16.12.2011 17:23:41
Josef

Hallo Claudia,
sind deine Ordner Unterordner des Posteinganges?
Oder wie heißt der deinen Ordnern übergeordnete Ordner?

« Gruß Sepp »

Anzeige
AW: @ Sepp: Kennst Du
16.12.2011 17:43:34
Claudia
Hallo Sepp,
der heisst "Postfach - Name, Vorname".
Darunter sind sowohl der Posteingang als auch meine eigenen Ordner.
Liebe Grüße
Claudia
AW: @ Sepp: Kennst Du
16.12.2011 17:52:56
Josef

Hallo Claudia,
probiere es so.
Sub ListOutlookMails()
  Dim olApp As Object, objFolder As Object
  
  Set olApp = CreateObject("outlook.application")
  Set objFolder = olApp.GetNameSpace("MAPI") '.GetDefaultFolder(6)
  
  
  getInfo objFolder.Folders("dein Ordner") 'deinen Ordner angeben!
  
  
  Set objFolder = Nothing
  Set olApp = Nothing
End Sub



« Gruß Sepp »

Anzeige
AW: @ Sepp: Kennst Du
16.12.2011 18:03:15
Claudia
Hallo Sepp,
Du bist mal wieder mein Held. Es funktioniert. Juhu! :-)
Zwei Fragen noch:
In Spalte C stehen vemutlich Personalnummern.
In Spalte D stehen die richtigen Namen.
Geht das in C auch?
Zweite Frage: Kannst Du auf die Mail ein Hyperlink einbauen, so dass ich die Mail direkt aufrufen kann?
Dann wäre ich super glücklich. :-)
Vielen lieben Dank!
AW: @ Sepp: Kennst Du
16.12.2011 21:22:37
Josef

Hallo Claudia,
normaler Link geht nicht, bzw. wüsste ich nicht wie.
In Spalte A (vor dem Datum) werden Shapes (Sterne) angelegt, beim Anklicken wird die Mail geöffnet.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Dim objSh As Worksheet
Dim lngRow As Long

Sub ListOutlookMails()
  Dim olApp As Object, objFolder As Object
  
  Set olApp = CreateObject("outlook.application")
  Set objFolder = olApp.GetNameSpace("MAPI") '.GetDefaultFolder(6)
  
  
  getInfo objFolder.Folders("dein Ordner") 'Ordner angeben!
  
  
  Set objFolder = Nothing
  Set olApp = Nothing
End Sub



Sub getInfo(objFolder As Object)
  Dim objItem As Object, objFo As Object
  Dim objShp As Shape
  
  On Error Resume Next
  
  For Each objItem In objFolder.Items
    If Not objItem Is Nothing Then
      If Clng(objItem.Class) = 43 Then
        If Not objSh Is Nothing Then
          If objSh.Name <> objFolder.Name Then Set objSh = Nothing
        End If
        If objSh Is Nothing Then
          If Not SheetExist(objFolder.Name) Then
            Set objSh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            With objSh
              .Name = objFolder.Name
              .Range("A1:E1") = Array("Datum", "Betreff", "Absender", "Empfänger", "Größe (kb)")
              .Range("A1:E1").Font.Bold = True
              .Range("A1:E1").ColumnWidth = 13
              .Columns(2).ColumnWidth = 70
              .Columns(3).ColumnWidth = 20
              .Columns(4).ColumnWidth = 20
            End With
          Else
            Set objSh = Sheets(objFolder.Name)
          End If
        End If
        lngRow = Application.Max(2, objSh.Cells(objSh.Rows.Count, 1).End(xlUp).Row + 1)
        objSh.Cells(lngRow, 1) = CDate(Clng(objItem.ReceivedTime))
        objSh.Cells(lngRow, 2) = objItem.Subject
        objSh.Cells(lngRow, 3) = IIf(Len(objItem.Sender.Name), objItem.Sender.Name, objItem.Sender.Address)
        objSh.Cells(lngRow, 4) = objItem.To
        objSh.Cells(lngRow, 5) = Round(objItem.Size / 1024, 2)
        Set objShp = objSh.Shapes.AddShape(msoShape5pointStar, 5#, objSh.Cells(lngRow, 1).Top + 2, objSh.Cells(lngRow, 1).Height - 2, objSh.Cells(lngRow, 1).Height - 2)
        objShp.Line.Visible = msoFalse
        objShp.OnAction = "openMail"
        objShp.AlternativeText = objItem.EntryID
      End If
    End If
  Next
  
  For Each objFo In objFolder.Folders
    getInfo objFo
  Next
  
  On Error GoTo 0
  
  Set objItem = Nothing
  Set objFo = Nothing
End Sub


Sub openMail()
  Dim olApp As Object, objMAPI As Object, objMail As Object
  Dim strID As String
  
  strID = ActiveSheet.Shapes(Application.Caller).AlternativeText
  
  Set olApp = CreateObject("outlook.application")
  Set objMAPI = olApp.GetNameSpace("MAPI") '.GetDefaultFolder(6)
  
  
  Set objMail = objMAPI.GetItemFromID(strID)
  objMail.Display
  
  Set objMail = Nothing
  Set objMAPI = Nothing
  Set olApp = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function



« Gruß Sepp »

Anzeige
Nachtrag
16.12.2011 22:28:58
Josef

Hallo Claudia,
füge im Code nach der Zeile
objShp.AlternativeText = objItem.EntryID

noch
objShp.Placement = xlMove

ein, damit die "Sterne" beim sortieren der Liste mit sortiert werden.

« Gruß Sepp »

Anzeige
AW: Nachtrag
17.12.2011 19:14:05
Claudia
Hallo Sepp,
irgendwas funktioniert nun nicht mehr.
Das Datum wird nicht mehr angezteigt und Sender und Empfäner auch nicht, nur der Betreff
Versuche ich die Mail zu öffnen" kommt ein Laufzeitfehler.
Das Element onnte nicht geöffnet werden. Versuchen Sie es noch einmal.
Liebe Grüße
Claudia
PS: Das passiert mit und ohne Nachtrag.
AW: Nachtrag
17.12.2011 19:15:28
Claudia
Im code bleibt er an dieser Stelle stecken:
Sub openMail()
Dim olApp As Object, objMAPI As Object, objMail As Object
Dim strID As String
strID = ActiveSheet.Shapes(Application.Caller).AlternativeText
Set olApp = CreateObject("outlook.application")
Set objMAPI = olApp.GetNameSpace("MAPI") '.GetDefaultFolder(6)
  Set objMail = objMAPI.GetItemFromID(strID)
objMail.Display
Set objMail = Nothing
Set objMAPI = Nothing
Set olApp = Nothing
End Sub

Anzeige
Hat sich erledigt, ich hatte einen
17.12.2011 19:29:45
Claudia
Kopierfehler drin.
Danke schön!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige