Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0568: Access-Datensatz für exklusive Bearbeitung sperren

 von 

Beschreibung 

Hier wird gezeigt, wie man bei einer Access-Datenbank einen Datensatz für die exclusive Bearbeitung sperren kann. Das wird hier am Beispiel einer kleinen Adress Tabelle über einen SoftLock demonstriert.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

GetUserNameA (GetUserName)

Download:

Download des Beispielprojektes [9,25 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'----------- Anfang Projektdatei ADO_SoftLock.vbp -----------
' Es muss ein Verweis auf 'Microsoft ActiveX Data Objects 2.5 Library' gesetzt werden.
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6) (MsComCtl.ocx)' wird benötigt.

'--- Anfang Formular "frmADO_SoftLock" alias frmADO_SoftLock.frm  ---
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Rahmensteuerelement "frameDB"
' Steuerelement: Schaltfläche "cmdUnlock" auf frameDB
' Steuerelement: Schaltfläche "cmdLock" auf frameDB
' Steuerelement: Listenanzeigesteuerungselement "lvwDB" auf frameDB
' Steuerelement: Beschriftungsfeld "lblInfo"

' Autor: Autor: Peter K. Sauer <peter.k.sauer@web.de>

Option Explicit

Private Declare Function GetUserName Lib "advapi32.dll" _
            Alias "GetUserNameA" (ByVal lpBuffer As String, _
            nSize As Long) As Long

Private AppDB As String
Private Cn As New ADODB.Connection
Private LockID As Long

Private Sub cmdLock_Click()
' Lock
   Dim Li As ListItem
   Dim ID As Long
   Dim Msg As String
   Dim LockTime As Date
   Dim LockUser As String
   
      Set Li = lvwDB.SelectedItem
      If Li Is Nothing Then
         Exit Sub
      End If
      
      ID = Val(Li.Key)
      If Not LockRecord(ID, LockTime, LockUser) Then
         Msg = "Record ist seit " & Format(LockTime, "hh:mm") & _
               vbCrLf & "von User " & LockUser & " gelockt  "
         MsgBox Msg, vbInformation, "Lock"
         Set Li = Nothing
         Exit Sub
      End If
      
      Li.ForeColor = vbRed
      lvwDB.Enabled = False
      Set Li = Nothing
      cmdUnlock.Enabled = True
      cmdLock.Enabled = False

End Sub

Private Sub cmdUnlock_Click()
' Unlock
   Dim Li As ListItem
   Dim ID As Long
   
      Set Li = lvwDB.SelectedItem
      If Li Is Nothing Then
         Exit Sub
      End If
      
      UnlockRecord
      
      Li.ForeColor = &H80000008
      lvwDB.Enabled = True
      Set Li = Nothing
      cmdUnlock.Enabled = False
      cmdLock.Enabled = True
End Sub

Private Sub Form_Activate()

      Me.Refresh

      'Connection zur DB herstellen
      If Cn.State = adStateClosed Then
         lblInfo.Visible = True
         lblInfo.Refresh
         If Not OpenConnection Then
            Unload Me
            Exit Sub
         End If
         ListViewFill
         lblInfo.Visible = False
         frameDB.Visible = True
      End If
End Sub

