Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema ListBox
BildScreenshot zu ListBox ListBox-Seite mit Beispielarbeitsmappe aufrufen

Email-Infos aus Outlook ins Excel einlesen

Betrifft: Email-Infos aus Outlook ins Excel einlesen von: Pascal
Geschrieben am: 23.11.2012 11:28:38

Guten Tag zusammen
Mal wieder stehe ich vor einer für mich unmöglich erscheinenden Aufgabe:
Aus Excel raus soll ein Makro gestartet werden, welches mir aus meinem Outlook 2010 alle Emails aus einem bestimmten Ordner ausliest.
Und zwar brauch ich dann in Excel nicht den Inhalt der Emails sondern nur die Werte:
Von wem das Email stammte
Betreff des Emails
Erhalten (wann hab ich das Email erhalten (Datum; Zeit)
Geht das irgendwie ?
Hat evt. jemand einen möglichen Lösungsvorschlag ?
Im voraus Herzlichen Dank !

  

Betrifft: AW: Email-Infos aus Outlook ins Excel einlesen von: Marc
Geschrieben am: 23.11.2012 11:54:19

Moin!
Hast du ein Glück!!!

Sub Outlook_InBox_Check()
 
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual

    Dim numMails As Long, i As Long, Email As Long
    Set OLF = CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6)
    numMails = OLF.Items.Count
    Sheets(1).[A:E].ClearContents
    zeil = 2
    
    'Sheets(1).Cells(1, 1) = "index"
    Sheets(1).Cells(1, 1) = "Absender"
    Sheets(1).Cells(1, 2) = "Betreff"
    Sheets(1).Cells(1, 3) = "erhalten (Datum)"
    Sheets(1).Cells(1, 4) = "erhalten (Zeit)"
    Sheets(1).Cells(1, 5) = "NETTO Bearbeitungszeit"
    
    'Sheets(1).Cells(1, 5) = "letzte Bearbeitung"
    'Sheets(1).Cells(1, 6) = "BRUTTO Bearbeitungszeit"
    'Sheets(1).Cells(1, sp + 6) = kenn
    
    'Tage vorm WE
    'Sheets(1).Cells(1, 7) = "Bearb ins WE"
    'Sheets(1).Cells(1, 8) = "Bearb aus WE"
    'Sheets(1).Cells(1, 9) = "Tage aus volle WE"

    'Application.ScreenUpdating = False
    While i < numMails
        i = i + 1
        Application.StatusBar = "Lese Posteingang " & Format(i / numMails, "0%")
        With OLF.Items(i)
            
            'If i = 60 Then Stop
            sp = 0
             
            If .Class = 43 Then
                eing = .itemproperties.Item(46)
                Bearb = .itemproperties.Item(17)
                kenn = .itemproperties.Item(38)
                
                If eing <> Bearb And kenn = 1 Then
                
                    zeitraum = Bearb - eing
                    Anfangs_WE = IIf(Weekday(eing, 2) >= 5, Abs(-7 + Weekday(eing, 2)), 0)
                    Ende_WE = IIf(Weekday(Bearb, 2) <= 2 And zeitraum > 3, 2, 0)
                    WE_s = IIf(zeitraum > 7, Fix(zeitraum / 7), 0)
    
                    Sheets(1).Cells(zeil, sp + 1) = .SenderName
                    Sheets(1).Cells(zeil, sp + 2) = .Subject
                    
                    Sheets(1).Cells(zeil, sp + 3) = Format(eing, "dd.mm.yyyy")
                    
                    Sheets(1).Cells(zeil, sp + 4) = Format(eing, "hh:mm")
                    Sheets(1).Cells(zeil, sp + 5) = Bearb - eing - IIf(Bearb - eing > 2,  _
Anfangs_WE - Ende_WE, 0) - WorksheetFunction.Max((WE_s * 2) - Anfangs_WE - Ende_WE, 0)
                    
                    'Sheets(1).Cells(zeil, sp + 4) = Format(Bearb, "ddd dd.mm.yy   -   hh:mm")
                    'Sheets(1).Cells(zeil, sp + 5) = zeitraum
                    'Sheets(1).Cells(zeil, sp + 6) = kenn
                    'Sheets(1).Cells(zeil, sp) = i
                    
                    'Tage vorm WE
                    'Sheets(1).Cells(zeil, sp + 6) = Anfangs_WE
                    'Sheets(1).Cells(zeil, sp + 7) = Ende_WE
                    'Sheets(1).Cells(zeil, sp + 8) = WorksheetFunction.Max((WE_s * 2) -  _
