Jame,
I did as you suggested and found that the code errors on the line that reads For Each oItm In oItems
[VBA]
Public Sub InsertIntoDoc(All As Boolean)
Dim itm As Variant
With lstFieldList
For x = 0 To .ListCount - 1
If All Then .Selected(x) = All
If .Selected(x) = True Then
With Selection
.InsertAfter (lstFieldList.List(x))
.Collapse (wdCollapseEnd)
.Paragraphs.Add
End With
End If
Next x
End With
End Sub
Sub UserForm_Initialize()
Dim oNspc As NameSpace
Dim oItm As ContactItem
Dim oItems As Items
Dim x As Integer
If Not DisplayStatusBar Then
DisplayStatusBar = True
End If
StatusBar = "Please Wait..."
x = 0
Set oApp = CreateObject("Outlook.Application")
Set oNspc = oApp.GetNamespace("MAPI")
Set oItems = oNspc.GetDefaultFolder(olFolderContacts).Items
'Make sure the Contacts folder contains entries
If oItems.Count > 0 Then
For Each oItm In oItems ' Error Occurs Here
'Make sure the oItm is a contact and not a DL
'Remove this If...Then condition if you want to include DLs
If oItm.Class = olContact Then
'If oItm.Class <> olDistributionList Then
With Me.cboContactList
.AddItem (oItm.FullName)
.Column(1, x) = oItm.BusinessAddress
.Column(2, x) = oItm.BusinessTelephoneNumber
End With
x = x + 1
End If
Next oItm
End If
StatusBar = ""
Set oItems = Nothing
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
End Sub
Private Sub cboContactList_Change()
Dim x As Integer
With lstFieldList
If .ListCount > 0 Then
For x = 0 To .ListCount - 1
.RemoveItem (0)
Next x
End If
For x = 0 To cboContactList.ColumnCount - 1
.AddItem (Me.cboContactList.Column(x))
Next x
End With
End Sub
Private Sub cmbAll_Click()
Call InsertIntoDoc(True)
End Sub
Private Sub cmbDetail_Click()
Call InsertIntoDoc(False)
End Sub
Private Sub cmbClose_Click()
Unload Me
End Sub
[/VBA]