Dim MyDB As Database, rs As Recordset Dim CustomerID As Long Dim rstFiltered As DAO.Recordset Dim FName As String Dim LName As String Dim Address As String Dim Address2 As String Dim City As String Dim State As String Dim ZIP As String Dim CustomerTel As String Dim CustomerEmail As String Dim TransferredTo As Boolean Dim lngRSCount As Long Set MyDB = DBEngine.Workspaces(0).Databases(0) Set rs = MyDB.OpenRecordset("Temp Email and Tel Table for Outlook") lngRSCount = rs.RecordCount DoCmd.SetWarnings False DoCmd.OpenQuery "Delete Temp Email and Tel Table for Outlook" DoCmd.Close acQuery, "Delete Temp Email and Tel Table for Outlook" DoCmd.OpenQuery "Append FName to TempOutlook Table" DoCmd.Close acQuery, "Append FName to TempOutlook Table" DoCmd.OpenQuery "Append FName2 to TempOutlook Table" DoCmd.Close acQuery, "Append FName2 to TempOutlook Table" DoCmd.SetWarnings True If lngRSCount = 0 Then MsgBox ("There aren't any contacts to send to Outlook.") Exit Function Else MsgBox ("1-The value of lngRSCount is: " & lngRSCount) rs.MoveLast rs.MoveFirst With rs 'first With Do Until .EOF FirstName = Nz(DLookup("FName", "Temp Email and Tel Table for Outlook")) LastName = Nz(DLookup("LName", "Temp Email and Tel Table for Outlook")) AddrStreet = Nz(DLookup("Address", "Temp Email and Tel Table for Outlook")) AddrStreet2 = Nz(DLookup("Address2", "Temp Email and Tel Table for Outlook")) AddrCity = Nz(DLookup("City", "Temp Email and Tel Table for Outlook")) AddrState = Nz(DLookup("State", "Temp Email and Tel Table for Outlook")) AddrZIP = Nz(DLookup("ZIP", "Temp Email and Tel Table for Outlook")) CustomerTel = Nz(DLookup("Telephone", "Temp Email and Tel Table for Outlook")) CustomerEmail = Nz(DLookup("Email", "Temp Email and Tel Table for Outlook")) MsgBox ("2-The value of FName is: " & FirstName) If TransferredTo = True Then MsgBox ("This contact has already been added to your Outlook Contacts. " _ & " If you want to make a change and send it to Outlook, uncheck the 'Transfered " _ & " to Outlook' checkmark, make your change and then click on 'Send Contact to Outlook'. " _ & " Please note, when you do this, you will have a duplicate contact in Outlook and you should " _ & " probably delete the older contact.") Exit Function End If #Const EarlyBind = False 'True = Use Early Binding 'False = Use Late Binding #If EarlyBind = True Then 'Early Binding Declarations 'Requires Ref to Microsoft Outlook XX.X Object Library Dim oOutlook As Outlook.Application Dim olContact As Outlook.ContactItem #Else 'Late Binding Declaration/Constants Dim olApp As Object Dim olContact As Object Const olContactItem = 2 #End If Set olApp = CreateObject("Outlook.Application") Set olContact = olApp.CreateItem(olContactItem) With olContact .FirstName = FirstName .LastName = LastName .FullName = FirstName & ", " & LastName .FileAs = LastName & ", " & FirstName .JobTitle = JobTitles .CompanyName = CompName .HomeAddressStreet = AddrStreet .HomeAddressCity = AddrCity .HomeAddressState = AddrState .HomeAddressPostalCode = AddrZIP .BusinessTelephoneNumber = ContactTel .Email1Address = CustomerEmail .MobileTelephoneNumber = CustomerTel .Save ' .Display 'Uncomment if you wish the user to see the contact pop-up MsgBox ("Thank you, I have filed " & FirstName & " " & LastName & "'s contact information in Outlook.") End With .MoveNext MsgBox ("7-I'm about to loop") Loop End With 'Ends first With End If rs.Close MyDB.Close Set rs = Nothing Set MyDB = Nothing Close Error_Handler_Exit: On Error Resume Next If Not olContact Is Nothing Then Set olContact = Nothing If Not olApp Is Nothing Then Set olApp = Nothing Exit Function Error_Handler: MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: AddOlContact" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "An Error has Occured!" Resume Error_Handler_Exit End Function