Soyez le premier à donner votre avis sur cette source.
Snippet vu 6 402 fois - Téléchargée 19 fois
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
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.