MOZEBITIPONOVO 01.04.2015 15:55
Predmet:Samo jedno otvaranje baze

Pozdrav!

Negde sam jednom našao na nekom forumu, sada kada mi treba nema šansi. Kako da se ne dozvoli otvaranje iste baze dva puta?

pmiroslav 01.04.2015 17:38
Predmet:Re: Samo jedno otvaranje baze

Probaj ovo. Kopiraj ovaj kod u neki modul i onda napravi Macro kojeg čeÅ¡ nazvati Autoexec i u njemu slijedeće:

Action: Run Code
Function: =winCheckMultipleInstances(False)

PreuzmiIzvorni kôd (vbnet):
  1. Option Compare Database
  2.  
  3. '******************** Code Start ********************
  4. ' Module mdlCheckMultipleInstances
  5. ' © Graham Mandeno, Alpha Solutions, Auckland, NZ
  6. ' graham@alpha.co.nz
  7. ' This code may be used and distributed freely on the condition
  8. '  that the above credit is included unchanged.
  9.  
  10. Private Const cMaxBuffer = 255
  11.  
  12. Private Declare Function apiGetClassName Lib "user32" _
  13.   Alias "GetClassNameA" _
  14.   (ByVal hWnd As Long, _
  15.   ByVal lpClassName As String, _
  16.   ByVal nMaxCount As Long) _
  17.   As Long
  18.    
  19. Private Declare Function apiGetDesktopWindow Lib "user32" _
  20.   Alias "GetDesktopWindow" _
  21.   () As Long
  22.  
  23. Private Declare Function apiGetWindow Lib "user32" _
  24.   Alias "GetWindow" _
  25.   (ByVal hWnd As Long, _
  26.   ByVal wCmd As Long) _
  27.   As Long
  28.  
  29. Private Const GW_CHILD = 5
  30. Private Const GW_HWNDNEXT = 2
  31.  
  32. Private Declare Function apiGetWindowText Lib "user32" _
  33.   Alias "GetWindowTextA" _
  34.   (ByVal hWnd As Long, _
  35.   ByVal lpString As String, _
  36.   ByVal aint As Long) _
  37.   As Long
  38.  
  39. Private Declare Function apiSetActiveWindow Lib "user32" _
  40.   Alias "SetActiveWindow" _
  41.   (ByVal hWnd As Long) _
  42.   As Long
  43.  
  44. Private Declare Function apiIsIconic Lib "user32" _
  45.   Alias "IsIconic" _
  46.   (ByVal hWnd As Long) _
  47.   As Long
  48.  
  49. Private Declare Function apiShowWindowAsync Lib "user32" _
  50.   Alias "ShowWindowAsync" _
  51.   (ByVal hWnd As Long, _
  52.   ByVal nCmdShow As Long) _
  53.   As Long
  54.  
  55. Private Const SW_SHOW = 5
  56. Private Const SW_RESTORE = 9
  57.  
  58. Public Function winGetClassName(hWnd As Long) As String
  59. Dim sBuffer As String, iLen As Integer
  60.   sBuffer = String$(cMaxBuffer - 1, 0)
  61.   iLen = apiGetClassName(hWnd, sBuffer, cMaxBuffer)
  62.   If iLen > 0 Then
  63.     winGetClassName = Left$(sBuffer, iLen)
  64.   End If
  65. End Function
  66.  
  67. Public Function winGetTitle(hWnd As Long) As String
  68. Dim sBuffer As String, iLen As Integer
  69.   sBuffer = String$(cMaxBuffer - 1, 0)
  70.   iLen = apiGetWindowText(hWnd, sBuffer, cMaxBuffer)
  71.   If iLen > 0 Then
  72.     winGetTitle = Left$(sBuffer, iLen)
  73.   End If
  74. End Function
  75.  
  76. Public Function winGetHWndDB(Optional hWndApp As Long) As Long
  77. Dim hWnd As Long
  78. winGetHWndDB = 0
  79. If hWndApp <> 0 Then
  80.   If winGetClassName(hWndApp) <> "OMain" Then Exit Function
  81. End If
  82. hWnd = winGetHWndMDI(hWndApp)
  83. If hWnd = 0 Then Exit Function
  84. hWnd = apiGetWindow(hWnd, GW_CHILD)
  85. Do Until hWnd = 0
  86.   If winGetClassName(hWnd) = "ODb" Then
  87.     winGetHWndDB = hWnd
  88.     Exit Do
  89.   End If
  90.   hWnd = apiGetWindow(hWnd, GW_HWNDNEXT)
  91. Loop
  92. End Function
  93.  
  94. Public Function winGetHWndMDI(Optional hWndApp As Long) As Long
  95. Dim hWnd As Long
  96. winGetHWndMDI = 0
  97. If hWndApp = 0 Then hWndApp = Application.hWndAccessApp
  98. hWnd = apiGetWindow(hWndApp, GW_CHILD)
  99. Do Until hWnd = 0
  100.   If winGetClassName(hWnd) = "MDIClient" Then
  101.     winGetHWndMDI = hWnd
  102.     Exit Do
  103.   End If
  104.   hWnd = apiGetWindow(hWnd, GW_HWNDNEXT)
  105. Loop
  106. End Function
  107.  
  108. Public Function winCheckMultipleInstances(Optional fConfirm As Boolean = True) As Boolean
  109. Dim fSwitch As Boolean, sMyCaption As String
  110. Dim hWndApp As Long, hWndDb As Long
  111. On Error GoTo ProcErr
  112.   sMyCaption = winGetTitle(winGetHWndDB())
  113.   hWndApp = apiGetWindow(apiGetDesktopWindow(), GW_CHILD)
  114.   Do Until hWndApp = 0
  115.     If hWndApp <> Application.hWndAccessApp Then
  116.       hWndDb = winGetHWndDB(hWndApp)
  117.       If hWndDb <> 0 Then
  118.         If sMyCaption = winGetTitle(hWndDb) Then Exit Do
  119.       End If
  120.     End If
  121.     hWndApp = apiGetWindow(hWndApp, GW_HWNDNEXT)
  122.   Loop
  123.   If hWndApp = 0 Then Exit Function
  124.   If fConfirm Then
  125.     If MsgBox(sMyCaption & " is already open@" _
  126.       & "Do you want to open a second instance of this database?@", _
  127.       vbYesNo Or vbQuestion Or vbDefaultButton2) = vbYes Then Exit Function
  128.   End If
  129.   apiSetActiveWindow hWndApp
  130.   If apiIsIconic(hWndApp) Then
  131.     apiShowWindowAsync hWndApp, SW_RESTORE
  132.   Else
  133.     apiShowWindowAsync hWndApp, SW_SHOW
  134.   End If
  135.   Application.Quit
  136. ProcEnd:
  137.   Exit Function
  138. ProcErr:
  139.   MsgBox Err.Description
  140.   Resume ProcEnd
  141. End Function