Pour se simplifier les appels base de donnée access

Commenter

Contenu du snippet

Je poste, (car je n'ai encore rien posté, et c'est pas juste !) un module .bas que j'ai créé (et que j'amende projets après projets) il y a bien 10 ans et que j'utilise très régulièrement
Il y a quelques fonctions très utiles (OpenRecord et ExecuteSQL) après avoir renseigné le nom de la Base dans la constante NomBase (déclarations)
Ces deux fonctions appellent Connect qui sauvegarde une copie de sécu de la base à chaque ouverture (au bout de 25 copies sur le disque, la fonction vous demande si vous voulez les effacer) après vous avoir demandé le chemin d'accès pour la toute première connexion. La fonction sauve ce chemin dans la base de registre et ne vous le demandera donc plus, sauf s'il ne trouve aucune base au chemin indiqué.
Bon les autres fonctions, vous en faites ce que vous voulez : gStrTraduitQuote est très utile pour gérer les guillemets simples, gStrTraduitNumerique pour gérer les points décimaux, à vous de voir

Source / Exemple : 


Option Explicit
Global pWrkJet                  As Workspace
Global gMainDB                  As Database
Private pBooSaved               As Boolean
Const NomBase = "FACT.mdb"      ' Renseigner ici le nom de la base Access

Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const HWND_FLAGS = SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wparam As Long, lParam As Long) As Long

Const pStrMessage = "Désolé, le logiciel a rencontré un problème grave. Veuillez vous adresser à votre administrateur"

Public Function ExecuteSQL(pStrSQL As String) As Boolean
Dim linti                   As Long

    On Error GoTo ErrorHandler
    If pStrSQL <> "" Then
        
        If Connect Then
            Screen.MousePointer = vbHourglass
StillExecute:
        
            gMainDB.Execute pStrSQL

            ExecuteSQL = True
            
        Else
            MsgBox "Base de donnée déconnectée. Redémarrer l'application", vbCritical, "Erreur d'objet"
        End If
        
    End If
Sortie:
    Screen.MousePointer = vbDefault
    Exit Function
    
ErrorHandler:

Dim pErr As Error

    Select Case Err '   err.description
        Case 3667
            'Une opération différente empèche l'exécution de cette opération.
            'cette operation n'est pas autorisée en ce moment -> il faut tester stillexecuting
            Resume StillExecute    'ceci est fait maintenant par BusyTest
            
        Case 3146, 3147, 3148, 3149, 3150, 3151, 3152, 3153, 65535, 3669, 63535
            ' 3146 echec de l'appel err.description, 3669 Execution annulée
            'ProcessErreur 10012
            'il serait interressant de connaitre l erreur !!!
            'For Each pErr In Errors
            '    If Err.Number <> 3146 Then
            '        ErrorLog pErr.Number & " - " & pErr.Description
            '    End If
            'Next
            Resume Sortie 'il vaudrait mieux reporter l'erreur err.description errors.count

        Case 3154
            'impossible de trouver la dll <nom>
        Case 3155, 3156, 3157, 3247
            'pour les tables liées
        Case 3231
            'champs trop long, données tronquées
        Case 3232
            'impossible de créer une table -> ne doit pas arriver
        Case 3234
            'expiration du délai d'attente -> à vérifier en connexion à distance
        Case 3235
            'type de donnée non gérée par le serveur
        Case 3238
            'donnée inexistante
        Case 3254
            'impossible de verrouiller les enregistrements
    End Select
    
    'pWrkJet.Rollback

    'ErrorLog Err.Description
    Resume Sortie
End Function
Public Function gStrTraduitQuote(ByVal StrTexte As String) As String
Dim pStrTexte As String
Dim linti As Long

