Recherche dans une base de données en ado

Télécharger le projet
Commenter

Description

Ce module permet de rechercher dans une base de données ACCES, avec Microsoft ADO Data control 6.0 (OLEDB), des données en temps réel.
Ce module utilise un listview.
N'oublier pas de changer le path pour la recherche de la base nommée Recherche.mbd

Source / Exemple : 


' *******************************
' * Réalisé Sebastien CORDIER   *
' * s-cordier@libertysurf.fr    *
' *******************************

' *******************************
' * Module Acteur               *
' *******************************
Option Explicit

' * Variables globales *
Dim Con As New Connection       ' Connection au moteur ADO
Dim Cmd As New Command          ' Commande pour le moteur ADO
Dim RS As Recordset             ' Tableau resultat
Dim strQuery As String          ' Chaine de requête
Dim bSelect As Boolean          ' Flag de selection
Dim strKeySelect As String      ' Chaine de la cle selectionner
Dim bTri As Boolean             ' Tri par NOM

' *******************************
' * Ajout d'un nouvel acteur    *
' *******************************
Private Sub cmdAdd_Click()
    ' * Variables locales *
    Dim strNom As String            ' Nom de l'acteur
    Dim strPrenom As String         ' Prenom de l'acteur
    Dim intResult As Integer        ' Résultat de la combobox
    
    ' Initialisation de la saisie
    strNom = UCase(Trim(txtNom.Text))
    strPrenom = UCase(Trim(txtPrenom.Text))
    
    ' * Initialisation de la commande
    strQuery = "INSERT INTO Acteur (NOM,PRENOM,PHOTO) VALUES('%','$','?')"
    
    ' Finitialisation de la requête
    strQuery = Replace(strQuery, "%", strNom, 1, , vbTextCompare)
    strQuery = Replace(strQuery, "$", strPrenom, 1, , vbTextCompare)
    strQuery = Replace(strQuery, "?", strImage, 1, , vbTextCompare)
    
    ' Demande de confirmation de l'ajout de l'acteur
    intResult = MsgBox("Voulez-vous ajouter l'acteur : " & vbCrLf & _
                        strPrenom & " " & strNom & vbCrLf & _
                        "à la table des acteurs.", vbOKCancel, "Ajout d'un acteur")
    
    ' Si confirmation ALORS
    If (intResult = vbOK) Then
        ' Initialisation de la commande
        Cmd.CommandText = strQuery
        
        ' Execution de la commande
        Set RS = Cmd.Execute
        
        ' Libération des ressources
        Set RS = Nothing
    End If

    ' Reset des valeurs
    bSelect = False                             ' Annulation de la selection
    strKeySelect = ""
    strImage = ""

    txtNom.Text = ""                            ' Annulation de la zone de saisie
    txtPrenom = ""
    
    txtSearch.Text = txtSearch.Text & " "       ' Annulation zone de recherche
    txtSearch.Text = Trim(txtSearch.Text)
    
    ' Repositionne le focus sur la zone de recherche
    txtSearch.SetFocus

End Sub

' *******************************
' * Suppression de l'acteur     *
' *******************************
Private Sub cmdDelete_Click()

    ' * Variables locales *
    Dim strKey As String            ' Variable cle
    Dim intResult As Integer        ' Resultat combo box
    
    ' Initialisation des variables
    strKey = Replace(strKeySelect, "K", "", 1, , vbTextCompare)
    
    ' Initialisation de la requête
    strQuery = "DELETE FROM Acteur WHERE ID_ACTEUR=%"
    strQuery = Replace(strQuery, "%", strKey, 1, , vbTextCompare)
    
    ' Affichage message box
    intResult = MsgBox("Vous êtes sur le point de supprimer : " & vbCrLf & _
                        UCase(Trim(txtNom.Text)) & " " & UCase(Trim(txtPrenom.Text)) & vbCrLf & _
                        "de la table des acteurs.", vbOKCancel)
                        
    ' Test si OK
    If (intResult = vbOK) Then
        ' Préparation de la commande
        Cmd.CommandText = strQuery
        
        ' Execution de la commande
        Set RS = Cmd.Execute
        
        ' Libération des ressources
        Set RS = Nothing
    End If
    
    ' Reset des valeurs
    bSelect = False             ' Annule la selection
    strKeySelect = ""
    
    txtNom.Text = ""            ' Efface la zone de saisie
    txtPrenom = ""
    
    txtSearch.Text = ""         ' Efface la zone de recherche
    
    ' Repositionne le focus sur la zone de recherche
    txtSearch.SetFocus
    
    
