Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lngMutexAttributes As Long, lngInitialOwner As Long, ByVal lpName As String) As Long
Dim lngMutexHandle as long
' Create a muxtex object
lngMutexHandle = CreateMutex(0, 1,"myApp")
' Did we get a new instance or a handle to an existing one?
If Err.LastDllError = ERROR_ALREADY_EXISTS Then
' App is already running
' Message user and quit.
MsgBox "This application is already running on this station and multiple instances are not allowed", vbOKOnly+vbCritical
' Call your exit routine here to quit the app.
Else
' App is not running - OK to continue
End If
' Used for semephore check.
Const ERROR_ALREADY_EXISTS = 183&
If Err.LastDllError = 183& Then
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hdata As Long) As Long
Public Function AppAlreadyUp(bAllowMultipleInstances As Boolean) As Long
Dim lngMutexHandle as long
Dim lngReturn as long
' Create a muxtex object
lngMutexHandle = CreateMutex(0, 1, myApp)
' Did we get a new instance or a handle to an existing one?
If Err.LastDllError = ERROR_ALREADY_EXISTS Then
' App is already running
If bAllowMultipleInstances = False Then
' Message user and quit.
MsgBox "This application is already running on this station and multiple instances are not allowed", vbOKOnly+vbCritical
' Call your exit routine here to quit the app.
Else
MsgBox "Warning, this application is already running on this station."
Else
' App is not running - OK to continue
' Mark the window with a property so we can find it again if we need to.
lngReturn = SetProp(Application.hWndAccessApp, "myApp", 1)
End If
End Function
Private Declare Function BringWindowToTop Lib "user32" (ByVal lngHWnd As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal lnghObject As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () 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 ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdSHow As Long) As Long
' For GetWindow
Const GW_HWNDNEXT = 2
Const GW_HWNDChild = 5
' For ShowWindow
Const SW_MAXIMIZE = 3
Const SW_SHOWNORMAL = 1
Const SW_SHOWMINIMIZED = 2
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
Dim strMsg As String
On Error GoTo AppAlreadyUp_Error
' Create a muxtex object
lngMutexHandle = CreateMutex(0, 1, "myApp")
' Did we get a new instance or a handle to an existing one?
If Err.LastDllError = ERROR_ALREADY_EXISTS Then
' App is already running
If bDisplayMsg = True Then
' Close the handle just created as
' it only points to the existing muxtex
lngReturn = CloseHandle(lngMutexHandle)
If bAllowMultipleInstances = False Then
strMsg = "This application is already running on this workstation. You cannot start another copy."
strMsg = strMsg & vbCrLf & "You will be switched to the existing copy."
Else
strMsg = "Warning: This application is already running on this workstation."
End If
MsgBox strMsg, vbOKOnly + vbCritical
End If
If bAllowMultipleInstances = False Then
' Find the existing instance, switch to it, then close this instance
lngHWnd = GetWindow(GetDesktopWindow(), GW_HWNDChild)
Do While lngHWnd > 0
If GetProp(lngHWnd, "myApp") = 1 Then
BringWindowToTop (lngHWnd)
lngReturn = ShowWindow(lngHWnd, SW_MAXIMIZE)
Exit Do
End If
lngHWnd = GetWindow(lngHWnd, GW_HWNDNEXT)
Loop
' Call application exit routine here or just quit your app.
End If
Else
lngReturn = SetProp(Application.hWndAccessApp, "myApp", 1)
End If
AppAlreadyUp_Exit:
On Error Resume Next
' Always return false just to pass something back
AppAlreadyUp = False
Exit Function
AppAlreadyUp_Error:
UnexpectedError ModuleName, RoutineName, Version, Err.Number, Err.Description, Err.Source, VBA.Erl
Resume AppAlreadyUp_Exit
End Function
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (17)
Commented:
Open in new window
Commented:
Kind Regards,
Mohamed
Commented:
Thank You for taking the time to respond and for providing a solution.
I will revert to you soonest I can test your code.
Kindest Regards,
Mohamed
Commented:
Author
Commented:Jim.
View More