Thanks so much for your help! :-)) Linda
copied this pessimistic locking VBA code into my db - it works in a form
that has no subforms, but does NOT work in forms having subforms - the only
thing different is how the module is called in the On Current property AND
the Const adhcRefreshInterval = 30 is NOT in the form (that has no
subforms)
***from the form (that has no subforms)
Private Sub Form_Current()
Me.txtLockStatus = adhGetLockMsg(Form_Protocols)
***from the form with a subform where the run-time error 6 occurs
Option Compare Database
Option Explicit
Const adhcRefreshInterval = 60
Private Sub Form_Current()
Me!txtLockStatus = adhGetLockMsg(Me)
Private Sub cmdClose_Click()
DoCmd.Close acForm, Me.Name
End Sub
Private Sub Form_Current()
Me!txtLockStatus = adhGetLockMsg(Me)
End Sub
Private Sub Form_Load()
Me.TimerInterval = adhcRefreshInterval * 1000
End Sub
Private Sub Form_Timer()
Me!txtLockStatus = adhGetLockMsg(Me)
End Sub
*** Also, the pessimistic locking VBA code seems to cause the following Not
On List VBA to go into a loop if the user tries to enter something not on
list
Private Sub VisitType_NotInList(NewData As String, Response As Integer)
Dim Result
Dim Msg As String
Dim CR As String
CR = Chr$(13)
' Exit this subroutine if the combo box was cleared.
If NewData = "" Then Exit Sub
' Ask the user if he or she wishes to add the new Visit Type.
Msg = "'" & NewData & "' is not in the list." & CR & CR
Msg = Msg & "Do you want to add it?"
If MsgBox(Msg, vbQuestion + vbYesNo) = vbYes Then
' If the user chose Yes, start the frmVisitAdd form in data
entry
' mode as a dialog form, passing the new Visit Type in
' NewData to the OpenForm method's OpenArgs argument. The
' OpenArgs argument is used in frmVisitAdd form's Form_Load
event
' procedure.
DoCmd.OpenForm "frmVisitAdd", , , , acAdd, acDialog, NewData
End If
' Look for the Fee Type the user created in the form.
Result = DLookup("[VisitType]", "WarehouseVisit", _
"[VisitType]='" & NewData & "'")
If IsNull(Result) Then
' If the Visit Type was not created, set the Response argument
' to suppress an error message and undo changes.
Response = acDataErrContinue
' Display a customized message.
MsgBox "Please try again!"
Else
' If the Visit Type was created, set the Response argument to
' indicate that new data is being added.
Response = acDataErrAdded
End If
End Sub
HERE'S THE MODULE FUNCTION FOR PESSIMISTIC LOCKING VBA
' From Access 97 Developer's Handbook
' by Litwin, Getz and Gilbert. (Sybex)
' Copyright 1997. All Rights Reserved.
'
Option Compare Database
Option Explicit
' Multiuser Error codes
Const adhcLockErrCantSave = 3186
Const adhcLockErrCantRead = 3187
Const adhcLockErrCantUpdate1 = 3188
Const adhcLockErrExclusive = 3189
Const adhcLockErrDatChngd = 3197
Const adhcLockErrCantUpdate2 = 3260
' Return values
Public Const adhcNotLocking = 0
Public Const adhcRetryUserNotNotified = 1
Public Const adhcRetryUserWasNotified = 2
Public Const adhcAbortOperation = 3
Public Const adhcDataChngErrNotHandled = 4
Public Const adhcOtherErrNotHandled = 5
Const adhcLockRetries = 60
Function adhGetLockMsg(frm As Form) As String
' Purpose:
' Check if form record is locked and by whom.
'
' From Access 97 Developer's Handbook
' by Litwin, Getz and Gilbert. (Sybex)
' Copyright 1997. All Rights Reserved.
'
' In:
' frm: pointer to form
' Out:
' Return Value: locking message
' History:
' Created 12/05/95 pel; Last Modified 12/20/95 pel
On Error GoTo adhGetLockMsgErr
Dim rst As Recordset
Dim strUser As String
Dim strMachine As String
Set rst = frm.RecordsetClone
rst.Bookmark = frm.Bookmark
rst.Edit
' do nothing
rst.Update
adhGetLockMsg = "Record isn't locked by another user"
adhGetLockMsgDone:
DoCmd.Hourglass False
On Error GoTo 0
Exit Function
adhGetLockMsgErr:
Call adhGetLockInfo(Err.Number, Err.Description, _
strUser, strMachine)
If Len(strUser) = 0 And Len(strMachine) = 0 Then
adhGetLockMsg = "Record isn't locked by another user"
Else
adhGetLockMsg = "Record locked by " & strUser & _
" on " & strMachine
End If
Resume adhGetLockMsgDone
End Function
Sub adhGetLockInfo(ByVal lngErr As Long, ByVal strErr As String, _
strUser As String, strMachine As String)
' Purpose:
' Parse locking error message to extract
' user and machine names.
'
' From Access 97 Developer's Handbook
' by Litwin, Getz and Gilbert. (Sybex)
' Copyright 1997. All Rights Reserved.
'
' In:
' lngErr: error number
' strErr: error message
' Out:
' strUser: user name or zls
' strMachine: machine name or zls
' History:
' Created 12/05/95 pel; Last Modified 12/20/95 pel
Dim intUserStart As Integer
Dim intUserLen As Integer
Dim intMachineStart As Integer
Dim intMachineLen As Integer
Const adhcLenByUser = 8
Const adhcLenOnMachine = 11
Select Case lngErr
Case adhcLockErrCantSave, adhcLockErrCantRead, _
adhcLockErrCantUpdate2, adhcLockErrExclusive, _
adhcLockErrCantUpdate1
If lngErr = adhcLockErrCantUpdate1 Then
strUser = "another part of this application"
strMachine = "this machine"
Else
intUserStart = InStr(1, strErr, "by user") + _
adhcLenByUser
intUserLen = InStr(intUserStart + 1, strErr, "'") - _
intUserStart + 1
intMachineStart = InStr(1, strErr, "on machine") + _
adhcLenOnMachine
intMachineLen = InStr(intMachineStart + 1, _
strErr, "'") - intMachineStart + 1
strUser = Mid$(strErr, intUserStart + 1, intUserLen - 2)
strMachine = Mid$(strErr, intMachineStart + 1, _
intMachineLen - 2)
If intUserLen <= 2 Then strUser = "<Unknown>"
If intMachineLen <= 2 Then strMachine = "<Unknown>"
End If
Case Else
strUser = ""
strMachine = ""
End Select
End Sub
Function adhHandleLockErr(ByVal lngErr As Long, _
ByVal strErr As String, intRetryCount As Integer) As Integer
' Purpose:
' Takes an error, determines whether it's a locking error.
' If it's a locking error, handles it and
' returns a status code; if it's not, returns a 0.
'
' From Access 97 Developer's Handbook
' by Litwin, Getz and Gilbert. (Sybex)
' Copyright 1997. All Rights Reserved.
'
' In:
' lngErr: error number
' strErr: error message
'
' Out:
' Retun Value: one of the following constants
' adhcNotLocking = 0
' adhcRetryUserNotNotified = 1
' adhcRetryUserWasNotified = 2
' adhcAbortOperation = 3
' adhcDataChngErrNotHandled = 4
' adhcOtherErrNotHandled = 5
' History:
' Created 01/12/95 pel; Last Modified 12/20/95 pel
On Error GoTo adhHandleLockErrErr
Dim strUser As String
Dim strMachine As String
Dim strErrMsg As String
Dim vbCrLf As String
Dim intStatus As Integer
Dim lngWait As Long
Dim lngW As Long
Dim fRetry As Integer
Dim strProcName As String
strProcName = "adhHandleLocking"
vbCrLf = Chr$(13) & Chr$(10)
'Initialize status flag that will become the return value
intStatus = adhcNotLocking
'Branch on error number
Select Case lngErr
'Error is of the type where another user has locked the record.
'Parse out the name of the user and machine (if possible)
'and send back a retry message.
Case adhcLockErrCantSave, adhcLockErrCantRead, _
adhcLockErrCantUpdate2, adhcLockErrExclusive, _
adhcLockErrCantUpdate1
Call adhGetLockInfo(lngErr, strErr, strUser, strMachine)
strErrMsg = "You've attempted to lock or save a record "
strErrMsg = strErrMsg & "that has been locked by " & _
"another user." & vbCrLf & vbCrLf
strErrMsg = strErrMsg & "The record is locked by user " & _
strUser & " on machine " & strMachine & vbCrLf & vbCrLf
strErrMsg = strErrMsg & "Choose Retry to try and save " & _
"again (recommended)." & vbCrLf
strErrMsg = strErrMsg & "Choose Cancel to abandon changes."
DoCmd.Hourglass True
If intRetryCount <= adhcLockRetries Then
' Let Windows and the Jet Engine catch up
DoEvents
' Space out the retries based on an number
' that increases by the number of retries
' and a random number
lngWait = intRetryCount ^ 2 * Int(Rnd * 20 + 5)
' Waste time, but let Windows multitask during
' this dead time.
For lngW = 1 To lngWait
DoEvents
Next lngW
'Increment retry counter and retry again;
'user not notified
intStatus = adhcRetryUserNotNotified
Else
DoCmd.Hourglass False
fRetry = MsgBox(strErrMsg, vbCritical + _
vbRetryCancel + vbDefaultButton1, "Locking Conflict")
DoCmd.Hourglass True
If fRetry = vbRetry Then
'Reset retry counter; user notified
intRetryCount = 0
intStatus = adhcRetryUserWasNotified
Else
DoCmd.Hourglass False
MsgBox "Operation cancelled.", _
vbCritical + vbOKOnly, "Unresolved Locking Conflict"
DoCmd.Hourglass True
'Abort operation; user notified
intStatus = adhcAbortOperation
End If
End If
Case adhcLockErrDatChngd
'Data change error has occurred which this procedure is
'not equipped to handle, so pass it back to calling
'procedure.
intStatus = adhcDataChngErrNotHandled
Case Else
'Not a (handled) locking error
intStatus = adhcNotLocking
End Select
adhHandleLockErr = intStatus
adhHandleLockErrDone:
DoCmd.Hourglass False
On Error GoTo 0
Exit Function
adhHandleLockErrErr:
Select Case Err
Case Else
MsgBox "Error#" & Err.Number & ": " & Err.Description, _
vbOKOnly + vbCritical, "adhHandleLockErr"
End Select
Resume adhHandleLockErrDone
End Function
--
The opinions expressed in this communication are my own, and do not
necessarily reflect those of my employer.