Need Code Optimization - MS Access - VBA

First: I have a difficult time following code that uses GoTo. IMO, the only time you should use GoTo syntax is for error handling. Otherwise, use Select Case, If-then or other logic flow syntax to control where you code goes.

Why are you looping through your controls and setting them to Default values? If this is a bound form, and you're just moving  to a different record, then Access will "clear" the form for you. If it's not bound, then just set the form to an empty string, or to 0, or whatever make sense. With complex forms moving through the control collection can take some time, so often you're better off explicitly clearing controls:

Me.Textbox1=""
Me.Combo2= ""

Move this out of your loop:

                            LBL_CANCELLED.Visible = False
                            lbl_ibshipper.Visible = False
                            btn_Details.Visible = False
                            txt_LoadID.Enabled = True
                            BTN_FIND.Caption = "SEARCH"
                            txt_LoadID.SetFocus

There's no need to call this for each control

replace ths block:

                            DoCmd.SetWarnings False
                            strSQLdel = "Delete * from TBL_LOAD_DET_TEMP"
                            DoCmd.RunSQL strSQLdel
                            DoCmd.SetWarnings True


With this line:

currentdb.execute "DELETE * FROM tbl_load_det_temp"

Use a Recordset instead of a string of DLookups:

txt_custPhone = DLookup("[CUST_PHONE]", "TBL_CUST_HED", "[CUST_ID] = " & [Forms]![frm_build_load]![cbo_custID])
                        txt_shipToName = DLookup("CUST_NAME", "TBL_CUST_HED", "[CUST_ID] = " & [Forms]![frm_build_load]![cbo_custID])
                        txt_shipToCity = DLookup("DET_CITY", "TBL_CUST_DET", "[DET_ID] = '" & [Forms]![frm_build_load]![cbo_shipToID] & "'")
                        txt_shipToState = DLookup("DET_STATE", "TBL_CUST_DET", "[DET_ID] = '" & [Forms]![frm_build_load]![cbo_shipToID] & "'")
                        txt_shipToZip = DLookup("DET_ZIP", "TBL_CUST_DET", "[DET_ID] = '" & [Forms]![frm_build_load]![cbo_shipToID] & "'")
                        txt_shipToPh = DLookup("DET_PHONE", "TBL_CUST_DET", "[DET_ID] = '" & [Forms]![frm_build_load]![cbo_shipToID] & "'")

should be written as

Dim rst = Currentdb.OpenRecordset("SELECT * FROM tbl_cust_hed WHERE cust_id=" Y forms("frm_build_load").cboCustID)
txt_shiptoname = rst("Cust_Name")
Same for the filter on ShipToID

Also, in the  section following "'--- If locks are present clear locks" you will save some time by executing a single update such as

strLock = "Update TBL_LOAD_HED set LD_RECLOCK='', LD_RECLOCK_USER= ''where LD_RECLOCK_USER ='" & strLockUser & "'"
currentdb.execute strLock

Select allOpen in new window

There are some more examples where you could do this too.

In the section titled "'--- Run query to populate form with record" you could extract all the data you need in one hit by adding some joins to the other relevant tables, eg:

strSQL = "Select t1.*, t2.CUST_PHONE, t2.CUST_NAME, t3.DET_CITY, t3.DET_STATE, t3.DET_ZIP, t3.DET_PHONE  from TBL_LOAD_HED t1
left join TBL_CUST_HED t2 on t1.LD_CUST_ID = t2.CUST_ID
left join TBL_CUST_DET t3 on t1.LD_SHIPTO_ID = t3.DET_ID
where t1.LD_NUM =" & sParm

Select allOpen in new window

THis would save having to run all those Dlookups.

There are probably more savings to be made, I will try to have a closer look.

Thanks, will get to work on changing the code recommended.  To answer your question this is an unbound form.  This is the reason for a lot of the extra code.  Almost all forms in my application are unbound just to have the control desired with searching, editing, and creating new records.

