.MoveNext not working

[Pat Hartman]

Good luck. Using the linked tables and an append query should be pretty simple. You can also use the linked table to help the users determine if the contact already exists to prevent duplicates. Outlook lets you add duplicates. It is a flat file so it doesn't care. Using Acces, will allow you to clean up the contacts more easily.

Doing stuff like this always worries me though so make sure you back up the contacts data before you run any update queries on it.

 

[NauticalGent]

I haven't had to do this in years but try linking to the contacts table in Outlook. I think it is in Other data sources. You can use this linked table like any other linked table. You can even update it. However, that process is a little strange. If you open the table and modify one of the entries, the entry shows #deleted# after the update completes. so it looks like the process deletes the old record and adds a new record because if you close and open the recordset, you see the updated record. If all you are doing is appending records, that should be fine.

I was wondering why no one had suggested this yet but I was keeping my silence because I was unsure. I just tested it on my work thin client and it worked like a charm.

I think it is in Other data sources.

That is correct.

 

[Pat Hartman]

I was wondering why no one had suggested this yet

It's too simple. Not enough of a challenge.

 

[SHANEMAC51]

Код записывает контактные данные первых лиц в контакты Outlook дважды. Это не идет на вторую запись.

The code writes the contact details of the first persons to Outlook contacts twice. It doesn't go to the second record

FirstName = Nz(DLookup("FName", "Temp Email and Tel Table for Outlook"))
LastName = Nz(DLookup("LName", "Temp Email and Tel Table for Outlook"))

this is an appeal to line 1, there is no condition

 

[SHANEMAC51]

    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)
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
''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set rs = MyDB.OpenRecordset("Temp Email and Tel Table for Outlook")
rs.movelast
rs.movefirst
    lngRSCount = rs.RecordCount
        
    
  
    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 = !FName       
      LastName = !LName       
      AddrStreet = !Address   
      AddrStreet2 = !Address2 
      AddrCity = !City         
      AddrState = !State       
      AddrZIP = !ZIP           
      CustomerTel = !Telephone 
      CustomerEmail = !Email   
      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