VBA Outlook Daten in Excel eintragen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: VBA Outlook Daten in Excel eintragen
von: Simon
Geschrieben am: 28.05.2015 16:11:32

Hallo,

ich fange gerade mit Outlook VBA und Excel ein. Möchte eine E-Mail von Outlook nach Excel übertragen.

Das klappt soweit auch ganz gut, bis auf ein paar Einschränkungen.

Erstmal mein Code:

Option Explicit


Sub CopyToExcel()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim oRng As Range
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Dim myTime As String
 
Const strPath As String = "\\xxxxxxxxx\ixxxxx\XXXX\xxxxx\xxxxxxxx\Auftrag.xlsx" 'the path of  _
the workbook
 
If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
    Application.StatusBar = "Please wait while Excel source is opened ... "
    Set xlApp = CreateObject("Excel.Application")
    bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Q1 2015")
 
'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
    rCount = rCount + 1
 
    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
        If InStr(1, vText(i), "Kundennummer:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("A" & rCount) = Trim(vItem(1))
        End If
 
        If InStr(1, vText(i), "Tarif") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
        End If
 
        If InStr(1, vText(i), "Eingabedatum") > 0 Then
            vItem = Split(vText(i), Chr(58))
            myTime = olItem.ReceivedTime
            xlSheet.Range("A" & rCount) = myTime
            xlSheet.Range("C" & rCount) = Trim(vItem(1))
        End If
 
        If InStr(1, vText(i), "Widerruf") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H" & rCount) = Trim(vItem(1))
        End If
 
        If InStr(1, vText(i), "Termin") > 0 Then
            vItem = Split(vText(i), Chr(58))
            myTime = olItem.ReceivedTime
            xlSheet.Range("J" & rCount) = Trim(vItem(1))
        End If
 
    Next i
    xlWB.Save
Next olItem
 
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub



Mein Problem: Es wird immer nur die aktuellste E-Mail in Excel übertragen. Es sollen aber alle E-Mails ausgelesen werden. Weiß jemand wie ich das schreibe?

Problem Nummer 2: Die E-Mail soll einen Betreff haben, dies geht aber mit dem Code da oben nicht. Weiß jemand wie ich einen bestimmten Betreff hinzufügen kann?

Problem Nummer 3:

Bei diesem Code: Hier steht in der E-Mail ein Datum. Dieser wird auch richtig in Excel eingegeben, allerdings von Excel erst dann als Datum erkannt, wenn ich einmal in die Zelle reinklicke. Vorher scheint es für Excel nur eine Zahl zu sein.

If InStr(1, vText(i), "Termin") > 0 Then
vItem = Split(vText(i), Chr(58))
myTime = olItem.ReceivedTime
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If


Wenn mir hier jemand helfen kann, dann wäre euch sehr sehr dankbar.

Bild

Betrifft: AW: VBA Outlook Daten in Excel eintragen
von: mumpel
Geschrieben am: 28.05.2015 20:03:31
Hallo!
Das wird schwierig wenn Du kein VBA kannst. Um alle Emails auszulesen muss man eine Schleife einbauen.
Hier mal ein Beispiel wie man alle Emails im angegebenen Ordner ansprechen kann.

Dim olApp          As Outlook.Application
Dim olName         As Outlook.Namespace
Dim olFolder       As Outlook.MAPIFolder
Dim Items          As Outlook.Items

Dim iInt           As Long

Dim lngItemsCount  As Long


   
   Set olApp = Application
   Set olName = olApp.GetNamespace("MAPI")
   Set olFolder = olName.Session.Folders("RMH Software").Folders("Posteingang")
   

       Set Application.ActiveExplorer.CurrentFolder = olFolder
           Set Items = olFolder.Items
               For iInt = Items.Count To 1 Step -1
                   Rem Hier der Code zum Auslesen 
               Next iInt

VBA/HTML - CodeConverter für Office-Foren, AddIn für Office 2002-2013 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:mumpel

Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

Du solltest Dich erstmal mit VBA befassen. Sonst wird es eine schwere Arbeit für mich/uns.
Gruß, René

Bild

Betrifft: AW: VBA Outlook Daten in Excel eintragen
von: mumpel
Geschrieben am: 28.05.2015 20:46:51
Zu Problem 3: Die Zellen bereits vorher (standardmäßig) als Datum formatieren.
Zu Problem 2: Wie genau meinst Du das?
Zu Problem 1: Auf die Schnelle mal eine Anpassung für alle Emails im angegebenen Ordner (Ordnernamen musst Du noch anpassen). Der Code ist ungetestet.

Sub CopyToExcel()

Dim olApp          As Outlook.Application
Dim olName         As Outlook.Namespace
Dim olFolder       As Outlook.MAPIFolder
Dim olItems        As Outlook.MailItem

Dim xlApp          As Excel.Application
Dim xlWB           As Excel.Workbook
Dim xlSheet        As Excel.Worksheet

Dim vText          As Variant
Dim vItem          As Variant

Dim iInhalt        As Long
Dim rCount         As Long
Dim iInt           As Long

Dim myTime         As String
Dim sText          As String
Const strPath      As String = "C:\Auftrag.xlsx"
  
   
   Set olApp = Application
   Set olName = olApp.GetNamespace("MAPI")
   Set olFolder = olName.Session.Folders("RMH Software").Folders("Posteingang")
   
       On Error Resume Next
           Set xlApp = GetObject(, "Excel.Application")
               If Err <> 0 Then Set xlApp = CreateObject("Excel.Application")
       On Error GoTo 0
           Set xlWB = xlApp.Workbooks.Open(strPath)
           Set xlSheet = xlWB.Sheets("Q1 2015")
                 Set Application.ActiveExplorer.CurrentFolder = olFolder
                     Set olItems = olFolder.Items
                         For iInt = olItems.Count To 1 Step -1
                             sText = olFolder.Items(iInt).Body
                             vText = Split(sText, Chr(13))
                             rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row + 1
                             For iInhalt = Ubound(vText) To 0 Step -1
                                 If InStr(1, vText(iInhalt), "Kundennummer:") > 0 Then
                                    vItem = Split(vText(iInhalt), Chr(58))
                                    xlSheet.Range("A" & rCount) = Trim(vItem(1))
                                 End If
                                 If InStr(1, vText(iInhalt), "Tarif") > 0 Then
                                    vItem = Split(vText(iInhalt), Chr(58))
                                    xlSheet.Range("B" & rCount) = Trim(vItem(1))
                                 End If
                                 If InStr(1, vText(iInhalt), "Eingabedatum") > 0 Then
                                    vItem = Split(vText(iInhalt), Chr(58))
                                    myTime = olFolder.Items(iInt).ReceivedTime
                                    xlSheet.Range("A" & rCount) = myTime
                                    xlSheet.Range("C" & rCount) = Trim(vItem(1))
                                 End If
                                 If InStr(1, vText(iInhalt), "Widerruf") > 0 Then
                                    vItem = Split(vText(iInhalt), Chr(58))
                                    xlSheet.Range("H" & rCount) = Trim(vItem(1))
                                 End If
                                 If InStr(1, vText(iInhalt), "Termin") > 0 Then
                                    vItem = Split(vText(iInhalt), Chr(58))
                                    myTime = olFolder.Items(iInt).ReceivedTime
                                    xlSheet.Range("J" & rCount) = Trim(vItem(1))
                                 End If
                             Next iInhalt
                         Next iInt
               xlWB.Save
End Sub

VBA/HTML - CodeConverter für Office-Foren, AddIn für Office 2002-2013 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:mumpel

Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0



 Bild

Beiträge aus den Excel-Beispielen zum Thema "VBA Outlook Daten in Excel eintragen"