' Module mdlCheckMultipleInstances
' © Graham Mandeno, Alpha Solutions, Auckland, NZ
' [email]graham@alpha.co.nz[/email]
' 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
MsgBox sMyCaption & " is already open@" & "Application already opened. Use other instance.@", vbOKOnly, mbTitle
'AppActivate "Absence Recorder"
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
Thanks for all your help.
