Slow Code/Query Execution

  • Thread starter Scott Whetsell, A.S. - WVSP
  • Start date
S

Scott Whetsell, A.S. - WVSP

I recently passed an update through into my code under the section of Update
Unit Client. The code was somewhat slow before as it is cumbersome, but the
new query take an average of 12-20 sec to run on each execution. Is there
any way to speed it up?

I understand that one of the sections in the first module is blocked out
(not used). I have plans to implement this section as well but it is creating
an undesirable delay in the record updates.

tbl_UnitLog contains:
UL_Unit Text (Special ID - Unit Name)
UL_Date Date (yyyy-mm-dd)
UL_Time Date (hh:nn:ss)
UL_Details Text (Free text)
UL_Status Text (Status code - status description)
UL_User Text (CurrentUser)
UL_UnitID Text (Parsed version of the UL_Unit field pulling the ID
out)
UL_DateTime UL_Date + UL_Time

qry_UnitClient1 Selects the most recent UL_DateTime for each UL_UnitID from
tbl_UnitLog using the MAX operator.

tbl_UnitClient combines data from several tables and serves as a temporary
container for the same till it changes. One record for each unit.

All front ends are run on A2k3 on WinXP or Vista. Max simultaneous users is
4, average is 2. All computers are connected on 10/100 Cat5E lan, some
connected at 100mbps some at 10mbps through an auxillary switch.

Any suggestions are appreciated, Thanks in advance.

==========CODE STARTS HERE==========
Option Compare Database
Option Explicit

Function unitLog(CCNo As Variant, Sts As String, Details As String, SRC As
Variant, _
Optional TimerValue As Variant, Optional NewDate As Date, Optional
NewTime As Date, _
Optional TestIndicator As Variant)
Dim dbs As Database, rst As DAO.Recordset, rst2 As DAO.Recordset, strQry As
String
Dim strSQL As String, rst99 As DAO.Recordset, NEWSTS As String

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogList")

With rst
Do While Not .EOF
Dim UNIT As String
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogLIst")
UNIT = rst(0)
If IsMissing(TestIndicator) Then TestIndicator = "N"
If TestIndicator <> "Y" Then
Set rst = dbs.OpenRecordset("tbl_UnitLog", dbOpenDynaset,
dbAppendOnly)
Else
Set rst = dbs.OpenRecordset("tbl_zzUnitLog", dbOpenDynaset,
dbAppendOnly)
End If
Sts = Trim(ParseText(Sts, 0, " - "))
If Sts = "STA" Then
NEWSTS = DLookup("Org_StationCode", "qry_AssignedUnit",
"[AssignedUnit]='" & UNIT & "'")
Else
NEWSTS = Sts
End If

' Determine if unit safety timers need activated or deactivated
If TestIndicator <> "Y" Then
If Not IsNull(SRC) Then
If Sts = "10-23" Then
strQry = "SELECT qry_UnitLog.UL_CCNo,
Last(qry_UnitLog.UL_STS) AS LastOfUL_STS, Count(qry_UnitLog.UL_Unit) AS
CountOfUL_Unit " & _
"FROM qry_UnitLog GROUP BY qry_UnitLog.UL_CCNo
HAVING (((qry_UnitLog.UL_CCNo)='" & CCNo & "') AND
((Last(qry_UnitLog.UL_STS))=""10-23""))"
Set rst2 = dbs.OpenRecordset(strQry)
If rst2.RecordCount = 0 Then Call
UnitTimer(Trim(ParseText(UNIT, 0, " - ")), Trim(SRC))
ElseIf (Sts = "10-8") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), SRC,
"OFF")
ElseIf (Sts = "TIMER") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), "UNIT
LOG")
GoTo Exit_unitLog
Else
Dim TimerSts As Variant, UnitID As Variant
UnitID = Trim(ParseText(UNIT, 0, " - "))
TimerSts = DLookup("OM_Expiration",
"tbl_OrganizationMembers", "[OM_UnitID]='" & UnitID & "'")
If (TimerSts <> "") Then
SRC = DLookup("EventCode", "tbl_CCNo", "[CCNo] =
'" & CCNo & "'")
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")),
Trim(SRC), TimerValue)
End If
End If
End If
End If

