ACCESSTOVB7 : LES FONCTIONS DCOUNT, DLOOKUP ET DSUM D'ACCESS EN VB7

Private Sub btnTest_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles btnTest.Click

    Me.Cursor = Cursors.WaitCursor
    If bOuvrirBaseDonnees(Application.StartupPath & "\AccessToVB7.mdb") Then

        Dim rVal1A! = DLookUp("Champ1", "Table1", "Critere1='A'")
        Dim rVal2A! = DLookUp("Champ2", "Table1", "Critere1='A'")
        Dim rVal1B! = DLookUp("Champ1", "Table1", "Critere1='B'")
        Dim rSomme1! = DSum("Champ1", "Table1")
        Dim iNbEnreg% = DCount("Champ1", "Table1")
        Dim iNbEnregA% = DCount("Champ1", "Table1", "Critere1='A'")
        ' Arrondi des réels, sinon il y a des décimales parasites !
        rSomme1 = Math.Round(rSomme1, 3)
        MsgBox( _
            "Val1A=" & rVal1A & ", Val2A=" & rVal2A & vbLf & _
            "Val1B=" & rVal1B & ", Somme1AB=" & rSomme1 & vbLf & _
            "NbEnreg=" & iNbEnreg & ", NbEnregA=" & iNbEnregA, _
            MsgBoxStyle.Information)

        ' Exécution d'une requête mise à jour
        Dim sSQL$ = "UPDATE Table1 SET Champ2 = Champ2+0.1 WHERE Critere1='A'"
        If bRqAction(sSQL) Then
            rVal2A! = DLookUp("Champ2", "Table1", "Critere1='A'")
            MsgBox("Modification : Val2A=" & rVal2A, MsgBoxStyle.Information)
        End If

        FermerBaseDonnees()

    End If
    Me.Cursor = Cursors.Default

End Sub

Option Strict On
Option Explicit On 

Module modAccessToVB7

Private m_sCheminBD$
Private m_oConn As New OleDb.OleDbConnection

Public Function bOuvrirBaseDonnees(ByVal sCheminBD$) As Boolean

    ' Ouvrir la base de données

    m_oConn.ConnectionString = _
        "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;" & _
        "Mode=Share Deny None;Data Source=" & sCheminBD
    m_sCheminBD = sCheminBD

    Try
        m_oConn.Open()
        bOuvrirBaseDonnees = True
    Catch ex As Exception
        MsgBox("Erreur lors de l'ouverture de la base :" & vbLf & _
            sCheminBD & vbLf & Err.Description, MsgBoxStyle.Critical)
    End Try

End Function

Public Sub FermerBaseDonnees()

    m_oConn.Close()

End Sub

Public Function DLookUp(ByVal sChamp$, ByVal sTable$, ByVal sCritere$, _
    Optional ByVal bPromptErr As Boolean = True) As Object

    ' Implementation de la fonction DLookUp d'Access en VB7 :
    ' Relever la valeur d'un champ d'une table avec un critère
    '  si la base, la table et le critère sont inchangés depuis le dernier appel,
    '  une mémorisation permet de gagner du temps !

    Static ht As New Hashtable ' Conserver de la valeur des champs
    Static sMemRq$             ' Conserver les paramètres de la requête

    ' Si on relance la même requête, on lit directement le champ dans le ht
    If m_sCheminBD & sTable & sCritere = sMemRq Then
        DLookup = ht(sChamp)
        Exit Function
    End If

    ' Objet commande = requête
    Dim oCmd As New OleDb.OleDbCommand
    oCmd.Connection = m_oConn ' La connexion doit bien sûr être ouverte avant
    oCmd.CommandType = CommandType.Text
    oCmd.CommandText = "Select * From " & sTable
    If sCritere <> "" Then oCmd.CommandText &= " Where " & sCritere
    Dim sMsgErr$ = _
        "Erreur lors de l'exécution de la requête dans DLookUp :" & vbLf & _
        oCmd.CommandText

    ' Création d'un DataReader pour récupérer la valeur des champs
    Dim dr As OleDb.OleDbDataReader
    Try
        dr = oCmd.ExecuteReader(CommandBehavior.SingleRow)
    Catch ex As Exception
        If bPromptErr Then MsgBox(sMsgErr & vbLf & Err.Description, MsgBoxStyle.Critical)
        Exit Function
    End Try

    If Not dr.HasRows Then
        ' Aucune donnée retournée : DLookUp renvoi DBNull
        DLookUp = System.DBNull.Value
    Else

        ' Lire les champs
        dr.Read()

        ' Stocker les champs ds le ht pour les retrouver facilement 
        '  au prochain appel identique
        If Not IsNothing(ht) Then ht.Clear()
        Dim i% ' Nb. de champs de la requête
        For i = 0 To dr.FieldCount - 1
            ht.Add(dr.GetName(i), dr.GetValue(i))
        Next i
        sMemRq = m_sCheminBD & sTable & sCritere

        ' Lire la valeur du champ
        Try
            DLookUp = dr.Item(sChamp)
        Catch ex As IndexOutOfRangeException
            If bPromptErr Then MsgBox( _
                "Champ introuvable dans la requête dans DLookUp :" & vbLf & _
                oCmd.CommandText & vbLf & Err.Description, MsgBoxStyle.Critical)
        Catch ex As Exception
            If bPromptErr Then MsgBox(sMsgErr & vbLf & _
                Err.Description, MsgBoxStyle.Critical)
        End Try

    End If
    dr.Close()

