App.Previnstance in Access? 1

[Ahliana]

I am working with Access 2000. I would like to test for a previous instance of the database being open. In VB, I could use:

If App.Previnstance Then
    sFormCaption = Me.Caption
    App.Activate sFormCaption
    Unload Me
End If

Is there something comparable in Access?

Thank you for your help.

Ahliana
Argue for your limitations and, sure enough, they're yours! - Richard Bach

 

[pullingteeth]

I forget where I got this from. It ain't pretty but it works. Put this in a class module, then call winCheckMultipleInstances from the AutoExec module (i.e. at startup).

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

 

[Ahliana]

PullingTeeth, you are on my holiday list! Kudos, it worked beautifully. You have solved an issue for us, and I appreciate it very much.



Ahliana
Argue for your limitations and, sure enough, they're yours! - Richard Bach