MS-Office-Forum

Zurück   MS-Office-Forum > Archive > Microsoft Access - Archiv > Microsoft Access - Archiv (2000)
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 11.01.2001, 14:36   #1
hanez
Down beim start testen ob anwendung läuft

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
 
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.01.2001, 15:41   #2
Mike
MOF Profi
MOF Profi
Standard

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

Code:

'---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
Mike ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.01.2001, 16:04   #3
hanez
Engel

hey mike,

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

vielen vielen dank.
 
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 17:20 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.