End Sub

' *******************************
' * Modification d'un acteur    *
' *******************************
Private Sub cmdModif_Click()
    
    ' * Variables locales *
    Dim strNom As String
    Dim strPrenom As String
    Dim strKey As String
    
    ' Initialisation des variables
    strNom = UCase(Trim(txtNom.Text))
    strPrenom = UCase(Trim(txtPrenom.Text))
    strKey = Replace(strKeySelect, "K", "", 1, , vbTextCompare)
    
    ' Initialisation de la requête
    strQuery = "UPDATE Acteur SET NOM='%',PRENOM='$',PHOTO='?' WHERE ID_ACTEUR=!"
    strQuery = Replace(strQuery, "%", strNom, 1, , vbTextCompare)
    strQuery = Replace(strQuery, "$", strPrenom, 1, , vbTextCompare)
    strQuery = Replace(strQuery, "?", strImage, 1, , vbTextCompare)
    strQuery = Replace(strQuery, "!", strKey, 1, , vbTextCompare)
    
    ' Init commande
    Cmd.CommandText = strQuery
    
    ' Execute la commande
    Set RS = Cmd.Execute
    
    ' liberation des ressources
    Set RS = Nothing
    
    ' Reinitialise les valeurs
    bSelect = False                 ' Annulation de la selection
    strKeySelect = ""
    strImage = ""
    
    txtNom.Text = ""                ' Annulation de la zone de saisie
    txtPrenom.Text = ""
    
    txtSearch.Text = ""             ' Annulation de la recherche
    
    ' Repositionne le focus
    txtSearch.SetFocus

End Sub

' ***************************
' * Chargement de la photo  *
' ***************************
Private Sub cmdPhoto_Click()

    Dim strFileName As String
    
    ' Gestion du cancel error
    On Local Error GoTo MyErr
    
    ' Init boite de dialogue
    cdlgPhoto.CancelError = True
    cdlgPhoto.Filter = "Fichiers Images |*.jpg;*.gif;*.bmp;*.ico"
    cdlgPhoto.FilterIndex = 1
    cdlgPhoto.ShowOpen
    strFileName = cdlgPhoto.FileName
    
    ' Affichage de la photo
    Set imgPhoto.Picture = Nothing
    
    On Local Error GoTo ErrImg
    
    Set imgPhoto.Picture = LoadPicture(strFileName)
    
    strImage = UCase(Trim(strFileName))
    
    Exit Sub
    
MyErr:
    Exit Sub
    
ErrImg:

    stbInfo.Panels("info").Text = "Erreur de chargement de l'image"
    
End Sub

' *******************************
' * Chargement de la feuille    *
' *******************************
Private Sub Form_Load()
    ' Definition de la chaine de connection
    ' c'est ici qu'il faut modifier le chemin à la base de donnée : Data Source=
    Con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\Programmation\Projets\Recherche.mdb;Persist Security Info=False"
    
    ' Connection à la base de donnée
    Con.Open
    
    ' Affectation des commandes à la connection active
    Cmd.ActiveConnection = Con
   
    ' Affectation des collones list view
    lsvResult.ColumnHeaders.Add , , "Nom", (lsvResult.Width * (3 / 6)), lvwColumnLeft
    lsvResult.ColumnHeaders.Add , , "Prénom", (lsvResult.Width * (3 / 6)), lvwColumnLeft
    lsvResult.View = lvwReport
    
    ' Init du trie
    bTri = False
    stbInfo.Panels("info").Text = "Recherche par Nom"
          
End Sub

' *******************************
' * Dechargement de la feuille  *
' *******************************
Private Sub Form_Unload(Cancel As Integer)
    ' Fermeture de la connection
    Con.Close
End Sub

' *******************************
' * Selection d'une item        *
' *******************************
Private Sub lsvResult_ItemClick(ByVal Item As MSComctlLib.ListItem)
    ' * variables locales *
    Dim strKey As String            ' chaine de la cle
    
    ' Gestionnaire d'erreur
    On Local Error GoTo Err
    
    If (Not bTri) Then
        ' Affichage du nom de l'acteur
        txtNom.Text = Item.Text
    
        ' Affichage du prénom de l'acteur
        txtPrenom.Text = Item.SubItems(1)
    Else
        ' Affichage du nom de l'acteur
        txtNom.Text = Item.SubItems(1)
    
        ' Affichage du prénom de l'acteur
        txtPrenom.Text = Item.Text
    End If
    
    ' Info selection
    'stbInfo.Panels("info").Text = "Selection : " & UCase(Trim(txtNom.Text)) & " " & UCase(Trim(txtPrenom.Text))
        
    ' test si deja selectionner
    If (strKeySelect = Item.Key) Then Exit Sub
    
    ' Mémorisation de la cle
    strKeySelect = Item.Key
     
    ' Sortie de la routine
    Exit Sub
    
MyErr:
    ' Desaffectation de la gestion erreur
    On Local Error GoTo 0
    
    ' Libération des ressources
    Set RS = Nothing
        
     Exit Sub
    
Err:
    ' Desaffectation de la gestion erreur
    On Local Error GoTo 0
        
    ' Libération des ressources
    Set RS = Nothing
    
End Sub

' ***************************
' * Recherche par prenom    *
' ***************************
Private Sub mnuPrenom_Click()
    
    ' Bascule le mode checked et not checked
    mnuPrenom.Checked = Not mnuPrenom.Checked
    
    ' Bascule le flag flip/flop
    bTri = Not bTri
    
    ' Reinit des valeurs
    txtNom.Text = ""                ' Zone de saisie
    txtPrenom.Text = ""
    
    bSelect = False                 ' Selection
    strKeySelect = ""
    
    lsvResult.ColumnHeaders.Clear   ' en-tête de colonne
    
    If (Not bTri) Then
        ' Affectation des collones list view
        lsvResult.ColumnHeaders.Add , , "Nom", (lsvResult.Width - 5) / 2
        lsvResult.ColumnHeaders.Add , , "Prénom", (lsvResult.Width - 5) / 2
        lsvResult.View = lvwReport
        stbInfo.Panels("info").Text = "Recherche par Nom"
    Else
        ' Affectation des collones list view
        lsvResult.ColumnHeaders.Add , , "Prenom", (lsvResult.Width - 5) / 2
        lsvResult.ColumnHeaders.Add , , "Nom", (lsvResult.Width - 5) / 2
        lsvResult.View = lvwReport
        stbInfo.Panels("info").Text = "Recherche par Prenom"
    End If
    
    ' Reinit recherche
    txtSearch.Text = txtSearch.Text & " "
    txtSearch.Text = Trim(txtSearch.Text)

End Sub

' ***************************
' * Procédure de quitter    *
' ***************************
Private Sub mnuQuitter_Click()
    Unload Me
End Sub

