Concevoir une liste qui filtre les enregistrements selon le contenu d'une zone de texte

Option Explicit
Option Compare Database

Private Sub Form_Load()

End Sub

'**********************************************************************
' Module            : Form_frmTowns
' Type              : Document VBA
' DateTime          : 20/09/2011
' Author            : Jean-Philippe AMBROSINO
' Review            : Jean-Philippe AMBROSINO
' Purpose           : Module de sélection d'une ville selon un critère
'
''**********************************************************************

Option Explicit
Option Compare Database

'Variable objet d'instance de la base de données
Private m_oDB                                               As DAO.Database
'Variable récupérant la sélection de la liste
Private m_strPostalCode                                     As String
Private m_strTown                                           As String
Private m_lngIDPostalCode                                   As Long
'Variable de la frappe en cours dans la zone de texte
Private m_strCurrentChars                                   As String
'Constantes des requêtes
Private Const TOWNCP_QUERY                                  As String = "qry_LBOListTownsCP"
Private Const CPTOWN_QUERY                                  As String = "qry_LBOListCPTowns"
'Constantes de légende du bouton d'inversion
Private Const CPTOWN_CAPTION                                As String = "Code Postal / Ville"
Private Const TOWNCP_CAPTION                                As String = "Ville / Code Postal"
'Constantes de largeurs de colonnes
Private Const CPT_TOWN_COLWIDTH                             As String = "0cm;1,6cm;7cm"
Private Const TOWN_CPT_COLWIDTH                             As String = "0cm;7cm;1,6cm"
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub cmdAdd_Click()
'Appelle la fonction AddNewTown pour ajouter une ville dans la base
    If _
            MsgBox("Normalement, vous n'avez pas à créer de nouvelles villes car elles ont toutes été implémentées dans la base..." _
                   & vbCrLf & "Toutefois, il est probable qu'un oubli ait été commis." & _
                   vbCrLf & vbCrLf & "Voulez-vous ajouter une autre ville ?", vbExclamation + vbYesNo + vbDefaultButton2, _
                   "Ajouter une ville") = vbYes Then
        AddNewTown
    End If
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub cmdClose_Click()
'Ferme le formulaire sans autre action (on peut y greffer un message de confirmation)
    DoCmd.Close acForm, Me.Name
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub cmdEraseEntry_Click()
'Efface la zone de texte, remet les contrôles à l'état initial et réinitialise la variable
    m_strCurrentChars = vbNullString
    cmdInvert.Caption = TOWNCP_CAPTION
    SetListOfCityProperties TOWNCP_QUERY, TOWN_CPT_COLWIDTH
    With Me.txtLookup
        .Value = vbNullString
        .SetFocus
    End With
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub cmdInvert_Click()
'Inverse la sélection et adapte la source de la liste en conséquence
    m_strCurrentChars = vbNullString
    Select Case cmdInvert.Caption
        Case CPTOWN_CAPTION
            SetListOfCityProperties TOWNCP_QUERY, TOWN_CPT_COLWIDTH
            Me.cmdInvert.Caption = TOWNCP_CAPTION
        Case TOWNCP_CAPTION
            SetListOfCityProperties CPTOWN_QUERY, CPT_TOWN_COLWIDTH
            Me.cmdInvert.Caption = CPTOWN_CAPTION
    End Select
    'Désactive les boutons
    Me.cmdUpdate.Enabled = False
    Me.cmdValid.Enabled = False
    With Me.txtLookup
        .Value = vbNullString
        .SetFocus
    End With
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub cmdUpdate_Click()
'Permet de mettre à jour une ville ou un code postal : le formulaire est à construire
Dim strCurrentSelection                                     As String
    strCurrentSelection = IIf(cmdInvert.Caption = CPTOWN_CAPTION, _
                              Me!lboPCTowns.Column(1) & " " & Me!lboPCTowns.Column(2), _
                              Me!lboPCTowns.Column(2) & " " & Me!lboPCTowns.Column(1))

    If MsgBox("Souhaitez-vous modifier le code postal ou la ville '" & _
              strCurrentSelection & "' ?", vbQuestion + vbYesNo, "Modifier") = vbYes Then
        m_lngIDPostalCode = Nz(Me.lboPCTowns.Column(0), 0)
        DoCmd.Close acForm, Me.Name
        '***************************************************************
        MsgBox "Formulaire cible à définir...", vbInformation, _
               "Mise en commentaire"
        'DoCmd.OpenForm "Formulaire_De_Mise_A_Jour", , , "IDPostalCode=" & m_lngIDPostalCode, _
         acFormEdit, acDialog, strCurrentSelection
        '***************************************************************
    End If
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub cmdValid_Click()
'Récupère la sélection effectuée sur la liste et la dépose dans les zones appropriées du formulaire appelant
'On entend par formulaire appelant, le formulaire qui a ouvert celui-ci
Dim m_strPostalCode                                         As Long
Dim m_strTown                                               As String
Dim m_lngIDPostalCode                                       As Long

    m_lngIDPostalCode = Nz(Me.lboPCTowns.Column(0), 0)
    If m_lngIDPostalCode Then
        'Affectation des valeurs aux variables selon la sélection
        m_strPostalCode = IIf(cmdInvert.Caption = CPTOWN_CAPTION, Me!lboPCTowns.Column(1), Me!lboPCTowns.Column(2))
        m_strTown = IIf(cmdInvert.Caption = CPTOWN_CAPTION, Me!lboPCTowns.Column(2), Me!lboPCTowns.Column(1))
        If MsgBox("Cette action va déposer la sélection :" & vbCrLf & m_strPostalCode & " " & m_strTown & " dans le formulaire..." & _
                  vbCrLf & vbCrLf & "Est-ce correct ?", vbQuestion + vbYesNo, "Confirmation") = vbYes Then
            DoCmd.Close acForm, Me.Name
            'On passe la valeur de 'ID à l'argument OpenArgs pour le récupérer...
            'On aurait pu procéder à l'aide d'une variable ou d'une propriété publique
            DoCmd.OpenForm "frmAppelant", , , , , acDialog, m_lngIDPostalCode
        End If
    End If
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub Form_Close()
'Fermer l'objet Database et distinguer la variable objet de l'objet réel qu'elle représente
    If Not m_oDB Is Nothing Then m_oDB.Close
    Set m_oDB = Nothing
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub Form_KeyPress(KeyAscii As Integer)
'Si l'utilsateur appuie sur Echap (27) le formulaire est fermé sans confirmation
'Utilisable seulement si la propriété KeyPreview = True
    If KeyAscii = 27 Then
        DoCmd.Close acForm, Me.Name
    End If
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub Form_Load()
'Active le sablier
    DoCmd.Hourglass True
    'Propriété du formulaire
    Me.KeyPreview = True
    'Initialise la base de données dans la variable
    Set m_oDB = CurrentDb
    'Prépare les contrôles
    Me.cmdInvert.Caption = TOWNCP_CAPTION
    Me.cmdAdd.Enabled = True
    Me.cmdUpdate.Enabled = False
    Me.lblCountTowns.Caption = CountTownFound(vbNullString)
    'Initialise la liste des communes
    SetListOfCityProperties TOWNCP_QUERY, TOWN_CPT_COLWIDTH
    'Désactive le sablier
    DoCmd.Hourglass False
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub lboPCTowns_Click()
Dim strCurrentSelection                                     As String
    'Affecte la sélection CP+Commune dans une variable quel que soit l'ordre des colonnes
    strCurrentSelection = IIf(cmdInvert.Caption = CPTOWN_CAPTION, _
                              Me!lboPCTowns.Column(1) & " " & Me!lboPCTowns.Column(2), _
                              Me!lboPCTowns.Column(2) & " " & Me!lboPCTowns.Column(1))

    'Libère le bouton de validation
    Me.cmdValid.Enabled = True
    'et celui de la mise à jour
    Me.cmdUpdate.Enabled = True
    Me.labelTownSelected1.Caption = strCurrentSelection
    Me.labelTownSelected2.Caption = labelTownSelected1.Caption
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub txtLookup_KeyPress(KeyAscii As Integer)
    UpdateTownList KeyAscii
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub AddNewTown()
'Permet d'ajouter une ville et son CP dans la base de données
Dim oRS                                                     As DAO.Recordset
Dim lngNewID                                                As Long
Dim strCurrentSelection                                     As String

    'Mise en place d'une gestion d'erreurs (DAO)
    On Error GoTo L_ErrAddNewTown
    'Demande le nom de la ville...
    m_strTown = UCase$(InputBox("Quel est le nom de la commune à ajouter ?", "Nouvelle commune"))
    'Vérifie si une entrée est saisie
    If Len(m_strTown) = 0 Then
        MsgBox "Le nom inscrit est incorrect ou bien vous avez annulé!", vbExclamation, "Erreur"
        Exit Sub
    End If
    'Demande le N° du code postal...
    m_strPostalCode = InputBox("Quel est le N° du code postal de cette ville '" & m_strTown & "' ?", "Code postal de la ville")
    'Vérifie si une entrée est saisie et comporte 5 caractères
    If Len(m_strPostalCode) <> 5 Then
        MsgBox "Le N° inscrit est incorrect ou bien vous avez annulé !", vbExclamation, "Erreur"
        Exit Sub
    End If
    'Confirmation de l'entrée (en MAJUSCULES non accentuées)...
    strCurrentSelection = m_strPostalCode & " " & RemoveCharAccents(m_strTown, True)
    If MsgBox("Veuillez confirmer que doit être ajouté '" & strCurrentSelection & "' dans la base ?", _
              vbQuestion + vbYesNo, "Ajout") = vbYes Then

        'Contrôle de l'existence de la ville
        If ThisTownExists(m_strTown, m_strPostalCode) Then
            MsgBox "La commune '" & m_strTown & _
                   "' existe déjà dans la base : elle a pour code postal " & m_strPostalCode & "...", vbExclamation, "Doublon"
            Exit Sub
        Else
            'Ouvre le Recordset sur la table pour ajouter les valeurs
            Set oRS = CurrentDb.OpenRecordset("TBLPostalCodes", dbOpenDynaset)
            With oRS
                .AddNew
                !PostalCode = m_strPostalCode
                !Town = m_strTown
                lngNewID = !IDPostalCode
                .update
                .Close
            End With
            'Met à jour la liste en conséquence
            With Me.lboPCTowns
                .Requery
            End With
            'Ajoute la nouvelle entrée dans la zone de texte selon l'inversion en cours
            If cmdInvert.Caption = CPTOWN_CAPTION Then
                Me.txtLookup = m_strPostalCode
            Else
                Me.txtLookup = m_strTown
            End If
            'Affecte l'ID à la variable comme si on l'avait sélectionnée
            m_lngIDPostalCode = lngNewID
            'Et au label au-dessous de la liste
            Me.labelTownSelected1.Caption = strCurrentSelection
            Me.labelTownSelected2.Caption = labelTownSelected1.Caption
            'Et on compte le nombre de villes trouvées
            Me.lblCountTowns.Caption = CountTownFound(vbNullString)
        End If
    End If

    On Error GoTo 0
