Eurico,
Sorry for the delay in getting back to this. I tracked this down finally.
The code appeared in the Jan 2005 issue of FoxTalk 2.0; "The Kit Box:Run
Once, Once and Only Once" by Andy Kramek and Marica Akins. However the
article only has bits and pieces of the code. The full VFP code was
available via download. I don't have access to that any more and I can't
find a copy of it anywhere here.
The code was based on creating a mutex as Dave posted, but extended a bit
by having the option to switch to the other instance if need be. FWIW,
below is my VBA port. Think I've included all the calls.
AppName() just provided a string of the application name.
Jim.
' Used for semaphore check.
Const ERROR_ALREADY_EXISTS = 183&
' For GetWindow
Const GW_HWNDNEXT = 2
Const GW_HWNDChild = 5
Private Declare Function BringWindowToTop Lib "user32" (ByVal lngHWnd As
Long) As Long
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA"
(lngMutexAttributes As Long, lngInitialOwner As Long, ByVal lpName As
String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal lnghObject As
Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal
lngHWnd As Long, ByVal lpString As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal
nRelationship As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd
As Long, ByVal lpString As String, ByVal hdata As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
nCmdSHow As Long) As Long
Public Function AppAlreadyUp(bAllowMultipleInstances As Boolean, bDisplayMsg
As Boolean) As Long
' Function checks for multiple instances of an application
' by creating a mutex object. If no error, then this is only
' instance running.
Const RoutineName = "AppAlreadyUp"
Const Version = "1.0"
Dim lngMutexHandle As Long
Dim lngHWnd As Long
Dim lngReturn As Long
10 On Error GoTo AppAlreadyUp_Error
' Create a muxtex object
20 lngMutexHandle = CreateMutex(0, 1, AppName())
' Did we get a new instance or a handle to an existing one?
30 If Err.LastDllError = ERROR_ALREADY_EXISTS Then
' App is already running
40 If bDisplayMsg = True Then
' Close the handle just created as
' it only points to the existing muxtex
50 lngReturn = CloseHandle(lngMutexHandle)
60 If bAllowMultipleInstances = False Then
70 gstrMBMsg = "This application is already running on this
workstation. You cannot start another copy."
80 gstrMBMsg = gstrMBMsg & vbCrLf & "You will be switched to the
existing copy."
90 Else
100 gstrMBMsg = "Warning: This application is already running on
this workstation."
110 End If
120 gintMBDef = vbOKOnly + vbCritical
130 gintMBBeep = True
140 gintMBLog = False
150 Call DisplayMsgBox
160 End If
170 If bAllowMultipleInstances = False Then
' Find the existing instance, switch to it, then close this
instance
180 lngHWnd = GetWindow(GetDesktopWindow(), GW_HWNDChild)
190 Do While lngHWnd > 0
200 If GetProp(lngHWnd, AppName()) = 1 Then
210 BringWindowToTop (lngHWnd)
220 lngReturn = ShowWindow(lngHWnd, 3)
230 Exit Do
240 End If
250 lngHWnd = GetWindow(lngHWnd, GW_HWNDNEXT)
260 Loop
270 Call ApplicationExit
280 End If
290 Else
300 lngReturn = SetProp(Application.hWndAccessApp, AppName(), 1)
310 End If
AppAlreadyUp_Exit:
320 On Error Resume Next
' Always return false just to pass something back
' Required because of being called from autoexec macro.
330 AppAlreadyUp = False
340 Exit Function
AppAlreadyUp_Error:
350 UnexpectedError ModuleName, RoutineName, Version, Err.Number,
Err.Description, Err.Source, VBA.Erl
360 Resume AppAlreadyUp_Exit
End Function
-----Original Message-----
From: [email protected] [mailto:[email protected]] On
Behalf Of Eurico Chagas Filho
Sent: Tuesday, July 14, 2009 10:20 PM
To: [email protected]
Subject: RE: How to avoid two instances
Hi Jim
Yeah please send it my way, thanks.
E.
[excessive quoting removed by server]
_______________________________________________
Post Messages to: [email protected]
Subscription Maintenance: http://leafe.com/mailman/listinfo/profox
OT-free version of this list: http://leafe.com/mailman/listinfo/profoxtech
Searchable Archive: http://leafe.com/archives/search/profox
This message:
http://leafe.com/archives/byMID/profox/d642fe3afbe64ec4ba0a3680ea297...@xps
** All postings, unless explicitly stated otherwise, are the opinions of the
author, and do not constitute legal or medical advice. This statement is added
to the messages for those lawyers who are too stupid to see the obvious.
