dgreen20
04-14-2020, 04:53 AM
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
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