'je traduis 1 quote en 2 quote et je laisse 2 ou plus quotes telles quelles
    If StrTexte <> "" Then
        linti = InStr(StrTexte, "'")
        Do While linti > 0
            pStrTexte = pStrTexte & Left(StrTexte, linti) & "'"
            StrTexte = Right(StrTexte, Len(StrTexte) - linti)
            linti = InStr(StrTexte, "'")
        Loop
        gStrTraduitQuote = pStrTexte & StrTexte
    End If
End Function
Function NomFichier(StrNom As String) As String
'extrait le nom du fichier d'un chemin d'acces complet
Dim Cmpt As Integer
    
    
    For Cmpt = Len(StrNom) To 1 Step -1
        If Mid$(StrNom, Cmpt, 1) = "/" Or Mid$(StrNom, Cmpt, 1) = "\" Then
            NomFichier = Right(StrNom, Len(StrNom) - Cmpt)
            Exit Function
        End If
    Next Cmpt
    
    NomFichier = StrNom
End Function
Public Function OpenRecord(ByVal sql As String, ByRef pRS As Recordset) As Boolean
Dim linti As Long
Dim pMouse As Long
    
    On Error GoTo ErrorHandler
    
    If sql <> "" Then
        If Connect Then
        
StillExecute:
                    
Appel:
            pMouse = Screen.MousePointer
            Screen.MousePointer = vbHourglass
            Set pRS = gMainDB.OpenRecordset(sql, dbOpenDynaset)
            
            Screen.MousePointer = pMouse
            If Not pRS Is Nothing Then
                If pRS.RecordCount Then
                    OpenRecord = True
                End If
            End If
        End If
        
Sortie:
       
    Screen.MousePointer = pMouse
    End If
    Exit Function
    
ErrorHandler:
Dim pErr As Error

    Select Case Err
        Case 3667
            'cette operation n'est pas autorisée en ce moment -> il faut tester stillexecuting Err.Description
            Resume StillExecute
            
        Case 3146, 3147, 3148, 3149, 3150, 3151, 3152, 3153, 65535, 3669, 63535
            ' 3146 echec de l'appel err.description, 3669 Execution annulée
            'il serait interressant de connaitre l erreur !!!
            'ProcessErreur 10012
            For Each pErr In Errors
                If pErr.Number <> 3146 Then
                    'ErrorLog pErr.Number & " - " & pErr.Description
                End If
            Next
            Resume Sortie 'il vaudrait mieux reporter l'erreur err.description errors.count

        Case 3154
            'impossible de trouver la dll <nom>
        Case 3155, 3156, 3157, 3247
            'pour les tables liées
        Case 3231
            'champs trop long, données tronquées
        Case 3232
            'impossible de créer une table -> ne doit pas arriver
        Case 3234
            'expiration du délai d'attente -> à vérifier en connexion à distance
        Case 3235
            'type de donnée non gérée par le serveur
        Case 3238
            'donnée inexistante
        Case 3254
            'impossible de verrouiller les enregistrements
            
    End Select
    'ErrorLog Err.Description
    Resume Sortie
    
End Function
Public Function FormatRef(ByVal NewData As String) As String
Dim linti As Long
Dim pStrBuffer As String

    NewData = DeFormatRef(NewData)
    pStrBuffer = Mid(NewData, 1, 2) & " " & Mid(NewData, 3, 2) & " " & Mid(NewData, 5, 2)
    FormatRef = pStrBuffer
End Function
Public Function DeFormatRef(ByVal NewData As String) As String
Dim linti As Long
Dim pStrBuffer As String

'on déformate a partir de la gauche
'on ne fait qu'enlever les blancs

    linti = InStr(NewData, " ")
    Do Until linti = 0
        pStrBuffer = pStrBuffer & Left(NewData, linti - 1)
        NewData = Right(NewData, Len(NewData) - linti)
        linti = InStr(NewData, " ")
    Loop
    
    DeFormatRef = pStrBuffer & NewData
    
