Exporting contacts to outlook

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 "Por favor seleccione una carpeta de Contactos"
 	  GoTo SelectContactFolder
    End If
    
    Forms![frmExportToOutlook].SetFocus
    Me![txtFolderName].Value = pfld.Name
    
    
 ErrorHandlerExit:
    Exit Function
 
 ErrorHandler:
    MsgBox "Error No: " & Err.Number & "; Descripción: " & 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 strNombre As String
    Dim strApellidoPat As String
    Dim strApellidoMat As String
    
    
    
    Dim strEMailAddress As String
    Dim strEMailAddress2 As String
    Dim strID As String
    Dim lngCount As Long
    Dim strMessage As String
    Dim lngResult As Long
    Dim strContactForm As String
    
 	Dim varReturn As Variant
    Dim lngPosition As Long
    
    '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![tblContacts].OpenRecordset(dbOpenTable, dbDenyRead)
    lngCount = rst.RecordCount
    strMessage = lngCount & " contactos a transferir a Outlook -- ¿Proceder?"
    
    'Ask if user wants to proceed with the export
    lngResult = MsgBox(strMessage, vbYesNo, "¿Proceder?")
    
    'Exit if user says No
    If lngResult = vbNo Then Exit Sub
    
    'Pick up name of contact form from text box, with IPM.Contact.Test Contact
    '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("IPM.Contact.hillel", "IPM.Contact")
    
    'Pick up category from text box, allowing a blank category
 	  
    'Turn on hourglass and initialize status bar to show progress of the export
    DoCmd.Hourglass True
    strMessage = "Exportando " & lngCount & " registros a Outlook"
    varReturn = Application.SysCmd(acSysCmdInitMeter, strMessage, lngCount)
    
    
    'Loop through the Access table, exporting each record to Outlook
    For lngPosition = 1 To lngCount
 	  With rst
 		 'Set variables to data from a record
 		 strID = Nz(![ID])
 		 strNombre = Nz(![Nombre])
 		 strApellidoMat = Nz(![ApellidoMat])
 		 strApellidoPat = Nz(![ApellidoPat])
 		 strEMailAddress = Nz(![Email])
 		 strEMailAddress2 = Nz(![Email2])
 		 
 				  
 	  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 = strID
 		 .FirstName = strNombre
 		 .MiddleName = strApellidoMat
 		 .LastName = strApellidoPat
 				  
 		 .Email1Address = strEMailAddress
 		 .Email2Address = strEMailAddress2
 				  
 				 
 		 'Close and save new contact item
 		 .Close (olSave)
 		 DoCmd.RunCommand acCmdSaveRecord
 		 
 		 'Update status bar with progress
 		 varReturn = Application.SysCmd(acSysCmdUpdateMeter, lngPosition)
 		 
 		
 		 
 	  End With
    rst.MoveNext
    Next lngPosition
    
    'Clear status bar and turn off hourglass
    varReturn = Application.SysCmd(acSysCmdClearStatus)
    DoCmd.Hourglass False
    
    MsgBox "Todos los Contactos han sido exportados!"
 	  
 ErrorHandlerExit:
    Exit Sub
 
 ErrorHandler:
    MsgBox "Error No: " & Err.Number & "; Descripción: " & Err.Description
    Resume ErrorHandlerExit
 
 End Sub