' Determine if unit is already on another call and clears if
necessary
'If TestIndicator <> "Y" Then
' Dim OldCCNo As Variant, OldSts As Variant
' OldCCNo = DLookup("UL_CCNo", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' OldSts = DLookup("Status", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' If Not IsNull(OldCCNo) Then
' If OldSts <> "10-8" Then
' If CCNo <> OldCCNo Then
' With rst
' rst.AddNew
' rst![UL_CCNo] = OldCCNo
' rst![UL_Unit] = UCase(UNIT)
' rst![UL_User] = UCase(Left(CurrentUser(), 3))
' rst![UL_STS] = "10-8"
' rst![UL_Details] = "UNIT REROUTED TO INC# " &
CCNo
' If (NewDate = "00:00:00") Then rst![UL_Date] =
Format(Date, "yyyy-mm-dd") Else rst![UL_Date] = NewDate
' If (NewTime = "00:00:00") Then rst![UL_Time] =
Format(Time(), "hh:nn:ss") Else rst![UL_Time] = NewTime
' rst.Update
' End With
' End If
' End If
' End If
'End If

' Add new unit activity to log
If (NewDate="00:00:00") Then NewDate = Format(Now(), "yyyy-mm-dd")
If (NewTime="00:00:00") Then NewTime = Format(Now(), "hh:nn:ss")
With rst
rst.AddNew
rst![UL_CCNo] = CCNo
rst![UL_Unit] = UCase(UNIT)
rst![UL_User] = UCase(Left(CurrentUser(), 3))
rst![UL_STS] = UCase(NEWSTS)
rst![UL_Details] = UCase(Trim(Details))
rst![UL_Date] = NewDate
rst![UL_Time] = NewTime
rst![UL_UnitID] = Trim(ParseText(UNIT, 0, " - "))
rst![UL_DateTime] = NewDate + NewTime
rst.Update
End With

' Update Unit Record to reflect current CCNo
If UCase(Sts) = "10-8" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
Else
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '" & CCNo
& "' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
End If
CurrentDb.Execute strSQL, dbFailOnError

' Alpha Patrol Status
If TestIndicator <> "Y" Then
If Sts = "10-41A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = '*'"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf Sts = "10-42A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = ''"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf ((Sts = "10-41") Or (Sts = "10-42")) Then
Dim AlphaSts As Variant
AlphaSts = DLookup("OM_Alpha", "tbl_OrganizationMembers",
"[OM_UnitID]='" & _
Trim(ParseText(UNIT, 0, " - ")) & "'")
If (AlphaSts = "*") Then
Dim rslt As Variant
rslt = MsgBox("" & UNIT & " is currently listed on Alpha
Patrol." & _
Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Clear unit from
Alpha Patrol?", _
vbYesNo, "Unit on Alpha Patrol")
If rslt = 6 Then
strSQL = "UPDATE tbl_OrganizationMembers SET
OM_Alpha = ''" & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0,
" - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
End If
End If
End If
End If

' Clear joined units when going off duty
If Sts = "10-42" Or Sts = "10-42A" Then
On Error Resume Next
Set rst = dbs.OpenRecordset("tbl_UnitsTogether")
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit1 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit2 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
End If

' Clear unit from pending unit list
strSQL = "DELETE * FROM tbl_TMPUnitLogList WHERE UnitID = '" & UNIT
& "'"
CurrentDb.Execute strSQL, dbFailOnError
.MoveNext
Loop
End With

' Update UnitClient
DoCmd.SetWarnings (0)
strSQL = "DELETE * FROM tbl_UnitClient"
CurrentDb.Execute strSQL, dbFailOnError
strSQL = "INSERT INTO tbl_UnitClient ( UnitID, [DateTime], Status,
ULRCN, CCNo, " & _
"AlphaPatrol, PatrolZone, PCO, TimerExpr ) SELECT
qry_UnitClient1.UL_UnitID, " & _
"qry_UnitClient1.DateTime, tbl_UnitLog.UL_STS, tbl_UnitLog.UL_RCN, "
& _
"tbl_UnitLog.UL_CCNo, tbl_OrganizationMembers.OM_Alpha,
tbl_Organizations." & _
"Org_SectionNumber, tbl_UnitLog.UL_User,
tbl_OrganizationMembers.OM_Expiration " & _
"FROM ((qry_UnitClient1 INNER JOIN tbl_UnitLog ON
(qry_UnitClient1.DateTime = " & _
"tbl_UnitLog.UL_DateTime) AND (qry_UnitClient1.UL_UnitID =
tbl_UnitLog.UL_UnitID)) " & _
"INNER JOIN tbl_OrganizationMembers ON tbl_UnitLog.UL_UnitID = " & _
"tbl_OrganizationMembers.OM_UnitID) INNER JOIN tbl_Organizations ON
" & _
"tbl_OrganizationMembers.OM_Org = tbl_Organizations.Org_Name " & _
"WHERE
(((qry_UnitClient1.UL_UnitID)<>DLookUp(""[CallSign]"",""[Settings]"")) AND "
& _
"((tbl_UnitLog.UL_STS) Not Like (""10-42*""))) " & _
"ORDER BY qry_UnitClient1.UL_UnitID"
CurrentDb.Execute strSQL, dbFailOnError
DoCmd.SetWarnings (-1)
Exit_unitLog:
strSQL = "UPDATE Settings SET UnitLogLastUpdate = #" & Format(Now(),
"yyyy-mm-dd hh:nn:ss") & "#"
CurrentDb.Execute strSQL, dbFailOnError
Set CCNo = Nothing
Set dbs = Nothing
Set rst = Nothing
Set rst2 = Nothing
Set rst99 = Nothing

End Function

Public Function UnitTimer(UnitID As String, SRC As Variant, Optional
TimerValue As Variant)
Dim strSQL As String

If (SRC = "UNIT LOG") And (IsMissing(TimerValue)) Then
1
TimerValue = InputBox("ENTER TIMER DURATION IN MINUTES OR 'OFF' TO TURN
TIMER OFF", "TIMER DURATION")
End If

If IsMissing(TimerValue) Then
TimerValue = DLookup("EventTimer", "tbl_EventCodes", "[EventCode]='" &
SRC & "'")
End If

If (IsNumeric(TimerValue) = False) And (UCase(Trim(TimerValue)) <> "OFF") Then
MsgBox "INVALID TIMER VALUE ENTERED, PLEASE TRY AGAIN", vbOKOnly, "ERROR"
GoTo 1
ElseIf IsNumeric(TimerValue) Then
TimerValue = Now + (TimerValue * 6.94444444444444E-04)
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = '" &
TimerValue & "'" & _
"WHERE OM_UnitID = '" & Trim(ParseText(UnitID, 0, " - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf TimerValue = "OFF" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = Null " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UnitID, 0, " - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
End If

End Function
 
S

Stefan Hoffmann

hi Scott,

Scott said:
The code was somewhat slow before as it is cumbersome, but the
new query take an average of 12-20 sec to run on each execution. Is there
any way to speed it up?
Click to expand...
What should your piece of code do?
tbl_UnitLog contains:
UL_Unit Text (Special ID - Unit Name)
UL_Date Date (yyyy-mm-dd)
UL_Time Date (hh:nn:ss)
UL_Details Text (Free text)
UL_Status Text (Status code - status description)
UL_User Text (CurrentUser)
UL_UnitID Text (Parsed version of the UL_Unit field pulling the ID
out)
UL_DateTime UL_Date + UL_Time
Click to expand...
Why are you storing redundant information? Later in your code you use

If (NewDate="00:00:00") Then NewDate = Format(Now(), "yyyy-mm-dd")
If (NewTime="00:00:00") Then NewTime = Format(Now(), "hh:nn:ss")

So why do you need UL_DateTime? You may use DateValue() and TimeValue()
to extract this information from a Date/Time value.
qry_UnitClient1 Selects the most recent UL_DateTime for each UL_UnitID from
tbl_UnitLog using the MAX operator.
Click to expand...
Do you have indices on UL_DateTime and UL_UnitID?
tbl_UnitClient combines data from several tables and serves as a temporary
container for the same till it changes. One record for each unit.
Click to expand...
Is this consolidated data or do we have redundancy again?

btw, I found that in your code: GoTo Exit_unitLog

Can you describe your desired result and the algorithm used?

Also, I don't find your "new" query.


mfG
--> stefan <--
 
D

dymondjack

Scott,

While I'm not going to pretend to have followed all of the code to
understand exactly what it is you are doing, I think I can make a single
suggestion drastically reduce the cycle time it takes to run this code.

Break this code down into multiple functions.

It's going to be a little bit of work to do this, but as I look through the
code, I see many things that you are doing that is generally done not all
stuffed into one function, but spread out through a number of different
functions to handle each smaller peice of information independantly.

When I got started with vba coding, somewhere I read that it is usually a
bad idea to pile all sorts of different operations into a single function.
Rather, a function generally should perfom one basic task, with all of the
relevant data passed to it to perform that task. Many times this invloves
calling procedures from within that procedure (these stacks can go pretty
deep sometimes), but each procedure itself should be clean and concise. This
will definately pay off in regards to performance (and readability,
debugging, and many other aspects of coding).

Consider the first part of your function unitLog(....). The first thing you
do is begin to loop through your tbl_TMPUnitLogList recordset. This in
itself is not part of the problem, but rather everything that is going on
inside this loop. At a quick count I came up with nearly twenty if/then
statements, all inside a single loop. The amount of time it takes for vba to
process all of that, for every single record, is signifigant.

As I mentioned, I'm not going to pretend I know everything the code is doing
here, or say that I can advise on how it *should* be structured, but I think
this is definately why your code is taking much longer than you would expect
to run.

*In general* (though this is only me), if I wind up nesting If statements
more than 3 or 4 layers deep in a single function, it's time for me to break
it into separate functions. I usually try and avoid any deep nestings of
conditionals.

Also, when looping a recordset (or anything else), I make it a point to try
and keep every conditional I can away from it... admittedly sometimes one or
two do end up in there, but as a general rule I try to avoid it.

One might think that ten or twenty or even thirty different functions would
take longer than throwing everything into one, but in my experience the
opposite is almost always true.

These are my thoughts on it... some people might have others, but IMHO, I
think you should think about restructuring your code if you want to get
better performance out of it.

hth


--
Jack Leach
www.tristatemachine.com

- "First, get your information. Then, you can distort it at your leisure."
- Mark Twain


Scott Whetsell said:
I recently passed an update through into my code under the section of Update
Unit Client. The code was somewhat slow before as it is cumbersome, but the
new query take an average of 12-20 sec to run on each execution. Is there
any way to speed it up?

I understand that one of the sections in the first module is blocked out
(not used). I have plans to implement this section as well but it is creating
an undesirable delay in the record updates.

tbl_UnitLog contains:
UL_Unit Text (Special ID - Unit Name)
UL_Date Date (yyyy-mm-dd)
UL_Time Date (hh:nn:ss)
UL_Details Text (Free text)
UL_Status Text (Status code - status description)
UL_User Text (CurrentUser)
UL_UnitID Text (Parsed version of the UL_Unit field pulling the ID
out)
UL_DateTime UL_Date + UL_Time

qry_UnitClient1 Selects the most recent UL_DateTime for each UL_UnitID from
tbl_UnitLog using the MAX operator.

tbl_UnitClient combines data from several tables and serves as a temporary
container for the same till it changes. One record for each unit.

All front ends are run on A2k3 on WinXP or Vista. Max simultaneous users is
4, average is 2. All computers are connected on 10/100 Cat5E lan, some
connected at 100mbps some at 10mbps through an auxillary switch.

Any suggestions are appreciated, Thanks in advance.

==========CODE STARTS HERE==========
Option Compare Database
Option Explicit

Function unitLog(CCNo As Variant, Sts As String, Details As String, SRC As
Variant, _
Optional TimerValue As Variant, Optional NewDate As Date, Optional
NewTime As Date, _
Optional TestIndicator As Variant)
Dim dbs As Database, rst As DAO.Recordset, rst2 As DAO.Recordset, strQry As
String
Dim strSQL As String, rst99 As DAO.Recordset, NEWSTS As String

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogList")

With rst
Do While Not .EOF
Dim UNIT As String
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogLIst")
UNIT = rst(0)
If IsMissing(TestIndicator) Then TestIndicator = "N"
If TestIndicator <> "Y" Then
Set rst = dbs.OpenRecordset("tbl_UnitLog", dbOpenDynaset,
dbAppendOnly)
Else
Set rst = dbs.OpenRecordset("tbl_zzUnitLog", dbOpenDynaset,
dbAppendOnly)
End If
Sts = Trim(ParseText(Sts, 0, " - "))
If Sts = "STA" Then
NEWSTS = DLookup("Org_StationCode", "qry_AssignedUnit",
"[AssignedUnit]='" & UNIT & "'")
Else
NEWSTS = Sts
End If

' Determine if unit safety timers need activated or deactivated
If TestIndicator <> "Y" Then
If Not IsNull(SRC) Then
If Sts = "10-23" Then
strQry = "SELECT qry_UnitLog.UL_CCNo,
Last(qry_UnitLog.UL_STS) AS LastOfUL_STS, Count(qry_UnitLog.UL_Unit) AS
CountOfUL_Unit " & _
"FROM qry_UnitLog GROUP BY qry_UnitLog.UL_CCNo
HAVING (((qry_UnitLog.UL_CCNo)='" & CCNo & "') AND
((Last(qry_UnitLog.UL_STS))=""10-23""))"
Set rst2 = dbs.OpenRecordset(strQry)
If rst2.RecordCount = 0 Then Call
UnitTimer(Trim(ParseText(UNIT, 0, " - ")), Trim(SRC))
ElseIf (Sts = "10-8") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), SRC,
"OFF")
ElseIf (Sts = "TIMER") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), "UNIT
LOG")
GoTo Exit_unitLog
Else
Dim TimerSts As Variant, UnitID As Variant
UnitID = Trim(ParseText(UNIT, 0, " - "))
TimerSts = DLookup("OM_Expiration",
"tbl_OrganizationMembers", "[OM_UnitID]='" & UnitID & "'")
If (TimerSts <> "") Then
SRC = DLookup("EventCode", "tbl_CCNo", "[CCNo] =
'" & CCNo & "'")
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")),
Trim(SRC), TimerValue)
End If
End If
End If
End If

' Determine if unit is already on another call and clears if
necessary
'If TestIndicator <> "Y" Then
' Dim OldCCNo As Variant, OldSts As Variant
' OldCCNo = DLookup("UL_CCNo", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' OldSts = DLookup("Status", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' If Not IsNull(OldCCNo) Then
' If OldSts <> "10-8" Then
' If CCNo <> OldCCNo Then
' With rst
' rst.AddNew
' rst![UL_CCNo] = OldCCNo
' rst![UL_Unit] = UCase(UNIT)
' rst![UL_User] = UCase(Left(CurrentUser(), 3))
' rst![UL_STS] = "10-8"
' rst![UL_Details] = "UNIT REROUTED TO INC# " &
CCNo
' If (NewDate = "00:00:00") Then rst![UL_Date] =
Format(Date, "yyyy-mm-dd") Else rst![UL_Date] = NewDate
' If (NewTime = "00:00:00") Then rst![UL_Time] =
Format(Time(), "hh:nn:ss") Else rst![UL_Time] = NewTime
' rst.Update
' End With
' End If
' End If
' End If
'End If

' Add new unit activity to log
If (NewDate="00:00:00") Then NewDate = Format(Now(), "yyyy-mm-dd")
If (NewTime="00:00:00") Then NewTime = Format(Now(), "hh:nn:ss")
With rst
rst.AddNew
rst![UL_CCNo] = CCNo
rst![UL_Unit] = UCase(UNIT)
rst![UL_User] = UCase(Left(CurrentUser(), 3))
rst![UL_STS] = UCase(NEWSTS)
rst![UL_Details] = UCase(Trim(Details))
rst![UL_Date] = NewDate
rst![UL_Time] = NewTime
rst![UL_UnitID] = Trim(ParseText(UNIT, 0, " - "))
rst![UL_DateTime] = NewDate + NewTime
rst.Update
End With

' Update Unit Record to reflect current CCNo
If UCase(Sts) = "10-8" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
Else
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '" & CCNo
& "' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
End If
CurrentDb.Execute strSQL, dbFailOnError

' Alpha Patrol Status
If TestIndicator <> "Y" Then
If Sts = "10-41A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = '*'"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf Sts = "10-42A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = ''"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf ((Sts = "10-41") Or (Sts = "10-42")) Then
Dim AlphaSts As Variant
AlphaSts = DLookup("OM_Alpha", "tbl_OrganizationMembers",
"[OM_UnitID]='" & _
Trim(ParseText(UNIT, 0, " - ")) & "'")
If (AlphaSts = "*") Then
Dim rslt As Variant
rslt = MsgBox("" & UNIT & " is currently listed on Alpha
Patrol." & _
Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Clear unit from
Alpha Patrol?", _
vbYesNo, "Unit on Alpha Patrol")
If rslt = 6 Then
strSQL = "UPDATE tbl_OrganizationMembers SET
OM_Alpha = ''" & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0,
" - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
End If
End If
End If
End If

' Clear joined units when going off duty
If Sts = "10-42" Or Sts = "10-42A" Then
On Error Resume Next
Set rst = dbs.OpenRecordset("tbl_UnitsTogether")
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit1 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit2 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
End If

' Clear unit from pending unit list
strSQL = "DELETE * FROM tbl_TMPUnitLogList WHERE UnitID = '" & UNIT
& "'"
CurrentDb.Execute strSQL, dbFailOnError
.MoveNext
Loop
End With

' Update UnitClient
DoCmd.SetWarnings (0)
strSQL = "DELETE * FROM tbl_UnitClient"
CurrentDb.Execute strSQL, dbFailOnError
strSQL = "INSERT INTO tbl_UnitClient ( UnitID, [DateTime], Status,
ULRCN, CCNo, " & _
"AlphaPatrol, PatrolZone, PCO, TimerExpr ) SELECT
qry_UnitClient1.UL_UnitID, " & _
"qry_UnitClient1.DateTime, tbl_UnitLog.UL_STS, tbl_UnitLog.UL_RCN, "
& _
"tbl_UnitLog.UL_CCNo, tbl_OrganizationMembers.OM_Alpha,
tbl_Organizations." & _
"Org_SectionNumber, tbl_UnitLog.UL_User,
tbl_OrganizationMembers.OM_Expiration " & _
"FROM ((qry_UnitClient1 INNER JOIN tbl_UnitLog ON
(qry_UnitClient1.DateTime = " & _
"tbl_UnitLog.UL_DateTime) AND (qry_UnitClient1.UL_UnitID =
tbl_UnitLog.UL_UnitID)) " & _
"INNER JOIN tbl_OrganizationMembers ON tbl_UnitLog.UL_UnitID = " & _
"tbl_OrganizationMembers.OM_UnitID) INNER JOIN tbl_Organizations ON
" & _
"tbl_OrganizationMembers.OM_Org = tbl_Organizations.Org_Name " & _
"WHERE
(((qry_UnitClient1.UL_UnitID)<>DLookUp(""[CallSign]"",""[Settings]"")) AND "
& _
"((tbl_UnitLog.UL_STS) Not Like (""10-42*""))) " & _
"ORDER BY qry_UnitClient1.UL_UnitID"
CurrentDb.Execute strSQL, dbFailOnError
DoCmd.SetWarnings (-1)
Exit_unitLog:
strSQL = "UPDATE Settings SET UnitLogLastUpdate = #" & Format(Now(),
"yyyy-mm-dd hh:nn:ss") & "#"
CurrentDb.Execute strSQL, dbFailOnError
Set CCNo = Nothing
Set dbs = Nothing
Set rst = Nothing
Set rst2 = Nothing
Set rst99 = Nothing

End Function

Public Function UnitTimer(UnitID As String, SRC As Variant, Optional
TimerValue As Variant)
Dim strSQL As String

If (SRC = "UNIT LOG") And (IsMissing(TimerValue)) Then
1
TimerValue = InputBox("ENTER TIMER DURATION IN MINUTES OR 'OFF' TO TURN
TIMER OFF", "TIMER DURATION")
End If

If IsMissing(TimerValue) Then
TimerValue = DLookup("EventTimer", "tbl_EventCodes", "[EventCode]='" &
SRC & "'")
End If

If (IsNumeric(TimerValue) = False) And (UCase(Trim(TimerValue)) <> "OFF") Then
MsgBox "INVALID TIMER VALUE ENTERED, PLEASE TRY AGAIN", vbOKOnly, "ERROR"
GoTo 1
ElseIf IsNumeric(TimerValue) Then
TimerValue = Now + (TimerValue * 6.94444444444444E-04)
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = '" &
TimerValue & "'" & _
"WHERE OM_UnitID = '" & Trim(ParseText(UnitID, 0, " - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf TimerValue = "OFF" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = Null " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UnitID, 0, " - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
End If

End Function
Click to expand...
 
S

Scott Whetsell, A.S. - WVSP

The code updates several tables based on information obtained from various
forms.
The tbl_UnitLog has the redundant time/date fields as I have not yet had
time to revise all the codes, forms, and reports to retarget to the combined
field. The Unit Log table keeps a history of all unit activity.
tbl_UnitClient hosts simply the most recent activity for each unit based on
the records in the tbl_UnitLog and pulls some related information from
tbl_OrganizationMembers and tbl_Organizations.

Other tables involved track personal information for each unit
(tbl_organizationmembers), and information for each Department
(tbl_organizations).

The new query starts at the line 'Update UnitClient and ends at the
Exit_unitLog.

This code has three basic sections.
1. Timer status for safety timers - runs the 2nd function
2. Appending new records to tbl_UnitLog
3. Updating tbl_UnitClient to the latest records.

All date, time, and ID fields are indexed.

tbl_UnitClient is technically redundant in that all the data is stored
elsewhere, but it consolidates it and is not stored long term. When a new
record is appended to tbl_UnitLog, tbl_UnitClient is updated to reflect the
new information, and drops any old information. This does not apply if the
new record beign appended is date/time stamped older than the current most
recent record. This allows users to back-date activity if necessary.
 
S

Scott Whetsell, A.S. - WVSP

Thank you for your suggestion, I will look into how to more effectively break
it down. My snag when initially writing it was inexperience and the somewhat
unique nature of what i was trying to do with it. I think i may have been
under the misconsumption when i wrote it that everything in one place is
better. Perhaps using one function to extract the units from the list then
another to start through the conditionals.

dymondjack said:
Scott,

While I'm not going to pretend to have followed all of the code to
understand exactly what it is you are doing, I think I can make a single
suggestion drastically reduce the cycle time it takes to run this code.

Break this code down into multiple functions.

It's going to be a little bit of work to do this, but as I look through the
code, I see many things that you are doing that is generally done not all
stuffed into one function, but spread out through a number of different
functions to handle each smaller peice of information independantly.

When I got started with vba coding, somewhere I read that it is usually a
bad idea to pile all sorts of different operations into a single function.
Rather, a function generally should perfom one basic task, with all of the
relevant data passed to it to perform that task. Many times this invloves
calling procedures from within that procedure (these stacks can go pretty
deep sometimes), but each procedure itself should be clean and concise. This
will definately pay off in regards to performance (and readability,
debugging, and many other aspects of coding).

Consider the first part of your function unitLog(....). The first thing you
do is begin to loop through your tbl_TMPUnitLogList recordset. This in
itself is not part of the problem, but rather everything that is going on
inside this loop. At a quick count I came up with nearly twenty if/then
statements, all inside a single loop. The amount of time it takes for vba to
process all of that, for every single record, is signifigant.

As I mentioned, I'm not going to pretend I know everything the code is doing
here, or say that I can advise on how it *should* be structured, but I think
this is definately why your code is taking much longer than you would expect
to run.

*In general* (though this is only me), if I wind up nesting If statements
more than 3 or 4 layers deep in a single function, it's time for me to break
it into separate functions. I usually try and avoid any deep nestings of
conditionals.

Also, when looping a recordset (or anything else), I make it a point to try
and keep every conditional I can away from it... admittedly sometimes one or
two do end up in there, but as a general rule I try to avoid it.

One might think that ten or twenty or even thirty different functions would
take longer than throwing everything into one, but in my experience the
opposite is almost always true.

These are my thoughts on it... some people might have others, but IMHO, I
think you should think about restructuring your code if you want to get
better performance out of it.

hth


--
Jack Leach
www.tristatemachine.com

- "First, get your information. Then, you can distort it at your leisure."
- Mark Twain


Scott Whetsell said:
I recently passed an update through into my code under the section of Update
Unit Client. The code was somewhat slow before as it is cumbersome, but the
new query take an average of 12-20 sec to run on each execution. Is there
any way to speed it up?

I understand that one of the sections in the first module is blocked out
(not used). I have plans to implement this section as well but it is creating
an undesirable delay in the record updates.

tbl_UnitLog contains:
UL_Unit Text (Special ID - Unit Name)
UL_Date Date (yyyy-mm-dd)
UL_Time Date (hh:nn:ss)
UL_Details Text (Free text)
UL_Status Text (Status code - status description)
UL_User Text (CurrentUser)
UL_UnitID Text (Parsed version of the UL_Unit field pulling the ID
out)
UL_DateTime UL_Date + UL_Time

qry_UnitClient1 Selects the most recent UL_DateTime for each UL_UnitID from
tbl_UnitLog using the MAX operator.

tbl_UnitClient combines data from several tables and serves as a temporary
container for the same till it changes. One record for each unit.

All front ends are run on A2k3 on WinXP or Vista. Max simultaneous users is
4, average is 2. All computers are connected on 10/100 Cat5E lan, some
connected at 100mbps some at 10mbps through an auxillary switch.

Any suggestions are appreciated, Thanks in advance.

==========CODE STARTS HERE==========
Option Compare Database
Option Explicit

Function unitLog(CCNo As Variant, Sts As String, Details As String, SRC As
Variant, _
Optional TimerValue As Variant, Optional NewDate As Date, Optional
NewTime As Date, _
Optional TestIndicator As Variant)
Dim dbs As Database, rst As DAO.Recordset, rst2 As DAO.Recordset, strQry As
String
Dim strSQL As String, rst99 As DAO.Recordset, NEWSTS As String

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogList")

With rst
Do While Not .EOF
Dim UNIT As String
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogLIst")
UNIT = rst(0)
If IsMissing(TestIndicator) Then TestIndicator = "N"
If TestIndicator <> "Y" Then
Set rst = dbs.OpenRecordset("tbl_UnitLog", dbOpenDynaset,
dbAppendOnly)
Else
Set rst = dbs.OpenRecordset("tbl_zzUnitLog", dbOpenDynaset,
dbAppendOnly)
End If
Sts = Trim(ParseText(Sts, 0, " - "))
If Sts = "STA" Then
NEWSTS = DLookup("Org_StationCode", "qry_AssignedUnit",
"[AssignedUnit]='" & UNIT & "'")
Else
NEWSTS = Sts
End If

' Determine if unit safety timers need activated or deactivated
If TestIndicator <> "Y" Then
If Not IsNull(SRC) Then
If Sts = "10-23" Then
strQry = "SELECT qry_UnitLog.UL_CCNo,
Last(qry_UnitLog.UL_STS) AS LastOfUL_STS, Count(qry_UnitLog.UL_Unit) AS
CountOfUL_Unit " & _
"FROM qry_UnitLog GROUP BY qry_UnitLog.UL_CCNo
HAVING (((qry_UnitLog.UL_CCNo)='" & CCNo & "') AND
((Last(qry_UnitLog.UL_STS))=""10-23""))"
Set rst2 = dbs.OpenRecordset(strQry)
If rst2.RecordCount = 0 Then Call
UnitTimer(Trim(ParseText(UNIT, 0, " - ")), Trim(SRC))
ElseIf (Sts = "10-8") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), SRC,
"OFF")
ElseIf (Sts = "TIMER") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), "UNIT
LOG")
GoTo Exit_unitLog
Else
Dim TimerSts As Variant, UnitID As Variant
UnitID = Trim(ParseText(UNIT, 0, " - "))
TimerSts = DLookup("OM_Expiration",
"tbl_OrganizationMembers", "[OM_UnitID]='" & UnitID & "'")
If (TimerSts <> "") Then
SRC = DLookup("EventCode", "tbl_CCNo", "[CCNo] =
'" & CCNo & "'")
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")),
Trim(SRC), TimerValue)
End If
End If
End If
End If

' Determine if unit is already on another call and clears if
necessary
'If TestIndicator <> "Y" Then
' Dim OldCCNo As Variant, OldSts As Variant
' OldCCNo = DLookup("UL_CCNo", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' OldSts = DLookup("Status", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' If Not IsNull(OldCCNo) Then
' If OldSts <> "10-8" Then
' If CCNo <> OldCCNo Then
' With rst
' rst.AddNew
' rst![UL_CCNo] = OldCCNo
' rst![UL_Unit] = UCase(UNIT)
' rst![UL_User] = UCase(Left(CurrentUser(), 3))
' rst![UL_STS] = "10-8"
' rst![UL_Details] = "UNIT REROUTED TO INC# " &
CCNo
' If (NewDate = "00:00:00") Then rst![UL_Date] =
Format(Date, "yyyy-mm-dd") Else rst![UL_Date] = NewDate
' If (NewTime = "00:00:00") Then rst![UL_Time] =
Format(Time(), "hh:nn:ss") Else rst![UL_Time] = NewTime
' rst.Update
' End With
' End If
' End If
' End If
'End If

' Add new unit activity to log
If (NewDate="00:00:00") Then NewDate = Format(Now(), "yyyy-mm-dd")
If (NewTime="00:00:00") Then NewTime = Format(Now(), "hh:nn:ss")
With rst
rst.AddNew
rst![UL_CCNo] = CCNo
rst![UL_Unit] = UCase(UNIT)
rst![UL_User] = UCase(Left(CurrentUser(), 3))
rst![UL_STS] = UCase(NEWSTS)
rst![UL_Details] = UCase(Trim(Details))
rst![UL_Date] = NewDate
rst![UL_Time] = NewTime
rst![UL_UnitID] = Trim(ParseText(UNIT, 0, " - "))
rst![UL_DateTime] = NewDate + NewTime
rst.Update
End With

' Update Unit Record to reflect current CCNo
If UCase(Sts) = "10-8" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
Else
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '" & CCNo
& "' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
End If
CurrentDb.Execute strSQL, dbFailOnError

' Alpha Patrol Status
If TestIndicator <> "Y" Then
If Sts = "10-41A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = '*'"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf Sts = "10-42A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = ''"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf ((Sts = "10-41") Or (Sts = "10-42")) Then
Dim AlphaSts As Variant
AlphaSts = DLookup("OM_Alpha", "tbl_OrganizationMembers",
"[OM_UnitID]='" & _
Trim(ParseText(UNIT, 0, " - ")) & "'")
If (AlphaSts = "*") Then
Dim rslt As Variant
rslt = MsgBox("" & UNIT & " is currently listed on Alpha
Patrol." & _
Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Clear unit from
Alpha Patrol?", _
vbYesNo, "Unit on Alpha Patrol")
If rslt = 6 Then
strSQL = "UPDATE tbl_OrganizationMembers SET
OM_Alpha = ''" & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0,
" - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
End If
End If
End If
End If

' Clear joined units when going off duty
If Sts = "10-42" Or Sts = "10-42A" Then
On Error Resume Next
Set rst = dbs.OpenRecordset("tbl_UnitsTogether")
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit1 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit2 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
End If

' Clear unit from pending unit list
strSQL = "DELETE * FROM tbl_TMPUnitLogList WHERE UnitID = '" & UNIT
& "'"
CurrentDb.Execute strSQL, dbFailOnError
.MoveNext
Loop
End With

' Update UnitClient
DoCmd.SetWarnings (0)
strSQL = "DELETE * FROM tbl_UnitClient"
CurrentDb.Execute strSQL, dbFailOnError
strSQL = "INSERT INTO tbl_UnitClient ( UnitID, [DateTime], Status,
ULRCN, CCNo, " & _
"AlphaPatrol, PatrolZone, PCO, TimerExpr ) SELECT
qry_UnitClient1.UL_UnitID, " & _
"qry_UnitClient1.DateTime, tbl_UnitLog.UL_STS, tbl_UnitLog.UL_RCN, "
& _
"tbl_UnitLog.UL_CCNo, tbl_OrganizationMembers.OM_Alpha,
tbl_Organizations." & _
"Org_SectionNumber, tbl_UnitLog.UL_User,
tbl_OrganizationMembers.OM_Expiration " & _
"FROM ((qry_UnitClient1 INNER JOIN tbl_UnitLog ON
Click to expand...
Click to expand...
 
D

dymondjack

As my boss is fond of saying... "First get all your ducks in a row, then
start shooting"

I feel obligated to make a couple of quick revisions to my previous posts:

Not every function I write is limited to 3 or 4 layers of conditional
nesting, but by the time I get that far I find myself looking at the whole
and giving some serious consideration as to weather it would be more
efficient to run them off seperate functions. Usually thats what I end up
doing.


There's actually a number of loops that get run in various code I use that
are nested further than this. A recent one provided by Allen Browne on
locking all controls on a form pops into mind. I forget how many
conditionals there are inside the loop, but its definately more than one (but
I dont think its more than 3 or 4, and considering what the loop
accomplishes, I think thats pretty good).

So I may have been a bit liberal with those statements, but certainly
wherever you can line up your ducks first, you're usually always better off
shooting in a line than at some random pattern.

--
Jack Leach
www.tristatemachine.com

- "First, get your information. Then, you can distort it at your leisure."
- Mark Twain


Scott Whetsell said:
Thank you for your suggestion, I will look into how to more effectively break
it down. My snag when initially writing it was inexperience and the somewhat
unique nature of what i was trying to do with it. I think i may have been
under the misconsumption when i wrote it that everything in one place is
better. Perhaps using one function to extract the units from the list then
another to start through the conditionals.

dymondjack said:
Scott,

While I'm not going to pretend to have followed all of the code to
understand exactly what it is you are doing, I think I can make a single
suggestion drastically reduce the cycle time it takes to run this code.

Break this code down into multiple functions.

It's going to be a little bit of work to do this, but as I look through the
code, I see many things that you are doing that is generally done not all
stuffed into one function, but spread out through a number of different
functions to handle each smaller peice of information independantly.

When I got started with vba coding, somewhere I read that it is usually a
bad idea to pile all sorts of different operations into a single function.
Rather, a function generally should perfom one basic task, with all of the
relevant data passed to it to perform that task. Many times this invloves
calling procedures from within that procedure (these stacks can go pretty
deep sometimes), but each procedure itself should be clean and concise. This
will definately pay off in regards to performance (and readability,
debugging, and many other aspects of coding).

Consider the first part of your function unitLog(....). The first thing you
do is begin to loop through your tbl_TMPUnitLogList recordset. This in
itself is not part of the problem, but rather everything that is going on
inside this loop. At a quick count I came up with nearly twenty if/then
statements, all inside a single loop. The amount of time it takes for vba to
process all of that, for every single record, is signifigant.

As I mentioned, I'm not going to pretend I know everything the code is doing
here, or say that I can advise on how it *should* be structured, but I think
this is definately why your code is taking much longer than you would expect
to run.

*In general* (though this is only me), if I wind up nesting If statements
more than 3 or 4 layers deep in a single function, it's time for me to break
it into separate functions. I usually try and avoid any deep nestings of
conditionals.

Also, when looping a recordset (or anything else), I make it a point to try
and keep every conditional I can away from it... admittedly sometimes one or
two do end up in there, but as a general rule I try to avoid it.

One might think that ten or twenty or even thirty different functions would
take longer than throwing everything into one, but in my experience the
opposite is almost always true.

These are my thoughts on it... some people might have others, but IMHO, I
think you should think about restructuring your code if you want to get
better performance out of it.

hth


--
Jack Leach
www.tristatemachine.com

- "First, get your information. Then, you can distort it at your leisure."
- Mark Twain


Scott Whetsell said:
I recently passed an update through into my code under the section of Update
Unit Client. The code was somewhat slow before as it is cumbersome, but the
new query take an average of 12-20 sec to run on each execution. Is there
any way to speed it up?

I understand that one of the sections in the first module is blocked out
(not used). I have plans to implement this section as well but it is creating
an undesirable delay in the record updates.

tbl_UnitLog contains:
UL_Unit Text (Special ID - Unit Name)
UL_Date Date (yyyy-mm-dd)
UL_Time Date (hh:nn:ss)
UL_Details Text (Free text)
UL_Status Text (Status code - status description)
UL_User Text (CurrentUser)
UL_UnitID Text (Parsed version of the UL_Unit field pulling the ID
out)
UL_DateTime UL_Date + UL_Time

qry_UnitClient1 Selects the most recent UL_DateTime for each UL_UnitID from
tbl_UnitLog using the MAX operator.

tbl_UnitClient combines data from several tables and serves as a temporary
container for the same till it changes. One record for each unit.

All front ends are run on A2k3 on WinXP or Vista. Max simultaneous users is
4, average is 2. All computers are connected on 10/100 Cat5E lan, some
connected at 100mbps some at 10mbps through an auxillary switch.

Any suggestions are appreciated, Thanks in advance.

==========CODE STARTS HERE==========
Option Compare Database
Option Explicit

Function unitLog(CCNo As Variant, Sts As String, Details As String, SRC As
Variant, _
Optional TimerValue As Variant, Optional NewDate As Date, Optional
NewTime As Date, _
Optional TestIndicator As Variant)
Dim dbs As Database, rst As DAO.Recordset, rst2 As DAO.Recordset, strQry As
String
Dim strSQL As String, rst99 As DAO.Recordset, NEWSTS As String

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogList")

With rst
Do While Not .EOF
Dim UNIT As String
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogLIst")
UNIT = rst(0)
If IsMissing(TestIndicator) Then TestIndicator = "N"
If TestIndicator <> "Y" Then
Set rst = dbs.OpenRecordset("tbl_UnitLog", dbOpenDynaset,
dbAppendOnly)
Else
Set rst = dbs.OpenRecordset("tbl_zzUnitLog", dbOpenDynaset,
dbAppendOnly)
End If
Sts = Trim(ParseText(Sts, 0, " - "))
If Sts = "STA" Then
NEWSTS = DLookup("Org_StationCode", "qry_AssignedUnit",
"[AssignedUnit]='" & UNIT & "'")
Else
NEWSTS = Sts
End If

' Determine if unit safety timers need activated or deactivated
If TestIndicator <> "Y" Then
If Not IsNull(SRC) Then
If Sts = "10-23" Then
strQry = "SELECT qry_UnitLog.UL_CCNo,
Last(qry_UnitLog.UL_STS) AS LastOfUL_STS, Count(qry_UnitLog.UL_Unit) AS
CountOfUL_Unit " & _
"FROM qry_UnitLog GROUP BY qry_UnitLog.UL_CCNo
HAVING (((qry_UnitLog.UL_CCNo)='" & CCNo & "') AND
((Last(qry_UnitLog.UL_STS))=""10-23""))"
Set rst2 = dbs.OpenRecordset(strQry)
If rst2.RecordCount = 0 Then Call
UnitTimer(Trim(ParseText(UNIT, 0, " - ")), Trim(SRC))
ElseIf (Sts = "10-8") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), SRC,
"OFF")
ElseIf (Sts = "TIMER") Then
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")), "UNIT
LOG")
GoTo Exit_unitLog
Else
Dim TimerSts As Variant, UnitID As Variant
UnitID = Trim(ParseText(UNIT, 0, " - "))
TimerSts = DLookup("OM_Expiration",
"tbl_OrganizationMembers", "[OM_UnitID]='" & UnitID & "'")
If (TimerSts <> "") Then
SRC = DLookup("EventCode", "tbl_CCNo", "[CCNo] =
'" & CCNo & "'")
Call UnitTimer(Trim(ParseText(UNIT, 0, " - ")),
Trim(SRC), TimerValue)
End If
End If
End If
End If

' Determine if unit is already on another call and clears if
necessary
'If TestIndicator <> "Y" Then
' Dim OldCCNo As Variant, OldSts As Variant
' OldCCNo = DLookup("UL_CCNo", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' OldSts = DLookup("Status", "qry_UnitStatus", "[Unit] = '" &
Trim(ParseText(UNIT, 0, " - ")) & "'")
' If Not IsNull(OldCCNo) Then
' If OldSts <> "10-8" Then
' If CCNo <> OldCCNo Then
' With rst
' rst.AddNew
' rst![UL_CCNo] = OldCCNo
' rst![UL_Unit] = UCase(UNIT)
' rst![UL_User] = UCase(Left(CurrentUser(), 3))
' rst![UL_STS] = "10-8"
' rst![UL_Details] = "UNIT REROUTED TO INC# " &
CCNo
' If (NewDate = "00:00:00") Then rst![UL_Date] =
Format(Date, "yyyy-mm-dd") Else rst![UL_Date] = NewDate
' If (NewTime = "00:00:00") Then rst![UL_Time] =
Format(Time(), "hh:nn:ss") Else rst![UL_Time] = NewTime
' rst.Update
' End With
' End If
' End If
' End If
'End If

' Add new unit activity to log
If (NewDate="00:00:00") Then NewDate = Format(Now(), "yyyy-mm-dd")
If (NewTime="00:00:00") Then NewTime = Format(Now(), "hh:nn:ss")
With rst
rst.AddNew
rst![UL_CCNo] = CCNo
rst![UL_Unit] = UCase(UNIT)
rst![UL_User] = UCase(Left(CurrentUser(), 3))
rst![UL_STS] = UCase(NEWSTS)
rst![UL_Details] = UCase(Trim(Details))
rst![UL_Date] = NewDate
rst![UL_Time] = NewTime
rst![UL_UnitID] = Trim(ParseText(UNIT, 0, " - "))
rst![UL_DateTime] = NewDate + NewTime
rst.Update
End With

' Update Unit Record to reflect current CCNo
If UCase(Sts) = "10-8" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
Else
strSQL = "UPDATE tbl_OrganizationMembers SET OM_CCNo = '" & CCNo
& "' " & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
End If
CurrentDb.Execute strSQL, dbFailOnError

' Alpha Patrol Status
If TestIndicator <> "Y" Then
If Sts = "10-41A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = '*'"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf Sts = "10-42A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = ''"
& _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0, " - "))
& "'"
CurrentDb.Execute strSQL, dbFailOnError
ElseIf ((Sts = "10-41") Or (Sts = "10-42")) Then
Dim AlphaSts As Variant
AlphaSts = DLookup("OM_Alpha", "tbl_OrganizationMembers",
"[OM_UnitID]='" & _
Trim(ParseText(UNIT, 0, " - ")) & "'")
If (AlphaSts = "*") Then
Dim rslt As Variant
rslt = MsgBox("" & UNIT & " is currently listed on Alpha
Patrol." & _
Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Clear unit from
Alpha Patrol?", _
vbYesNo, "Unit on Alpha Patrol")
If rslt = 6 Then
strSQL = "UPDATE tbl_OrganizationMembers SET
OM_Alpha = ''" & _
"WHERE OM_UnitID = '" & Trim(ParseText(UNIT, 0,
" - ")) & "'"
CurrentDb.Execute strSQL, dbFailOnError
End If
End If
End If
End If

