Function PlaceResourceLock(strResourceTag As String, strSubTag As String, intLockLevel As Integer, bolDisplayMessage As Boolean) As Variant
' For a given resource tag & sub tag, try and create a lock record.
' Notes on lock level:
' '1' - Shared - More then one user can have a shared lock.
' '2' - Mutually Exclusive - Only one user can hold a mutually exclusive lock.
' Other users can hold a shared lock.
' '3' - Exclusive - Only one user can hold a exclusive lock.
' No other user can be holding a lock.
' Note: If a lock is requested and a user is already holding a lock,
' the existing lock will be promoted (if possible), demoted (always possible), or
' refreshed based on the current lock level and the level being requested.
' Set some constants so if we error out we know what was going on
Const Routine = "PlaceResourceLock"
Const Version = "1.0"
Dim dbCur As DAO.Database
Dim rst As DAO.Recordset
Dim strCriteria As String
Dim strUserName As String
Dim strStationName As String
Dim strMsg As String
Dim strResourceDisplayName As String
Dim intLockCountTry As Integer
Dim lngWait As Long
Dim lngX As Long
On Error GoTo PlaceResourceLockError
Set dbCur = CurrentDb()
' Get user and station name
strUserName = WhoAmI(True)
strStationName = WhoAmI(False)
' Format nice display name for resource
' for use in messages.
If strSubTag = "" Then
strResourceDisplayName = strResourceTag
Else
strResourceDisplayName = strResourceTag & "-" & strSubTag
End If
' Try and open the table with DenyWrite
' so we have exclusive access.
' We need to do this because checking
' and placing a lock must be an atomic
' operation.
Set rst = dbCur.OpenRecordset("tblResourceLocks", dbOpenDynaset, dbDenyWrite)
' First, do we already have an existing lock?
strCriteria = "[ResourceTag] = " & Chr$(34) & strResourceTag & Chr$(34)
strCriteria = strCriteria & " AND [SubTag] = " & Chr$(34) & strSubTag & Chr$(34)
strCriteria = strCriteria & " AND [UserName] = " & Chr$(34) & strUserName & Chr$(34)
strCriteria = strCriteria & " AND [StationName] = " & Chr$(34) & strStationName & Chr$(34)
rst.FindFirst strCriteria
' Did we find one?
If rst.NoMatch = True Then
' No existing lock, so we'll be adding.
' Find out if there are any conflicts
' Criteria for finding a lock record for the resource tag, sub, and level being requested.
strCriteria = "[ResourceTag] = " & Chr$(34) & strResourceTag & Chr$(34)
strCriteria = strCriteria & " AND [SubTag] = " & Chr$(34) & strSubTag & Chr$(34)
strCriteria = strCriteria & " AND [LockLevel] > " & Mid$("210", intLockLevel, 1)
rst.FindFirst strCriteria
' Did we find one?
If rst.NoMatch = True Then
' No current conflicting lock records.
' Place the lock.
rst.AddNew
rst![ResourceTag] = strResourceTag
rst![SubTag] = strSubTag
rst![UserName] = strUserName
rst![StationName] = strStationName
rst![LockLevel] = intLockLevel
rst![LockPlaced] = Now()
rst.Update
' Indicate we got lock
PlaceResourceLock = True
Else
' Existing locks that conflict.
If bolDisplayMessage = True Then
' Read records and build up a string
' with all the locks outstanding.
strMsg = "Cannot add lock for resource '" & strResourceDisplayName & vbCrLf
strMsg = strMsg & "Locks are being held by following users(s):" & vbCrLf & vbCrLf
strMsg = "Resource '" & strResourceDisplayName & "' is locked by following users(s):" & vbCrLf & vbCrLf
strMsg = strMsg & "Station \ User - Lock Placed" & vbCrLf
Do Until rst.EOF
strMsg = strMsg & rst![StationName] & " \ " & rst![UserName] & " - " & rst![LockPlaced] & vbCrLf
rst.MoveNext
Loop
' Close the recordset before we message
' the user so we don't hold open the table.
rst.Close
Set rst = Nothing
MsgBox strMsg, vbExclamation + vbOKOnly
End If
' Indicate that we did not get the lock
PlaceResourceLock = False
End If
Else
' We have an existing lock. Are we trying to
' promote, demote, or refreshing the lock we have?
If intLockLevel > rst![LockLevel] Then
' Trying to promote - need to check for locks other then ours.
strCriteria = "[ResourceTag] = " & Chr$(34) & strResourceTag & Chr$(34)
strCriteria = strCriteria & " AND [SubTag] = " & Chr$(34) & strSubTag & Chr$(34)
strCriteria = strCriteria & " AND [LockLevel] > " & Mid$("210", intLockLevel, 1)
strCriteria = strCriteria & " AND [UserName] <> " & Chr$(34) & strUserName & Chr$(34)
strCriteria = strCriteria & " AND [StationName] <> " & Chr$(34) & strStationName & Chr$(34)
rst.FindFirst strCriteria
' Did we find one?
If rst.NoMatch = True Then
' No current conflicting lock records, so
' promote the lock.
rst.Edit
rst![LockLevel] = intLockLevel
rst![LockPlaced] = Now()
rst.Update
' Indicate we got lock
PlaceResourceLock = True
Else
' Existing locks that conflict.
If bolDisplayMessage = True Then
' Read records and build up a string
' with all the locks outstanding.
strMsg = "Cannot promote lock for resource '" & strResourceDisplayName & vbCrLf
strMsg = strMsg & "Locks are being held by following users(s):" & vbCrLf & vbCrLf
strMsg = strMsg & "Station \ User - Lock Placed" & vbCrLf
Do Until rst.EOF
If rst![StationName] <> strStationName Or rst![UserName] <> strUserName Then
strMsg = strMsg & rst![StationName] & " \ " & rst![UserName] & " - " & rst![LockPlaced] & vbCrLf
End If
rst.MoveNext
Loop
' Close the recordset before we message
' the user so we don't hold open the table.
rst.Close
Set rst = Nothing
MsgBox strMsg, vbExclamation + vbOKOnly
End If
' Indicate that we did not get the lock
PlaceResourceLock = False
End If
ElseIf intLockLevel < rst![LockLevel] Then
' Demoting the lock
rst.Edit
rst![LockLevel] = intLockLevel
rst![LockPlaced] = Now()
rst.Update
PlaceResourceLock = True
Else
' Refreshing the lock.
rst.Edit
rst![LockPlaced] = Now()
rst.Update
PlaceResourceLock = True
End If
End If
PlaceResourceLockExit:
On Error Resume Next
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
Set dbCur = Nothing
Exit Function
PlaceResourceLockError:
'Table locked by another user
If Err.Number = CNT_ERR_RESERVED Or Err.Number = CNT_ERR_UNABLE_TO_LOCK_TABLE Or Err.Number = CNT_ERR_COULDNT_UPDATE Or Err.Number = CNT_ERR_OTHER Then
intLockCountTry = intLockCountTry + 1
If intLockCountTry > 5 Then
PlaceResourceLock = False
Resume PlaceResourceLockExit
Else
DoEvents
DBEngine.Idle DB_FREELOCKS
lngWait = intLockCountTry ^ 2 * Int(Rnd * 20 + 5)
For lngX = 1 To lngWait
DoEvents
Next lngX
Resume
End If
Else
MsgBox "Unexpected error" & Err.Number & " - " & Err.Description & " - Line: " & VBA.Erl & " in routine: " & Routine & " version: " & Version
PlaceResourceLock = Null
Resume PlaceResourceLockExit
End If
End Function
Function ClearResourceLock(strResourceTag As String, strSubTag As String, strUser As String, strStationName As String) As Variant
' Clear locks based on passed criteria
' calling routine should pass an '*' (asterick)
' to clear all locks for a given field.
Const Routine = "ClearResourceLock"
Const Version = "1.0"
Dim dbCur As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
Dim strWhere As String
Dim intLockCountTry As Integer
Dim lngWait As Long
Dim lngX As Long
On Error GoTo ClearResourceLockError
Set dbCur = CurrentDb()
If strResourceTag & strUser & strStationName <> "" Then
' Start of SQL Select
strSQL = "Select * FROM tblResourceLocks "
' Construct the WHERE clause
strWhere = ""
If strResourceTag <> "*" And strResourceTag <> "" Then
strWhere = strWhere & "ResourceTag = " & Chr$(34) & strResourceTag & Chr$(34) & " AND "
If strSubTag <> "*" Then strWhere = strWhere & "SubTag = " & Chr$(34) & strSubTag & Chr$(34) & " AND "
End If
If strUser <> "*" And strUser <> "" Then
strWhere = strWhere & "UserName = " & Chr$(34) & strUser & Chr$(34) & " AND "
End If
If strStationName <> "*" And strStationName <> "" Then
strWhere = strWhere & "StationName = " & Chr$(34) & strStationName & Chr$(34) & " AND "
End If
' Add WHERE clause if needed.
If strWhere <> "" Then strSQL = strSQL & "WHERE " & left$(strWhere, Len(strWhere) - 5)
strSQL = strSQL & ";"
Set rst = dbCur.OpenRecordset(strSQL, dbOpenDynaset, dbDenyWrite)
' Delete all records found.
Do Until rst.EOF = True
rst.Delete
rst.MoveNext
Loop
ClearResourceLock = True
Else
MsgBox "Invalid call to " & Routine & " - No Arguments passed"
ClearResourceLock = False
End If
ClearResourceLockExit:
On Error Resume Next
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If
Set dbCur = Nothing
Exit Function
ClearResourceLockError:
'Table locked by another user
If Err.Number = CNT_ERR_RESERVED Or Err.Number = CNT_ERR_UNABLE_TO_LOCK_TABLE Or Err.Number = CNT_ERR_COULDNT_UPDATE Or Err.Number = CNT_ERR_OTHER Then
intLockCountTry = intLockCountTry + 1
If intLockCountTry > 5 Then
ClearResourceLock = False
Resume ClearResourceLockExit
Else
DoEvents
DBEngine.Idle DB_FREELOCKS
lngWait = intLockCountTry ^ 2 * Int(Rnd * 20 + 5)
For lngX = 1 To lngWait
DoEvents
Next lngX
Resume
End If
Else
MsgBox "Unexpected error " & Err.Number & " - " & Err.Description & " - Line: " & VBA.Erl & " in routine: " & Routine & " version: " & Version
ClearResourceLock = Null
Resume ClearResourceLockExit
End If
End Function
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (11)
Author
Commented:Here are the constants:
Const CNT_ERR_RESERVED = 3000
Const CNT_ERR_UNABLE_TO_LOCK_TAB
Const CNT_ERR_COULDNT_UPDATE = 3260
Const CNT_ERR_OTHER = 3262
Const CNT_ERR_NO_CURRENT_ROW = 3021
as for the follow-up article, I never got around to writing it mainly because I never found a situation where the concurrency issues were enough of a problem to warrant taking the time to do so.
Jim.
Commented:
Kindest Regards,
Mohamed
Author
Commented:If you do implement this and find that concurrency is an issue with locking the table, let me know and I'll take the time to work up the code and article for the reservation technique. Cannot make any promises on a time frame though as I am quite busy at the moment.
Jim.
Commented:
Fantastic article on 'Resource Locking'. Thank you. This addresses one of my biggest challenges in my MS Access applications.
One Question though, Where in the Application should the functions be called?
Thanks
Anton Greffrath
Author
Commented:Glad you enjoyed the article.
<<Where in the Application should the functions be called?>>
Anywhere you want/need them. For example, if I have a single label printer that's shared, then I "lock" the printer just before I print, and clear the lock when I'm done.
If I'm tracking users, then I place a "user" lock right after the login form and don't clear it until the app quits.
Or if I have a call record that a supervisor needs to look at, it becomes "locked" on based on some condition, then is not cleared until a supervisor reviews the problem.
Think of the locks more as a flag or reservation.
Jim.
View More