J
John Riddle
Hello,
I have a contact form with a custom page ("Additional Contacts") that uses
ADO to loop through a public folder (where the contact item resides) and
populate a list box with all additional contacts at the contact's company. I
have about 3,000 contacts in the public folder and it takes more than 5
minutes to open the form and populate the list box. Is this normal, or is
there something that I'm doing wrong? I've modified the "Company-Contact
Selector" form that I got from slipstick.com.
I'm pasting my code below:
'-> Global variables
Dim rsContacts
Dim rsContactEntry
Dim fpgContact
Dim sCompanyName
Dim sFullName
Dim InitialValue
Dim LoadValue
'-> Global Constants
Const olFolderContacts = 10
Const adVarChar = 200
Const adSmallInt = 2
Const adUseClient = 3
Const adOpenStatic = 3
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Const adCmdFile = 5
Const myLink = 2
Sub Item_CustomPropertyChange(ByVal propName)
Select Case propName
Case "SelectName"
m_cboSelectName_Change
Case Else
' MsgBox propName & " changed"
End Select
End Sub
Function Item_Open()
FillAdditionalContacts
End Function
Sub cmdRefreshList_Click()
FillAdditionalContacts
End Sub
Sub cmdOpenContact_Click()
OpenSelectedContact
End Sub
Sub OpenSelectedContact()
Dim ns
Dim sFilter
Dim sEntryID
Dim sStoreID
Dim itmContact
sFullName = fpgContact.lstAdditionalContacts.Value
'-> Filter for matching company name and contact name
sFilter = "(CompanyName = '" & sCompanyName & "') AND (FullName = '" &
sFullName & "')"
rsContacts.Filter = sFilter
If rsContacts.RecordCount > 1 Then
'-> Warning only
MsgBox rsContacts.RecordCount & " entries were found with the same name."
End If
rsContacts.MoveFirst
'-> Get contact item and display information
sEntryID = rsContacts.Fields("EntryID").Value
sStoreID = rsContacts.Fields("StoreID").Value
Set ns = Application.GetNameSpace("MAPI")
Set itmContact = ns.GetItemFromID(sEntryID, sStoreID)
itmContact.Display
Set itmContact = Nothing
Set ns = Nothing
End Sub
Function FillAdditionalContacts()
Dim ns
Dim fldContacts
Dim raFieldNames
Dim raFieldValues
Dim itmContacts
Dim itmContact
Dim cboSelectCompany
Dim cboSelectName
Dim AdditionalContacts
sCompanyName = Item.CompanyName
Set ns = Application.GetNameSpace("MAPI")
Set fpgContact = Item.GetInspector.ModifiedFormPages("Additional Contacts")
'-> Create empty recordset and load contacts
'-> Create an ADO standalone recordset for holding contact information
'-> Create contacts recordset
Set rsContacts = CreateObject("ADODB.Recordset")
'-> Create fields
rsContacts.CursorLocation = adUseClient
rsContacts.Fields.Append "CompanyName", adVarChar, 128
rsContacts.Fields.Append "FullName", adVarChar, 128
rsContacts.Fields.Append "FileAs", adVarChar, 128
rsContacts.Fields.Append "EntryID", adVarChar, 256
rsContacts.Fields.Append "StoreID", adVarChar, 256
rsContacts.Fields.Append "JobTitle", adVarChar, 256
'-> Open recordset
rsContacts.Open
Set fldContacts = ns.Folders("Public Folders")
Set fldContacts = fldContacts.Folders("All Public Folders")
Set fldContacts = fldContacts.Folders("Contacts")
'-> Load contact information from the specified contacts folder into
'-> the contacts recordset.
'-> This routine can be called multiple times
'-> to load contacts from different contact folders. Once contacts are
'-> loaded into recordset, then source folder doesn't need to be
'-> preserved. Contact records are retreived using EntryID & StoreID.
'-> Array of field names, must match field names from
m_CreateContactsRecordset
raFieldNames = Array("CompanyName", _
"FullName", _
"FileAs", _
"EntryID", _
"StoreID", _
"JobTitle")
'-> Put contacts in recordset
Set itmContacts = fldContacts.Items
For Each itmContact in itmContacts
raFieldValues = Array(itmContact.CompanyName, _
itmContact.FullName, _
itmContact.FileAs, _
itmContact.EntryID, _
itmContact.Parent.StoreID, _
itmContact.JobTitle)
rsContacts.AddNew raFieldNames, raFieldValues
Next
Set itmContacts = Nothing
Set fldContacts = Nothing
'-> Load Candidate names into cboSelectCompany combo box
'-> Setup combo box and clear
Set AdditionalContacts = fpgContact.lstAdditionalContacts
AdditionalContacts.Clear
'-> Filter for records with matching company name and sort on fullname
rsContacts.Filter = "CompanyName = '" & sCompanyName & "'"
rsContacts.Sort = "FullName"
If rsContacts.RecordCount > 0 Then
'-> Load contact names into combo box
AdditionalContacts.Enabled = True
rsContacts.MoveFirst
While rsContacts.Eof = False
AdditionalContacts.AddItem rsContacts.Fields("FullName").Value & _
" -- " & rsContacts.Fields("JobTitle")
rsContacts.MoveNext
Wend
Else
'-> No records found
cboSelectName.Enabled = False
Item.UserProperties.Find("ContactAddress").Value = ""
Item.UserProperties.Find("ContactPhone").Value = ""
Item.UserProperties.Find("ContactFax").Value = ""
End If
rsContacts.Filter = ""
Set cboSelectName = Nothing
End Function
Function Item_Close()
'-> Clean things up
rsContacts.Close
Set rsContacts = Nothing
Set fpgContact = Nothing
End Function
Sub Item_CustomPropertyChange(ByVal propName)
Select Case propName
Case "SelectName"
m_cboSelectName_Change
Case Else
' MsgBox propName & " changed"
End Select
End Sub
Sub m_cboSelectName_Change
InitialValue = fpgContact.lstAdditionalContacts.Value
LoadValue = Split(InitialValue, " -- ")
sFullName = LoadValue(0)
m_FillContactInfo sCompanyName, sFullName
End Sub
Sub m_FillContactInfo(sCompanyName, sFullName)
Dim ns
Dim sFilter
Dim sEntryID
Dim sStoreID
Dim itmContact
'-> Filter for matching company name and contact name
sFilter = "(CompanyName = '" & sCompanyName & "') AND (FullName = '" &
sFullName & "')"
rsContacts.Filter = sFilter
If rsContacts.RecordCount > 0 Then
If rsContacts.RecordCount > 1 Then
'-> Warning only
MsgBox rsContacts.RecordCount & " entries were found with the same name."
End If
rsContacts.MoveFirst
'-> Get contact item and display information
sEntryID = rsContacts.Fields("EntryID").Value
sStoreID = rsContacts.Fields("StoreID").Value
Set ns = Application.GetNameSpace("MAPI")
Set itmContact = ns.GetItemFromID(sEntryID, sStoreID)
'-> Have to use UserProperties because fields are read only
Item.UserProperties.Find("ContactAddress").Value =
itmContact.BusinessAddress
Item.UserProperties.Find("ContactPhone").Value =
itmContact.BusinessTelephoneNumber
Item.UserProperties.Find("ContactEmail").Value = itmContact.Email1Address
Item.UserProperties.Find("ContactJobTitle").Value = itmContact.JobTitle
Item.UserProperties.Find("ContactFullName").Value = itmContact.FullName
Set itmContact = Nothing
Set ns = Nothing
Else
'-> No matching records found
Item.UserProperties.Find("ContactAddress").Value = ""
Item.UserProperties.Find("ContactPhone").Value = ""
Item.UserProperties.Find("ContactJobTitle").Value = ""
Item.UserProperties.Find("ContactHomePhone").Value = ""
Item.UserProperties.Find("ContactEmail").Value = ""
End If
rsContacts.Filter = ""
End Sub
I have a contact form with a custom page ("Additional Contacts") that uses
ADO to loop through a public folder (where the contact item resides) and
populate a list box with all additional contacts at the contact's company. I
have about 3,000 contacts in the public folder and it takes more than 5
minutes to open the form and populate the list box. Is this normal, or is
there something that I'm doing wrong? I've modified the "Company-Contact
Selector" form that I got from slipstick.com.
I'm pasting my code below:
'-> Global variables
Dim rsContacts
Dim rsContactEntry
Dim fpgContact
Dim sCompanyName
Dim sFullName
Dim InitialValue
Dim LoadValue
'-> Global Constants
Const olFolderContacts = 10
Const adVarChar = 200
Const adSmallInt = 2
Const adUseClient = 3
Const adOpenStatic = 3
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Const adCmdFile = 5
Const myLink = 2
Sub Item_CustomPropertyChange(ByVal propName)
Select Case propName
Case "SelectName"
m_cboSelectName_Change
Case Else
' MsgBox propName & " changed"
End Select
End Sub
Function Item_Open()
FillAdditionalContacts
End Function
Sub cmdRefreshList_Click()
FillAdditionalContacts
End Sub
Sub cmdOpenContact_Click()
OpenSelectedContact
End Sub
Sub OpenSelectedContact()
Dim ns
Dim sFilter
Dim sEntryID
Dim sStoreID
Dim itmContact
sFullName = fpgContact.lstAdditionalContacts.Value
'-> Filter for matching company name and contact name
sFilter = "(CompanyName = '" & sCompanyName & "') AND (FullName = '" &
sFullName & "')"
rsContacts.Filter = sFilter
If rsContacts.RecordCount > 1 Then
'-> Warning only
MsgBox rsContacts.RecordCount & " entries were found with the same name."
End If
rsContacts.MoveFirst
'-> Get contact item and display information
sEntryID = rsContacts.Fields("EntryID").Value
sStoreID = rsContacts.Fields("StoreID").Value
Set ns = Application.GetNameSpace("MAPI")
Set itmContact = ns.GetItemFromID(sEntryID, sStoreID)
itmContact.Display
Set itmContact = Nothing
Set ns = Nothing
End Sub
Function FillAdditionalContacts()
Dim ns
Dim fldContacts
Dim raFieldNames
Dim raFieldValues
Dim itmContacts
Dim itmContact
Dim cboSelectCompany
Dim cboSelectName
Dim AdditionalContacts
sCompanyName = Item.CompanyName
Set ns = Application.GetNameSpace("MAPI")
Set fpgContact = Item.GetInspector.ModifiedFormPages("Additional Contacts")
'-> Create empty recordset and load contacts
'-> Create an ADO standalone recordset for holding contact information
'-> Create contacts recordset
Set rsContacts = CreateObject("ADODB.Recordset")
'-> Create fields
rsContacts.CursorLocation = adUseClient
rsContacts.Fields.Append "CompanyName", adVarChar, 128
rsContacts.Fields.Append "FullName", adVarChar, 128
rsContacts.Fields.Append "FileAs", adVarChar, 128
rsContacts.Fields.Append "EntryID", adVarChar, 256
rsContacts.Fields.Append "StoreID", adVarChar, 256
rsContacts.Fields.Append "JobTitle", adVarChar, 256
'-> Open recordset
rsContacts.Open
Set fldContacts = ns.Folders("Public Folders")
Set fldContacts = fldContacts.Folders("All Public Folders")
Set fldContacts = fldContacts.Folders("Contacts")
'-> Load contact information from the specified contacts folder into
'-> the contacts recordset.
'-> This routine can be called multiple times
'-> to load contacts from different contact folders. Once contacts are
'-> loaded into recordset, then source folder doesn't need to be
'-> preserved. Contact records are retreived using EntryID & StoreID.
'-> Array of field names, must match field names from
m_CreateContactsRecordset
raFieldNames = Array("CompanyName", _
"FullName", _
"FileAs", _
"EntryID", _
"StoreID", _
"JobTitle")
'-> Put contacts in recordset
Set itmContacts = fldContacts.Items
For Each itmContact in itmContacts
raFieldValues = Array(itmContact.CompanyName, _
itmContact.FullName, _
itmContact.FileAs, _
itmContact.EntryID, _
itmContact.Parent.StoreID, _
itmContact.JobTitle)
rsContacts.AddNew raFieldNames, raFieldValues
Next
Set itmContacts = Nothing
Set fldContacts = Nothing
'-> Load Candidate names into cboSelectCompany combo box
'-> Setup combo box and clear
Set AdditionalContacts = fpgContact.lstAdditionalContacts
AdditionalContacts.Clear
'-> Filter for records with matching company name and sort on fullname
rsContacts.Filter = "CompanyName = '" & sCompanyName & "'"
rsContacts.Sort = "FullName"
If rsContacts.RecordCount > 0 Then
'-> Load contact names into combo box
AdditionalContacts.Enabled = True
rsContacts.MoveFirst
While rsContacts.Eof = False
AdditionalContacts.AddItem rsContacts.Fields("FullName").Value & _
" -- " & rsContacts.Fields("JobTitle")
rsContacts.MoveNext
Wend
Else
'-> No records found
cboSelectName.Enabled = False
Item.UserProperties.Find("ContactAddress").Value = ""
Item.UserProperties.Find("ContactPhone").Value = ""
Item.UserProperties.Find("ContactFax").Value = ""
End If
rsContacts.Filter = ""
Set cboSelectName = Nothing
End Function
Function Item_Close()
'-> Clean things up
rsContacts.Close
Set rsContacts = Nothing
Set fpgContact = Nothing
End Function
Sub Item_CustomPropertyChange(ByVal propName)
Select Case propName
Case "SelectName"
m_cboSelectName_Change
Case Else
' MsgBox propName & " changed"
End Select
End Sub
Sub m_cboSelectName_Change
InitialValue = fpgContact.lstAdditionalContacts.Value
LoadValue = Split(InitialValue, " -- ")
sFullName = LoadValue(0)
m_FillContactInfo sCompanyName, sFullName
End Sub
Sub m_FillContactInfo(sCompanyName, sFullName)
Dim ns
Dim sFilter
Dim sEntryID
Dim sStoreID
Dim itmContact
'-> Filter for matching company name and contact name
sFilter = "(CompanyName = '" & sCompanyName & "') AND (FullName = '" &
sFullName & "')"
rsContacts.Filter = sFilter
If rsContacts.RecordCount > 0 Then
If rsContacts.RecordCount > 1 Then
'-> Warning only
MsgBox rsContacts.RecordCount & " entries were found with the same name."
End If
rsContacts.MoveFirst
'-> Get contact item and display information
sEntryID = rsContacts.Fields("EntryID").Value
sStoreID = rsContacts.Fields("StoreID").Value
Set ns = Application.GetNameSpace("MAPI")
Set itmContact = ns.GetItemFromID(sEntryID, sStoreID)
'-> Have to use UserProperties because fields are read only
Item.UserProperties.Find("ContactAddress").Value =
itmContact.BusinessAddress
Item.UserProperties.Find("ContactPhone").Value =
itmContact.BusinessTelephoneNumber
Item.UserProperties.Find("ContactEmail").Value = itmContact.Email1Address
Item.UserProperties.Find("ContactJobTitle").Value = itmContact.JobTitle
Item.UserProperties.Find("ContactFullName").Value = itmContact.FullName
Set itmContact = Nothing
Set ns = Nothing
Else
'-> No matching records found
Item.UserProperties.Find("ContactAddress").Value = ""
Item.UserProperties.Find("ContactPhone").Value = ""
Item.UserProperties.Find("ContactJobTitle").Value = ""
Item.UserProperties.Find("ContactHomePhone").Value = ""
Item.UserProperties.Find("ContactEmail").Value = ""
End If
rsContacts.Filter = ""
End Sub