Utilisation ado avec une base ms access


Base MS Access & ADO (VB6) V1.1



Ajouter le composant ADO à votre projet VB


Allez dans Projet > Références puis cocher Microsoft ActiveXDataObjetcs 2.x Library
Pour l'exemple, supposons que vous choisissez Microsoft ActiveX DataObjetcs 2.8 Library

Connexion


Pour vous connecter à votre Base de Donnée, vous devez établir une connexion.
Je vous conseille d'écrire les codes ci-dessous dans un module, par exemple SQL puisque les codes vont vous servir dans d'autres projets.


L'objet qui permet de connecter la base est ADODB.Connection et utilise une chaîne de connexion. Je vous propose une fonction de connexion toute faite dont vous pouvez modifier la chaîne de connexion à votre guise. Le module commence donc ainsi : 

Option Explicit 
Option Compare Binary 

Private dbPassWord As String 
Public cnx As New ADODB.Connection 
Private URL_BASE As String 


Public Sub ConnexionBase(Optional ByVal cheminBase As String) 
Dim ChaineConnexion  As String    

   If cheminBase <> vbNullString Then URL_BASE = cheminBase 

   On Error GoTo erreur 
   ChaineConnexion = "Provider=Microsoft.Jet.OLEDB.4.0;DataSource=" & _ 
                     URL_BASE & ";Persist Security Info=False;" & _ 
                     "JetOLEDB:Database Password=" & dbPassWord 
   cnx.Open ChaineConnexion 

   Exit Sub 

erreur: 
  If cnx.State Then cnx.Close 
  MsgBox "Erreur de connexion à votre base " & vbCrLf & URL_BASE, vbCritical, _ 
         "Echec Connexion" 
End Sub 

' Permet de définir le mot de passe pour se connecter à la base
Public Sub setPasswordBase(Optional s As String = "") : dbPassWord = s : End Sub 

' Permet de définir le chemin d'accès à la base
Public Sub setURLase(Optional s As String = "") :  URL_BASE = s : End Sub


