Exporting to Outlook 07

[JBurlison]

i Cannot get this to work i think i need to set Outlook.Folder because it red flags me there in the debugger

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
        StrLastName
        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 Function

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