I was always told that using Goto is more effecient when having long code that you do not need to to through.  In this case there is a whole section of code that gets jumped over by the "if" statement being true.  In the code below when the IF statement is true then it skips over the italicized code:


    If BTN_FIND.Caption = "FIND" Then
        If Me.isdirty = True Then
            If MsgBox("Form has been changed.  Do you want to clear the form?", vbYesNo, "WARNING") = vbYes Then
               
        '--- Clear all form controls upon confirmation
       
                For Each ctl In Me.Controls
                    Select Case ctl.ControlType
                        Case acComboBox, acListBox, acOptionGroup, acTextBox, acCheckBox
                            ctl.Value = ctl.DefaultValue
                            End Select
                           
        '--- Ensure form is back to normal state, no labels showing.  Change FIND button to SEARCH state
        '--- enable LoadID control for search criteria and set focus here
       
                            LBL_CANCELLED.Visible = False
                            lbl_ibshipper.Visible = False
                            btn_Details.Visible = False
                            txt_LoadID.Enabled = True
                            BTN_FIND.Caption = "SEARCH"
                            txt_LoadID.SetFocus
                    Next
       
        '--- Go to RemoveLock to remove any record locks applied
       
>>>>                        GoTo RemoveLock
                       
           Else
                Exit Sub
            End If
       
        '--- If form is not dirty with record then clear form without user confirmation
       
        Else
       
        '--- Clear all form controls
       
                    For Each ctl In Me.Controls
                        Select Case ctl.ControlType
                            Case acComboBox, acListBox, acOptionGroup, acTextBox, acCheckBox
                                ctl.Value = ctl.DefaultValue
                                End Select
                               
        '--- Ensure form is back to normal state, no labels showing.  Change FIND button to SEARCH state
        '--- enable LoadID control for search criteria and set focus here
       
                                Me.LBL_CANCELLED.Visible = False
                                Me.lbl_ibshipper.Visible = False
                                Me.btn_Details.Visible = False
                                Me.txt_LoadID.Enabled = True
                                Me.BTN_FIND.Caption = "SEARCH"
                                txt_LoadID.SetFocus
                        Next

        '--- Go to RemoveLock to remove any record locks applied
       
                            GoTo RemoveLock
                           
                       
                   
>>>> RemoveLock:

A golden rule of programming is "Never use goto (other than in on error goto statements)". It's not more efficient and can lead to terrible trouble debugging.

I'd remove the gotos if it was me. But I don't think it's affecting the performance of your form.

Thanks Jim.  To answer  a couple of your questions:

1. You have no error handling  - depending on the number of users, your bound to get collisions when trying to place and clear locks.  You must account for this.

The record lock happens at form level.  Nobody else can call the record if "LOCKED" is present in current record within the table.  They get a message telling them the record is locked by "username", try again later.  No person can have the same record in a form at the same time, so therefore it cannot be edited by more than one person.

2. Your only handling exclusive locking, which you are going to find very restrictive, unless your point is to use this for editing only (i.e. what if someone runs a report against the table while someone else is editing; is that OK?, etc).

Thats correct.  Reports do not look for this lock, so it will not prevent users from running any reports with locked records.

<<The record lock happens at form level.  Nobody else can call the record if "LOCKED" is present in current record within the table.  They get a message telling them the record is locked by "username", try again later.  No person can have the same record in a form at the same time, so therefore it cannot be edited by more than one person.>>

  Understood, but you missed the point.  All the locks for each user are being placed against one table (TBL_LOAD_HED).  In fact I didn't mention it, but this code will fail logically:

        '--- Apply record lock to selected record
                   
                                strLock = "select * from TBL_LOAD_HED where LD_NUM =" & sParm
                                Set rs = CurrentDb.OpenRecordset(strLock, dbOpenDynaset, dbSeeChanges)
                               
                                rs.Edit
                                    rs.Fields("LD_RECLOCK") = "LOCKED"
                                    rs.Fields("LD_RECLOCK_USER") = Environ("USERNAME")
                                rs.Update
                                rs.Close
                                Set rs = Nothing


  as you don't bother to lock the table while your placing the lock.  If two users go after the same record at the same instant, they both may be granted a lock.   You need to be locking TBL_LOAD_HED while you place the lock.

Also, a comment on this:

strLock = "select * from TBL_LOAD_HED where LD_NUM =" & sParm

 Never return more fields then you need.  And second, this is the actual data table; you don't want your lock flag in there.  Why?

1. You need to lock the table while placing the lock.

2. If the power goes out/shoftware process is interuppted, you'll need to go through every record in the table to clear all the locks.  Again read the article I posted the link to.   A single lock table for all table locks is a much better approach.

Jim.

Jim, thanks again for your assistance.  I am looking at changing the Lock routine to the article you posted.  However I have a question.  I am trying to modify it the the first instance without the flexible options that are not needed.  I have the table set up as below.  I am trying to create the functions but I am getting lost in removing the extra code.  Any Insights to what I should/could remove?

I have changed the name of the table for my standard naming convention.

PLUMMET:

The query string with Joins is a tremendous idea, not sure why I never thought of it.........  

Anyhow, I am getting this error when executing it.

                    strCustInfo = "Select t1.*, t2.CUST_PHONE, t2.CUST_NAME, t3.DET_CITY, t3.DET_STATE, t3.DET_ZIP, t3.DET_PHONE" & _
                        "from TBL_LOAD_HED t1" & _
                        "left join TBL_CUST_HED t2 on t1.LD_CUST_ID = t2.CUST_ID" & _
                        "left join TBL_CUST_DET t3 on t1.LD_SHIPTO_ID = t3.DET_ID" & _
                        "where t1.LD_NUM = " & sParm
                    Set rst = CurrentDb.OpenRecordset(strCustInfo, dbOpenSnapshot) '<<<<<<<<<<<< BREAK HAPPENS HERE
strCustInfo-Error.PNG

It looks like you need to add some spaces - in front of "from", "Left join" (two of these!) and "where"

Otherwise it looks ok I reckon. This will be better:

 

strCustInfo = "Select t1.*, t2.CUST_PHONE, t2.CUST_NAME, t3.DET_CITY, t3.DET_STATE, t3.DET_ZIP, t3.DET_PHONE " & _
                        "from TBL_LOAD_HED t1" & _
                        " left join TBL_CUST_HED t2 on t1.LD_CUST_ID = t2.CUST_ID" & _
                        " left join TBL_CUST_DET t3 on t1.LD_SHIPTO_ID = t3.DET_ID" & _
                        " where t1.LD_NUM = " & sParm

Select allOpen in new window

Cheers,
John

<<Any Insights to what I should/could remove?>>

  There is not much to remove outside of the lock level flag (Resource Tag is = LOC_TABLE_NAME and SubTag = LOC_REC_ID), but why would you want to?  Just drop the code into a module and call it like this:

 Dim varRet as Variant

 varReturn = PlaceResourceLock("TBL_LOAD_HED", sParam, 3,  True)
 If varReturn = True then
    ' Ok to edit the record
 Else
    ' Could not get a lock - message displayed by routine or an error occured - in either case, we do nothing here.
 End If

and to clear:

 varReturn = ClearResourceLock("TBL_LOAD_HED", sParam, WhoAmI(True), WhoAmI(False))

  And your done!

Jim.

John, Query works great in SQL but cannot get it to work in access.  I have messed with it for a long time and give up!  lol.

I have tried changing it to Access SQL but still get an error.  thoughts?

Wow I'm so stupid.  Nevermind on that one John!  I created a view in SQL and using that to populate the form.  Wow, some of us are really slow! haha.

Jim,

I have created the table:

tblResourceLock
LockID – Autonumber – Primary Key
ResourceTag – Text – Index 1A
ResourceSubTag – Text - Index 1B
UserID – Long – User ID that placed lock
DTPlaced – Date/Time
LockLevel – Integer


and created the two Functions for PlaceResourceLock and ClearResourceLock.

Now question is how do I call this in the form?  

Thanks