' ***************************************************
' * Changement du contenu de la zone de recherche   *
' ***************************************************
Private Sub txtSearch_Change()
    
    ' * Variable locales *
    Dim strSearch As String             ' Zone texte de recherche
    Dim liItem As ListItem              ' Variable pour l'affichage du résultat
    Dim Cpt As Integer                  ' Compteur affichage
    
    ' Lecture de la valeur saisie
    strSearch = Trim(txtSearch.Text)
    strSearch = UCase(strSearch)
    
    ' Efface la zone résultat
    lsvResult.ListItems.Clear
    txtNom.Text = ""
    txtPrenom.Text = ""
    bSelect = False
    
    ' Info de Base
    stbInfo.Panels("info").Text = "0 acteurs"
    
       
    ' Test de la cohérence de la saisie
    If (txtSearch.Text = "") Then Exit Sub
    
    ' Définition de la requête
    If (Not bTri) Then
        strQuery = "SELECT * from Acteur WHERE NOM LIKE '$' ORDER BY NOM ASC"
    Else
        strQuery = "SELECT * from Acteur WHERE PRENOM LIKE '$' ORDER BY PRENOM ASC"
    End If
    
    ' Remplace les etoiles par %
    strSearch = Replace(strSearch, "*", "%", 1, , vbTextCompare)
    
    ' Test si existence d'un %
    If (InStr(1, strSearch, "%", vbTextCompare) = 0) Then
        strSearch = strSearch & "%"
    End If
    
    ' Construction de la requête
    strQuery = Replace(strQuery, "$", strSearch, 1, , vbTextCompare)
    
    ' Préparation de la commande
    Cmd.CommandText = strQuery
    
    ' Execution de la commande
    Set RS = Cmd.Execute
    
    ' Init compteur
    Cpt = 0
    
    ' Test si résultat
    If (Not RS.EOF) Then
        ' Il y a donc un résultat => Boucle d'affichage
        While (Not RS.EOF)
            ' Affichage résultat
            If (Not bTri) Then
                Set liItem = lsvResult.ListItems.Add(, "K" & CStr(RS!ID_ACTEUR), RS!NOM)
                liItem.SubItems(1) = RS!PRENOM
            Else
                Set liItem = lsvResult.ListItems.Add(, "K" & CStr(RS!ID_ACTEUR), RS!PRENOM)
                liItem.SubItems(1) = RS!NOM
            End If
           
            ' Incrémente le compteur
            Cpt = Cpt + 1
            
            ' Passe à l'élément suivant
            RS.MoveNext
            
            ' Autorise les evenements
            'DoEvents
        Wend
    End If
    
    ' Affichage du résultat
    stbInfo.Panels("info").Text = Cpt & " acteurs"
    
    ' Libération des ressources
    Set RS = Nothing

End Sub

' * Procédure recherchant si l'acteur existe
Public Function IsActeurExist(Name As String, Surname As String) As Boolean

    ' Retour par defaut
    IsActeurExist = False
    
    ' Initialisation de la requête
    strQuery = "SELECT * from Acteur WHERE NOM='%' AND PRENOM='$'"
    
    ' Finition de la requête
    strQuery = Replace(strQuery, "%", UCase(Trim(Name)), 1, , vbTextCompare)
    strQuery = Replace(strQuery, "$", UCase(Trim(Surname)), 1, , vbTextCompare)
    
    ' Préparation de la requête
    Cmd.CommandText = strQuery
    
    ' Execution de la requête
    Set RS = Cmd.Execute
    
    ' Test si existance
    If (RS.EOF) Then
        ' Libération des ressources
        Set RS = Nothing
        Exit Function
    End If
    
    ' Retour OK
    IsActeurExist = True
    
    ' Libération des ressources
    Set RS = Nothing
    
End Function

Conclusion :


lorsque vous tapez une lettre dans le texbox de recherche, le module recherche dans la base de données, tous les noms ou prénoms commencant par cette lettre, et ainsi de suite par rapport à la seconde lettre.
Vous avez la possibilité de mettre une étoile dans le champ de recherche pour tout vous afficher
Télécharger le projet

Codes Sources

A voir également

Du même auteur (cs_seb)