Loop through records in Business Contact Manager not working

[susand]

I am endeavouring to loop through all the account items in Business Contact Manager to automatically link the Account with a Business Contact. I am able to get the first item and then the next but then it just keeps sitting on the next item.

I am very new at VBA progamming. Below is the code I have done so far.

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Dim bcmAccountsFldr As Outlook.Folder
Dim bcmContactsFldr As Outlook.Folder
Dim bcmAcct As Outlook.ContactItem
Dim bcmContact As Outlook.ContactItem
Dim userProp As Outlook.UserProperty
Dim strAcctCompany As String
Dim strContactCompany As String


Set olApp = CreateObject("Outlook.Application")
Set objNS = olApp.GetNamespace("MAPI")
Set olFolders = objNS.Session.Folders
Set bcmRootFolder = olFolders("Business Contact Manager")
Set bcmAccountsFldr = bcmRootFolder.Folders("Accounts")


Set bcmAcct = bcmAccountsFldr.Items.GetFirst

'loop here through accounts

Do Until bcmAcct = "Nothing"

strAcctCompany = bcmAcct.CompanyName
Set bcmContactsFldr = bcmRootFolder.Folders("Business Contacts")
Set bcmContact = bcmContactsFldr.Items.Find("[CompanyName] = strAcctCompany")
If TypeName(bcmContact) = "Nothing" Then
Else
strContactCompany = bcmContact.LastName
MsgBox (strContactCompany)
End If

Set bcmAcct = bcmAccountsFldr.Items.GetNext


Loop


It continues to stay on the next item after the first item.

Can anyone help me with this please?

[susand]

Okay sorted it out from an absolute beginners guide book - phew.

Should be
For Each bcmAcct in bcmAccountsFldr.Items
b
Next

[susand]

Okay sorted it out from an absolute beginners guide book - phew.

Should be
For Each bcmAcct in bcmAccountsFldr.Items
- code -
Next

My find is not working but figure it must be the field name