Is there a way for MS Acces to display on the user's computer if it was opened in exclusive mode?

user_19672699 0
Viewed 58

I'm working at a company as an intern. I never used vba in my life before. I need to display if the MS Access database was opened in exclusive mode at the user's computer. It needs to has some kind of red indicator if the user is opened with exclusive mode in any other case it should display a green indicator. The Access is used in shared mode.

Edit: I found this on a Hungarian page. (link to the page: https://prog.hu/tudastar/101971/access-megnyitasi-opciok-lekerdezese-vba-ban)

Function IsCurDBExclusive () As Integer
  'Purpose: Determine if the current database is open exclusively.
  'Returns: 0 if database is not open exclusively.
  '         -1 if database is open exclusively.
  '         Err if any error condition is detected.

  Dim db As DAO.Database
  Dim hFile As Integer
  hFile = FreeFile

  Set db = CurrentDb
  If Dir$(db.name) <> "" Then
    On Error Resume Next
      Open db.name For Binary Access Read Write Shared As hFile
        Select Case Err
          Case 0
            IsCurDBExclusive = False
          Case 70
            IsCurDBExclusive = True
          Case Else
            IsCurDBExclusive = Err
        End Select
      Close hFile
    On Error GoTo 0
  Else
    MsgBox "Couldn't find " & db.name & "."
  End If
End Function

I don't know where I should put to try it out, if it even works or good.

ms-access vba
1 Answers
 Public Function IsCurDBExclusive() As Integer

  Dim db As DAO.Database
  Dim hFile As Integer
  hFile = FreeFile

  Set db = CurrentDb
  If Dir$(db.Name) <> "" Then
    On Error Resume Next
      Open db.Name For Binary Access Read Write Shared As hFile

        Select Case Err
          Case 0   
            IsCurDBExclusive = False
            MsgBox "Shared mode"
          Case 70  
            IsCurDBExclusive = True
            MsgBox "Exclusive mode", 0, "Attention"
             If ActiveWorkbook.ExclusiveAccess Then
                ActiveWorkbook.MultiUserEditing
             End If
            'Form!MENU.BackColor = lngRed
          Case Else
            IsCurDBExclusive = Err
        End Select


      Close hFile
    On Error GoTo 0
  Else
    MsgBox "Couldn't find " & db.Name & "."
  End If
  
End Function

Private Sub Form_Load()
    IsCurDBExclusive
End Sub

I managed to make it work. Here is the code guys.

user_196726990
Related