Mail in Excel bereitstellen
23.02.2007 10:03:42
Anthony
Ein bestimmter Ordner in Outlook soll ausgelesen werden und in einem Excel Workbook ausgegeben werden. Falls die Kurzform in der Listbox Interessant ist soll ein Klick auf den jeweiligen Eintrag genügen um die Mail zu öffnen.
Nur glaube ich hierfür nicht den richtigen Code zu haben. Außerdem soll die Excel Datei in einem Abstand von 5 Minuten das Postfach nach neuen Mails befragen (Ist hier nicht angegeben aber das war dann der Plan)....
Geht so etwas überhaupt - ich glaube nämlich immer mehr das ich mir zu viel wünsche...
Option Explicit
Sub ListBox_Fill_With_Outlook_Contacts()
Dim myOutlook As Object
Dim conId As Integer
Dim conFolder As Object
Dim conItem As Object
Dim Qe As Integer
Dim ErrMsg As String
Application.StatusBar = " . . . die Adressen werden aus Outlook eingelesen"
Set myOutlook = CreateObject("Outlook.Application")
Set conFolder = myOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Sheets("Tabelle1").ListBox1.ColumnCount = 7
Sheets("Tabelle1").ListBox1.ColumnWidths = "70; 70; 28; 70; 28; 70; 70"
For conId = 1 To conFolder.Items.Count
Set conItem = conFolder.Items(conId)
With conItem
Sheets("Tabelle1").ListBox1.AddItem " "
On Error GoTo conError
Sheets("Tabelle1").ListBox1.List(conId - 1, 0) = .FirstName & " " & .LastName
Application.StatusBar = "Datensatz " & conId & " von " & conFolder.Items.Count & " wird gelesen: " & .FirstName
If .BusinessAddressPostOfficeBox = "" Then
Sheets("Tabelle1").ListBox1.List(conId - 1, 1) = .BusinessAddressStreet
Else
Sheets("Tabelle1").ListBox1.List(conId - 1, 1) = .BusinessAddressPostOfficeBox
End If
Sheets("Tabelle1").ListBox1.List(conId - 1, 2) = .BusinessAddressPostalCode
Sheets("Tabelle1").ListBox1.List(conId - 1, 3) = .BusinessAddressCity
Sheets("Tabelle1").ListBox1.List(conId - 1, 4) = .CustomerID
Sheets("Tabelle1").ListBox1.List(conId - 1, 5) = .AssistantName
Sheets("Tabelle1").ListBox1.List(conId - 1, 6) = .MiddleName
errorStepin:
End With
Next conId
ErrorExit:
Set conItem = Nothing
Set conFolder = Nothing
Set myOutlook = Nothing
Application.DisplayAlerts = True
Application.StatusBar = False
Exit Sub
conError:
Select Case Err
Case 438
Set conItem = conFolder.Items(conId)
ErrMsg = "Datensatz " & conId & " ist korrupt, oder untestützt die Abfrage nicht."
ErrMsg = ErrMsg & vbCrLf & "Datensatzkennung:"
ErrMsg = ErrMsg & vbCrLf & "Erstelldatum: " & conItem.CreationTime
ErrMsg = ErrMsg & vbCrLf & "ObjectID" & conItem.EntryID
ErrMsg = ErrMsg & vbCrLf
ErrMsg = ErrMsg & vbCrLf & "Löschen ? "
Qe = MsgBox(ErrMsg, vbYesNo + vbCritical + vbDefaultButton2, "Datenfehler")
If Qe = vbYes Then
conItem.Delete
MsgBox ("Datensatz " & conId & " wurde gelöscht")
Resume errorStepin
Else
MsgBox "Datenimport wegen Datenfehler bei Datensatz " & conId & " abgebrochen"
Resume ErrorExit
End If
Case Else
MsgBox Err & ": " & Err.Description
Resume ErrorExit
End Select
End Sub