Prevent App from opening twice?

Overthere
Overthere used Ask the Experts™
on
I have an Access app that is now an .mde file on each users desktop.  The backend data is stored on a shared network drive.  Overall things seem to be working fine.  However, I've noticed that one of my users opened the application twice on his computer.  Is there a way to prevent the app from opening more than once?

THANKS!!
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®

Commented:
I had done this awhile back, but don't have any code to help you.  The idea used was:

1). Create a registry entry for your app and include a value for keeping track of whether or not the app is currently loaded.

2). Have a routine that runs at startup that reads this value.  If value is '0', allow the app to complete loading, else kill the app.

3). When app finishes loading, flip the value to 1.

4). When app is being closed, flip it back to 0.



Another way you could try:

1). Read all open window captions (there is a Windows API to do that) then see if any matches your app's caption.

2). None found, allow it to start, else Kill the app.

Sorry I can't give you code examples, but here is a site that might get you some along those lines:

http://www.mvps.org/access

K
Jim Dettman (EE MVE)President / Owner
Most Valuable Expert 2017
Most Valuable Expert 2012

Commented:
Yeah, there are a couple of ways:

1. Use the Windows API to check the title of the window.
2. Use DDE to compare main topics.

  The 2nd is a lot simpler, but many don't like to use DDE any more.  Below is the #2 solution, let me know if you want the other.

Jim.

Function AppIsRunning() As Integer
    Dim db As Database
    Set db = CurrentDb()
    If TestDDELink(db.Name) Then
        AppIsRunning = -1
    Else
        AppIsRunning = 0
    End If
End Function

' Helper Function
Function TestDDELink(ByVal strAppName$) As Integer
   
    Dim varDDEChannel
    On Error Resume Next
    Application.SetOption ("Ignore DDE Requests"), True
    varDDEChannel = DDEInitiate("MSAccess", strAppName)
   
   ' When the app isn't already running this will error
    If Err Then
       TestDDELink = False
    Else
        TestDDELink = True
        DDETerminate varDDEChannel
        DDETerminateAll
    End If
    Application.SetOption ("Ignore DDE Requests"), False

End Function

Author

Commented:
Jim,

I copied this code to a module and then from within an autoexec macro, I called the AppIsRunning function.  It still lets me run 2 copies of the app.  What am I doing wrong?  It's a typical Monday for me so your assistance is GREATLY appreciated.

Thanks again!
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

A simple solution if you have packaged it up and provided a shortcut you can include /EXCL in the shortcut which forces the frontend to be opened exclusively.

Cheers, Andrew

Commented:
Here are the functions I used to prevent 2 versions of the application from running. If one is running and a user tries to start another he gets an messagebox informing him of this and then it closes the program. The sub routine main is stored in a module, which is the first thing my application runs upon startup. All of the lines with ' in front are remarks.

Sub Main()
Dim MultiInstResult As Integer
'Call procedure to determine if an instance of<BR>
'the application is already loaded<BR>
MultiInstResult = MultiInst
'Handle the result from the MultiInst function<BR>
If MultiInstResult = OPEN_APPLICATION Then
     rbsubfm1.Show
     'No instance of the application is already open,<BR>
     'continue to load the login form<BR>
ElseIf MultiInstResult = SINGLE_INSTANCE_OPEN Then

   'An instance already exists cancel the <BR>
   'current application load<BR>
    End
End If
End Sub


Private Function MultiInst() As Integer
'This function determines if a single instance of the <BR>
'application is already running.<BR>
Dim hwndFound As Long   'The window handle<BR>
Dim strWindowName       'The Caption on the window<BR>
'Set the caption of the application form<BR>
strWindowName = "NYT Rte Book & Subscriber List Facility"

'Get the handle of the application if it is open<BR>
hwndFound = FindWindow(vbNullString, strWindowName)
If hwndFound Then
     'Set the function return<BR>
     MultiInst = SINGLE_INSTANCE_OPEN
     MsgBox "A instance of the application is already open." & vbCrLf & vbCrLf & "Only one open instance allowed.", vbOKOnly + vbExclamation, "RouteBooks"

     'If application minimized, restore, show it on top<BR>
     If IsIconic(hwndFound) Then
          ShowWindow hwndFound, SW_RESTORE
          'Show the window infront of all other windows<BR>
          SetForegroundWindow hwndFound
     Else
          'Bring the application top most on the screen<BR>
          SetForegroundWindow hwndFound
    End If
ElseIf hwndFound = 0 Then
    'Set the function return so it will continue loading<BR>
    MultiInst = OPEN_APPLICATION
End If

End Function
Jim Dettman (EE MVE)President / Owner
Most Valuable Expert 2017
Most Valuable Expert 2012

Commented:
I'm not sure why it's not working.  Which version of Access did you try this with?  It's been some time since I tried the code (A95) as I use the API approach myself.

I warn the user for multiple instances of Access running (performance issues) and then stop them for multiple copies of the app running.

Jim.

Commented:
I use Access 97' but this code was actually taken from some Visual Basic program I wrote. I assume that for the most part it should work the same.

Commented:
Hi Overthere,

I use this code to stop the app opening twice.

1. Create a module and paste the code below into it.
2. Create a macro called Autoexec.
3. In the Action column select RunCode
4. In the Function Name field type: winCheckMultipleInstances(False)

Hope this helps.
Mavreich

CodeStart:---------------------------------------------

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

EndCode:-------------------------------------------------

Commented:

No comment has been added lately, so it's time to clean up this TA.
I will leave a recommendation in the Cleanup topic area that this question is:
 - PAQ'd and pts removed
Please leave any comments here within the
next seven days.

PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER !

Nic;o)
per recommendation

SpideyMod
Community Support Moderator @Experts Exchange

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial