PDA

Vollständige Version anzeigen : beim start testen ob anwendung läuft


hanez
11.01.2001, 15:36
Hallo,

gibt es eine möglichkeit per vba rauszufinden ob eine bestimmte mdb datei auf dem lokalen rechner geöffnet ist oder nicht.

wenn sie geöffnet ist darf meine mdb nicht weiter geöffnet werden, sondern ein warnfenster erscheinen und nach einem click auf OK das programm wieder beenden. wenn sie nicht geöffnet ist soll meine mdb ganz normal weiter starten.

der grund dafür ist, daß einige mitarbeiter nicht besonders gut mit dem pc umgehen können und dann das frontend mehrfach auf einem arbeitsplatz geöffnet ist.

schöne grüße


hanez

Mike
11.01.2001, 16:41
Hallo Hanez,
hier ein Beispiel, was bei mir seit langem läuft. Sieht etwas kompliziert aus, ist auch umfangreich, aber einfach anzuwenden.
Mike

Aufruf: winCheckMultipleInstances True

'---Posted By Graham Mandeno---
'Preventing multiple instances of a database
' The simplest way to ensure that only one instance of the database can be opened on one desktop is to open the mdb file exclusively.
' However, with the shared mode set, if you have the Application Title set under Tools/Startup, another way would be to iterate through all windows
' at startup and display a warning message if a window's caption matches the Application Title.
' This solution uses the titlebar of the database window. It checks each other instance of Access currently running and if the titlebar of the ODb
' class window matches the active instance then it activates the other instance and terminates the current one. An optional boolean argument fConfirm
' causes a confirmation message to be displayed before switching and terminating (the default for fConfirm is True). The function winCheckMultipleInstances
' can be called from initialisation code, or even directly from AutoExec:

' RunCode=winCheckMultipleInstances(False)

'******************** Code Start ********************
' Module mdlCheckMultipleInstances
' © Graham Mandeno, Alpha Solutions, Auckland, NZ
' graham@alpha.co.nz
' 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 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 vbYes = MsgBox("Die Anwendung '" + sMyCaption & _
"' ist bereits geöffnet@Wollen Sie sie ein weiteres mal starten?@", vbYesNo Or vbQuestion Or vbDefaultButton2) 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

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

hanez
11.01.2001, 17:04
hey mike,

das ist ja super-cool. genau so hatte ich mir das vorgestellt.

vielen vielen dank.