CONNEXION ADO ACCESS + FONCTIONS OUTILS

' ===========
' Module SQL
' ===========
Option Explicit
Option Compare Binary

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


' ===========================================
' Définir le  password pour acceder à la base
Public Sub setPasswordBase(Optional s As String = "")
  dbPassWord = s
End Sub


' ===========================================
' Ouvrir la connexion à la base MS ACCESS
Public Sub ConnexionBase()
Dim ChaineConnexion  As String
    ' Récupérer le chemin de la base depuis l'INI
    URL_BASE = LireINI("Base", "Chemin")

    On Error GoTo erreur
    ' Connexion
    ChaineConnexion = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & URL_BASE & ";Persist Security Info=False;"
    ChaineConnexion = ChaineConnexion & "Jet OLEDB:Database Password=" & dbPassWord
    cnx.Open ChaineConnexion
    Exit Sub
erreur:
   Dim path As String
   If cnx.State = 1 Then cnx.Close
   path = InputBox("Chemin", "Saisir le path de la base", App.path & "\base.mdb")
   If path = "end" Then End
   Call EcrireINI("Base", "Chemin", path)
   Resume
End Sub

' ===========================================
' Tester si la connexion est "correcte"
Public Function TesterConnexion(ByVal url As String) As Boolean
Dim ChaineConnexion  As String
    On Error GoTo erreur
    ChaineConnexion = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & url & ";Persist Security Info=False"
    cnx.Open ChaineConnexion
    cnx.Close

    MsgBox "Connexion réussie", vbInformation, "Succés de la connexion"
    TesterConnexion = True
    Exit Function
erreur:
    If cnx.State Then cnx.Close
    MsgBox "Le chemin " & url & " n'est pas valide", vbCritical, "Echec de la connexion"
    TesterConnexion = False
    Exit Function
End Function

' ===========================================
'   Compacter & Archiver la base de données
Public Sub CompactJetDatabase(ByVal Location As String, _
                              Optional BackupOriginal As Boolean = True)
Dim strBackupFile As String
Dim strTempFile As String
    On Error GoTo CompactErr
    If Len(Dir(Location)) Then
     
        'création de la copie de sauvegarde
       If BackupOriginal = True Then
           strBackupFile = App.path & "\" & "backup.mdb"
           If Len(Dir(strBackupFile)) Then Kill strBackupFile
           FileCopy Location, strBackupFile
       End If

        'Definition de la base temporaire
       strTempFile = App.path & "\" & "temp.mdb"
       If Len(Dir(strTempFile)) Then Kill strTempFile
       
       'DBEngine.CompactDatabase olddb, newdb, locale, options, password
       DBEngine.CompactDatabase Location, strTempFile, ";pwd=" & dbPassWord, , ";pwd=" & dbPassWord   ' Compacter la base courrante -> base temp
       Kill Location                                    ' Supprimer la base courrante
       FileCopy strTempFile, Location                   ' Copier base tmp -> base courrante
       Kill strTempFile
    End If
    MsgBox "La base de donnée est nettoyée", vbInformation, "Terminé"
    Exit Sub
CompactErr:
    MsgBox "Une erreur est apparue lors du nettoyage de la base de données", vbInformation, "Erreur détectée"
    Exit Sub
End Sub


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

' ===========================================
' Formatter les booléens
Public Function BoolSQL(ByVal bBool As Boolean) As String
    BoolSQL = IIf(bBool, "-1", "0")
End Function

' ===========================================
' Formatter les valeurs numériques
Public Function NombreSQL(ByVal nb As String) As String
    If nb = "" Then
        NombreSQL = 0
    Else
        NombreSQL = Chr(39) & Replace(nb, ".", ",") & Chr(39)
    End If
End Function

' ===========================================
'Convertie 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) & Chr(47) & jour(0) & Chr(47) & jour(2) & Chr(35)
  ElseIf nbVal = 1 Then
    DateSQL = Chr(35) & jour(0) & "/01/" & jour(1) & Chr(35)
  Else
    DateSQL = Chr(35) & "01/01/" & datej & Chr(35)
  End If
End Function



' ===========================================
' Comment utiliser les requêtes de type select
' ===========================================
Dim rs          As ADODB.Recordset
Dim sql         As String
dim nbVal       As Integer

Set rs = New ADODB.Recordset 'Allocation

sql = "SELECT Champ FROM table"

Call ConnexionBase
rs.Open sql, cnx, adOpenStatic, adLockReadOnly 'Execution de la requête

nbVal = rs.RecordCount
If (nbVal = 0) Then
    MsgBox "No result"
Else
    Dim i As Integer
    For i=1 To nbVal
        MsgBox i & ") Champ  = " & rs("Champ")
        rs.MoveNext 'suivant
    Next i
End If

rs.Close          'Fermer le recordset
Set rs = Nothing  'Libération de la mémoire allouée
cnx.Close         'Fermer la connexion à la base


' ===========================================
' Pour Update, Insert, Delete ...
' ===========================================
Dim sql As String

sql = "UPDATE table SET "
sql = sql & "Champ = " & TXTVersSQL(txtValeurChamp.Text) & " "
sql = sql & "WHERE id= " & id.Text & ";"

Call ConnexionBase
cnx.Execute sql
cnx.Close