Concrètement, si votre base nécessite un mot de passe, vous devez le définir (une seule fois durant l'exécution de votre projet en utilisant setPasswordBase.

Par exemple, pour définir le mot de passe 1j2ep9 

Call setPasswordBase("1j2ep9")


De la même façon, vous devez renseigner au moins une fois le chemin d'accès complet à la base : c:\base.mdb (une seule fois suffit). 

Call setURLase("c:\base.mdb")

Ou alors lors de la première connexion : 

Call ConnexionBase("c:\base.mdb")


Vous aurez compris que pour vous connecter à la base, il vous suffit de faire 

Call ConnexionBase()

Déconnexion


Petit aparté, il existe deux écoles quand à l'ouverture et la fermeture de la connexion.
Une première méthode consiste à ouvrir la connexion à la base dès le lancement du projet et à la fermer lorsque l'appli se termine. Personnellement, je ne suis pas fan de cette méthode : C'est inutile de laisser la base ouverte lorsque l'on fait rien dessus.
L'intérêt principal de cette méthode et d'économiser le temps de connexion.
Je préfères ouvrir la base lorsque les traitements le demandent (ouvrir le plus tard possible) et la fermer en fin de traitement. Bien sur, inutile d'ouvrir et de fermer la connexion pour chaque requête : pour une série de requêtes autant ouvrir à l'exécution de la première et fermer après la dernière.

A vous de choisir votre méthode...

Bon,maintenant comment fermer la connexion, c'est tout simple 

Cnx.Close


Je n'ai pas fait de méthode volontairement puisqu'il s'agit d'une ligne à taper... mais ça serait plus propre de définir une méthode et de placer cnx en private (encapsulation des données)

Ajouter des données


A ce stade, quelques précisions sont nécessaires sur le formatage des informations.

Les dates


MSAccess utilise le format américain (mm/dd/yyyy) et il est nécessaire d'encadrer les dates par des #. Je vous propose donc pour chaque utilisation d'une date d'appeler la fonction suivante : 

' Converti une date au format jj/mm/aaaa au format US : mm/jj/aaaa
Public Function DateSQL(ByVal datej As String) As String 
Dim jour() As String 
Dim poSp   As Integer 

  ' Suppression de l'heure si existe
  poSp = InStr(1, datej, " ") 
  If poSp > 0 Then datej = Mid(datej, 1,poSp - 1) 

  ' Mise en forme
  jour = Split(datej, "/") 
  Dim nbVal As Single 

  nbVal = UBound(jour) 
  If nbVal = 2 Then 
    DateSQL = Chr(35) & jour(1) & "/" & jour(0) &"/" & jour(2) & Chr(35) 
  ElseIf nbVal = 1 Then 
    DateSQL = Chr(35)  & jour(0) & "/01/" & jour(1) &Chr(35) 
  Else 
    DateSQL = "#01/01/" & datej & Chr(35) 
  End If 

End Function


Elle fait quelques traitements supplémentaires mais devrait vous donner entière satisfaction.

Utilisation : 

DateSQL(variableContenantUneDate)

Les chaînes de caractères


En SQL, le simple quotte sert à délimiter les chaînes, il faut donc protéger les simples quottes au sein de chaîne, par exemple, enr emplaçant les simple quotte par deux simples quottes. A cet effet, je vous propose la fonction ci-dessous : 

Function TXTVersSQL(message As String) As String 
  message = Replace(message,"'", "''") 
  TXTVersSQL = Chr(39) & message & Chr(39) 
End Function


Utilisation : 

TXTVersSQL("l'école de l'étang")  'vas renvoyer "'l''école de l''étang'"

Les booléens


MSAccess manipule les booléens -1 = Oui et 0 = non. De la même façon, voici une méthode qui vous permettra de vous simplifier les traitements : 

Public Function BoolSQL(ByVal bBool As Boolean) As String : BoolSQL = IIf(bBool,"-1", "0") : End Function


Utilisation : 

BoolSQL(True) 'renvoi donc -1


Pour afficher un Booléen, autant utiliser une méthode qui converti la valeur Access en texte comme par exemple Oui/Non : 

Public Function Affich_Bool(ByVal b As Boolean) As String : Affich_Bool= IIf(b, "Oui", "Non"): End Function

Ajouter un élément dans la base


Bon maintenant, nous sommes prêt à insérer un élément : Supposons que vous voulez ajouter un nom, un date, un booléen.

Soit la table USERS telle que :
id (numéro auto)
nom (texte)
ddn (date)
admin (booléen)


La requête SQL s'écrit donc :
INSERT INTO USERS (nom, ddn, admin) VALUES (les valeurs)

Créons la méthode pour ajouter un USER : 

Public Function ajoutUser(ByVal Mynom as String, ByVal Myddn as Date, ByVal Myadmin as Boolean) As Boolean 
Dim sql As String 

  sql = "INSERT INTO USERS (nom, ddn, admin) VALUES ( " 
  sql = sql & TXTVersSQL(Mynom) & ", " 
  sql = sql & DateSQL (Myddn)   & ", " 
  sql = sql & BoolSQL(Myadmin)  & ");" 

  On Error GoTo erreur 
  Call ConnexionBase 
  cnx.Execute sql 
  cnx.Close 
  ajoutUser = True 
  Exit Function 

erreur: 
  If cnx.State Then cnx.Close 
  'Debug.Print sql
  ajoutUser = False 
End Function


Au passage, cette fonction permet de tester si la requête c'est bien passée. Ainsi dans votre code : 
If ajoutUser(txtNom.Text, dtpNaiss.Value, chkAdmin.Value = vbChecked) Then 
      MsgBox "Personne ajoutée", vbInformation, "Succés" 
Else 
      MsgBox "Vérifiez votre saisie",vbInformation, "Echec" 
End If

notez que l'id de la personne est automatiquement généré par Access et qu'on n'a pas besoin de le préciser.

Les requêtes de modifications (UPDATE) de suppressions (DELETE) fonctionnent suivant le même schéma. Je vous renvoie à de la documentation en ligne pour toutes informations relatives à leurs syntaxes.

C'est bien joli, mais supposons que vous ayez besoin de récupérer l'id du dernier élément ajouté.

Récupérer des informations depuis la base


A ce stade, nous allons effectuer une requête de type SELECT afin de récupérer des enregistrements. Ils sont renvoyés sous forme de ligne chacune étant découpée en colonne (autant de colonnes que de champs entre les instructions SELECT et FROM).

L'objet permettant de récupérer des résultats d'un SELECT est le RecordSet (jeu d'enregistrement) 

Public Function getLastIDUser(current As client) As Integer 
Dim sqlid   As String 
Dim rs      As ADODB.Recordset  'Déclarer le RecordSet
Dim id      As Integer 

  id = 0 

  sqlid = "SELECT MAX(id) AS LASTID FROM USERS;" 

  On Error GoTo erreur 
  Call ConnexionBase 
  cnx.Execute sql 

  Set rs = New ADODB.Recordset  'Créer une instance de RecordSet
  rs.Open sqlid, cnx, adOpenStatic, adLockReadOnly  ' L'ouvrir
  id = rs("LASTID")  ' Accés à la valeur


  rs.Close  'Fermer le RecordSet
  Set rs = Nothing  'Libérer la mem. (tout obj avec utilisé avec new doit être libéré avec set .. Nothing)
  cnx.Close 

  getLastIDUser = id 
  Exit Function 
erreur: 
  If cnx.State Then cnx.Close 
  getLastIDUser = -1 
End Function


Et comment faire lorsque l'on a plus d'une ligne à afficher ?
Vous avez une méthode RecordCount qui vous permet de connaître le nombre de lignes dans le Recordset. Pour Passer à la ligne suivant, MoveNext est fait pour ça.
Voyons ça en pratique, et listons tous les USERS que nous ajoutons à une MSFlexGrid : 

Public Sub Afficher_Users(flex As MSFlexGrid) 
Dim sql  As String 
Dim rs   As ADODB.Recordset 
Dim I    As Integer, total As Integer 
Dim txt  As String 

  sql ="SELECT ID, NOM, DDN, ADMIN " & _ 
       "FROM USERS " & _ 
       "ORDER BY NOM ASC;" 
  'Debug.Print sql

   On Error GoTo erreur 
   Set rs = New ADODB.Recordset 
   Call ConnexionBase 
   rs.Open sql, cnx, adOpenStatic, adLockReadOnly 

   'Mise en forme de la flex
   With flex 
       .Visible = False 
       .Rows = 1  'Vider la flex
       .Cols = 4 
       .Row = 0  'Se placer à la premiere ligne
       For i = 0 To .Cols - 1 
         .col = I  'Se balader de colone en colone
         Select Case i 
             Case0: 
                .Text = "ID" 
                .ColAlignment(i)  = flexAlignLeftCenter 
            Case 1: 
                .Text = "Nom" 
                .ColAlignment(i)  = flexAlignLeftCenter 
            Case 2: 
                .Text = "DDN" 
                 .ColAlignment(i) = flexAlignLeftCenter 
            Case 3: 
                .Text = "Admin" 
                .ColAlignment(i)  = flexAlignLeftCenter 
         End Select 

        .CellAlignment = flexAlignCenterCenter 
     Next i 
   End With 

   total = rs.RecordCount 
   For i = 1 To total 
       txt =rs("ID") & vbTab 
       txt = txt& rs("NOM") & vbTab 
       txt = txt& rs("DDN") & vbTab & Affich_Bool(rs("ADMIN")) 
      flex.AddItem txt 
      rs.MoveNext  'Passer à la ligne suivante du Recordset
   Next i 

   rs.Close 
   Set rs = Nothing 
   cnx.Close 
   flex.Visible = total > 0 
   Exit Sub 
erreur: 
   If cnx.State Then cnx.Close 
End Sub


Quelques remarques :
  • Pour le debug, mieux vaut prévoir un Debug.Print sql.
  • Ensuite, pour optimiser les traitements, il est préférable de stocker la valeur du rs.RecordCount (puisqu'elle est fixe) plutôt que l'utiliser dans la boucle. En effet, cette seconde méthode est juste mais vous aller faire appel à RecordCount à chaque tour de boucle pour rien et gaspiller du temps processeur.
  • Lorsque la base contient des valeur nulles (null autorisé) vous risquez d'avoir un bug. Personnellement, je n'aime pas trop autoriser les valeurs nulles. Mais au cas où, vous pouvez protéger la récupération desvaleurs en encadrant tous les rs("..") par rs_to_flexCell(rs("..")) :

Public Function rs_to_flexCell(ByVal s As Variant) As String 
    rs_to_flexCell= IIf(Not IsNull(s) And s <> "", s, " ") 
End Function

La boucle for devient alors, si le nom est facultatif 
 For i = 1 To total 
       txt = rs("ID") & vbTab 
       txt = txt& rs_to_flexCell(rs("NOM")) & vbTab 
       txt = txt& rs("DDN") & vbTab & Affich_Bool(rs("DATES")) 

       flex.AddItem txt 
       rs.MoveNext  'Passer à la ligne suivante du Recordset
   Next i
  • Supposons maintenant que vous vouliez disposez en en-tête de colonne le nom des champs tels qu'ils sont dans la base. Rs.Fields vous permet d'y accéder. Ainsi, la génération des en-têtes de la flex s'écrit :

    Dim nbCol As Integer 
    nbCol = rs.Fields.Count 

    'Afficher les Nom des champs dans la flex
    .Row = 0 
    .Cols = nbCol 
    For i = 0 To nbCol - 1 
      .Col = i 
      .Text = rs.Fields(i).Name 
      .CellAlignment   = flexAlignCenterCenter 
      .ColAlignment(i) = flexAlignLeftCenter 
    Next i

Les champs sont affichés dans l'ordre que vous avez défini entre le SELECT et le FROM.

Afficher_Users s'écrit donc : 

Public Sub Afficher_Users(flex As MSFlexGrid) 
Dim sql As String 
Dim rs As ADODB.Recordset 
Dim i As Integer, total As Integer 
Dim txt As String 
Dim nbCol As Integer 

  sql ="SELECT ID, NOM, DDN, ADMIN " & _ 
       "FROM USERS " & _ 
       "ORDER BY NOM ASC;" 
  'Debug.Print sql

   On Error GoTo erreur 
   Set rs = New ADODB.Recordset 
   Call ConnexionBase 
   rs.Open sql, cnx, adOpenStatic, adLockReadOnly 

   'Mise en forme de la flex
   With flex 
      .Visible = False 
      .Rows = 1  'Vider la flex
      .Cols = 4 
      'Afficher les Nom des champs dans la flex
      .Row = 0 
      nbCol = rs.Fields.Count 
      .Cols = nbCol 
      For i = 0To nbCol - 1 
        .Col  = i 
        .Text = rs.Fields(i).Name 
       .CellAlignment   = flexAlignCenterCenter 
       .ColAlignment(i) = flexAlignLeftCenter 
      Next i 
   End With 

   total = rs.RecordCount 
   For i = 1 To total 
       txt = rs("ID") & vbTab 
       txt = txt& rs("NOM") & vbTab 
       txt = txt& rs("DDN") & vbTab & Affich_Bool(rs("DATES")) 
       flex.AddItem txt 
       rs.MoveNext  'Passer à la ligne suivante du Recordset
   Next i 

   rs.Close 
   Set rs = Nothing 
   cnx.Close 
   flex.Visible = total > 0 
   Exit Sub 
erreur: 
   If cnx.State Then cnx.Close 
End Sub

Trouver le mot de passe d'une base MS Access


Vous voulez autoriser les utilisateurs de votre application à mettre un mot de passe sur leur base. Je vous propose le code ci-dessous afin de le trouver et de vous connecter facilement (ce code n'est pas de moi mais fonctionne très bien) : 

'===========================================
'   Récupérer le mot de pass de la base

Function xGetAccessPwd(ByVal FileName As String) As String

Dim n As Long, s1 As String * 1, s2 As String * 1
Dim dbname          As String
Dim passw           As String
Dim bckPass         As String
Dim mask97          As String
Dim mask2k          As String
Dim priv            As String
Dim priv2           As String
Dim prviput         As Boolean
Dim TrebaObavestiti As Boolean
Dim cnn1            As ADODB.Connection

 mask97 = Chr(&H4E) & Chr(&H86) & Chr(&HFB) & Chr(&HEC) & _
          Chr(&H37) & Chr(&H5D) & Chr(&H44) & Chr(&H9C) & _
          Chr(&HFA) & Chr(&HC6) & Chr(&H5E) & Chr(&H28) & _
          Chr(&HE6) & Chr(&H13)


  mask2k = Chr(&H4E) & Chr(&H99) & Chr(&HEC) & Chr(&H42) & _
           Chr(&H9C) & Chr(&HD9) & Chr(&H28) & Chr(&HC) & _
           Chr(&H8A) & Chr(&H4B) & Chr(&H7B) & Chr(&HEA) & _
           Chr(&HDF) & Chr(&H68) & Chr(&H13) & Chr(&HD0) & _
           Chr(&HB1) & Chr(&H2B) & Chr(&H79) & Chr(&H8D) & _
           Chr(&H7C)



  ' set the masking characters
  dbname = FileName
  passw = ""
  Open dbname For Binary As #1      ' open the database
  Seek #1, &H42
  For n = 1 To 21
  ' actual password recovery module
       s1 = Mid(mask2k, n, 1)
       s2 = Input(1, 1)
       If (Asc(s1) Xor Asc(s2)) <> 0 Then
          passw = passw & Chr(Asc(s1) Xor Asc(s2))
       End If
       If n <> 1 Then s2 = Input(1, 1)
  Next

  Close 1
  prviput = True
 TrebaObavestiti = True
  If passw = vbNullString Then
'        MsgBox "No Password Found"
      xGetAccessPwd = passw
  Else

       Set cnn1 = New Connection
      cnn1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                             "DataSource=" & FileName & ";" & _
                             "Persist Security Info=False" & ";"
       On Error Resume Next
       'Before we get into rush, let see if there is password
       If cnn1.State = adStateClosed Then cnn1.Open
       If Err.Number = -2147217843 Then
          'this means that password exists
          'Debug.Print "password protected..."
       Else
           If Err.Number = 0 Then
            'MsgBox "No Password Found", vbInformation
            xGetAccessPwd = ""
           End If
       End If

       Err.Clear

       'Lets try open it with masked password in first step,
       'this happens very rare
      cnn1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                             "DataSource=" & FileName & ";" & _
                              "Persist Security Info=False;" & _
                             "Jet OLEDB:Database Password=" & passw & ";"

       s1 = Chr(0)
       bckPass = passw
       Screen.MousePointer = vbHourglass
       On Error GoTo EH
       'If I pass thru this that men as that we got password if not
       'we'll get into error handling routine

       If cnn1.State = adStateClosed Then cnn1.Open
      Screen.MousePointer = vbDefault
      cnn1.Close
       Set cnn1 = Nothing
'        MsgBox "The Password Is: " & passw, vbInformation
      xGetAccessPwd = passw

  End If
  Exit Function

EH:

   If Err.Number = -2147467259 Or Err.Number = -2147217805 Then
       s1 = Chr(Asc(s1) + 1)
       GoToskip1
   End If
   If Err.Number <> -2147217843 Then  'Not valid password
       MsgBox "error: " & Err.Number & ", " & Err.Description, vbCritical
   Else
   'Watch out this little trick, We will use last character
   'from the masked password and
   'try to find password, lets xor it
   '(this works if password is 18 chars or less)
skip1:

       If Asc(s1) = 255 Then
          MsgBox "mail ivan@chameleon.co.yu", vbInformation
          Exit Function
       End If

     If prviput Then
         s1 = Right(passw, 1)
     Else

       If TrebaObavestiti Then
          MsgBox "Password is more then 18 chars long." & _
                 " Must use brute force attack!", vbInformation
          TrebaObavestiti = False
       End If

         'We will get here only if password is longer then 18
         s1 = Chr(Asc(s1) + 1)
      End If

     passw = bckPass
     If Len(passw) > 2 Then
       For n = 1 To Len(passw)
           If Right(passw, 1) = s1 Then
            passw = Mid(passw, 1, Len(passw) - 1)
           End If
       Next
     End If
     priv = ""
     For n = 1 To Len(passw)
           If n Mod 2 <> 0 Then
              s2 = Mid(passw, n, 1)
              If (Asc(s1) Xor Asc(s2)) <> 0 Then
                 priv = priv & Chr(Asc(s1) Xor Asc(s2))
              End If
           Else
              s2 = Mid(passw, n, 1)
              priv = priv & s2
           End If
     Next

     If priv = vbNullString Then
       'MsgBox "No Password Found", vbInformation
      xGetAccessPwd = ""
     Else

       'Lets try with this password if its ok.
       'We are finished if not will do it 255 times more
       If prviput Then
          prviput = False
          s1 = Asc(0)
       End If
       passw = priv
      cnn1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "DataSource=" & FileName & ";" & _
      "Persist Security Info=False;" & _
      "Jet OLEDB:Database Password=" & _
      DuplirajApostrof(passw) & ";"
      'Debug.Print s1, Asc(s1), passw
       Resume
     End If
   End If
End Function

Public Function DuplirajApostrof(ByVal s As String) As String
   'We have to be sure that we include all characters in brute force attack
   Dim i As Long
   i = InStr(1, s, """")
   If i <> 0 Then
      DuplirajApostrof = Left(s, i) & """" & DuplirajApostrof(Mid(s, i + 1, Len(s) - i + 1))
   Else
       DuplirajApostrof = s
   End If
End Function


Utilisation: 

Call setPasswordBase (xGetAccessPwd(URL_BASE))


Bon code ;)

++

Zlub

A voir également

Publié par Zlub.
Ce document intitulé «  Utilisation ado avec une base ms access  » issu de CodeS-SourceS (https://codes-sources.commentcamarche.net/) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.
Ajouter un commentaire

Commentaires

Commenter la réponse de michmar007
Connexion à une base de données access sécurisée
Création de setup proprement