Pls HELP!! Run-Time Error 6 
Author Message
 Pls HELP!! Run-Time Error 6

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.



Tue, 22 Apr 2003 03:00:00 GMT  
 
 [ 1 post ] 

 Relevant Pages 

1. Run-time error 3141 PLS HELP

2. Microsoft Visual C++ Run time library Run time error R6025

3. Microsoft Visual C++ Run time library Run time error R6025

4. HELP : Error 91 : Run-Time Error 91 Object Variable or With

5. HELP "Run-time error 432" HELP

6. Run-time error '-2147417846 (8001010a)': Automation error (error 440)

7. Run-time error '-2147417846 (8001010a)': Automation error (error 440)

8. hWnd Property Help Example gives Run-time error 2475 in Access but not in VB6

9. Run-Time Error 2486 - Can't Carry Out Operation at Present Time

10. Run-Time Error 3197 - please help its driving me insane

11. HELP ASAP: Run-time error 2486 Access2000

12. Help with handling a run-time error in a macro

 

 
Powered by phpBB® Forum Software