' Clear joined units when going off duty
If Sts = "10-42" Or Sts = "10-42A" Then
On Error Resume Next
Set rst = dbs.OpenRecordset("tbl_UnitsTogether")
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit1 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
strSQL = "DELETE * FROM tbl_UnitsTogether WHERE Unit2 = '" &
ParseText(UNIT, 0, " - ") & "'"
CurrentDb.Execute strSQL
End If

' Clear unit from pending unit list
strSQL = "DELETE * FROM tbl_TMPUnitLogList WHERE UnitID = '" & UNIT
& "'"
CurrentDb.Execute strSQL, dbFailOnError
.MoveNext
Loop
End With

' Update UnitClient
DoCmd.SetWarnings (0)
strSQL = "DELETE * FROM tbl_UnitClient"
CurrentDb.Execute strSQL, dbFailOnError
strSQL = "INSERT INTO tbl_UnitClient ( UnitID, [DateTime], Status,
ULRCN, CCNo, " & _
Click to expand...
Click to expand...
Click to expand...
 
A

Albert D. Kallal

Actually one main issue here of performance here is pretty simple: you most
definitely in all circumstances who want to make real hand stands to avoid
the opening a record set over and over inside of a loop.

all its plan and conceptual level why this is so:

Ask yourself if you're going to walk across the street, which is faster

