Hi Douglas/Alan:
What I do is to make 2 general modules with startup attributes, including a
check of whether or not another frontend database is open- and if so, close
the current frontend immediately:
GENERAL MODULE # 1:
Option Compare Database
Option Explicit
---------------------------------------------------
Function callproperties()
Call SetStartupProperties
End Function
---------------------------------------------------
Sub SetStartupProperties()
'If DATE > #12/1/2002# Then
'Application.Quit acQuitSaveAll
'End If
'ChangeProperty "StartupShowDBWindow", dbBoolean, False
'ChangeProperty "StartupShowStatusBar", dbBoolean, False
'ChangeProperty "AllowBuiltinToolbars", dbBoolean, False
'ChangeProperty "AllowFullMenus", dbBoolean, True
'ChangeProperty "AllowBreakIntoCode", dbBoolean, False
'ChangeProperty "AllowSpecialKeys", dbBoolean, True
'ChangeProperty "AllowBypassKey", dbBoolean, False
ChangeProperty "confirmrecordchanges", dbBoolean, False
ChangeProperty "confirmdocumentdeletions", dbBoolean, False
ChangeProperty "confirmactionqueries", dbBoolean, False
'here's where I check for "multiple instances"
Call MultiAccess.winCheckMultipleInstances(False)
AddAppProperty "AppTitle", dbText, "Zfile Medical Database System"
Application.RefreshTitleBar
'Application.SetOption tobreakonerrors, 2
Exit Sub
End Sub
GENERAL MODULE # 2:
Option Compare Database
Option Explicit
'******************** Code Start ********************
' Module mdlCheckMultipleInstances
' © Graham Mandeno, Alpha Solutions, Auckland, NZ
' (e-mail address removed)
' 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
'******************** Code End ********************
Regards,
Al
