Option Compare Database

'******************** 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