Anfangs_WE - Ende_WE, 0)
                    
                    zeil = zeil + 1
                End If
            End If
        End With
    Wend
    
    '########################################################################################### _
############
    
    Dim ChosenFolder As Object
        
Auswahl:
    Application.ScreenUpdating = True
    Mehr_lesen = MsgBox("Möchtest Du einen weiteren Ordner durchsuchen?", vbYesNo + vbQuestion,  _
"Weiteren Ordner wählen")
    Application.ScreenUpdating = False
    If Mehr_lesen = vbYes Then
    
        Set ChosenFolder = CreateObject("Outlook.Application").GetNamespace("MAPI").PickFolder
        If ChosenFolder Is Nothing Then MsgBox ("Du hast keinen weiteren Ordner ausgewählt!"):  _
GoTo Ende:
        
        numMails = ChosenFolder.Items.Count
        i = 0
        
        While i < numMails
            i = i + 1
            Application.StatusBar = "Lese " & ChosenFolder.fullfolderpath & Format(i / numMails, _
 " 0%")
            On Error Resume Next
            With ChosenFolder.Items(i)
                sp = 0
                
                If .Class = 43 Then
                    eing = .itemproperties.Item(46)
                    Bearb = .itemproperties.Item(17)
                    kenn = .itemproperties.Item(38)
                    
                    If eing <> Bearb And kenn = 1 Then 'nur bearbeitete und als erledigt  _
gekennzeichnet.
                        zeitraum = Bearb - eing
                        Anfangs_WE = IIf(Weekday(eing, 2) >= 5, Abs(-7 + Weekday(eing, 2)), 0)
                        
                        Ende_WE = IIf(Weekday(Bearb, 2) <= 2 And zeitraum > 4, 2, 0)
                        WE_s = IIf(zeitraum > 7, Fix(zeitraum / 7), 0)
                        
                        If zeitraum > 2 Then
                            zeitraum = zeitraum - Anfangs_WE
                        Else
                            zeitraum = zeitraum - Ende_WE - WorksheetFunction.Max((WE_s * 2) -  _
Anfangs_WE - Ende_WE, 0)
                        End If
        
                        Sheets(1).Cells(zeil, sp + 1) = .SenderName
                        Sheets(1).Cells(zeil, sp + 2) = .Subject
                        Sheets(1).Cells(zeil, sp + 3) = Format(eing, "dd.mm.yyyy")
                        Sheets(1).Cells(zeil, sp + 4) = Format(eing, "hh:mm")
                        Sheets(1).Cells(zeil, sp + 5) = zeitraum
                        
                        If Sheets(1).Cells(zeil, sp + 5) < 0 Then Sheets(1).Cells(zeil, sp + 5). _
Interior.ColorIndex = 3
                        
                        zeil = zeil + 1
                    End If
                End If
            End With
        Wend
        
        GoTo Auswahl
    End If
    
Ende:
    
    '########################################################################################### _
############
    Columns("C:C").TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)
    [c:E].Columns.AutoFit
    Set OLF = Nothing
    Set ChosenFolder = Nothing
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
End Sub
Gruß, MCO


  

Betrifft: AW: Email-Infos aus Outlook ins Excel einlesen von: Pascal
Geschrieben am: 23.11.2012 12:30:01

Hallo
das ging aber Superhyperschnell :-)
werde mir den Code gleich mal austesten und näher anschaun.
VIELEN VIELEN HERZLICHEN DANK SCHON MAL !!!


 

Beiträge aus den Excel-Beispielen zum Thema "Email-Infos aus Outlook ins Excel einlesen"