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