It almost works perfect and thats almost good enough

R

Robert A. Riley

Hi all
I have the code below in the lost focus event. It does work, but it
does not update the form that is onscreen.
What do I need to add?
Any help is appreciated.
This is my first VBA try, my other programming has been (autocad) LISP,
so I know it is not good basic code, but it works
and that is good enough for now. I need this done by the 28'th.

Robert



Private Sub Ctl400_Meter_Run_LostFocus()
Dim Current_Scout_Rank As String
Dim Current_Event As String
Current_Scout_Rank = Forms("scout-event").[Scout Rank].Value
Current_Event = Screen.ActiveControl.Name
Dim dbs As DAO.Database
Dim rsCurr As DAO.Recordset
Dim strSQL As String
Set dbs = CurrentDb
strSQL = "Select [Scout Name],[Scout Rank],[" & Current_Event & "] From
[scout-event] Where [Scout Rank] = " & Chr(34) & Current_Scout_Rank &
Chr(34) & " And [" & Current_Event & "] Is Null;"
Set rsCurr = dbs.OpenRecordset(strSQL, dbOpenDynaset)
If rsCurr.BOF = False And rsCurr.EOF = False Then 'IF A
'** there is at least one record in the recordset
rsCurr.MoveFirst
Do While rsCurr.EOF = False 'WHILE A
MsgBox "No scoring provided yet becuse not all of the event results
have been entered for this rank."
'goto the end of the recordset to the end
Do While rsCurr.EOF = False 'WHILE B
rsCurr.MoveNext
Loop 'WHILE B
Loop 'WHILE A
End If 'IF A
strSQL = "Select [Scout Name],[Scout Rank],[" & Current_Event & "],[" &
Current_Event & " Points" & "] From [scout-event] Where [Scout Rank] = "
& Chr(34) & Current_Scout_Rank & Chr(34) & " And [" & Current_Event & "]
Is NOT Null ORDER BY [" & Current_Event & "];"
Set rsCurr = dbs.OpenRecordset(strSQL, dbOpenDynaset)
If rsCurr.BOF = False And rsCurr.EOF = False Then 'IF B
'** there is at least one record in the recordset
rsCurr.MoveFirst 'goto first record in recordset
Do While rsCurr.EOF = False 'WHILE C
If rsCurr.EOF = False Then 'IF C
'Dim scoutname As String Dim scoutrank As String Dim
scouteventresult As String Dim scouteventpoints As String
'Let scoutname = rscurr(0) Let scoutrank = rscurr(1) Let
scouteventresult = rscurr(2) Let scouteventpoints = rscurr(3)
'MsgBox scoutname MsgBox scoutrank MsgBox scouteventresult MsgBox
scouteventpoints
Dim Event_score As Integer
Event_score = 100
Dim Event_result As String
Event_result = rsCurr(2)
Dim Next_event_result As String
'put the score into first place
With rsCurr
.Edit
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
MsgBox "First Place"
MsgBox Event_score
'finished scoring first place
Do While Event_score >= 60 And rsCurr.EOF = False 'WHILE D there
is scoring above 5 place to do
Dim Tie_count As Integer
Tie_count = 1
rsCurr.MoveNext
If rsCurr.EOF = False Then 'IF D
Next_event_result = rsCurr(2)
End If 'IF D
Do While Event_result = Next_event_result And rsCurr.EOF = False
'WHILE E check for a tie
'enter the same score for the other person(s) in a tie
With rsCurr
.Edit
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
MsgBox "A TIE"
MsgBox Event_score
Tie_count = Tie_count + 1
'finished scoring the tie
If rsCurr.EOF = False Then 'IF E
rsCurr.MoveNext
End If 'IF E
Next_event_result = rsCurr(2)
Loop 'WHILE E check for a tie
Event_score = Event_score - (10 * Tie_count)
Tie_count = 1
If rsCurr.EOF = False Then 'IF F
Event_result = rsCurr(2)
With rsCurr
.Edit
MsgBox "NEXT PLACE"
MsgBox Event_score
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
End If 'IF F closed
Loop ' WHILE there is scoring above 5 place to do
' set the rest of the scores to 50
Event_score = 50
With rsCurr
.Edit
MsgBox "Finishing"
MsgBox Event_score
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
If rsCurr.EOF = False Then
rsCurr.MoveNext
End If
' set the rest of the scores to 50
End If 'IF C
Loop 'WHILE C
End If 'IF B
rsCurr.Close
Set rsCurr = Nothing
dbs.Close
Set dbs = Nothing
End Sub
 
K

Kevin

Try either Me.Refresh if the form is based on a table
directly or Me.requery if the form is based on a query.

Hope this helps!

Kevin
-----Original Message-----
Hi all
I have the code below in the lost focus event. It does work, but it
does not update the form that is onscreen.
What do I need to add?
Any help is appreciated.
This is my first VBA try, my other programming has been (autocad) LISP,
so I know it is not good basic code, but it works
and that is good enough for now. I need this done by the 28'th.