1) walking across the street

2) using a helicopter

It turns out that the above answer depends. If the helicopter sitting on the
ground, by the time you open the door get into the helicopter, close the
door, strap up your seatbelt, go through the long engine and safety
checklist of things to do, start the engine, and then wait for the blades
and engine to get up to operating speed, and THEN the helicopter finally
gets
Airborne. You can well see that simply just walking across the street will
be far faster.

On the other hand if the helicopters is already Airborne and flying at full
speed, it's likely doing over 100mph, and that fly over the street will
occur so fast that you'll not even likely had time to look up and see the
chopper buzz overhead. You likely not even taken one foot step and the
chopper
will have gone many times farther than walking.

You must think of opening a record set exactly like starting up that
helicopter. The time cost and penalty of opening a record set is really
quite large. all kinds of permissions have to be tested, perhaps some SQL
has to be parsed, memory has to be allocated, communication at the operating
system, this list just goes on for absolutely forever.

So you want to modify your code in such a way that you don't repeatedly open
up a recordsets inside of that loop over and over.

I've only taken a really quick look and glance at your code, but avoiding
repeated open of recordset is the best performance advice I can give you in
a real short amount of time....
 
S

Scott Whetsell, A.S. - WVSP

Point very well taken. I believe my reliance on opening the recordsets is my
lack of knowledge of SQL statements. Following some suggestions I've already
received, I am working on a new draft function breaking down my current
function into about 6 seperate functions and doing as many calculations as
possible out of the loop. Any guidance on the qry to update the unit client
at the bottom of the first function I posted would be appreciated. When I
get the draft finished I will post for review.

