I didn't think you would want the complete code so I just sent up to the
part
where I was getting the error. You are correct the source of the
recordset
was an SQL statement that selected from the query. I have since created
the
query to match exactly to my recordset. I still get the same result
though.
I added a line of code to open the query and the result is the eight
records.
However, rs.EOF is still true when the results should match that of the
openquery command. The complete revised code is attached. Please keep in
mind that I am an amateur at this and it was self taught so it may not
appear
to be very professionally written. Thanks!
'This procedure considers the ELF when updating from the WL
'and updates from the WL only when the requested shift does not
'exceed the threshold. It will override a person higher on the
'waitlist if the requested shift will put it over the limit.
On Error GoTo Err_cmdWaitList_Click
Dim cn As ADODB.Connection, rs As ADODB.Recordset, rsTeam As
ADODB.Recordset
Dim x As Integer, AvailDate As Date, Slots As Integer, WL_Count As
Integer,
strAM As String, strLP As String
Dim dteAvailDateAM() As Date, a As Integer, dteAvailDateLP() As Date, L As
Integer, dteWL_Date As Date
Dim lngID() As Long, lngRecID As Long, i As Integer, GrpAvail As Double,
intCount As Integer
Dim intE As Integer, intL As Integer, intF As Integer, Max As Integer,
intTeam As Long, ReturnValue As Variant
strAM = "Account Maintenance"
strLP = "Loss Prevention"
Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset
Set rsTeam = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
End With
With rsTeam
Set .ActiveConnection = cn
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
End With
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryDelExpired"
ReDim lngID(0)
i = 1
ReDim dteAvailDateAM(0)
a = 1
ReDim dteAvailDateLP(0)
L = 1
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "Select Count(EligibleDates) AS RecCount FROM
sqlAvailSummAM"
.Open
End With
intCount = rs!RecCount
'Initialize progress meter.
ReturnValue = SysCmd(acSysCmdInitMeter, "Checking for WaitList
Updates-Account Maintenance", intCount)
AM:
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "sqlAvailSummAM"
.Open
End With
DoCmd.OpenQuery "sqlAvailSummAM"
If rs.EOF Then
GoTo LP
End If
Do Until rs.EOF
ReDim Preserve dteAvailDateAM(a)
dteAvailDateAM(a) = rs!WL_Date
a = a + 1
rs.MoveNext
Loop
For a = 1 To UBound(dteAvailDateAM)
ReturnValue = SysCmd(acSysCmdUpdateMeter, a)
dteWL_Date = dteAvailDateAM(a)
'AM Specialty
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "Select EligibleDates, E_Ct, L_Ct, F_Ct,
GroupThreshold, Avail FROM qryTimeOffAvailSummAM WHERE Avail >0 AND WL >0
AND
Specialty = -1 AND EligibleDates = #" & dteWL_Date & "#"
.Open
End With
If rs.EOF Then
GoTo AM_NonSpec
End If
Slots = CLng(rs!Avail + 0.1)
intE = rs!E_Ct
intL = rs!L_Ct
intF = rs!F_Ct
Max = rs!GroupThreshold
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "SELECT TO_ID, CompassID, AmountOff FROM
qryWaitList WHERE DeptName = '" & strAM & "'" & " and Specialty = -1 and
DateBegin = #" & dteWL_Date & "# ORDER BY WL_Order"
.Open
End With
For x = 1 To Slots
If rs!AmountOff = "E" And (Max - (intF + intE)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intE = intE + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "L" And (Max - (intF + intL)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intL = intL + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "F" And ((Max - (intF + intE)) >= 1 And
(Max -
(intF + intL)) >= 1) Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intF = intF + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
Else
rs.MoveNext
x = x - 1
If rs.EOF Then
Exit For
End If
End If
Next x
'AM Non Specialty
AM_NonSpec:
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "Select EligibleDates, E_Ct, L_Ct, F_Ct,
GroupThreshold, Avail FROM qryTimeOffAvailSummAM WHERE [Avail] >0 AND WL
AND Specialty = 0 AND EligibleDates = #" & dteWL_Date & "#"
.Open
End With
Slots = CLng(rs!Avail + 0.1)
intE = rs!E_Ct
intL = rs!L_Ct
intF = rs!F_Ct
Max = rs!GroupThreshold
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "SELECT TO_ID, CompassID, AmountOff FROM
qryWaitList WHERE DeptName = '" & strAM & "'" & " and Specialty = 0 and
DateBegin = #" & dteWL_Date & "# ORDER BY WL_Order"
.Open
End With
For x = 1 To Slots
If rs!AmountOff = "E" And (Max - (intF + intE)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intE = intE + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "L" And (Max - (intF + intL)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intL = intL + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "F" And ((Max - (intF + intE)) >= 1 And
(Max -
(intF + intL)) >= 1) Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intF = intF + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
Else
rs.MoveNext
x = x - 1
If rs.EOF Then
Exit For
End If
End If
Next x
Next a
LP:
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "Select DISTINCT Count(EligibleDates) AS RecCount FROM
qryTimeOffAvailGroupLP"
.Open
End With
intCount = rs!RecCount
'Reset status text
ReturnValue = SysCmd(acSysCmdClearStatus)
'Initialize progress meter.
ReturnValue = SysCmd(acSysCmdInitMeter, "Checking for WaitList
Updates-Loss
Prevention", intCount)
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "Select DISTINCT EligibleDates AS WL_Date FROM
qryTimeOffAvailGroupLP"
.Open
End With
If rs.EOF Then
GoTo FinishIt
End If
Do Until rs.EOF
ReDim Preserve dteAvailDateLP(L)
dteAvailDateLP(L) = rs!WL_Date
L = L + 1
rs.MoveNext
Loop
For L = 1 To UBound(dteAvailDateLP)
dteWL_Date = dteAvailDateLP(L)
ReturnValue = SysCmd(acSysCmdUpdateMeter, L)
'LP Specialty
With rsTeam
If rsTeam.State = adStateOpen Then
.Close
End If
.Source = "Select EligibleDates, SumOfE_Ct As E_Ct, SumOfL_Ct
As L_Ct, SumOfF_Ct As F_Ct, GroupThreshold, GroupAvail FROM
qryTimeOffAvailGroupLP_Spec WHERE EligibleDates = #" & dteWL_Date & "#"
.Open
End With
If rsTeam.EOF Then
GoTo LP1
End If
Slots = CLng(rsTeam!GroupAvail + 0.1)
intE = rsTeam!E_Ct
intL = rsTeam!L_Ct
intF = rsTeam!F_Ct
Max = rsTeam!GroupThreshold
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "SELECT TO_ID, CompassID, AmountOff FROM
qryWaitList WHERE DeptName = '" & strLP & "'" & " AND Specialty = -1 AND
DateBegin = #" & dteWL_Date & "# ORDER BY WL_Order"
.Open
End With
For x = 1 To Slots
If rs!AmountOff = "E" And (Max - (intF + intE)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intE = intE + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "L" And (Max - (intF + intL)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intL = intL + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "F" And ((Max - (intF + intE)) >= 1 And
(Max -
(intF + intL)) >= 1) Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intF = intF + 1
rs.MoveNext
If rs.EOF Then
Exit For
End If
Else
rs.MoveNext
x = x - 1
If rs.EOF Then
Exit For
End If
End If
Next x
'LP Non-Specialty
LP1:
With rsTeam
If rsTeam.State = adStateOpen Then
.Close
End If
.Source = "Select EligibleDates, E_Ct, L_Ct, F_Ct, TeamID,
TeamThreshold, GroupAvail, TeamAvail FROM qryTimeOffAvailGroupLP WHERE
Specialty = 0 AND ThresholdID = 'LP1' AND EligibleDates = #" & dteWL_Date
&
"#"
.Open
End With
If rsTeam.EOF Then
GoTo LP2
End If
GrpAvail = rsTeam!GroupAvail
Do Until GrpAvail = 0 Or rsTeam.EOF
intTeam = rsTeam!teamid
Slots = CLng(rsTeam!TeamAvail + 0.1)
intE = rsTeam!E_Ct
intL = rsTeam!L_Ct
intF = rsTeam!F_Ct
Max = rsTeam!TeamThreshold
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "SELECT TO_ID, CompassID, AmountOff FROM
qryWaitListLP_Team WHERE TeamID =" & intTeam & "AND DateBegin = #" &
dteWL_Date & "# ORDER BY WL_Order"
.Open
End With
For x = 1 To Slots
If rs!AmountOff = "E" And GrpAvail >= 0.5 Then
If (Max - (intF + intE)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intE = intE + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "L" And GrpAvail >= 0.5 Then
If (Max - (intF + intL)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intL = intL + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "F" And GrpAvail >= 1 Then
If ((Max - (intF + intE)) >= 1 And (Max - (intF + intL)) >= 1)
Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intF = intF + 1
GrpAvail = GrpAvail - 1
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
Else
rs.MoveNext
x = x - 1
If rs.EOF Then
Exit For
End If
End If
Next x
rsTeam.MoveNext
Loop
LP2:
With rsTeam
If rsTeam.State = adStateOpen Then
.Close
End If
.Source = "Select EligibleDates, E_Ct, L_Ct, F_Ct, TeamID,
TeamThreshold, GroupAvail, TeamAvail FROM qryTimeOffAvailGroupLP WHERE
Specialty = 0 AND ThresholdID = 'LP2' AND EligibleDates = #" & dteWL_Date
&
"#"
.Open
End With
If rsTeam.EOF Then
GoTo LP3
End If
GrpAvail = rsTeam!GroupAvail
Do Until GrpAvail = 0 Or rsTeam.EOF
intTeam = rsTeam!teamid
Slots = CLng(rsTeam!TeamAvail + 0.1)
intE = rsTeam!E_Ct
intL = rsTeam!L_Ct
intF = rsTeam!F_Ct
Max = rsTeam!TeamThreshold
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "SELECT TO_ID, CompassID, AmountOff FROM
qryWaitListLP_Team WHERE TeamID =" & intTeam & "AND DateBegin = #" &
dteWL_Date & "# ORDER BY WL_Order"
.Open
End With
For x = 1 To Slots
If rs!AmountOff = "E" And GrpAvail >= 0.5 Then
If (Max - (intF + intE)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intE = intE + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "L" And GrpAvail >= 0.5 Then
If (Max - (intF + intL)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intL = intL + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "F" And GrpAvail >= 1 Then
If ((Max - (intF + intE)) >= 1 And (Max - (intF + intL)) >= 1)
Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intF = intF + 1
GrpAvail = GrpAvail - 1
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
Else
rs.MoveNext
x = x - 1
If rs.EOF Then
Exit For
End If
End If
Next x
rsTeam.MoveNext
Loop
LP3:
With rsTeam
If rsTeam.State = adStateOpen Then
.Close
End If
.Source = "Select EligibleDates, E_Ct, L_Ct, F_Ct, TeamID,
TeamThreshold, GroupAvail, TeamAvail FROM qryTimeOffAvailGroupLP WHERE
Specialty = 0 AND ThresholdID = 'LP3' AND EligibleDates = #" & dteWL_Date
&
"#"
.Open
End With
If rsTeam.EOF Then
GoTo LP4
End If
GrpAvail = rsTeam!GroupAvail
Do Until GrpAvail = 0 Or rsTeam.EOF
intTeam = rsTeam!teamid
Slots = CLng(rsTeam!TeamAvail + 0.1)
intE = rsTeam!E_Ct
intL = rsTeam!L_Ct
intF = rsTeam!F_Ct
Max = rsTeam!TeamThreshold
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "SELECT TO_ID, CompassID, AmountOff FROM
qryWaitListLP_Team WHERE TeamID =" & intTeam & "AND DateBegin = #" &
dteWL_Date & "# ORDER BY WL_Order"
.Open
End With
For x = 1 To Slots
If rs!AmountOff = "E" And GrpAvail >= 0.5 Then
If (Max - (intF + intE)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intE = intE + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "L" And GrpAvail >= 0.5 Then
If (Max - (intF + intL)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intL = intL + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "F" And GrpAvail >= 1 Then
If ((Max - (intF + intE)) >= 1 And (Max - (intF + intL)) >= 1)
Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intF = intF + 1
GrpAvail = GrpAvail - 1
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
Else
rs.MoveNext
x = x - 1
If rs.EOF Then
Exit For
End If
End If
Next x
rsTeam.MoveNext
Loop
LP4:
With rsTeam
If rsTeam.State = adStateOpen Then
.Close
End If
.Source = "Select EligibleDates, E_Ct, L_Ct, F_Ct, TeamID,
TeamThreshold, GroupAvail, TeamAvail FROM qryTimeOffAvailGroupLP WHERE
Specialty = 0 AND ThresholdID = 'LP4' AND EligibleDates = #" & dteWL_Date
&
"#"
.Open
End With
GrpAvail = rsTeam!GroupAvail
Do Until GrpAvail = 0 Or rsTeam.EOF
intTeam = rsTeam!teamid
Slots = CLng(rsTeam!TeamAvail + 0.1)
intE = rsTeam!E_Ct
intL = rsTeam!L_Ct
intF = rsTeam!F_Ct
Max = rsTeam!TeamThreshold
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "SELECT TO_ID, CompassID, AmountOff FROM
qryWaitListLP_Team WHERE TeamID =" & intTeam & "AND DateBegin = #" &
dteWL_Date & "# ORDER BY WL_Order"
.Open
End With
For x = 1 To Slots
If rs!AmountOff = "E" And GrpAvail >= 0.5 Then
If (Max - (intF + intE)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intE = intE + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "L" And GrpAvail >= 0.5 Then
If (Max - (intF + intL)) >= 1 Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intL = intL + 1
GrpAvail = GrpAvail - 0.5
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
ElseIf rs!AmountOff = "F" And GrpAvail >= 1 Then
If ((Max - (intF + intE)) >= 1 And (Max - (intF + intL)) >= 1)
Then
ReDim Preserve lngID(i)
lngID(i) = rs!TO_ID
i = i + 1
intF = intF + 1
GrpAvail = GrpAvail - 1
rs.MoveNext
End If
If rs.EOF Then
Exit For
End If
Else
rs.MoveNext
x = x - 1
If rs.EOF Then
Exit For
End If
End If
Next x
rsTeam.MoveNext
Loop
Next L
FinishIt:
For i = 1 To UBound(lngID)
lngRecID = lngID(i)
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "Select TO_ID, Reason, Approved, UpdateTime, UpdateUser
FROM tblTimeOff WHERE TO_ID = " & lngRecID & ""
.Open
End With
rs!Reason = 5
rs!Approved = -1
rs!UpdateTime = Now()
rs!UpdateUser = CurrentUser()
rs.Update
Next i
Dim strOutputFormat As String, strName As String, strPath As String
strOutputFormat = "Snapshot Format"
strName = "rptWaitListUpdates"
'strPath = "C:\Attendance\rptWaitListUpdates.snp"
strPath = "W:\SchdAttn\Data\WaitListUpdates.snp"
MsgBox "Wait List updates are complete."
'DoCmd.OpenReport "rptWaitListUpdates", acViewNormal
DoCmd.OutputTo acOutputReport, strName, strOutputFormat, strPath, True
With rs
If rs.State = adStateOpen Then
.Close
End If
.Source = "UPDATE tblTimeOff SET tblTimeOff.WL_Order = Null WHERE
(((tblTimeOff.WL_Order) Is Not Null) AND ((tblTimeOff.Approved)=-1))"
.Open
End With
Exit_cmdWaitList_Click:
If Not IsNull(rs) Then Set rs = Nothing
If Not IsNull(rsTeam) Then Set rs = Nothing
If Not IsNull(cn) Then Set cn = Nothing
Erase dteAvailDateAM
Erase dteAvailDateLP
Erase lngID
ReturnValue = SysCmd(acSysCmdRemoveMeter)
DoCmd.SetWarnings True
Exit Sub
Err_cmdWaitList_Click:
MsgBox Err.Description
Resume Exit_cmdWaitList_Click
End Sub
Brendan Reynolds said:
I'm finding the code very difficult to read, and I think it is not
complete.
One thing that stands out, though, is that the original poster said that
the
query returns eight records, but the source of the recordset is not the
query, but a SQL statement that selects from the query - how many of
those
eight records meet the criteria of the SQL statement, i.e. [WL] > 0 and
[Avail] > 0?
--
Brendan Reynolds (MVP)
http://brenreyn.blogspot.com
The spammers and script-kiddies have succeeded in making it impossible
for
me to use a real e-mail address in public newsgroups. E-mail replies to
this post will be deleted without being read. Any e-mail claiming to be
from brenreyn at indigo dot ie that is not digitally signed by me with a
GlobalSign digital certificate is a forgery and should be deleted without
being read. Follow-up questions should in general be posted to the
newsgroup, but if you have a good reason to send me e-mail, you'll find
a useable e-mail address at the URL above.
Andi Mayer said:
On Tue, 11 Jan 2005 11:51:06 -0800, str8trini
I hope Brendan steps in, because I am a DAO-orientated
but my expirence with ADO showed me:
you don't get a recordcount with ADO
therefore it everytime -1 (unknown)
Have you tried to walk through the rs?
While not rs.eof
debug.print rs.fields(0)
rs.movenext
wend
---
If you expect an answer to a personal mail, add the word "manfred" to
the
first 10 lines in the message
MW