How do I change the following code to include user properties?


Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Company / Private person"
.Cells(1, 2).Value = "Street address"
.Cells(1, 3).Value = "Postal code"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.CompanyName, strDummy) 0 Then
Cells(i, 1).Value = .CompanyName
Cells(i, 2).Value = .BusinessAddressStreet
Cells(i, 3).Value = .BusinessAddressPostalCode
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If
Next olItem


With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub