Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

VBA Code to Export Contact Data from Access to Outlook

Status
Not open for further replies.

pockets26

IS-IT--Management
Jul 28, 2005
3
CA
Looking for some assistance on a project that I am working on. I am new to VBA so please bear with me. I have designed a custom contact form in Outlook to accomodate a custom list of contact information into. I am using Access that has a table set up in it and a form with VBA code that prompts me for the contact folder that I want to export the data to. I found some sample code that I am working with and have tested my custom contact form with the sample code and it works fine. So I have modified the code on the Access form to add my custom fields and modify the database name that it needs to pull the information from. When I do this and run the command to export I get an Access error with the following description: Error No: 3265; Description: Item not found in Collection. I get the prompt that tells me how many contacts there are to import and the status bar starts but just stays in that same spot after the error message. My code that I am using is below. Does anyone have any ideas on what the problem would be and how to correct it? Any information is greatly appreciated, as I mentioned earlier I am very new to this whole scripting procedure


Option Compare Database
Option Explicit

'Declare the pfld variable as Public so it can be set in one procedure and used in another
Public pfld As Outlook.MAPIFolder
Dim appOutlook As Outlook.Application
Dim nms As Outlook.NameSpace


Private Sub cmdSelectFolder_Click()

Call SelectFolder

End Sub

Function SelectFolder()

On Error GoTo ErrorHandler

Set appOutlook = CreateObject("Outlook.Application")
Set nms = appOutlook.GetNamespace("MAPI")

SelectContactFolder:
Set pfld = nms.PickFolder
Debug.Print "Default item type: " & pfld.DefaultItemType
If pfld.DefaultItemType <> olContactItem Then
MsgBox "Please select a Contacts folder"
GoTo SelectContactFolder
End If

Forms![frmExportToOutlook].SetFocus
Me![txtFolderName].Value = pfld.Name
Me![LastContact].Value = ""

ErrorHandlerExit:
Exit Function

ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit

End Function

Private Sub cmdExport_Click()

On Error GoTo ErrorHandler

Dim dbs As Database
Dim rst As Recordset
Dim itms As Outlook.Items
Dim itm As Outlook.ContactItem
Dim strTitle As String
Dim strFirstName As String
Dim strMiddleName As String
Dim strLastName As String
Dim strSuffix As String
Dim strJobTitle As String
Dim strCompany As String
Dim strLastNameFirst As String
Dim strBusinessStreet As String
Dim strBusinessStreet2 As String
Dim strBusinessCity As String
Dim strBusinessState As String
Dim strBusinessPostalCode As String
Dim strBusinessCountry As String
Dim strBusinessPhone As String
Dim strBusinessFax As String
Dim strHomeStreet As String
Dim strHomeStreet2 As String
Dim strHomeCity As String
Dim strHomeState As String
Dim strHomePostalCode As String
Dim strHomeCountry As String
Dim strHomePhone As String
Dim strHomeFax As String
Dim strOtherStreet As String
Dim strOtherStreet2 As String
Dim strOtherCity As String
Dim strOtherState As String
Dim strOtherPostalCode As String
Dim strOtherCountry As String
Dim strOtherPhone As String
Dim strOtherFax As String
Dim strMobilePhone As String
Dim strEMailAddress As String
Dim strEMailAddress2 As String
Dim strContactID As String
Dim lngCount As Long
Dim strMessage As String
Dim lngResult As Long
Dim strContactForm As String
Dim strCategory As String
Dim varReturn As Variant
Dim lngPosition As Long
Dim dteBirthdate As Date
Dim dteSpouseBirthdate As Date
Dim strInvestmentAdvisor As String
Dim strBranch As String
Dim dteAnnualReview As Date
Dim dteAnnual As Date
Dim dteFirstQuarter As Date
Dim dteSecondQuarter As Date
Dim dteThirdQuarter As Date
Dim dteFourthQuarter As Date
Dim dteSemiAnnual1 As Date
Dim dteSemiAnnual2 As Date
Dim strCSINotes As String

'If Folder Name textbox is blank, call function to select folder
If Me![txtFolderName].Value = "" Then Call SelectFolder
Set itms = pfld.Items

'Set reference to Access table containing contact data
Set dbs = CurrentDb
Set rst = dbs![Csi].OpenRecordset(dbOpenTable, dbDenyRead)
lngCount = rst.RecordCount
strMessage = lngCount & " contact records to transfer to Outlook -- proceed?"

'Ask if user wants to proceed with the export
lngResult = MsgBox(strMessage, vbYesNo, "Proceed?")

'Exit if user says No
If lngResult = vbNo Then Exit Sub

'Pick up name of contact form from text box, with IPM.Contact.CSI CRM as a default in case the text box is blank. If this form (or any specified form) is not available, the standard Contact form will be used instead
strContactForm = Nz(Me![txtContactForm], "IPM.Contact.CSI CRM")

'Pick up category from text box, allowing a blank category
strCategory = Nz(Me![txtCategory])

'Turn on hourglass and initialize status bar to show progress of the export
DoCmd.Hourglass True
strMessage = "Exporting " & lngCount & " records to Outlook"
varReturn = Application.SysCmd(acSysCmdInitMeter, strMessage, lngCount)
Me![LastContact].Value = ""

'Loop through the Access table, exporting each record to Outlook
'The Nz function is used to convert blanks into zeros or zero-length strings, in some cases supplying default values
'The vbCrLf constant represents a carriage return + linefeed
For lngPosition = 1 To lngCount
With rst
'Set variables to data from a record
strContactID = Nz(![CustomerID])
strTitle = Nz(![Title])
strFirstName = Nz(![FirstName])
strMiddleName = Nz(![MiddleName])
strLastName = Nz(![LastName])
strSuffix = Nz(![Suffix])
strJobTitle = Nz(![JobTitle])
strCompany = Nz(![Company])
strLastNameFirst = Nz(![LastName]) & ", " & Nz(![FirstName])
strBusinessStreet = Nz(![BusinessStreet1]) & IIf(Nz(![BusinessStreet2]) <> "", vbCrLf & Nz(![BusinessStreet2]), "")
strBusinessCity = Nz(![BusinessCity])
strBusinessState = Nz(![BusinessState])
strBusinessPostalCode = Nz(![BusinessPostalCode])
strBusinessCountry = Nz(![BusinessCountry])
strBusinessPhone = Nz(![BusinessPhone])
strBusinessFax = Nz(![BusinessFax])
strHomeStreet = Nz(![HomeStreet1]) & IIf(Nz(![HomeStreet2]) <> "", vbCrLf & Nz(![HomeStreet2]), "")
strHomeCity = Nz(![HomeCity])
strHomeState = Nz(![HomeState])
strHomePostalCode = Nz(![HomePostalCode])
strHomeCountry = Nz(![HomeCountry])
strHomePhone = Nz(![HomePhone])
strHomeFax = Nz(![HomeFax])
strOtherStreet = Nz(![OtherStreet1]) & IIf(Nz(![OtherStreet2]) <> "", vbCrLf & Nz(![OtherStreet2]), "")
strOtherCity = Nz(![OtherCity])
strOtherState = Nz(![OtherState])
strOtherPostalCode = Nz(![OtherPostalCode])
strOtherCountry = Nz(![OtherCountry])
strOtherPhone = Nz(![OtherPhone])
strOtherFax = Nz(![OtherFax])
strMobilePhone = Nz(![MobilePhone])
strEMailAddress = Nz(![E-mailAddress])
strEMailAddress2 = Nz(![E-mail2Address])


'1/1/4501 is the way Outlook stores a blank date
'dteLastVisit = Nz(![LastVisit], #1/1/4501#)
'intNoChildren = Nz(![NumberChildren])
'strCustomerType = Nz(![CustomerType], "Standard")
dteBirthdate = Nz(![Birthdate])
dteSpouseBirthdate = Nz(![SpouseBirthdate])
strInvestmentAdvisor = Nz(![InvestmentAdvisor])
strBranch = Nz(![Branch])
dteAnnualReview = Nz(![AnnualReview])
dteAnnual = Nz(![Annual])
dteFirstQuarter = Nz(![FirstQuarter])
dteSecondQuarter = Nz(![SecondQuarter])
dteThirdQuarter = Nz(![ThirdQuarter])
dteFourthQuarter = Nz(![FourthQuarter])
dteSemiAnnual1 = Nz(![SemiAnnual1])
dteSemiAnnual2 = Nz(![SemiAnnual2])
strCSINotes = Nz(![CSINotes])

End With

'Create a contact item
Set itm = itms.Add(strContactForm)

'Write values from variables to fields in the new Contact item
With itm
'Standard Contact fields
.CustomerID = strContactID
.Title = strTitle
.FirstName = strFirstName
.MiddleName = strMiddleName
.LastName = strLastName
.Suffix = strSuffix
.JobTitle = strJobTitle
.CompanyName = strCompany
.BusinessAddressStreet = strBusinessStreet
.BusinessAddressCity = strBusinessCity
.BusinessAddressState = strBusinessState
.BusinessAddressPostalCode = strBusinessPostalCode
.BusinessAddressCountry = strBusinessCountry
.BusinessTelephoneNumber = strBusinessPhone
.BusinessFaxNumber = strBusinessFax
.HomeAddressStreet = strHomeStreet
.HomeAddressCity = strHomeCity
.HomeAddressState = strHomeState
.HomeAddressPostalCode = strHomePostalCode
.HomeAddressCountry = strHomeCountry
.HomeTelephoneNumber = strHomePhone
.HomeFaxNumber = strHomeFax
.OtherAddressStreet = strOtherStreet
.OtherAddressCity = strOtherCity
.OtherAddressState = strOtherState
.OtherAddressPostalCode = strOtherPostalCode
.OtherAddressCountry = strOtherCountry
.OtherTelephoneNumber = strOtherPhone
.OtherFaxNumber = strOtherFax
.MobileTelephoneNumber = strMobilePhone
.Email1Address = strEMailAddress
.Email2Address = strEMailAddress2
.Categories = strCategory

