Autor: Rainer Beckerbauer (Ramses) --- Aus Excel VBA - Gruppe: Outlook & Excel
Senden einer EXCEL Kontakt-Datenliste nach Outlook
Diese Daten können auch von Outlook direkt importiert werden, allerdings muss der Datenbereich
mit einem Namen benannt sein und sie müssen die Kontakfelder umständlich zuordnen.
Mit diesem Code können Sie das ganze auch von EXCEL aus steuern.
Dazu benötigen Sie eine Tabelle mit folgender Datenstruktur
Dann können Sie mit dem nachfolgenden Code Ihre Daten aus EXCEL direkt nach Outlook senden:
Weitere Artikel der Gruppe: Outlook & Excel Aus Excel VBA
Nach oben
Outlook und Excel (5) Adressbuch und Kontakte
Autor: Rainer Beckerbauer (Ramses) - Erstellt: -- - Letzte Revision: --Gruppenthema: 6 Folgen 1 2 3 4 5 6 Sie sind in Folge:5
Listbox füllen mit Daten aus dem Outlook Adressbuch
In dieser Übung werden wir das Adressbuch von Outlook auslesen, und die wichtigsten Daten in einer Userform-Listbox darstellen.
Die Kontaktdaten können in der Listbox ausgewählt und weiter verwendet werden.
Für diese Übung benötigen Sie folgendes:
Eine leere Mappe
Eine Userform mit:
1 Commandbutton
1 Listbox
Wenn Sie die Userform erstellt haben, fügen Sie den folgenden Code in den Commandbutton ein.
In dieser Übung werden wir das Adressbuch von Outlook auslesen, und die wichtigsten Daten in einer Userform-Listbox darstellen.
Die Kontaktdaten können in der Listbox ausgewählt und weiter verwendet werden.
Für diese Übung benötigen Sie folgendes:
Eine leere Mappe
Eine Userform mit:
1 Commandbutton
1 Listbox
Wenn Sie die Userform erstellt haben, fügen Sie den folgenden Code in den Commandbutton ein.
Private Sub CommandButton1_Click()
'(C) by Ramses
'Verweis auf die Outlook Library muss gesetzt sein
'Variablen Deklaration
Dim MyOutId As Integer
Dim MyOutFolder As Object
Dim MyOutApp As Object
Dim MyConItem As Object
Dim Qe As Integer
Dim ErrMsg As String
'Bildschirmaktualisierung ausschalten
'Application.DisplayAlerts = False
'... und Statusbar-Info ausgeben
Application.StatusBar = " die Adressen werden aus Outlook geholt " _
& " - das kann einen Moment dauern."
'Object Deklaration
Set MyOutApp = CreateObject("Outlook.Application")
'Zugriff auf die MAPI Schnittstelle
Set MyOutFolder = MyOutApp.GetNamespace("MAPI").GetDefaultFolder(10)
'Zuweisen der Anzahl Spalten in der Listbox
Me.ListBox1.ColumnCount = 7
'Zuweisen der Spaltenbreite in Pt
'1 cm ~ 28,3 Pt
Me.ListBox1.ColumnWidths = "70; 70; 28; 70; 28; 70; 70"
'Einlesen der Daten
For MyOutId = 1 To MyOutFolder.Items.Count
'Zuweisen des Object für jeden Contact
Set MyConItem = MyOutFolder.Items(MyOutId)
'Einlesen des Contacts beginnen
With MyConItem
'Neuen Eintrag in Listbox einfügen
Me.ListBox1.AddItem " "
'ListIndex - 1 um auf das vorher erzeugte Item zuzugreifen
On Error GoTo conError
Me.ListBox1.List(MyOutId - 1, 0) = .FirstName & " " & .LastName
'Statusbar Information anzeigen
'um den Benutzer den Fortschritt anzuzeigen
Application.StatusBar = "Datensatz " & MyOutId & " von " & MyOutFolder.Items.Count & " wird gelesen: " & .FirstName
If .BusinessAddressPostOfficeBox = "" Then
Me.ListBox1.List(MyOutId - 1, 1) = .BusinessAddressStreet
Else
Me.ListBox1.List(MyOutId - 1, 1) = .BusinessAddressPostOfficeBox
End If
Me.ListBox1.List(MyOutId - 1, 2) = .BusinessAddressPostalCode
Me.ListBox1.List(MyOutId - 1, 3) = .BusinessAddressCity
Me.ListBox1.List(MyOutId - 1, 4) = .CustomerID
Me.ListBox1.List(MyOutId - 1, 5) = .AssistantName
Me.ListBox1.List(MyOutId - 1, 6) = .MiddleName
ErrorStepin:
End With
Next MyOutId
ErrorExit:
'Object Variablen leeren
Set MyConItem = Nothing
Set MyOutFolder = Nothing
Set MyOutApp = Nothing
'Bildschirm einschalten
Application.DisplayAlerts = True
'Statusbar zurücksetzen
Application.StatusBar = False
Exit Sub
conError:
Select Case Err
Case 438
'Es kann sein, dass ein Datensatz korrupt ist, aber in Outlook korrekt angezeigt wird
'Allerdings können diese Datensätze nicht mit externen Geräte synchronisiert werden
Set MyConItem = MyOutFolder.Items(MyOutId)
ErrMsg = "Datensatz " & MyOutId & " ist korrupt, oder unterstützt die Abfrage nicht."
ErrMsg = ErrMsg & vbCrLf & "Datensatzkennung:"
ErrMsg = ErrMsg & vbCrLf & "Erstelldatum: " & MyConItem.CreationTime
ErrMsg = ErrMsg & vbCrLf & "ObjectID" & MyConItem.EntryID
ErrMsg = ErrMsg & vbCrLf
ErrMsg = ErrMsg & vbCrLf & "Löschen ? "
Qe = MsgBox(ErrMsg, vbYesNo + vbCritical + vbDefaultButton2, "Datenfehler")
If Qe = vbYes Then
MyConItem.Delete
MsgBox ("Datensatz " & MyOutId & " wurde gelöscht")
'Listenzählung korrigieren
MyOutId = MyOutId + 1
Me.ListBox1.ListIndex(MyOutId).Delete
Resume ErrorStepin
Else
MsgBox "Datenimport wegen Datenfehler bei Datensatz " & MyOutId & " abgebrochen"
Resume ErrorExit
End If
Case Else
MsgBox Err & ": " & Err.Description
Resume ErrorExit
End Select
End Sub
'(C) by Ramses
'Verweis auf die Outlook Library muss gesetzt sein
'Variablen Deklaration
Dim MyOutId As Integer
Dim MyOutFolder As Object
Dim MyOutApp As Object
Dim MyConItem As Object
Dim Qe As Integer
Dim ErrMsg As String
'Bildschirmaktualisierung ausschalten
'Application.DisplayAlerts = False
'... und Statusbar-Info ausgeben
Application.StatusBar = " die Adressen werden aus Outlook geholt " _
& " - das kann einen Moment dauern."
'Object Deklaration
Set MyOutApp = CreateObject("Outlook.Application")
'Zugriff auf die MAPI Schnittstelle
Set MyOutFolder = MyOutApp.GetNamespace("MAPI").GetDefaultFolder(10)
'Zuweisen der Anzahl Spalten in der Listbox
Me.ListBox1.ColumnCount = 7
'Zuweisen der Spaltenbreite in Pt
'1 cm ~ 28,3 Pt
Me.ListBox1.ColumnWidths = "70; 70; 28; 70; 28; 70; 70"
'Einlesen der Daten
For MyOutId = 1 To MyOutFolder.Items.Count
'Zuweisen des Object für jeden Contact
Set MyConItem = MyOutFolder.Items(MyOutId)
'Einlesen des Contacts beginnen
With MyConItem
'Neuen Eintrag in Listbox einfügen
Me.ListBox1.AddItem " "
'ListIndex - 1 um auf das vorher erzeugte Item zuzugreifen
On Error GoTo conError
Me.ListBox1.List(MyOutId - 1, 0) = .FirstName & " " & .LastName
'Statusbar Information anzeigen
'um den Benutzer den Fortschritt anzuzeigen
Application.StatusBar = "Datensatz " & MyOutId & " von " & MyOutFolder.Items.Count & " wird gelesen: " & .FirstName
If .BusinessAddressPostOfficeBox = "" Then
Me.ListBox1.List(MyOutId - 1, 1) = .BusinessAddressStreet
Else
Me.ListBox1.List(MyOutId - 1, 1) = .BusinessAddressPostOfficeBox
End If
Me.ListBox1.List(MyOutId - 1, 2) = .BusinessAddressPostalCode
Me.ListBox1.List(MyOutId - 1, 3) = .BusinessAddressCity
Me.ListBox1.List(MyOutId - 1, 4) = .CustomerID
Me.ListBox1.List(MyOutId - 1, 5) = .AssistantName
Me.ListBox1.List(MyOutId - 1, 6) = .MiddleName
ErrorStepin:
End With
Next MyOutId
ErrorExit:
'Object Variablen leeren
Set MyConItem = Nothing
Set MyOutFolder = Nothing
Set MyOutApp = Nothing
'Bildschirm einschalten
Application.DisplayAlerts = True
'Statusbar zurücksetzen
Application.StatusBar = False
Exit Sub
conError:
Select Case Err
Case 438
'Es kann sein, dass ein Datensatz korrupt ist, aber in Outlook korrekt angezeigt wird
'Allerdings können diese Datensätze nicht mit externen Geräte synchronisiert werden
Set MyConItem = MyOutFolder.Items(MyOutId)
ErrMsg = "Datensatz " & MyOutId & " ist korrupt, oder unterstützt die Abfrage nicht."
ErrMsg = ErrMsg & vbCrLf & "Datensatzkennung:"
ErrMsg = ErrMsg & vbCrLf & "Erstelldatum: " & MyConItem.CreationTime
ErrMsg = ErrMsg & vbCrLf & "ObjectID" & MyConItem.EntryID
ErrMsg = ErrMsg & vbCrLf
ErrMsg = ErrMsg & vbCrLf & "Löschen ? "
Qe = MsgBox(ErrMsg, vbYesNo + vbCritical + vbDefaultButton2, "Datenfehler")
If Qe = vbYes Then
MyConItem.Delete
MsgBox ("Datensatz " & MyOutId & " wurde gelöscht")
'Listenzählung korrigieren
MyOutId = MyOutId + 1
Me.ListBox1.ListIndex(MyOutId).Delete
Resume ErrorStepin
Else
MsgBox "Datenimport wegen Datenfehler bei Datensatz " & MyOutId & " abgebrochen"
Resume ErrorExit
End If
Case Else
MsgBox Err & ": " & Err.Description
Resume ErrorExit
End Select
End Sub
Senden einer EXCEL Kontakt-Datenliste nach Outlook
Diese Daten können auch von Outlook direkt importiert werden, allerdings muss der Datenbereich
mit einem Namen benannt sein und sie müssen die Kontakfelder umständlich zuordnen.
Mit diesem Code können Sie das ganze auch von EXCEL aus steuern.
Dazu benötigen Sie eine Tabelle mit folgender Datenstruktur
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Dann können Sie mit dem nachfolgenden Code Ihre Daten aus EXCEL direkt nach Outlook senden:
Option Explicit
Sub Send_Contact_List()
Dim qWks As Worksheet, i As Integer
Dim MyOutApp As Object, MyOutCon As Object
'Wo stehen die Kontaktdaten
Set qWks = Worksheets("TabelleKontaktdaten")
'Outlook Objekt erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Mit "With" wird auf das Tabellenobjekt referenziert
With qWks
'Zählschleife starten
'Dazu wird der letzten Eintrag in Spalte A bestimmt
'Der Adressenbereich beginn in Zeile 2
'deshalb startet auch die Zählschleife dort
For i = 2 To Range("A65536").End(xlUp).Row
'Outlook Kontaktobject erstellen
Set MyOutCon = MyOutApp.CreateItem(2)
'Eine vollständige Liste der möglichen Felder
'finden Sie in der Outlook-VBA-Hilfe
With MyOutCon
.LastName = Cells(i, 1).Value
.FirstName = Cells(i, 1).Offset(0, 1).Value
.BusinessAddressStreet = Cells(i, 1).Offset(0, 2).Value
.BusinessAddressPostalCode = Cells(i, 1).Offset(0, 3).Value
.BusinessAddressCity = Cells(i, 1).Offset(0, 4).Value
.BusinessAddressCountry = Cells(i, 1).Offset(0, 5).Value
.BusinessAddressState = Cells(i, 1).Offset(0, 6).Value
.Email1Address = Cells(i, 1).Offset(0, 7).Value
.Save
End With
'Object entfernen
Set MyOutCon = Nothing
Next i
End With
Set MyOutApp = Nothing
End Sub
Sub Send_Contact_List()
Dim qWks As Worksheet, i As Integer
Dim MyOutApp As Object, MyOutCon As Object
'Wo stehen die Kontaktdaten
Set qWks = Worksheets("TabelleKontaktdaten")
'Outlook Objekt erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Mit "With" wird auf das Tabellenobjekt referenziert
With qWks
'Zählschleife starten
'Dazu wird der letzten Eintrag in Spalte A bestimmt
'Der Adressenbereich beginn in Zeile 2
'deshalb startet auch die Zählschleife dort
For i = 2 To Range("A65536").End(xlUp).Row
'Outlook Kontaktobject erstellen
Set MyOutCon = MyOutApp.CreateItem(2)
'Eine vollständige Liste der möglichen Felder
'finden Sie in der Outlook-VBA-Hilfe
With MyOutCon
.LastName = Cells(i, 1).Value
.FirstName = Cells(i, 1).Offset(0, 1).Value
.BusinessAddressStreet = Cells(i, 1).Offset(0, 2).Value
.BusinessAddressPostalCode = Cells(i, 1).Offset(0, 3).Value
.BusinessAddressCity = Cells(i, 1).Offset(0, 4).Value
.BusinessAddressCountry = Cells(i, 1).Offset(0, 5).Value
.BusinessAddressState = Cells(i, 1).Offset(0, 6).Value
.Email1Address = Cells(i, 1).Offset(0, 7).Value
.Save
End With
'Object entfernen
Set MyOutCon = Nothing
Next i
End With
Set MyOutApp = Nothing
End Sub
Dieses Thema hat weitere Beiträge
Outlook und Excel (1) Grundlagen und Einführung
Outlook und Excel (2) Workbooks und Worksheets versenden
Outlook und Excel (3) Serienmail mit Excel
Outlook und Excel (4) Aufgaben und Notizen erstellen
Outlook und Excel (5) Adressbuch und Kontakte
Outlook und Excel (6) Diagramme und Bereiche versenden
Outlook und Excel (1) Grundlagen und Einführung
Outlook und Excel (2) Workbooks und Worksheets versenden
Outlook und Excel (3) Serienmail mit Excel
Outlook und Excel (4) Aufgaben und Notizen erstellen
Outlook und Excel (5) Adressbuch und Kontakte
Outlook und Excel (6) Diagramme und Bereiche versenden
Weitere Artikel der Gruppe: Outlook & Excel Aus Excel VBA
Nach oben
rechte seite