Private Sub Form_Load()

      AppDB = IIf(Right(App.Path, 1) = "\", App.Path, _
                 App.Path & "\") & "ADO_SoftLock.mdb"
                 
      With lblInfo
         .Alignment = vbCenter
         .AutoSize = True
         .BorderStyle = 1
         .Font.Size = 10
         .BackColor = vbYellow
         .Caption = vbCrLf & _
                    "  Connection Datenbank  " & vbCrLf & _
                    "Moment bitte" & vbCrLf
         .Visible = False
      End With
      
      With frameDB
         .Height = 4215
         .Width = 9735
         .Visible = False
         cmdUnlock.Enabled = False
      End With
End Sub

Private Function OpenConnection() As Boolean

      On Error Goto Fehler
      With Cn
         .CursorLocation = adUseClient
         .Mode = adModeShareDenyNone
         .Provider = "Microsoft.Jet.OLEDB.4.0"
         .ConnectionString = "Data Source=" & AppDB
         .Open
      End With
      OpenConnection = True
      Exit Function

Fehler:
      Fehleranzeige Err.Number, Err.Description
End Function

Private Sub Fehleranzeige(ErrNumber As Long, _
                          ErrDescription As String)
   Dim Msg As String
   
      Msg = "Fehler " & ErrNumber & vbCrLf & vbCrLf & _
            ErrDescription
      MsgBox Msg, vbInformation, "Fehler"
End Sub

Private Sub Form_Resize()

      If Me.WindowState = vbMinimized Then
         Exit Sub
      End If
      
      On Error Resume Next
      
      With lblInfo
         .Top = (Me.ScaleHeight - .Height) / 2
         .Left = (Me.ScaleWidth - .Width) / 2
      End With
      
      With frameDB
         .Top = (Me.ScaleHeight - .Height) / 2
         .Left = (Me.ScaleWidth - .Width) / 2
      End With
End Sub

Private Sub ListViewFill()

   Dim Rs As New ADODB.Recordset
   Dim sSQL As String
   Dim Li As ListItem
      
      On Error Goto Fehler
      sSQL = "Select * From Adressen " & _
             "Order By AD_Name Asc"
      With Rs
         .CursorLocation = adUseClient
         .CursorType = adOpenKeyset
         .LockType = adLockReadOnly
         .ActiveConnection = Cn
         .Open sSQL
      End With
      
      'Listview anlegen
      With lvwDB
         .View = lvwReport
         .LabelEdit = lvwManual
         .FullRowSelect = True
         .HideSelection = False
         
         .ColumnHeaders.Add , , "ID", 1200
         .ColumnHeaders.Add , , "Name", 2250
         .ColumnHeaders.Add , , "Vorname", 2250
         .ColumnHeaders.Add , , "Land", 600
         .ColumnHeaders.Add , , "Plz", 800
         .ColumnHeaders.Add , , "Ort", 2250
         
         Do While Not Rs.EOF
            Set Li = .ListItems.Add
            Li.Key = Rs.Fields("AD_ID").Value & "x"
            Li.Text = Rs.Fields("AD_ID").Value
            Li.SubItems(1) = Rs.Fields("AD_Name").Value & vbNullString
            Li.SubItems(2) = Rs.Fields("AD_Vorname").Value & vbNullString
            Li.SubItems(3) = Rs.Fields("AD_Land").Value & vbNullString
            Li.SubItems(4) = Rs.Fields("AD_Plz").Value & vbNullString
            Li.SubItems(5) = Rs.Fields("AD_Ort").Value & vbNullString
            Rs.MoveNext
         Loop
      End With
      Rs.Close
      Set Rs = Nothing
      
      Exit Sub
Fehler:
      Fehleranzeige Err.Number, Err.Description
End Sub

Private Sub Form_Unload(Cancel As Integer)

      If Cn.State = adStateOpen Then
         'gelockten Datensatz freigeben
         If LockID > 0 Then
            UnlockRecord
         End If
         Cn.Close
      End If
      
      Set Cn = Nothing
End Sub

Private Function LockRecord(ID As Long, LockTime As Date, _
                                        LockUser As String) As Boolean

   Dim Rs As New ADODB.Recordset
   Dim sSQL As String
   Dim Li As ListItem
   Dim d As Date
   Dim UserName As String
   Dim i As Long
      
      On Error Goto Fehler
      sSQL = "Select * From Adressen " & _
             "Where AD_ID=" & ID
      With Rs
         .CursorLocation = adUseClient
         .CursorType = adOpenKeyset
         .LockType = adLockOptimistic
         .ActiveConnection = Cn
         .Open sSQL
         
         If Not IsNull(.Fields("AD_LockLast").Value) Then
            'Datensatz ist gelockt
            d = .Fields("AD_LockLast").Value
            'letztes Update <= 2 Minuten
            If DateDiff("s", d, Now) <= 120 Then
               LockTime = .Fields("AD_LockStart").Value
               LockUser = .Fields("AD_LockUser").Value
               .Close
               Set Rs = Nothing
               Exit Function
            End If
         End If
         
         'User ermitteln
         UserName = String(30, Chr(0))
         GetUserName UserName, 30
         i = InStr(1, UserName, Chr(0))
         If i > 0 Then
            UserName = Left(UserName, i - 1)
         End If
         
         'Lock Record
         .Fields("AD_LockStart").Value = Now
         .Fields("AD_LockLast").Value = Now
         .Fields("AD_LockUser").Value = UserName
         .Update
         .Close
      End With
      'alle 20 Sekunden LockLast Updaten
      LockID = ID
      Timer1.Interval = 20000
      Set Rs = Nothing
      LockRecord = True
      Exit Function
      
Fehler:
      Fehleranzeige Err.Number, Err.Description
End Function

Private Function UnlockRecord() As Boolean

   Dim sSQL As String
   
      'Unlock gelockten Recordset
      sSQL = "Update Adressen Set " & _
             "AD_LockStart = NULL, " & _
             "AD_LockLast = NULL, " & _
             "AD_LockUser = '' " & _
             " Where AD_ID = " & LockID
      Cn.Execute sSQL
      LockID = 0
      Timer1.Interval = 0
End Function

Private Sub Timer1_Timer()

   Dim sSQL As String
   Dim Zeit As String
   
      If LockID = 0 Then
         Exit Sub
      End If
         
      'Update auf gelockten Recordset, Zeit erneuern
      Zeit = Format(Now, "\#mm\/dd\/yyyy hh:mm:ss\#")
      sSQL = "Update Adressen Set AD_LockLast = " & Zeit & _
             " Where AD_ID = " & LockID
      Cn.Execute sSQL
End Sub

'--- Ende Formular "frmADO_SoftLock" alias frmADO_SoftLock.frm  ---
'------------ Ende Projektdatei ADO_SoftLock.vbp ------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Wolfgang Garske am 14.09.2005 um 15:13

Der Sourcecode funktioniert nicht.
App hat keine Variable.
Ein Label hat keine Refresh Funktion.
Ein IIF hat nur 2 Werte und nicht 4.