Outlook - VBA Parameter

ub ContactsToExcel()

'Deklaration  
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 Integer

'Outlook-Objekte öffnen  
Set nspMapi = Application.GetNamespace("MAPI")  
Set folMapi = nspMapi.GetDefaultFolder(olFolderContacts)
Set itmAll = folMapi.Items

'Verteilerlisten herausfiltern, nur 'Richtige Kontakte' verwenden  
strContactFilter = "[MessageClass] = 'IPM.Contact'"  
Set itmReal = itmAll.Restrict(strContactFilter)

'Excel-Objekte öffnen  
Set excApp = CreateObject("Excel.Application")  
Set excWkb = excApp.Workbooks.Add
Set excWks = excWkb.Sheets(1)

'Erstes Sheet Excel-Worksheet aufbereiten  
With excWks

'Sheet-Name  
.Name = "Outlook-Kontakte"  

'Spaltenüberschriften  
.cells(1, 1).Value = "Firma"  
'.cells(1, 2).Value = "Nachname"  
'.cells(1, 3).Value = "Vorname"  
.cells(1, 2).Value = "PLZ"  
.cells(1, 3).Value = "Ort"  
.cells(1, 4).Value = "Strasse"  
.cells(1, 5).Value = "Land"  
.cells(1, 6).Value = "Telefon"  
.cells(1, 7).Value = "Fax"  
.cells(1, 8).Value = "Homepage"  
.cells(1, 9).Value = "E-Mail"  
.cells(1, 10).Value = "KundenNr."  
.cells(1, 11).Value = "Linie"  
.cells(1, 12).Value = "Notizen"  


'Spaltenüberschriften fett  
.Rows("1:1").Font.Bold = True  

'Outlook-Kontakte nach Excel übertragen  
intRow = 2

For Each itmContacts In itmReal
    If (itmContacts.CompanyName <> "") Then  
        .cells(intRow, 1).Value = itmContacts.CompanyName
        '.cells(intRow, 2).Value = itmContacts.LastName  
        '.cells(intRow, 3).Value = itmContacts.FirstName  
        .cells(intRow, 2).Value = itmContacts.BusinessAddressPostalCode
        .cells(intRow, 3).Value = itmContacts.BusinessAddressCity
        .cells(intRow, 4).Value = itmContacts.BusinessAddressStreet
        .cells(intRow, 5).Value = itmContacts.BusinessAddressCountry
        .cells(intRow, 6).Value = itmContacts.BusinessTelephoneNumber
        .cells(intRow, 7).Value = itmContacts.BusinessFaxNumber
        .cells(intRow, 8).Value = itmContacts.BusinessHomePage
        .cells(intRow, 9).Value = itmContacts.Email1Address
        .cells(intRow, 10).Value = itmContacts.CustomerID
        '.cells(intRow, 11).Value = itmContacts.im  
        
        intRow = intRow + 1
    End If


Next itmContacts

'Optimale Spaltenbreite  
.Columns.AutoFit
End With

'Excel einblenden  
excApp.Visible = 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