End Function

Public Function DSum(ByVal sChamp$, ByVal sTable$, Optional ByVal sCritere$ = "") As Object

    ' Implementation de la fonction DSum d'Access en VB7 :
    '  Faire un cumul d'un champ d'une table avec un critère

    ' Objet commande
    Dim oCmd As New OleDb.OleDbCommand
    oCmd.Connection = m_oConn
    oCmd.CommandType = CommandType.Text
    oCmd.CommandText = "Select Sum(" & sChamp & ") AS SommeDeChamp From " & sTable
    If sCritere <> "" Then oCmd.CommandText &= " Where " & sCritere

    Try
        DSum = oCmd.ExecuteScalar()
    Catch ex As Exception
        MsgBox("Erreur lors de l'exécution de DSum" & vbLf & _
            oCmd.CommandText & vbLf & Err.Description, MsgBoxStyle.Critical)
    End Try

End Function

Public Function DCount(ByVal sChamp$, ByVal sTable$, Optional ByVal sCritere$ = "") As Object

    ' Implementation de la fonction DCount d'Access en VB7 :
    '  Compter le nombre d'enregistrement (via un champ) d'une table avec un critère

    'objet commande
    Dim oCmd As New OleDb.OleDbCommand
    oCmd.Connection = m_oConn
    oCmd.CommandType = CommandType.Text
    oCmd.CommandText = "Select Count(*) From " & sTable
    If sCritere <> "" Then oCmd.CommandText &= " Where " & sCritere

    Try
        DCount = oCmd.ExecuteScalar()
    Catch ex As Exception
        MsgBox("Erreur lors de l'exécution de DCount :" & vbLf & _
            oCmd.CommandText & vbLf & Err.Description, MsgBoxStyle.Critical)
    End Try

End Function

Public Function bRqAction(ByRef sSQL$, _
    Optional ByRef bPromptErr As Boolean = True) As Boolean

    ' Exécuter une requête Action (il faut la créer à la volée, on ne peut pas 
    '  modifier le code SQL d'une requête action existante dans une base Access)

    Dim oCmd As New OleDb.OleDbCommand
    oCmd.Connection = m_oConn
    oCmd.CommandType = CommandType.Text
    oCmd.CommandText = sSQL

    Try
        oCmd.ExecuteNonQuery()
        bRqAction = True
    Catch ex As Exception
        If bPromptErr Then MsgBox("Erreur lors de l'exécution de la requête :" & vbLf & _
            sSQL & vbLf & Err.Description, MsgBoxStyle.Critical)
    End Try

End Function

Public Function bDefinirRequeteSelection(ByRef sNomRq$, ByRef sSQL$) As Boolean

    ' Modifier le code SQL d'une requête sélection existante dans une base Access
    ' (note : on ne peut pas modifier le code SQL d'une requête action 
    '  existante dans une base Access)

    ' Suppression de la requête existante (requête sélection = vue : view)
    Dim oCmd As New OleDb.OleDbCommand
    oCmd.Connection = m_oConn
    oCmd.CommandType = CommandType.Text
    oCmd.CommandText = "drop view " & sNomRq
    Try
        oCmd.ExecuteNonQuery()
    Catch ex As Exception
        ' Pas grave si la rq n'existe pas déjà
    End Try

    ' Recréer la vue
    oCmd.Connection = m_oConn
    oCmd.CommandType = CommandType.Text
    oCmd.CommandText = "Create view " & sNomRq & " As " & sSQL
    ' Ne marche pas
    'oCmd.CommandText = "Create Or Replace view " & sNomRq & " As " & sSQL

    ' Executer la recréation de la vue
    Try
        oCmd.ExecuteNonQuery()
        bDefinirRequeteSelection = True
    Catch ex As Exception
        MsgBox("Erreur lors de la création de la vue dans bDefinirRequeteSelection" & vbLf & _
            oCmd.CommandText & vbLf & Err.Description)
    End Try

End Function

Public Function Nz(ByRef vVal As Object, Optional ByRef vDef As Object = 0) As Object

    ' Implementation de la fonction Nz d'Access en VB7 :
    ' Non Zero : renvoyer 0 (ou une autre valeur par défaut) 
    '  si la valeur du champ de bd est null
    '  ou sinon renvoyer simplement la valeur

    If IsDBNull(vVal) Then Nz = vDef : Exit Function
    If vVal Is System.DBNull.Value Then Nz = vDef : Exit Function
    Nz = vVal

End Function

Public Function sValeurPtDecimal$(ByRef rVal!)

    ' Remplacer la virugle par un point pour les critères en valeur réels
    '  car le SQL est executé en langue anglaise, avec toujours un point décimal

    sValeurPtDecimal = CStr(rVal)
    sValeurPtDecimal = Replace(sValeurPtDecimal, ",", ".")

End Function

End Module

Télécharger le zip