Sub FixPrivateContacts()
    Dim objApp As Application
    Dim objFolder As MAPIFolder
    Dim objSelection As Selection
    
    Set objApp = CreateObject("Outlook.Application")
    Set objFolder = objApp.ActiveExplorer.CurrentFolder
    If objFolder.DefaultMessageClass = "IPM.Contact" Then
        Set objSelection = objApp.ActiveExplorer.Selection
        Select Case objSelection.Count
            Case 0
                MsgBox "No items were selected", _
                  vbOKOnly, "Nothing to do"
            Case Else
                Call DoFix(objSelection)
        End Select
    Else
        MsgBox "Please select a Contacts folder and try again.", _
          vbExclamation + vbOKOnly, _
          "Not a Contacts Folder"
    End If
    
    ' release objects
    Set objFolder = Nothing
    Set objSelection = Nothing
    Set objApp = Nothing
End Sub

Private Sub DoFix(objSelection As Selection)
    Dim objItem As ContactItem
    
    For Each objItem In objSelection
        With objItem
            If .Class = olContact Then
                .Sensitivity = olNormal
                .Save
            End If
        End With
    Next
    
    ' release object
    Set objItem = Nothing
End Sub