Excelzelle aus Outlook-Makro befüllen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Magico777,
versuche mal folgenden Code:

Sub ContactsToExcel()
Option Explicit
'============================================================================
' Read all contacts from Server-Contacts-Folder and create a XLS-File
'============================================================================
Bin nicht sicher wieviel ich aus dem Internet, Sperl?, übernommen habe vllt. den einen oder anderen entscheidenden Tipp.
Gebaut habe ich dieses Macro selbst, auch getestet, problemlos in kurzer Zeit 5000 Kontakte ausgelesen.
' Worksheets("Auslesen").UnProtect Password:="sperl"
'Deklaration
Dim oApp As New Outlook.Application
Dim nspMapi As Outlook.NameSpace
Dim folMapi As Outlook.MAPIFolder
Dim itmAll As Outlook.Items
Dim itmReal As Outlook.Items
Dim itmContacts As Outlook.ContactItem
Dim strContactFilter As String
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Long, k As Long
'Outlook-Objekte öffnen
Set nspMapi = oApp.GetNamespace("MAPI")
Set folMapi = nspMapi.GetDefaultFolder(olFolderContacts)
Set itmAll = folMapi.Items
Set itmReal = folMapi.Items
'============================================================================
Set excApp = Nothing
Set excApp = New Excel.Application
excApp.Visible = True 'für debug
excApp.ScreenUpdating = True 'False
excApp.Workbooks.Add
Set excWkb = excApp.ActiveWorkbook
If excWkb.Sheets.count > 1 Then
Set excWks = excWkb.Sheets(2)
Else
Set excWks = excWkb.Sheets(1)
End If
'Excel-Worksheet aufbereiten
With excWks
.Name = "Auslesen"
'Spaltenüberschriften
.Cells(1, 1).Value = "Vorname"
.Cells(1, 2).Value = "Nachname"
.Cells(1, 3).Value = "Strasse"
.Cells(1, 4).Value = "PLZ"
.Cells(1, 5).Value = "Ort"
.Cells(1, 6).Value = "Land"
.Cells(1, 7).Value = "Telefon"
.Cells(1, 8).Value = "BusinessAddressCountry"
.Cells(1, 9).Value = "BusinessFaxNumber"
.Cells(1, 10).Value = "BusinessTelephoneNumber"
.Cells(1, 11).Value = "MobileTelephoneNumber"
.Cells(1, 12).Value = "Email1Address"
.Cells(1, 13).Value = "Email1DisplayName"
.Cells(1, 14).Value = "FullName"
.Cells(1, 15).Value = "LastNameAndFirstName"
.Cells(1, 16).Value = "CreationTime"
.Cells(1, 17).Value = "LastModificationTime"
'Spaltenüberschriften fett
.Rows("1:1").Font.Bold = True
End With
'============================================================================
'Outlook-Kontakte nach Excel übertragen
intRow = 2
excApp.ScreenUpdating = True 'False
With excWks
For k = 1 To itmReal.count 'Each itmContacts In itmReal
If itmReal(k).Class = olContact Then
Set itmContacts = itmReal(k)
.Cells(intRow, 1).Value = itmContacts.FirstName
.Cells(intRow, 2).Value = itmContacts.LastName
.Cells(intRow, 3).Value = itmContacts.CompanyName
.Cells(intRow, 4).Value = itmContacts.JobTitle
.Cells(intRow, 5).Value = itmContacts.BusinessAddressStreet
.Cells(intRow, 6).Value = itmContacts.BusinessAddressPostalCode
.Cells(intRow, 7).Value = itmContacts.BusinessAddressCity
.Cells(intRow, 8).Value = itmContacts.BusinessAddressCountry
.Cells(intRow, 9).Value = itmContacts.BusinessFaxNumber
.Cells(intRow, 10).Value = itmContacts.BusinessTelephoneNumber
.Cells(intRow, 11).Value = itmContacts.MobileTelephoneNumber
.Cells(intRow, 12).Value = itmContacts.Email1Address
.Cells(intRow, 13).Value = itmContacts.Email1DisplayName
.Cells(intRow, 14).Value = itmContacts.FullName
.Cells(intRow, 15).Value = itmContacts.LastNameAndFirstName
.Cells(intRow, 16).Value = itmContacts.CreationTime
.Cells(intRow, 17).Value = itmContacts.LastModificationTime
intRow = intRow + 1
Else
intRow = intRow 'debug
End If
.Cells(intRow, 18).Value = itmReal(k).Class 'abweichende Class in Zeile festhalten.
.Cells(intRow, 19).Value = k
Next k
'Optimale Spaltenbreite
.Columns.AutoFit
End With
'Excel einblenden
excApp.Visible = True
excApp.ScreenUpdating = True
'Speicher freigeben
Set itmReal = Nothing
Set itmAll = Nothing
Set folMapi = Nothing
Set nspMapi = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub

Antwort wäre nett.
Gruß
firmus

Hi Magico777,
ich denke ich habe Deine Anforderung verstanden.
1. Outlook is offen
2. in Outlook wird ein Macro aufgerufen.
3. Dieses Macro soll Informationen, die in Outlook vorliegen in eine XLS-Datei ausgeben.
4. Dazu soll eine XLS-Instanz gestartet werden, damit die gefundenen Informationen in einer
XLS-Datei abgelegt werden können.
Genau das tut das Macro.
Mein Anwendungsfall:
Die Kontaktdaten sollen verifiziert und korrigiert werden.
Dazu habe ich den Kontakte-Folder Eintrag für Eintrag ausgelesen und in eine XLS-Tabelle gestellt.
Um zu wissen welche Felder übertragen wurden, ist auch ein Block enthalten der in die erste Zeile die Spalten-Überschriften setzt.
Das geht vllt. etwas über Deine Anforderung hinaus, ist aber ein lauffähiges Beispiel, das Du an die Details Deiner Anforderung anpassen kannst.
Im Macro sind die XLS-Instanz noch auf Visible und Screen-update True gesetzt.
Diese sollten natürlich in der "Produktion" ausgeschaltet sein.
Das Macro läuft in Outlook, in "VbaProject.OTM" unter "ThisOutlookSession"
Hoffe das hilft Dir weiter.
Gruß
firmus

Beliebteste Forumthreads (12 Monate)

Excelzelle aus Outlook-Makro befüllen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread