Carte du site
 Remerciements
 Netiquette
 Bugs
 Tables
 Requêtes
 Formulaires
 États (rapports)
 Modules
 APIs
 Chaînes
 Date/Time
 Général
 Ressources
 Téléchargeables

 Termes d'usage

APIs: Prévenir l'utilisation multiple de la même base de données

Author(s)
Graham Mandeno

Prévenir l'utilisation multiple de la même base de données.

    La façon la plus simple de s'assurer qu'une seule instance de la base de données ne soit ouverte sur le PC est encore d'ouvrir la base de données en mode exclusif.

   Cependant, en mode partagé, si votre application utilise un titre spécifique (voir Application Title  sous le menu Tools/Startup), une autre façon consiste à vérifier, en partant l'application, qu'aucune autre fenêtre n'existe avec ce nom spécifique.

    La solution proposée utilise le titre de la fenêtre maîtresse. Elle vérifie si une autre instance d'Access est en cours d'utilisation sur ce PC et si oui, si elle correspond au titre de l'application: si c'est le cas, elle termine l'application actuelle qui est en cours de démarrage. Un argument optionnel booléen, fConfirm, cause l'afficahge d'un message de confirmation, avnat de terminer (par défaut, fConfirm est Vrai). La fonctin winCheckMultipleInstances peut être appelée dans un code d'initialisation, ou directement depuis AutoExec:   

RunCode   
    =winCheckMultipleInstances(False)

'******************** Code Start ********************
Option Compare Database
Option Explicit
 
' Module mdlCheckMultipleInstances
' © Graham Mandeno, Alpha Solutions, Auckland, NZ
' graham@alpha.co.nz
' This code may be used and distributed freely on the condition
'  that the above credit is included unchanged. 
' Module mdlCheckMultipleInstances ' © Graham Mandeno, Alpha Solutions, Auckland, NZ ' graham@alpha.co.nz ' Ce code peut être utilisé et distribué gratuitement à la condition ' que cette note en en établissant la paternité, demeure inchangée.

Private Const cMaxBuffer = 255 Private Declare Function apiGetClassName Lib "user32" _ Alias "GetClassNameA" _ (ByVal hWnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) _ As Long Private Declare Function apiGetDesktopWindow Lib "user32" _ Alias "GetDesktopWindow" _ () As Long Private Declare Function apiGetWindow Lib "user32" _ Alias "GetWindow" _ (ByVal hWnd As Long, _ ByVal wCmd As Long) _ As Long Private Const GW_CHILD = 5 Private Const GW_HWNDNEXT = 2 Private Declare Function apiGetWindowText Lib "user32" _ Alias "GetWindowTextA" _ (ByVal hWnd As Long, _ ByVal lpString As String, _ ByVal aint As Long) _ As Long Private Declare Function apiSetActiveWindow Lib "user32" _ Alias "SetActiveWindow" _ (ByVal hWnd As Long) _ As Long Private Declare Function apiIsIconic Lib "user32" _ Alias "IsIconic" _ (ByVal hWnd As Long) _ As Long Private Declare Function apiShowWindowAsync Lib "user32" _ Alias "ShowWindowAsync" _ (ByVal hWnd As Long, _ ByVal nCmdShow As Long) _ As Long Private Const SW_SHOW = 5 Private Const SW_RESTORE = 9 Public Function winGetClassName(hWnd As Long) As String Dim sBuffer As String, iLen As Integer sBuffer = String$(cMaxBuffer - 1, 0) iLen = apiGetClassName(hWnd, sBuffer, cMaxBuffer) If iLen > 0 Then winGetClassName = Left$(sBuffer, iLen) End If End Function Public Function winGetTitle(hWnd As Long) As String Dim sBuffer As String, iLen As Integer sBuffer = String$(cMaxBuffer - 1, 0) iLen = apiGetWindowText(hWnd, sBuffer, cMaxBuffer) If iLen > 0 Then winGetTitle = Left$(sBuffer, iLen) End If End Function Public Function winGetHWndDB(Optional hWndApp As Long) As Long Dim hWnd As Long winGetHWndDB = 0 If hWndApp <> 0 Then If winGetClassName(hWndApp) <> "OMain" Then Exit Function End If hWnd = winGetHWndMDI(hWndApp) If hWnd = 0 Then Exit Function hWnd = apiGetWindow(hWnd, GW_CHILD) Do Until hWnd = 0 If winGetClassName(hWnd) = "ODb" Then winGetHWndDB = hWnd Exit Do End If hWnd = apiGetWindow(hWnd, GW_HWNDNEXT) Loop End Function Public Function winGetHWndMDI(Optional hWndApp As Long) As Long Dim hWnd As Long winGetHWndMDI = 0 If hWndApp = 0 Then hWndApp = Application.hWndAccessApp hWnd = apiGetWindow(hWndApp, GW_CHILD) Do Until hWnd = 0 If winGetClassName(hWnd) = "MDIClient" Then winGetHWndMDI = hWnd Exit Do End If hWnd = apiGetWindow(hWnd, GW_HWNDNEXT) Loop End Function Public Function winCheckMultipleInstances(Optional fConfirm As Boolean = True) As Boolean Dim fSwitch As Boolean, sMyCaption As String Dim hWndApp As Long, hWndDb As Long On Error GoTo ProcErr sMyCaption = winGetTitle(winGetHWndDB()) hWndApp = apiGetWindow(apiGetDesktopWindow(), GW_CHILD) Do Until hWndApp = 0 If hWndApp <> Application.hWndAccessApp Then hWndDb = winGetHWndDB(hWndApp) If hWndDb <> 0 Then If sMyCaption = winGetTitle(hWndDb) Then Exit Do End If End If hWndApp = apiGetWindow(hWndApp, GW_HWNDNEXT) Loop If hWndApp = 0 Then Exit Function If fConfirm Then If MsgBox(sMyCaption & " is already open@" _ & "Do you want to open a second instance of this database?@", _ vbYesNo Or vbQuestion Or vbDefaultButton2) = vbYes Then Exit Function End If apiSetActiveWindow hWndApp If apiIsIconic(hWndApp) Then apiShowWindowAsync hWndApp, SW_RESTORE Else apiShowWindowAsync hWndApp, SW_SHOW End If Application.Quit ProcEnd: Exit Function ProcErr: MsgBox Err.Description Resume ProcEnd End Function '******************** Code End ********************

© 1998-2001, Dev Ashish, All rights reserved. Optimized for Microsoft Internet Explorer