'Custom fields -- modify as needed for your custom form
'The Debug.Print statements are for debugging possible problems
'Debug.Print "Writing " & dteLastVisit & " to Last Visit field"
'.UserProperties("LastVisit") = dteLastVisit
'Debug.Print "Writing " & intNoChildren & " to Number Children field"
'.UserProperties("NumberChildren") = intNoChildren
'Debug.Print "Writing " & strCustomerType & " to Customer Type field"
'.UserProperties("CustomerType") = strCustomerType
Debug.Print "Writing " & dteBirthdate & " to Birthdate field"
.UserProperties("Birthdate") = dteBirthdate
Debug.Print "Writing " & dteSpouseBirthdate & " to Spouse Birthdate field"
.UserProperties("SpouseBirthdate") = dteSpouseBirthdate
Debug.Print "Writing " & strInvestmentAdvisor & " to Investment Advisor field"
.UserProperties("InvestmentAdvisor") = strInvestmentAdvisor
Debug.Print "Writing " & strBranch & " to Branch field"
.UserProperties("Branch") = strBranch
Debug.Print "Writing " & dteAnnualReview & " to Annual Review field"
.UserProperties("AnnualReview") = dteAnnualReview
Debug.Print "Writing " & dteAnnual & " to Annual field"
.UserProperties("Annual") = dteAnnual
Debug.Print "Writing " & dteFirstQuarter & " to First Quarter field"
.UserProperties("FirstQuarter") = dteFirstQuarter
Debug.Print "Writing " & dteSecondQuarter & " to Second Quarter field"
.UserProperties("SecondQuarter") = dteSecondQuarter
Debug.Print "Writing " & dteThirdQuarter & " to Third Quarter field"
.UserProperties("ThirdQuarter") = dteThirdQuarter
Debug.Print "Writing " & dteFourthQuarter & " to Fourth Quarter field"
.UserProperties("FourthQuarter") = dteFourthQuarter
Debug.Print "Writing " & dteSemiAnnual1 & " to SemiAnnual1 field"
.UserProperties("SemiAnnual1") = dteSemiAnnual1
Debug.Print "Writing " & dteSemiAnnual2 & " to SemiAnnual2 field"
.UserProperties("SemiAnnual2") = dteSemiAnnual2
Debug.Print "Writing " & strCSINotes & " to CSINotes field"
.UserProperties("CSINotes") = strCSINotes

'Close and save new contact item
.Close (olSave)
DoCmd.RunCommand acCmdSaveRecord

'Update status bar with progress
varReturn = Application.SysCmd(acSysCmdUpdateMeter, lngPosition)

'Write information about contact just processed to a textbox on the form
Me![LastContact] = strContactID & " -- " & strLastNameFirst
End With
rst.MoveNext
Next lngPosition

'Clear status bar and turn off hourglass
varReturn = Application.SysCmd(acSysCmdClearStatus)
DoCmd.Hourglass False

MsgBox "All Contacts exported!"
Me![txtLastContact].Requery

ErrorHandlerExit:
Exit Sub

ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit

End Sub

Private Sub cmdQuit_Click()

On Error GoTo ErrorHandler

Application.Quit

ErrorHandlerExit:
Exit Sub

ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit

End Sub


Private Sub Form_Load()

On Error GoTo ErrorHandler

DoCmd.RunCommand acCmdSizeToFitForm

Me![ContactForm] = "IPM.Contact.CSI CRM"
Me![LastContact] = ""
Me![FolderName] = ""
Me![Category] = ""

ErrorHandlerExit:
Exit Sub

ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit

End Sub

Thanks
pockets
 
Do you know which line is causing you the problem?

If not, take out your error handling so that when the error occurs VBA will highlight the line that is causing the problem. RE-post that line and i'll take a look..

sugarflux
 
Thanks for the reply sufarflux. I do not know which line is causing the error as it does not show. I will take the error handler out and see what happens and then post it.
 
Sugarflux, I took the error handler off and it then showed me which lines were giving the problems. They were all in the section 'Set variables to data from a record and I was able to figure out what was going on. I have a couple of other small issues happening yet but I know what I need to do now. Thanks for the information, it helped a great deal and makes more sense to me know. If I run into any more problems I will post but for now looks good. Thanks
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top