Robert



Private Sub Ctl400_Meter_Run_LostFocus()
Dim Current_Scout_Rank As String
Dim Current_Event As String
Current_Scout_Rank = Forms("scout-event").[Scout Rank].Value
Current_Event = Screen.ActiveControl.Name
Dim dbs As DAO.Database
Dim rsCurr As DAO.Recordset
Dim strSQL As String
Set dbs = CurrentDb
strSQL = "Select [Scout Name],[Scout Rank],[" & Current_Event & "] From
[scout-event] Where [Scout Rank] = " & Chr(34) & Current_Scout_Rank &
Chr(34) & " And [" & Current_Event & "] Is Null;"
Set rsCurr = dbs.OpenRecordset(strSQL, dbOpenDynaset)
If rsCurr.BOF = False And rsCurr.EOF = False Then 'IF A
'** there is at least one record in the recordset
rsCurr.MoveFirst
Do While rsCurr.EOF = False 'WHILE A
MsgBox "No scoring provided yet becuse not all of the event results
have been entered for this rank."
'goto the end of the recordset to the end
Do While rsCurr.EOF = False 'WHILE B
rsCurr.MoveNext
Loop 'WHILE B
Loop 'WHILE A
End If 'IF A
strSQL = "Select [Scout Name],[Scout Rank],[" & Current_Event & "],[" &
Current_Event & " Points" & "] From [scout-event] Where [Scout Rank] = "
& Chr(34) & Current_Scout_Rank & Chr(34) & " And [" & Current_Event & "]
Is NOT Null ORDER BY [" & Current_Event & "];"
Set rsCurr = dbs.OpenRecordset(strSQL, dbOpenDynaset)
If rsCurr.BOF = False And rsCurr.EOF = False Then 'IF B
'** there is at least one record in the recordset
rsCurr.MoveFirst 'goto first record in recordset
Do While rsCurr.EOF = False 'WHILE C
If rsCurr.EOF = False Then 'IF C
'Dim scoutname As String Dim scoutrank As String Dim
scouteventresult As String Dim scouteventpoints As String
'Let scoutname = rscurr(0) Let scoutrank = rscurr (1) Let
scouteventresult = rscurr(2) Let scouteventpoints = rscurr (3)
'MsgBox scoutname MsgBox scoutrank MsgBox scouteventresult MsgBox
scouteventpoints
Dim Event_score As Integer
Event_score = 100
Dim Event_result As String
Event_result = rsCurr(2)
Dim Next_event_result As String
'put the score into first place
With rsCurr
.Edit
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
MsgBox "First Place"
MsgBox Event_score
'finished scoring first place
Do While Event_score >= 60 And rsCurr.EOF = False 'WHILE D there
is scoring above 5 place to do
Dim Tie_count As Integer
Tie_count = 1
rsCurr.MoveNext
If rsCurr.EOF = False Then 'IF D
Next_event_result = rsCurr(2)
End If 'IF D
Do While Event_result = Next_event_result And rsCurr.EOF = False
'WHILE E check for a tie
'enter the same score for the other person(s) in a tie
With rsCurr
.Edit
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
MsgBox "A TIE"
MsgBox Event_score
Tie_count = Tie_count + 1
'finished scoring the tie
If rsCurr.EOF = False Then 'IF E
rsCurr.MoveNext
End If 'IF E
Next_event_result = rsCurr(2)
Loop 'WHILE E check for a tie
Event_score = Event_score - (10 * Tie_count)
Tie_count = 1
If rsCurr.EOF = False Then 'IF F
Event_result = rsCurr(2)
With rsCurr
.Edit
MsgBox "NEXT PLACE"
MsgBox Event_score
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
End If 'IF F closed
Loop ' WHILE there is scoring above 5 place to do
' set the rest of the scores to 50
Event_score = 50
With rsCurr
.Edit
MsgBox "Finishing"
MsgBox Event_score
rsCurr(3) = Event_score
.Update
.Bookmark = .LastModified
End With
If rsCurr.EOF = False Then
rsCurr.MoveNext
End If
' set the rest of the scores to 50
End If 'IF C
Loop 'WHILE C
End If 'IF B
rsCurr.Close
Set rsCurr = Nothing
dbs.Close
Set dbs = Nothing
End Sub

.
Click to expand...
 
R

Robert Riley

Thanks, but I now get the dialog box about "This record has been changed
by another user sense you started editing it. It has the option buttons
to discard, copy to clipboard or Save record. Do I need to force a save
to the table in my code?

Thanks

Rob
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

code to rename image files from query 1
HELP - New to this - or Get your laughs here 8
Why won't this code work? 5
Use access to rename / overwrite image files. 2
Macro Help Needed: Compiling data from multiple sheets and then transposing it during the paste. 2
code under click event works on one PC and not on another... 1

Top