Here is the latest code.  I have removed all the Dlookup strings.  Changed the Locking to another method. (Similar to Jim's, but still cannot get his to work)

Does this look better?  Anything else I should look at changing?

Private Sub btn_find_Click()
On Error GoTo Err_btn_find_Click

        '--- Set form variables
            
            Dim Tblname As String
            Dim LockUser As String
            Dim LockDate As String
            Dim strUserName As String
            Dim ctl As Control
            Dim rs As Recordset
            Dim strRecLock As String
            Dim sParm As Variant
            
         '--- Set form parameters and set focus on ReqDate control
         
            Tblname = "TBL_LOAD_HED"
            LockUser = foSUserName()
            LockDate = Now()
            sParm = Me.txt_LoadID
            txt_reqDate.SetFocus

         
        '--- Enable message to user "ESC to cancel search" and apply Green button color for search
        
         lbl_cancelsrch.Visible = True
         Me.BTN_FIND.BackColor = RGB(153, 204, 0)
         
        '--- See what state FIND Button is in FIND or SEARCH.  Check to see if form has data or not
        '--- If form has data, prompt user to confirm clearing of form
        
    If BTN_FIND.Caption = "FIND" Then
        If Me.isdirty = True Then
            If MsgBox("Form has been changed.  Do you want to clear the form?", vbYesNo, "WARNING") = vbYes Then
            
                 If DCount("*", "TBL_REC_LOCK", "[LOC_USER_ID] ='" & LockUser & "' And [LOC_TABLE_NAME] = '" & Tblname & "'") >= 1 Then
        
                 DoCmd.SetWarnings False
                 strSQL = "DELETE from [TBL_REC_LOCK] where [LOC_USER_ID] = '" & LockUser & "' and [LOC_TABLE_NAME] = '" & Tblname & "'"
                 DoCmd.RunSQL (strSQL)
                 DoCmd.SetWarnings True
                 
                 End If
            Else
            Exit Sub
            End If

        '--- Clear all form controls upon confirmation
        
                For Each ctl In Me.Controls
                    Select Case ctl.ControlType
                        Case acComboBox, acListBox, acOptionGroup, acTextBox, acCheckBox
                            ctl.Value = ctl.DefaultValue
                            End Select
                            
        '--- Ensure form is back to normal state, no labels showing.  Change FIND button to SEARCH state
        '--- enable LoadID control for search criteria and set focus here
        
                            LBL_CANCELLED.Visible = False
                            lbl_ibshipper.Visible = False
                            btn_Details.Visible = False
                            txt_LoadID.Enabled = True
                            BTN_FIND.Caption = "SEARCH"
                            txt_LoadID.SetFocus
                    Next
        Else
        
        '--- If form is not dirty with record then clear form without user confirmation
        
            If DCount("*", "TBL_REC_LOCK", "[LOC_USER_ID] ='" & LockUser & "' And [LOC_TABLE_NAME] = '" & Tblname & "'") >= 1 Then
   
                DoCmd.SetWarnings False
                strSQL = "DELETE from [TBL_REC_LOCK] where [LOC_USER_ID] = '" & LockUser & "' and [LOC_TABLE_NAME] = '" & Tblname & "'"
                DoCmd.RunSQL (strSQL)
                DoCmd.SetWarnings True
            End If
            
        '--- Clear all form controls
        
                    For Each ctl In Me.Controls
                        Select Case ctl.ControlType
                            Case acComboBox, acListBox, acOptionGroup, acTextBox, acCheckBox
                                ctl.Value = ctl.DefaultValue
                                End Select
                                
                                
        '--- Ensure form is back to normal state, no labels showing.  Change FIND button to SEARCH state
        '--- enable LoadID control for search criteria and set focus here
        
                                Me.LBL_CANCELLED.Visible = False
                                Me.lbl_ibshipper.Visible = False
                                Me.btn_Details.Visible = False
                                Me.txt_LoadID.Enabled = True
                                Me.BTN_FIND.Caption = "SEARCH"
                                txt_LoadID.SetFocus
                        Next
    
        '--- Remove any records in DET TEMP Table for next record

                            DoCmd.SetWarnings False
                            strSQLdel = "Delete * from TBL_LOAD_DET_TEMP"
                            DoCmd.RunSQL strSQLdel
                            DoCmd.SetWarnings True
                            
                Exit Sub
            End If
        
        '--- If FIND Button is in SEARCH state then
        
    ElseIf Me.BTN_FIND.Caption = "SEARCH" Then
    
        Dim LockRecID As String
        LockRecID = txt_LoadID
        
        '--- See if search criteria has been entered.  If no valid criteria then error message to user
        
        If IsNull(txt_LoadID) = True Or txt_LoadID = "" Then
            MsgBox "Nothing to search.  Enter valid Load Number", vbOKOnly, "ERROR"
            txt_LoadID.SetFocus
            Exit Sub
        ElseIf DCount("*", "TBL_LOAD_HED", "[LD_NUM]=" & sParm) = 0 Then
            MsgBox "No records matching search criteria. Enter a valid Load Number", vbOKOnly, "ERROR"
            txt_LoadID.SetFocus
            Exit Sub
        End If
        
        '--- check to see if record is locked before ruturning record to user.  If locked LOCK notification
        '--- to user, exit sub, set focus to LoadID control
                

        If DCount("*", "TBL_REC_LOCK", "[LOC_REC_ID] ='" & LockRecID & "' And [LOC_TABLE_NAME] = '" & Tblname & "'") >= 1 Then
           MsgBox "Another User has this record locked.  Try again later", vbOKOnly, "RECORD LOCKED"
           txt_LoadID.SetFocus
           Exit Sub
        End If
        
    
        '--- If valid criteria and no locks found then return FIND button to FIND state and original color
        '--- set form to dirty
            
                Me.BTN_FIND.Caption = "FIND"
                BTN_FIND.BackColor = RGB(47, 54, 153)
                Me.isdirty = True
                
        '--- Run query to populate form with record
        
                strSQL = "Select * from VW_LOAD_HED where LD_NUM =" & sParm
                Set rs = CurrentDb.OpenRecordset(strSQL)
                
                    rs.MoveFirst
                        txt_carrier = rs.Fields("LD_CARRIER")
                        txt_reqDate = rs.Fields("LD_REQ_DATE")
                        txt_shipDate = rs.Fields("LD_SHIP_DATE")
                        cbo_custID = rs.Fields("LD_CUST_ID")
                        txt_CustName = rs.Fields("LD_CUST_NAME")
                        txt_CustCity = rs.Fields("LD_CUST_CITY")
                        txt_CustState = rs.Fields("LD_CUST_STATE")
                        txt_CustZip = rs.Fields("LD_CUST_ZIP")
                        txt_custPhone = rs.Fields("CUST_PHONE")
                        txt_delCarrier = rs.Fields("LD_DEL_CARRIER")
                        txt_apptDate = rs.Fields("LD_APPT_DATE")
                        txt_apptTime = rs.Fields("LD_APPT_TIME")
                        cbo_shipToID = rs.Fields("LD_SHIPTO_ID")
                        txt_shipToName = rs.Fields("DET_NAME")
                        txt_shipToCity = rs.Fields("DET_CITY")
                        txt_shipToState = rs.Fields("DET_STATE")
                        txt_shipToZip = rs.Fields("DET_ZIP")
                        txt_shipToPh = rs.Fields("DET_PHONE")
                        txt_Instr = rs.Fields("LD_INSTRUCTIONS")
                        txt_delDate = rs.Fields("LD_DEL_DATE")
                        txt_bolNum = rs.Fields("LD_SHIP_NUM")
                        txt_bolLoc = rs.Fields("LD_SHIP_LOC")
                        cbo_inbShipperID = rs.Fields("LD_INB_SHIPPER")
                        txt_locName = rs.Fields("LD_LOC")
                        cbo_loc = rs.Fields("LD_LOC")
                        txt_createdBy = rs.Fields("LD_CREATED_BY")
                        txt_createdOn = rs.Fields("LD_CREATED_DATE")
                        txt_modifiedBy = rs.Fields("LD_MODIFIED_BY")
                        txt_modifiedOn = rs.Fields("LD_MODIFIED_DATE")
                    rs.Close
                    Set rs = Nothing
                    
        '--- Append LOAD DET records to TEMP table and requery DET subform
                    
                    DoCmd.SetWarnings False
                    DoCmd.OpenQuery "QRY_LOAD_DET_FIND", acViewNormal
                    DoCmd.SetWarnings True
                    
                    Forms![frm_build_load].[FRM_LOAD_DET].Requery
                    
        '--- Hide message "ESC to cancel search"
                    
                    Me.lbl_cancelsrch.Visible = False
                    
        '--- Apply record lock to selected record
                    
                DoCmd.SetWarnings False
                    strSQL = "INSERT INTO TBL_REC_LOCK ([LOC_TABLE_NAME],[LOC_REC_ID],[LOC_USER_ID],[LOC_DT_PLACED])" & _
                        "VALUES ('" & Tblname & "', '" & LockRecID & "', '" & LockUser & "', '" & LockDate & "')"
                
                DoCmd.RunSQL (strSQL)
                DoCmd.SetWarnings True
                          
    End If
        
Exit_btn_find_Click:
    Exit Sub

Err_btn_find_Click:
    MsgBox Err.Description
    Resume Exit_btn_find_Click
    
End Sub

Select allOpen in new window

Changing  "DoCmd.RunSQL (strSQL) " to "CurrentDB.Execute strSQL" did the trick for performance!  

Thanks guys for your assistance on this!  You have been a tremendous help!  

I am splitting the points to both since you both gave valuable solutions on this optimization!

The answers to this question have been a tremendous help!  Thanks to everyone who helped out.  Wish I had more points to allocate!

I'm surprised that you didn't also select my first comment, especially since you did select comment #36486853, which said exactly the same thing (i.e. move the code our of your loops, and use Currentdb.Execute instead of DoCmd.RunSQL).

Sorry LSM!!!  Its very hard to award points in this system with so many great people helping!  I did overlook you this time.  

Sorry AGAIN!

No troubles, just wanted to make the point that the comment suggested had been offered previously. It's really up to the Experts to insure they do not duplicate posts. As the question thread gets longer, however, that becomes a bit more difficult of course, but taking the time to review previous comments is just part of the deal (at least in my opinion).

Scott