End Function
Public Function SetTopMostWindow(Window As Form, Topmost As Boolean) As Long
    If Topmost = True Then
        SetTopMostWindow = SetWindowPos(Window.hwnd, HWND_TOPMOST, 0, 0, 0, 0, HWND_FLAGS)
    Else
        SetTopMostWindow = SetWindowPos(Window.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, HWND_FLAGS)
    End If
End Function
Public Function Connect() As Boolean
Dim pStrPath As String
Dim pMouse As Long

    On Error GoTo ErrorHandler
    
    'ouvre les bases
    pMouse = Screen.MousePointer
    If pWrkJet Is Nothing Then
        Screen.MousePointer = vbHourglass
        Set pWrkJet = CreateWorkspace("", "admin", "", dbUseJet)
    End If
    
    If gMainDB Is Nothing Then
        Screen.MousePointer = vbHourglass
        pStrPath = GetSetting("FACT", "DATA", "PATH", "")
        If pStrPath = "" Then
            GoTo ErrorHandler:
        End If
        If Not pBooSaved Then Save
        Set gMainDB = pWrkJet.OpenDatabase(pStrPath)
        Screen.MousePointer = pMouse
    End If
    
    Connect = True
    Exit Function
    
ErrorHandler:
    If gMainDB Is Nothing Then
        Annexe.Recherche.ShowOpen
        pStrPath = Annexe.Recherche.FileName
        If pStrPath = NomBase Then
            Screen.MousePointer = vbDefault
            MsgBox "Impossible d'ouvrir la base de donnée", vbCritical, "Erreur d'objet"
            Connect = False
        Else
            SaveSetting "FACT", "DATA", "PATH", pStrPath
            If Not pBooSaved Then Save
            Set gMainDB = pWrkJet.OpenDatabase(pStrPath)
            Connect = True
            Screen.MousePointer = pMouse
        End If
        On Error GoTo 0
        
        Exit Function
    End If  '   gMainDB.name   gMainDB.connect  err err.description app.path

End Function
Public Function GetMaintenant() As String
    GetMaintenant = Format(Now(), "dd/mm/yyyy")
End Function

Public Function gStrTraduitNumerique(ByVal pNum As Single) As String
Dim pStrTexte As String, pStrNum As String
Dim linti As Long

    pStrNum = Trim(pNum)
    linti = InStr(pStrNum, ",")
    Do While linti > 0
        pStrTexte = pStrTexte & Left(pStrNum, linti - 1) & "."
        pStrNum = Right(pStrNum, Len(pStrNum) - linti)
        linti = InStr(pStrNum, "'")
    Loop
    gStrTraduitNumerique = pStrTexte & pStrNum

End Function
Public Function FiltreChiffre(ByVal NewData) As String
Dim pStr As String
    
    pStr = NewData
    Select Case pStr
        Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ","
        Case "."
            pStr = ","
        Case Else
            pStr = ""
    End Select
    FiltreChiffre = pStr
End Function
Public Function FiltreChiffreASCII(ByVal NewData) As String
Dim pStr As String
    
    pStr = NewData
    Select Case pStr
        Case Asc("0"), Asc("1"), Asc("2"), Asc("3"), Asc("4"), Asc("5"), Asc("6"), Asc("7"), Asc("8"), Asc("9"), Asc(",")
        Case Asc(".")
            pStr = Asc(",")
        Case 8 'backspace
        
        Case Else
            pStr = 0
    End Select
    FiltreChiffreASCII = pStr
End Function
Public Function Today() As String
    Today = Right("0" & Day(Now), 2) & "/" & Right("0" & Month(Now), 2) & "/" & Year(Now)
End Function
Public Function Maj(ByVal pStrIn As String) As String
'retourne la string en minuscule avec la première lettre en majuscule
'et supprime les doublonds d'espace
Dim linti   As Long

    If pStrIn <> "" Then
        pStrIn = Trim(pStrIn)
        ' formate le nom pour avoir la première lettre en Maj et les autres en Min
        pStrIn = UCase(Left(pStrIn, 1)) & Right(pStrIn, Len(pStrIn) - 1)
    End If
    Maj = pStrIn
    
