Extramly complex export need help!

[JBurlison]

ok trying to export to outlook but no luck i have been searching the web for help but nothing any suggestions or resources would be a big help!



This button export the contact to outlook:
dose not work.

Private Sub Command25_Click()
On Error GoTo ErrorHandler

Set appOutlook = GetObject(, "Outlook.Application")

Dim LngContact As Long
Dim LngContactCount As Long
Dim Fld 'As Outlook.Folder
Dim FldContacts 'As Outlook.Folder
Dim ConNew 'As Outlook.ContactItem
Dim ConTest 'As Outlook.ContactItem
Dim StrFullname As String
Dim StrFirstName As String
Dim StrLastName As String
Dim StrBusinessphone As String
Dim StrMobilePhone As String
Dim StrFaxNumber As String
Dim StrNotes As String
Dim StrJobTitle As String
Dim StrStreetAddress As String
Dim StrCity As String
Dim StrStateProv As String
Dim StrPostalCode As String
Dim StrCountry As String
Dim StrCompanyName As String
Dim StrEMail As String
Dim StrSalutation As String

Set appOutlook = GetObject(, "Outlook.Application")
Set nms = appOutlook.getnamespace("MAPI")
Set FldContacts = nms.GetDefultFolder(olFolderTasks)

On Error Resume Next
Set Fld = nms.Folders("Personal Folders")
Set FldContacts = Fld.Folders("Client Contacts")

If FldContacts Is Nothing Then
    Set FldContacts = _
    Fld.Folders.Add("Client Contacts", _
                    olFolderContacts)
End If

On Error GoTo ErrorHandler

LngContactCount = 0
Set db = CurrentDb
Set rts = db.OpenRecordset("Client Usernames and Passwords")

With rts
    Do While Not .EOF
        StrFullname = Me.User
        Debug.Print "Contact name: " & StrFullname

        If StrFullname = "" Then
            GoTo NextContact
        End If

        On Error Resume Next

        Set ConTest = FldContacts.Items(StrFullname)

        If ConTest.FullName <> StrFullname Then
            Debug.Print StrFullname & " Not Found"
        ElseIf ConTest.FullName = StrFullname Then
            Debug.Print StrFullname & " Found"
            GoTo NextContact
        End If

        On Error GoTo ErrorHandler

        StrCompanyName = Nz(![Company])
        StrFirstName = Left(FullName, InStr(1, FullName, " ") - 1)
        StrLastName = Trim(Right(FullName, Len(FullName) - Len(FullName)))
        StrEMail = Nz(![E-Mail Address])
        StrJobTitle = Nz(![Job Title])
        StrBusinessphone = Nz(![Business Phone])
        StrMobilePhone = Nz(![Mobile Phone])
        StrFaxNumber = Nz(![Fax Number])
        StrNotes = Nz(![Notes])
        StrStreetAddress = Nz(![Address])
        StrCity = Nz(![City])
        StrStateProv = Nz(![State/Province])
        StrPostalCode = Nz(![Zip/Postalcode])
        StrCountry = Nz(![Country/Region])

        Set ConNew = FldContacts.Items.Add
        With ConNew
            .CustomerID = StrFullname
            .FirstName = StrFirstName
            .LastName = StrJobTitle
            .BusinessAddressStreet = StrStreetAddress
            .BusinessAddressCity = StrCity
            .BusinessAddressState = StrStateProv
            .BusinessAddressPostalCode = StrPostalCode
            .BusinessAddressCountry = StrCountry
            .CompanyName = StrCompanyName
            .Email1Address = StrEMail
            .BusinessTelephoneNumber = StrBusinessphone
            .BusinessFaxNumber = StrMobilePhone
            .Body = StrNotes
            .Close (olSave)
        End With

        LngContactCount = LngContactCount + 1

NextContact:
        .MoveNext
    Loop
End With

rts.Close

If LngContactCount = 0 Then
    MsgBox "No contacts to export to Outlook"
Else
    MsgBox LngContactCount & " contact(s) exported to Outlook"
End If

ErrorHandlerExit:
Exit Sub

ErrorHandler:

If Err.Number = 429 Then
    Set appOutlook = CreateObject("Outlook.Application")
    Resume Next
Else
    MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
    Resume ErrorHandlerExit
End If

End Sub