|
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.
|