End Function
Private Sub Save()
Dim pStrPath As String
Dim pStrNom As String
Dim pStrNewNom As String
Dim plIntI As Long
Dim plIntJ As Long
Dim pBoo As Boolean
Dim pNomBase As String

    On Error Resume Next
    pNomBase = UCase(Left(NomBase, Len(NomBase) - 4))
    pStrPath = GetSetting(pNomBase, "DATA", "PATH", "")
    pStrNom = Left(pStrPath, InStr(pStrPath, ".") - 1)
    
    Do Until pBoo
        pStrNewNom = pStrNom & "_" & Trim(plIntI) & ".sav"
        If Dir(pStrNewNom) = "" Then
            FileCopy pStrPath, pStrNewNom
            pBoo = True
        End If
        plIntI = plIntI + 1
    Loop
    If plIntI >= 26 Then
        If MsgBox("Il y a plus de 25 bases " & pNomBase & " sauvegardées, voulez-vous supprimer les 24 premières bases ?", vbInformation + vbYesNo, "Bases sauvegardées") = vbYes Then
            plIntI = plIntI - 1
            FileCopy pStrNom & "_" & plIntI & ".sav", pStrNom & "_0.sav"
            plIntJ = plIntI
            Do Until plIntJ = 0
                pStrNewNom = pStrNom & "_" & Trim(plIntJ) & ".sav"
                If Dir(pStrNewNom) <> "" Then
                    Kill pStrNewNom
                End If
                plIntJ = plIntJ - 1
            Loop
        End If
    End If
    
End Sub

Public Function GetDerFact() As Long
Dim pRS As Recordset
Dim pStrSQL As String
Dim pVarPreviousCle As String

    pStrSQL = "SELECT DER_FACTURE FROM T_Dernier"
    If OpenRecord(pStrSQL, pRS) Then
        GetDerFact = pRS!DER_FACTURE
    Else
        MsgBox pStrMessage, vbCritical, "Erreur d'objet"
        'il y a un probleme, la cle vaudra 0 !
    End If

End Function

Public Function GetNewFact() As Long
Dim pRS As Recordset
Dim pStrSQL As String
Dim pVarPreviousCle As String

    pVarPreviousCle = GetDerFact
    pStrSQL = "UPDATE T_Dernier SET DER_FACTURE =" & Trim(CLng(pVarPreviousCle) + 1)
    ExecuteSQL pStrSQL
    pStrSQL = "SELECT DER_FACTURE FROM T_Dernier"
    If OpenRecord(pStrSQL, pRS) Then
        GetNewFact = pRS!DER_FACTURE
    Else
        MsgBox pStrMessage, vbCritical, "Erreur d'objet"
        'il y a un probleme, la cle vaudra 0 !
    End If
    
End Function
Public Function GetNewCle() As Long
Dim pRS As Recordset
Dim pStrSQL As String
Dim pVarPreviousCle As String

    
    pStrSQL = "SELECT DER_CLE FROM T_Dernier"
    If OpenRecord(pStrSQL, pRS) Then
        pVarPreviousCle = pRS!DER_CLE
        pStrSQL = "UPDATE T_Dernier SET DER_CLE =" & Trim(CLng(pVarPreviousCle) + 1)
        ExecuteSQL pStrSQL
        pStrSQL = "SELECT DER_CLE FROM T_Dernier"
        If OpenRecord(pStrSQL, pRS) Then
            GetNewCle = pRS!DER_CLE
        Else
            MsgBox pStrMessage, vbCritical, "Erreur d'objet"
            'il y a un probleme, la cle vaudra 0 !
        End If
    Else
        MsgBox pStrMessage, vbCritical, "Erreur d'objet"
        'il y a un probleme, la cle vaudra 0 !
    End If
End Function

A voir également

S'inscrire maintenant

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.