Optimistic Record Locking

Sub UpdateWithValueBasedOptimisticLocking()
    Dim conn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim affectedRows As Long
    Dim retryCount As Integer

    ' Original values (would come from your form/data)
    Dim originalSalary As Currency: originalSalary = 50000
    Dim originalLastName As String: originalLastName = "Smith"
    Dim employeeID As Long: employeeID = 123

    retryCount = 0

    Do While retryCount < 3
        On Error GoTo ErrorHandler

        Set conn = New ADODB.Connection
        conn.ConnectionString = "Provider=SQLOLEDB;Data Source=YourServer;Initial Catalog=YourDatabase;User ID=YourUser;Password=YourPassword;"
        conn.Open
        conn.BeginTrans

        ' SQL with value-based optimistic locking
        Dim strSQL As String
        strSQL = "UPDATE Employees SET " & _
                 "Salary = u/NewSalary, " & _
                 "LastName = u/NewLastName, " & _
                 "ModifiedDate = GETDATE() " & _
                 "WHERE EmployeeID = u/EmployeeID " & _
                 "AND Salary = u/OriginalSalary " & _  ' Optimistic lock check
                 "AND LastName = u/OriginalLastName"

        Set cmd = New ADODB.Command
        With cmd
            .ActiveConnection = conn
            .CommandType = adCmdText
            .CommandText = strSQL

            ' Parameters
            .Parameters.Append .CreateParameter("@NewSalary", adCurrency, adParamInput, , 55000)
            .Parameters.Append .CreateParameter("@NewLastName", adVarChar, adParamInput, 50, "UpdatedName")
            .Parameters.Append .CreateParameter("@EmployeeID", adInteger, adParamInput, , employeeID)
            .Parameters.Append .CreateParameter("@OriginalSalary", adCurrency, adParamInput, , originalSalary)
            .Parameters.Append .CreateParameter("@OriginalLastName", adVarChar, adParamInput, 50, originalLastName)
        End With

        cmd.Execute affectedRows

        If affectedRows > 0 Then
            conn.CommitTrans
            MsgBox "Update successful!"
            Exit Do
        Else
            conn.RollbackTrans
            retryCount = retryCount + 1

            If retryCount < 3 Then
                ' Refresh original values for next attempt
                If GetCurrentValues(employeeID, originalSalary, originalLastName) Then
                    MsgBox "Record was modified. Retrying with current values..."
                    CleanupObjects cmd, conn
                    Application.Wait Now + TimeValue("00:00:01")
                Else
                    MsgBox "Record not found or unable to read current values!"
                    Exit Do
                End If
            Else
                MsgBox "Update failed after 3 attempts due to conflicts."
            End If
        End If

        GoTo Cleanup

ErrorHandler:
        If Not conn Is Nothing And conn.State = adStateOpen Then conn.RollbackTrans
        MsgBox "Error: " & Err.Description
        Exit Do

Cleanup:
        CleanupObjects cmd, conn
    Loop
End Sub

Function GetCurrentValues(employeeID As Long, ByRef salary As Currency, ByRef lastName As String) As Boolean
    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset

    On Error GoTo ErrorHandler

    Set conn = New ADODB.Connection
    conn.ConnectionString = "Provider=SQLOLEDB;Data Source=YourServer;Initial Catalog=YourDatabase;User ID=YourUser;Password=YourPassword;"
    conn.Open

    Set rs = conn.Execute("SELECT Salary, LastName FROM Employees WHERE EmployeeID = " & employeeID)

    If Not rs.EOF Then
        salary = rs.Fields("Salary").Value
        lastName = rs.Fields("LastName").Value
        GetCurrentValues = True
    Else
        GetCurrentValues = False
    End If

    rs.Close
    conn.Close
    Exit Function

ErrorHandler:
    GetCurrentValues = False
    If Not rs Is Nothing Then If rs.State = adStateOpen Then rs.Close
    If Not conn Is Nothing Then If conn.State = adStateOpen Then conn.Close
End Function