winCheckMultipleInstances not working AC2010.

[TheSmileyCoder]

I have found that users sometimes minimize my application, and then later, start it "again" thus starting a new instance of the program.

I want to prevent this from happening.

Current setup:
Frontend is a MDE file.
Backend is mdb file on shared network drive.
Acccess Version: 2010
Windows 7

I found this code at http://access.mvps.org/access/api/api0041.htm.

The problem is I can't get it to work, the sMyCaption variable is set to "" thus it doesn't really matter what happens in the rest of the code. I have tried and tried to understand the API calls, but I am getting nowhere and my head starts to hurt! I would appreciate it if anyone with more API skills then me, can spot what might go wrong.

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

[NeoPa]

If the users have their own copy of the FE then it might be easier simply to check the size of the LDB file. Painless and reliable.

[TheSmileyCoder]

I did consider that, but I believe if the access application exits in error, that the .ldb file is left behind, and not cleaned up. How would you handle that?

[ADezii]

@TheSmileyCoder :

1. I made a very subtle change in the Entry Level Function which really was not necessary.
2. The Code works exactly as intended, as long as:
   1. You do not Pass a False Argument to the winCheckMultipl eInstances() Function, as in:
      

      winCheckMultipleInstances(False)

   2. Your Code for winCheckMultipl eInstances() is exactly as follows:
      

      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
        
        apiSetActiveWindow hWndApp
        
        If apiIsIconic(hWndApp) Then
          apiShowWindowAsync hWndApp, SW_RESTORE
        Else
          apiShowWindowAsync hWndApp, SW_SHOW
        End If
      End If
        
      Application.Quit
      
      ProcEnd:
        Exit Function
      ProcErr:
        MsgBox Err.Description
          Resume ProcEnd
      End Function

[NeoPa]

Smiley:
if the access application exits in error, that the .ldb file is left behind, and not cleaned up. How would you handle that?

Just as you would normally. Delete the file, then everything works normally again. You wouldn't expect everything to work perfectly when you had spurious files around.

Actually, it's a bonus, as it draws atention to the problem rather than leaving it there unnoticed until it mucks up something else - possibly in a way that's more subtle and hard to ascertain ;-)

PS. This seems to me to be a perfect illustration of the KISS concept.

[TheSmileyCoder]

@ adezii, Are you getting a non empty string value in sMyCaption? And what version of access are you using? I cant help but wonder if this is in someway related to me using Ac2010 and the code simply breaks in 2010.

@NeoPa How would you detect whether the a existing .ldb is the result of a bad exit (crash) or the result of the app allready being in use? I suppose I could try to kill it and catch the error if it is in use, but that also seems a bit crude, and file errors often seem to have poor performance/response times in my experience.

Thank you both for your time so far

[NeoPa]

That question relies on knowing if multiple users have their own front-ends. If so, then the very existence of the file means that the user has it open already. If not, then it becomes more complicated and some parsing of the LDB file data may be required.

[ADezii]

Are you getting a non empty string value in sMyCaption? And what version of access are you using? I cant help but wonder if this is in someway related to me using Ac2010 and the code simply breaks in 2010.

Sorry, but I forgot to mention that I am using Access 2002. I'm sending you my Demo Version for the Definitive Test. Open a 2nd Instance of the Demo, then click the Command Button - the Code should work fine.