I use this code in my Access 2K apps to check for multple instances of
my Access2K apps and it works fine on XP and WIn2K OS.
However, trying it on Access 2003/ XP OS it doesn't work and gets stuck
in a loop (Do Until hWndApp = 0)
Any ideas?
Private Const cMaxBuffer = 255
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 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 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, myCaption As String, hWndApp As Long,
hWndDb As Long
myCaption = winGetTitle(winGetHWndDB())
hWndApp = apiGetWindow(apiGetDesktopWindow(), GW_CHILD)
Do Until hWndApp = 0
If hWndApp <> Application.hWndAccessApp Then
hWndDb = winGetHWndDB(hWndApp)
If hWndDb <> 0 Then
If myCaption = winGetTitle(hWndDb) Then Exit Do
End If
End If
hWndApp = apiGetWindow(hWndApp, GW_HWNDNEXT)
Loop
If hWndApp = 0 Then Exit Function
'leaving this code in allows the user the option of opening another
instance:
'*If fConfirm Then
'* If MsgBox(myCaption & " is already open" & vbCrLf & vbCrLf &
"" _
'* & "Do you want to open a second instance of this database?",
_
'* vbYesNo Or vbQuestion Or vbDefaultButton2) = vbYes Then Exit
Function
'*End If
If fConfirm Then
msgbox "You cannot open a second instance of this database."
End If
apiSetActiveWindow hWndApp
If apiIsIconic(hWndApp) Then
apiShowWindowAsync hWndApp, SW_RESTORE
Else
apiShowWindowAsync hWndApp, SW_SHOW
End If
DoCmd.Quit
End Function