Prevent a Second Instance of Access?

Hi all,

Here is some code i came accross that prevent a second instance opening....

1. In a module place this code....  
2. In the first line of the Autoexec macro place a runcode action with winCheckMultipleInstances(False) as the function name

Hope this helps

Mavreich


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.
 
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