Selectively Control Updating Outlook Contact from Access

[dgreen20]

Cross posting from an Access forum (https://www.access-programmers.co.uk/forums/threads/selectively-control-updating-outlook-contact-from-access.310801/).

How do I delete an existing record and then repopulate it in Outlook? The below code is deleting the 1st record populated, not repopulating it and moving to the next record.

        If vbYes Then
            If Not TypeName(con) = "Nothing" Then
                'Full replacement of existing record
                'Delete the current record
                con.Delete
                'Populate the current record from Access.
                With olContact
                    .CustomerID = rst("Name_ID")
                    .FirstName = Nz(rst("First_Name"), "")
                    .MiddleName = Nz(rst("MI"), "")
                    .LastName = rst("Last_Name")
                    .FullName = rst("FullName")
                    .FileAs = rst("FullName")
                    .Save
                End With

The next set of issues are 1) how to identify that a specific field is different between Access and Outlook and then 2) how to let the user make a decision to change the value or not.

The specific section of code that I'm looking for help in is here.

The user has clicked a message box asking if they want to just allow Access to make the changes (Yes) or do it manually (No). They have chosen No. I need to show them every mismatched value and given them a chance to change it or trust it.

 
                'Selectively update values that are different between Access and Outlook
                If Not TypeName(con) = "Nothing" Then
                    With olContact
                    'If the First Name value in Outlook Contact doesn't match the Access contact then
                        If .FirstName <> rst("First_Name") Then
                            MsgBox "Change Outlook name to match Access", vbYesNo
                            If vbYes Then
                                .FirstName = rst("First_Name")
                            'If vbNo Then
                           'Leave the value alone and move on 
                          'what goes here to move to the next field to check?
                            End If
                        End If
                        .Save
                    End With 

Below is the whole code if you need to see it in context. Feel free to critique the code, if you think there is a better way to organize this.

Private Sub ExportAccessContacts_Click()
    'https://social.msdn.microsoft.com/Forums/office/en-US/50c8c35e-0058-45a3-a3b1-7dd605f44e91/using-the-access-table-with-vba-in-outlook-contacts-i-want-to-export-and-import?forum=accessdev
    'https://docs.microsoft.com/en-us/office/vba/api/outlook.contactitem
    Dim OlApp As Object
    Dim olContact As Object
    On Error GoTo HandleErr
    
    Const olContactItem = 2                       'https://docs.microsoft.com/en-us/office/vba/api/outlook.olitemtype
    
    Set OlApp = CreateObject("Outlook.Application")
    
    Dim appOutlook As Outlook.Application
    Dim nms As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
    Dim con As Outlook.ContactItem
    Dim lngContactID As Long
    
    Dim ClickResult As VbMsgBoxResultEx
    Dim strFile As String
    
    Dim rst As Dao.Recordset
    Set rst = CurrentDb.OpenRecordset("q_Contacts_Search", dbOpenSnapshot)
    
    Set appOutlook = GetObject(, "Outlook.Application")
    Set nms = appOutlook.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderContacts)
    
    'Move to the first record in the table/query
    rst.MoveFirst
    
    'Continue to do the below loop until all records are either added to Outlook or have been confirmed that they were already there.
    Do Until rst.EOF
        
        lngContactID = rst("Name_ID")
        strFile = "C:\Users\" & fOSUserName() & "\Pictures\AVC_Backend\Contacts\" & rst("First_Name") & " " & rst("Last_Name") & ".png"
        Set con = fld.Items.Find("[CustomerID] = " & lngContactID)
        Set olContact = OlApp.CreateItem(olContactItem)
        
        'Give user option to use all values from Access or selectively update Outlook (one record at a time)
        MsgBox "Trust Access (Yes) or Go Slow (No)", vbYesNoCancel
        
        If vbYes Then
            If Not TypeName(con) = "Nothing" Then
                'Full replacement of existing record
                'Delete the current record
                con.Delete
                'Populate the current record from Access.
                With olContact
                    .CustomerID = rst("Name_ID")
                    .FirstName = Nz(rst("First_Name"), "")
                    .MiddleName = Nz(rst("MI"), "")
                    .LastName = rst("Last_Name")
                    .FullName = rst("FullName")
                    .FileAs = rst("FullName")
                    .Save
                End With
                rst.MoveNext

            Else
                'Create a new record if the Name_ID isn't already in the default Outlook Contacts folder.
                With olContact
                    .CustomerID = rst("Name_ID")
                    .FirstName = Nz(rst("First_Name"), "")
                    .MiddleName = Nz(rst("MI"), "")
                    .LastName = rst("Last_Name")
                    .FullName = rst("FullName")
                    .FileAs = rst("FullName")
                    End If
                    .Save
                End With
                rst.MoveNext
                'Start over again with the next record in the table/query
            End If

            If vbNo Then
                'Selectively update values that are different between Access and Outlook
                If Not TypeName(con) = "Nothing" Then
                    With olContact
                        If .FirstName <> rst("First_Name") Then
                            MsgBox "Change Outlook name to match Access", vbYesNo
                            If vbYes Then
                                .FirstName = rst("First_Name")
                            'If vbNo Then
                            'what goes here to move to the next field to check?
                            End If
                        End If
                        .Save
                    End With
                    rst.MoveNext

                Else
                    'Create a new record if the Name_ID isn't already in the default Outlook Contacts folder.
                    With olContact
                        .CustomerID = rst("Name_ID")
                        .FirstName = Nz(rst("First_Name"), "")
                        .MiddleName = Nz(rst("MI"), "")
                        .LastName = rst("Last_Name")
                        .FullName = rst("FullName")
                        .FileAs = rst("FullName")
                        End If
                        .Save
                    End With
                    'Move to the next record
                    rst.MoveNext
                End If
            End If
        End If
    Loop
    'clean up
    Set olContact = Nothing
    Set con = Nothing
    Set fld = Nothing
    Set nms = Nothing
    Set appOutlook = Nothing
    
    rst.Close
    Set rst = Nothing
    
    MsgBox "Done"
    
HandleExit:
    Exit Sub
    
HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
            Resume HandleExit
            Resume
    End Select
End Sub