Accesstovb7 : les fonctions dcount, dlookup et dsum d'access en vb7
Description
Ce code est utile lors d'une migration du code VBA Access vers VB7
(en ne conservant que la base Access.mdb sans le code VBA)
Je suis parti d'une version en VB6 migrée en VB7, mais je me suis fait aider pour la réécriture en pur .Net avec OleDb (sans DAO donc)
Les fonctions DCount, DLookUp et DSum d'Access en VB6 :
www.vbfrance.com/code.aspx?id=24179
(en ne conservant que la base Access.mdb sans le code VBA)
Source / Exemple :
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
Conclusion :
Je suis parti d'une version en VB6 migrée en VB7, mais je me suis fait aider pour la réécriture en pur .Net avec OleDb (sans DAO donc)
Les fonctions DCount, DLookUp et DSum d'Access en VB6 :
www.vbfrance.com/code.aspx?id=24179
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.