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
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()
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)
A ce stade, quelques précisions sont nécessaires sur le formatage des informations.
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)
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'"
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
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é.
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 :
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
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
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