Thanks.
 
S

Scott Whetsell, A.S. - WVSP

Here is how I have broken down the code so far, I have not yet tested it, and
I am still looking for a suggestion for the query to update the unit client.
Any suggestions are also welcome on the code i have alread updated.

Thanks

======LOOKING TO UPDATE CODE=======
strSQL = "INSERT INTO tbl_UnitClient ( UnitID, [DateTime], Status,
ULRCN, CCNo, " & _
"AlphaPatrol, PatrolZone, PCO, TimerExpr ) SELECT
qry_UnitClient1.UL_UnitID, " & _
"qry_UnitClient1.DateTime, tbl_UnitLog.UL_STS, tbl_UnitLog.UL_RCN, "
& _
"tbl_UnitLog.UL_CCNo, tbl_OrganizationMembers.OM_Alpha,
tbl_Organizations." & _
"Org_SectionNumber, tbl_UnitLog.UL_User,
tbl_OrganizationMembers.OM_Expiration " & _
"FROM ((qry_UnitClient1 INNER JOIN tbl_UnitLog ON
(qry_UnitClient1.DateTime = " & _
"tbl_UnitLog.UL_DateTime) AND (qry_UnitClient1.UL_UnitID =
tbl_UnitLog.UL_UnitID)) " & _
"INNER JOIN tbl_OrganizationMembers ON tbl_UnitLog.UL_UnitID = " & _
"tbl_OrganizationMembers.OM_UnitID) INNER JOIN tbl_Organizations ON
" & _
"tbl_OrganizationMembers.OM_Org = tbl_Organizations.Org_Name " & _
"WHERE
(((qry_UnitClient1.UL_UnitID)<>DLookUp(""[CallSign]"",""[Settings]"")) AND "
& _
"((tbl_UnitLog.UL_STS) Not Like (""10-42*""))) " & _
"ORDER BY qry_UnitClient1.UL_UnitID"
==============================


===========NEW CODE============
Function UnitLog(CCNo As Variant, Sts As String, Details As String, SRC As
Variant, _
Optional TimerValue As Variant, Optional NewDate As Date, Optional NewTime
As Date)

Dim dbs As Database, rst As DAO.Recordset, Unit As String, UnitID As String,
DateTime As Date

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogList")

Sts = UCase(Trim(ParseText(Sts,0," - ")))
If Sts = "STA" Then Sts =
Dlookup("Org_StationCode","qry_AssignedUnit","[AssignedUnit]='" & Unit & "'")
If NewDate = "00:00:00" Then NewDate = Format(Now(),"yyyy-mm-dd")
If NewTime = "00:00:00" Then NewTime = Format(Now(),"hh:nn:ss")
DateTime = Format(NewDate + NewTime, "yyyy-mm-dd hh:nn:ss")

With rst
Do While Not .EOF
UnitID = rst(0)
Unit = Dlookup("AssignedUnit","qry_AssignedUnit","[OM_UnitID]='" & UnitID
& "'")
' Set Safety Timers As Appropriate
If Not IsNull(SRC) Then SafetyTimer(UnitID, SRC, Sts, CCNo, TimerValue)

' Append to Unit Log
strSQL = "INSERT INTO tbl_UnitLog (UL_UnitID, UL_Unit, UL_STS, UL_Details,
UL_CCNo, " & _
"UL_DateTime, UL_User) VALUES ('" & UnitID & "', '" & Unit & "', '" & Sts
& "', '" & _
Details & "', '" & CCNo & "', #" & DateTime & "#, '" &
UCase(CurrentUser()) & "'")
Currentdb.Execute strSQL

