API: Preventing multiple instances of a database

    The simplest way to ensure that only one instance of the database can be opened on one desktop is to open the mdb file exclusively.

    However, with the shared mode set, if you have the Application Title  set under Tools/Startup, another way would be to iterate through all windows at startup and display a warning message if a window's caption matches the Application Title.

    This solution uses the titlebar of the database window.  It checks each other instance of Access currently running and if the titlebar of the ODb class window matches the active instance then it activates the other instance and terminates the current one.  An optional boolean argument fConfirm causes a confirmation message to be displayed before switching and terminating (the default for fConfirm is True). The function winCheckMultipleInstances can be called from initialisation code, or even directly from AutoExec:   

RunCode   
    =winCheckMultipleInstances(False)

'******************** Code Start ********************
' 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.
 
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 ********************