Pour se simplifier les appels base de donnée access
Soyez le premier à donner votre avis sur cette source.
Snippet vu 6 402 fois - Téléchargée 19 fois
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
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
- Pour se simplifier les appels base de donnée access
- Base de données javascript - Conseils pratiques -Javascript
- Connexion base de données - Conseils pratiques -PHP
- Base de données stock ✓ - Forum Visual Basic
- Simplifier une fraction - Forum C / C++ / C++.NET
- Afficher les données d'une base de données dans un tableau php ✓ - Forum PHP
4 sept. 2010 à 14:06
>>Merci de cette grande délicatesse dans tes propos
Personne (ou presque) ne le fait ici, et on se porte très bien, rassure-toi.
>>A l'époque ou ça a été écrit (1998) ADO n'existait pas !
Maintenant tu le sais, et on ne t'assassinera pas pour ça, hein ;)
>>Replace ?
Replace() ne parcourt la chaine qu'une fois, donc pas de problème de ce côté-là si c'est de cela que tu parlais. Tu ne dois donc pas lancer ça sur un SQL complet mais sur le contenu des chaines que tu mets dedans : "SELECT * FROM maTable WHERE monChamp='" & Pure(maChaine) & "';".
4 sept. 2010 à 08:36
A l'époque ou ça a été écrit (1998) ADO n'existait pas !
Replace ? ben dis donc, avec Pure = Replace(Str, "'", "''") la base va se remplir de quotes alors !
4 sept. 2010 à 01:49
- NomFichier : Se résume en 3 lignes ...
## Dim P As Integer: P = InStrRev(StrNom, "")## If P 0 Then P InStrRev(StrNom, "/")
## If P <> 0 Then NomFichier = Right(StrNom, Len(StrNom) - P)
De plus, il faut utiliser ADO et non DAO.
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.