' Update UnitClient As Appropriate
UpdateUnitClient()

' Alpha Patrol Status
If Left(Sts,5) = "10-41" or Left(Sts,5) = "10-42" Then
UpdateAlphaPatrol(UnitID, Sts)

' Remove From Pending Unit List
CurrentDb.Execute "DELETE * FROM tbl_TMPUnitLogList WHERE UnitID = '" &
UnitID & "'"
.MoveNext
Loop
End With

' Log system update for unit activity
CurrentDb.Execute "UPDATE Settings SET UnitLogLastUpdate = #" & Now() & "#"

Set rst = Nothing
Set dbs = Nothing

End Function

Function SafetyTimer(UnitID As String, SRC As Variant, Sts As String, CCNo
As String, Optional TimerValue As Variant)
Dim strSQL As String, Unit2 As Variant
If Sts = "10-8" or Sts = "10-17" Then
TimerValue = "OFF"
ElseIf Sts = "TIMER" Then
SRC = "UNIT LOG"
ElseIf Sts = "10-23" Then
Unit2 = DLookup("UnitID","tbl_UnitClient","[Status]='10-23' AND [CCNo]='" &
CCNo & "'")
If Not IsNull(Unit2) Then Exit Function
ElseIf Not
IsNull(Dlookup("OM_Expiration","tbl_OrganizationMembers","[OM_UnitID]='" &
UnitID & "'") Then
SRC = DLookup("EventCode","tbl_CCNo","[CCNo] = '" & CCNo & "'")
Else Exit Function
EndIf

If (SRC = "UNIT LOG") And (IsMissing(TimerValue)) Then
1
TimerValue = InputBox("Enter timer duation in minutes or 'OFF' to turn
timer off.", & _
"Specify Timer Duration")
ElseIf (IsMissing(TimerValue) Then
TimerValue = DLookup("EventTimer","tbl_EventCodes","[EventCode]='" & SRC &
"'")
End If

If (IsNumeric(TimerValue) = False) AND (TimerValue <> "OFF") Then
GoTo 1
ElseIf IsNumeric(TimerValue) Then
TimerValue = Now + (TimerValue * 6.94444444444444E-04)
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = #" &
TimerValue & "# " & _
"WHERE OM_UnitID = '" & UnitID & "'"
Else strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = Null " & _
"WHERE OM_UnitID = '" & UnitID & "'"
End If
Currentdb.Execute strSQL
End Function



Function UpdateUnitClient()

End Function


Function UpdateAlphaPatrol(UnitID As String, Sts As String)
Dim AlphaSts As String, strSQL As String
AlphaSts = Dlookup("OM_Alpha","tbl_OrganizationMembers","[OM_UnitID]='" &
UnitID & "'")
If Sts = "10-41A" Then
strSQL = UPDATE tbl_OrganizationMembers SET OM_Alpha = '*' " & _
"WHERE OM_UnitID = '" & UnitID & "'"
Else
strSQL = UPDATE tbl_OrganizationMembers SET OM_Alpha = '*' " & _
"WHERE OM_UnitID = '" & UnitID & "'"
End If
CurrentDb.Execute strSQL
End Function
=============END CODE=============
 
S

Scott Whetsell, A.S. - WVSP

Here is the new code I came up with and the time has been reduced to 1-4
seconds. Thanks to everyone for their help.

Option Compare Database
Option Explicit

Function unitLog(CCNo As Variant, Sts As String, Details As String, SRC As
Variant, _
Optional TimerValue As Variant, Optional NewDate As Date, Optional
NewTime As Date)

Dim dbs As Database, rst As DAO.Recordset, UNIT As String, UnitID As String,
DateTime As Date
Dim OldCCNo As Variant

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tbl_TMPUnitLogList")

Sts = UCase(Trim(ParseText(Sts, 0, " - ")))
If NewDate = "00:00:00" Then NewDate = Format(Now(), "yyyy-mm-dd")
If NewTime = "00:00:00" Then NewTime = Format(Now(), "hh:nn:ss")
DateTime = Format(NewDate + NewTime, "yyyy-mm-dd hh:nn:ss")

With rst
Do While Not .EOF
UNIT = rst(0)
UnitID = Trim(ParseText(UNIT, 0, " - "))
If Sts = "STA" Then Sts = DLookup("Org_StationCode",
"qry_AssignedUnit", "[OM_UnitID]='" & UnitID & "'")
' Set Safety Timers As Appropriate
If Not IsNull(SRC) Then Call SafetyTimer(UnitID, SRC, Sts, CCNo,
TimerValue)
If Sts = "TIMER" Then GoTo 1
' Update Unit Log
Call UpdateUnitLog(UnitID, UNIT, CCNo, Sts, Details, DateTime)
' Alpha Patrol Status
If Left(Sts, 5) = "10-41" Or Left(Sts, 5) = "10-42" Then Call
UpdateAlphaPatrol(UnitID, Sts)
' Remove From Pending Unit List
1
CurrentDb.Execute "DELETE * FROM tbl_TMPUnitLogList WHERE UnitID =
'" & UnitID & "'"
.MoveNext
Loop
End With

' Log system update for unit activity
CurrentDb.Execute "UPDATE Settings SET UnitLogLastUpdate = #" & Now() & "#"

Set rst = Nothing
Set dbs = Nothing

End Function


Function SafetyTimer(UnitID As String, SRC As Variant, Sts As String, CCNo
As Variant, Optional TimerValue As Variant)
Dim strSQL As String, Unit2 As Variant
If Sts = "10-8" Or Sts = "10-17" Then
TimerValue = "OFF"
ElseIf Sts = "TIMER" Then
SRC = "UNIT LOG"
ElseIf Sts = "10-23" Then
Unit2 = DLookup("UnitID", "tbl_UnitClient", "[Status]='10-23' AND
[CCNo]='" & CCNo & "'")
If Not IsNull(Unit2) Then Exit Function
ElseIf Not IsNull(DLookup("OM_Expiration", "tbl_OrganizationMembers",
"[OM_UnitID]='" & UnitID & "'")) Then
SRC = DLookup("EventCode", "tbl_CCNo", "[CCNo] = '" & CCNo & "'")
Else: Exit Function
End If
If (SRC = "UNIT LOG") And (IsMissing(TimerValue)) Then
1
TimerValue = InputBox("Enter timer duation in minutes or 'OFF' to turn
timer off.", _
"Specify Timer Duration")
ElseIf (IsMissing(TimerValue)) Then
TimerValue = DLookup("EventTimer", "tbl_EventCodes", "[EventCode]='" &
SRC & "'")
End If
If (IsNumeric(TimerValue) = False) And (TimerValue <> "OFF") Then
GoTo 1
ElseIf IsNumeric(TimerValue) Then
TimerValue = Now + (TimerValue * 6.94444444444444E-04)
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = #" &
TimerValue & "# " & _
"WHERE OM_UnitID = '" & UnitID & "'"
Else: strSQL = "UPDATE tbl_OrganizationMembers SET OM_Expiration = Null " _
& "WHERE OM_UnitID = '" & UnitID & "'"
End If
CurrentDb.Execute strSQL
End Function



Function UpdateUnitLog(UnitID As String, UNIT As String, CCNo As Variant,
Sts As String, Details As String, DateTime As Date)
Dim OldCCNo As Variant, strSQL As String
' Clear from Previous Call as Appropriate
OldCCNo = (DLookup("OM_CCNo", "tbl_OrganizationMembers", "[OM_UnitID]='" &
UnitID & "'"))
If Not IsNull(OldCCNo) And (OldCCNo <> CCNo) Then
strSQL = "INSERT INTO tbl_UnitLog (UL_UnitID, UL_Unit, UL_STS,
UL_Details, UL_CCNo, " & _
"UL_DateTime, UL_User) VALUES ('" & UnitID & "', '" & UNIT & "',
'10-8', 'UNIT REROUTED " & _
"TO INCIDENT " & OldCCNo & "', '" & OldCCNo & "', #" & DateTime &
"#, '" & UCase(CurrentUser()) & "')"
CurrentDb.Execute strSQL
End If
' Append to Unit Log
strSQL = "INSERT INTO tbl_UnitLog (UL_UnitID, UL_Unit, UL_STS, UL_Details,
UL_CCNo, " & _
"UL_DateTime, UL_User) VALUES ('" & UnitID & "', '" & UNIT & "', '" &
Sts & "', '" & _
Details & "', '" & CCNo & "', '" & DateTime & "', '" &
UCase(CurrentUser()) & "')"
CurrentDb.Execute strSQL
' Update CCNo Status
If Sts <> "10-8" Then
CurrentDb.Execute "UPDATE tbl_OrganizationMembers SET OM_CCNo = '" &
CCNo & "' WHERE OM_UnitID = '" & UnitID & "'"
Else: CurrentDb.Execute "UPDATE tbl_OrganizationMembers SET OM_CCNo = ''
WHERE OM_UnitID = '" & UnitID & "'"
End If
' Clear Joined Units when going 10-42
If Sts = "10-42" Or Sts = "10-42A" Then
CurrentDb.Execute "DELETE * FROM tbl_UnitsTogether WHERE Unit1 = '" &
UnitID & "' OR Unit2 = '" & UnitID & "'"
End If
End Function



Function UpdateAlphaPatrol(UnitID As String, Sts As String)
Dim AlphaSts As Variant, strSQL As String
AlphaSts = DLookup("OM_Alpha", "tbl_OrganizationMembers", "[OM_UnitID]='" &
UnitID & "'")
If Sts = "10-41A" Then
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = '*' " & _
"WHERE OM_UnitID = '" & UnitID & "'"
Else
strSQL = "UPDATE tbl_OrganizationMembers SET OM_Alpha = '' " & _
"WHERE OM_UnitID = '" & UnitID & "'"
End If
CurrentDb.Execute strSQL
End Function
 

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

DLookup returns Error '3464'-Data Type Mismatch in Criteria Expres 14
Help with listing files using Allen Browne's (modified) code 1
Repeated call to InternetExplorer.Application seems to hang the PC 4
Help with this code please. 2
Complicated append 8
Update query using Count 4
Automatically Attach an Excel File to an Email 4
How to optimize a query called in code VBA 6

Top