L_ExAddNewTown:
    'Libère l'objet de la mémoire
    Set oRS = Nothing
    Exit Sub

L_ErrAddNewTown:
    'Message si erreur
    MsgBox Err.Description, vbExclamation, Err.Source
    'Reprendre la suite...
    Resume L_ExAddNewTown
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Function ThisTownExists(ByVal Town As String, ByVal PostalCode As _
                                                      String) As Long
'Vérifie si la paire une commune et son CP existe déjà dans la base
Dim oRS                                                     As DAO.Recordset
Dim SQL                                                     As String
Dim blnExists                                               As Boolean
Dim SQLCheckTown                                            As String
Dim m_strPostalCode                                         As Long

    On Error GoTo L_ErrThisTownExists

    SQL = "SELECT IDPostalCode FROM TBLPostalCodes WHERE Town = '" & Town & "' AND PostalCode = '" & PostalCode & "';"
    Set oRS = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
    With oRS
        'Si un enregistrement est trouvé...
        If Not .EOF Then ThisTownExists = .Fields(0).Value
        .Close
    End With

    On Error GoTo 0
L_ExThisTownExists:
    'Libère l'objet de la mémoire
    Set oRS = Nothing
    Exit Function

L_ErrThisTownExists:
    MsgBox Err.Description, vbExclamation, Err.Source
    Resume L_ExThisTownExists
