VB 5/6-Tipp 0568: Access-Datensatz für exklusive Bearbeitung sperren
von Peter K. Sauer
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: | Verwendete API-Aufrufe: | Download: |
'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-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | |||||||
VB5 | |||||||
VB6 |
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.