End Function
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub UpdateTownList(KeyAscii As Integer)
'Met à jour la liste des communes en fonction des caractères tapés dans la zone de texte
Dim SQL                                                     As String
Dim SQLWhere                                                As String
Dim strCityCount                                            As String

    'Selon le sens de la recherche
    Select Case cmdInvert.Caption
        Case CPTOWN_CAPTION
            'Sens Code postal => Ville
            Select Case KeyAscii
                Case 8, 48 To 57
                    'Backspace ou un nombre : acceptés
                Case Else
                    'Sinon rien
                    KeyAscii = 0
                    MsgBox "Un caractère numérique est requis ici !", vbExclamation, "Erreur de frappe"
                    m_strCurrentChars = vbNullString
                    Exit Sub
            End Select
            If KeyAscii = 8 Then
                'Si on appuie sur Backspace alors on retire un caractère
                On Error Resume Next
                m_strCurrentChars = Left$(m_strCurrentChars, Len(m_strCurrentChars) - 1)
                On Error GoTo 0
            Else
                'Sinon la variable s'incrémente et prend le caractère tapé
                m_strCurrentChars = m_strCurrentChars & Chr(KeyAscii)
            End If
            'On applique alors le critère à la chaîne SQL
            SQL = "SELECT IDPostalCode, PostalCode, Town "
            SQL = SQL & "FROM TBLPostalCodes "
            SQLWhere = "WHERE PostalCode Like '" & m_strCurrentChars & "*' "
            SQL = SQL & SQLWhere & "ORDER BY PostalCode;"
            'Et on rafraîchit la liste selon cette clause SQL
            SetListOfCityProperties SQL, CPT_TOWN_COLWIDTH

        Case TOWNCP_CAPTION
            Select Case KeyAscii
                Case 8, 32
                    'Backspace, un espace : acceptés
                Case 39, 45
                    'apostrophe ou tiret : refusés
                    KeyAscii = 0
                    MsgBox "Les apostrophes et les tirets ne sont pas normalisés pour les noms des villes !" & _
                           vbCrLf & vbCrLf & "Rendez-vous ici pour plus d'infos :" & _
                           vbCrLf & "http://www.laposte.fr/sna/rubrique.php3?id_rubrique=87", vbExclamation, "Erreur de frappe"
                    m_strCurrentChars = vbNullString

                    'Voir "http://www.laposte.fr/sna/rubrique.php3?id_rubrique=87" pour plus d'infos
                Case 65 To 90
                    'MAJUSCULE : acceptés
                Case 97 To 122
                    'minuscule : acceptés donc converti en majuscule
                    KeyAscii = KeyAscii - 32
                    'MAJUSCULE accentuées
                Case 192, 193, 194, 195, 196, 197: KeyAscii = 65    'A
                Case 199: KeyAscii = 67                    'C
                Case 200, 201, 202, 203: KeyAscii = 69     'E
                Case 204, 205, 206, 207: KeyAscii = 73     'I
                Case 209: KeyAscii = 78                    'N
                Case 210, 211, 212, 213, 214: KeyAscii = 79    'O
                Case 217, 218, 219, 220: KeyAscii = 85     'U
                    'minuscules accentuées
                Case 224, 225, 226, 227, 228, 229: KeyAscii = 65    '97:a
                Case 231: KeyAscii = 67                    '99:c
                Case 232, 233, 234, 235: KeyAscii = 69     '101:e
                Case 236, 237, 238, 239: KeyAscii = 73     '105:i
                Case 241: KeyAscii = 78                    '110:n
                Case 242, 243, 244, 245, 246: KeyAscii = 79    '111:o
                Case 249, 250, 251, 252: KeyAscii = 85     '117:u
                Case Else
                    'Sinon rien
                    KeyAscii = 0
                    MsgBox "Un caractère alphabétique est requis ici !", vbExclamation, "Erreur de frappe"
                    m_strCurrentChars = vbNullString
                    Exit Sub
            End Select

            If KeyAscii = 8 Then
                'Si on appuie sur Backspace alors on retire un caractère
                On Error Resume Next
                m_strCurrentChars = Left(m_strCurrentChars, Len(m_strCurrentChars) - 1)
                On Error GoTo 0
            Else
                'Sinon la variable s'incrémente et prend le caractère tapé
                m_strCurrentChars = m_strCurrentChars & Chr(KeyAscii)
            End If
            'Si aucun caractère tapé alors on pose un astérisque de manière à ne pas provoquer une erreur
            If Len(m_strCurrentChars) = 0 Then m_strCurrentChars = "*"
            'On applique alors le critère à la chaîne SQL
            SQL = "SELECT IDPostalCode, Town, PostalCode FROM TBLPostalCodes "
            SQLWhere = "WHERE Town Like '" & m_strCurrentChars & "*' "
            SQL = SQL & SQLWhere & "ORDER BY Town;"
            'Et on rafraîchit la liste selon cette clause SQL
            SetListOfCityProperties SQL, TOWN_CPT_COLWIDTH
    End Select
    'Et on compte le nombre de villes trouvées
    Me.lblCountTowns.Caption = CountTownFound(SQLWhere)
    'Si la zone ne contient que * on efface la variable (cas de KeyAscii = 8)
    If Len(m_strCurrentChars) Then
        If (Asc(Left$(m_strCurrentChars, 1)) = 42) And (Len(m_strCurrentChars) = 1) Then
            m_strCurrentChars = vbNullString
        End If
    End If
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Sub SetListOfCityProperties(ByVal Source As String, ColWidth As String)
'Rafraîchit la liste des villes
    With lboPCTowns
        .ColumnCount = 3
        .BoundColumn = 3
        .RowSource = Source
        .ColumnWidths = ColWidth
    End With
End Sub
''' ---------------------------------------------------------------------------------------------------------------------------------------
Private Function CountTownFound(ByVal SQLWhere As String) As String
'Compte le nombre de villes correspondant au critère
Dim oRS                                                     As DAO.Recordset
Dim SQL                                                     As String
Dim lngRowCount                                             As Long

    On Error GoTo L_ErrCountTownFound
    'On ouvre le RecordSet sur le critère en cours...
    SQL = "SELECT COUNT(IDPostalCode) AS NBRows "
    SQL = SQL & "FROM TBLPostalCodes " & SQLWhere
    Set oRS = m_oDB.OpenRecordset(SQL, dbOpenSnapshot)
    With oRS
        lngRowCount = Nz(.Fields(0).Value, 0)
        'Si la variable est > 0
        If lngRowCount Then
            CountTownFound = lngRowCount & " commune" & IIf(lngRowCount = 1, " ", "s ") & "trouvée" & _
                             IIf(lngRowCount = 1, " ", "s ")
        Else
            CountTownFound = "Aucune commune trouvée..."
        End If
        .Close
    End With

    On Error GoTo 0
L_ExCountTownFound:
    'Libère l'objet de la mémoire
    Set oRS = Nothing
    Exit Function

L_ErrCountTownFound:
    MsgBox Err.Description, vbExclamation, Err.Source
    Resume 'L_ExCountTownFound
End Function

Function RemoveCharAccents(ByVal TextToChange As String, Optional ByVal ToUpperCase As Boolean = False)
'Permet de substituer les accents d'un chaîne avec option MAJUSCULE
Const CHARS_WITH_ACCENTS                                    As String = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÒÓÔÕÖ&#216;ÙÚÛÜàáâãäåèéêëìíîïòóôõö&#248;ùúûü&#255;&#209;Ç&#241;ç"
Const CHARS_WITHOUT_ACCENTS                                 As String = "AAAAAAEEEEIIIIOOOOOOUUUUaaaaaaeeeeiiiioooooouuuuyNCnc"
Dim C                                                       As Integer
Dim strChar                                                 As String
Dim strNoAccentChars                                        As String
Dim strFinalString                                          As String

    strFinalString = TextToChange
    strNoAccentChars = CHARS_WITHOUT_ACCENTS
    If ToUpperCase Then
        strNoAccentChars = UCase$(CHARS_WITHOUT_ACCENTS)
    End If
    For C = 1 To Len(CHARS_WITH_ACCENTS)
        strChar = Mid$(CHARS_WITH_ACCENTS, C, 1)
        If InStr(1, strFinalString, strChar, vbBinaryCompare) Then
            strFinalString = Replace(strFinalString, strChar, Mid$(strNoAccentChars, C, 1))
        End If
    Next C
    RemoveCharAccents = IIf(ToUpperCase, UCase(strFinalString), strFinalString)
End Function

                Case 39, 45
                    'apostrophe ou tiret : refusés
                    KeyAscii = 0
                    MsgBox "Les apostrophes et les tirets ne sont pas normalisés pour les noms des villes !" & _
                           vbCrLf & vbCrLf & "Rendez-vous ici pour plus d'infos :" & _
                           vbCrLf & "http://www.laposte.fr/sna/rubrique.php3?id_rubrique=87", vbExclamation, "Erreur de frappe"
                    m_strCurrentChars = vbNullString