Change Query Top Values Property with VBA-2 ~ LEARN MS-ACCESS TIPS AND TRICKS

Continued from Last Week's Topic.

Through last week’s introduction, we have seen various ways the Top Value and other properties change the SQL string of a SELECT Query. Now we will learn how to redefine the Query for the Top Values and other property changes.

As I have mentioned earlier three types of Queries; SELECT, APPEND, and MAKE-TABLE only have the Top Values property. SELECT and MAKE-TABLE queries have almost identical SQL string with DISTINCT, TOP nn, PERCENT clauses appearing immediately after the SELECT clause at the beginning of the SQL string.

A sample SQL string of a make-table query is given below:

SELECT TOP 15 PERCENT SalesReportQ.* INTO chart
FROM SalesReportQ
ORDER BY SalesReportQ.Total DESC;

Unlike SELECT and MAKE-TABLE Queries APPEND Queries have the Top Values property settings inserted somewhere in the middle of the SQL string immediately after the SELECT clause. Check the sample SQL of Append Query given below:

INSERT INTO Table3 ( xID, Field1, Field2 )
SELECT DISTINCT TOP 17 PERCENT Table2.ID, Table2.Field1, Table2.Field2
FROM Table2
ORDER BY Table2.ID DESC;

Our VBA program scans through the SQL String to find the TOP Values property Clauses in the SQL String(wherever they appear), removes the existing settings, and insert changes as per input from the User.

First, we will create a form for the User to input Query Top Values property values and click a Command Button to redefine the SQL.

Image of a sample form is given below:

Two text boxes with the name Qry and TopVal, for Query name and for Top values parameters respectively, and a checkbox with the name Unik for Unique value selection. The Top Values text box can be set with a number or a number with a percentage symbol (like 20 or 15%). If the Unik checkbox is set then the query suppresses duplicate records based on the selected field values in the Query.

After setting the Query property values in the above controls the user should click the Command Button to redefine the SQL of the selected query in the Query Name control. The Command Button's name is cmdRun (with the Caption: Modify Query). When the Command Button is clicked the cmdRun_Click() Event Procedure is run (the VBA Code is given below) and validates the input values in the controls above and calls the QryTopVal() function (with parameters: query name, Top Values property value, and Checkbox value) to redefine the Query based on the user inputs.

Form Module Code.

Private Sub cmdRun_Click()
Dim strQuery, strTopVal, bool As Boolean
Dim msg As String

On Error GoTo cmdRun_Click_Err

msg = ""
strQuery = Nz(Me![Qry], "")
If Len(strQuery) = 0 Then
   msg = "  *>>  Query Name not found." & vbCr
End If
strTopVal = Nz(Me![TopVal], 0)
If strTopVal = 0 Then
   msg = msg & "  *>>  Top Property Value not given."
End If
bool = Nz(Me![Unik], 0)
If Len(msg) > 0 Then
    msg = "Invalid Parameter Values:" & vbCr & vbCr & msg
    msg = msg & vbCr & vbCr & "Query not changed, Program Aborted...."
    MsgBox msg, , "cmdRun_Click()"
Else
    'Call the QryTopVal() Function to redefine the Query
    QryTopVal strQuery, strTopVal, bool
End If

cmdRun_Click_Exit:
Exit Sub

cmdRun_Click_Err:
MsgBox Err.Description, , "cmdRun_Click()"
Resume cmdRun_Click_Exit
End Sub

Copy and paste the above VBA Code into the Form Module and save the Form. Don't forget to name the Command Button as cmdRun.

The Main Function QryTopVal().

The main function QryTopVal() checks the Query Type (SELECT or APPEND or MAKE-TABLE) and if found valid then reads the SQL of the query. Checks for the existence of Top Values and other Property settings and if they exist then remove them. Redefines the query based on the Top Values and other property inputs from the user.

Copy and paste the following VBA Code of QryTopVal() into the Standard Module and save it:

Public Function QryTopVal(ByVal strQryName As String, _
                       ByVal TopValORPercent As String, _
                       Optional ByVal bulUnique As Boolean = False)
'--------------------------------------------------------------------
'Author : a.p.r. pillai
'Date   : Jun 2011
'Remarks: All Rights Reserved by www.msaccesstips.com
'Valid Query Types:
'  0 - SELECT
' 64 - APPEND
' 80 - MAKE TABLE
'--------------------------------------------------------------------
Dim strSQL1 As String, strSQL2 As String, strTopValue
Dim db As Database, qrydef As QueryDef, sql As String
Dim loc, qryType As Integer, locTop
Dim txt(1 To 3) As String, num
Dim J, xt, msg As String

On Error GoTo QryTopVal_Err

txt(1) = "DISTINCT"
txt(2) = "TOP"
txt(3) = "PERCENT"

Set db = CurrentDb
Set qrydef = db.QueryDefs(strQryName)
qryType = qrydef.Type

If qryType = 0 Or qryType = 64 Or qryType = 80 Then
   xt = qrydef.sql

   GoSub ParseSQL

   loc = InStr(1, TopValORPercent, "%")

   If loc > 0 Then
      TopValORPercent = Left(TopValORPercent, Len(TopValORPercent) - 1)
   End If

   If Val(TopValORPercent) = 0 Then
      sql = strSQL1 & strSQL2
   Else
      sql = strSQL1 & IIf(bulUnique, "DISTINCT ", "") & "TOP " & TopValORPercent & IIf(loc > 0, " PERCENT ", "") & strSQL2
   End If

   qrydef.sql = sql
   msg = "Query Definition of " & strQryName & vbCr & vbCr & "Changed successfully."
   MsgBox msg, , "QryTop()"
Else
   msg = strQryName & " - Invalid Query Type" & vbCr & vbCr
   msg = msg & "Valid Query Types: SELECT, APPEND and MAKE-TABLE"
   MsgBox msg, , "QryTop"
End If

QryTopVal_Exit:
Exit Function

ParseSQL:
For J = 1 To UBound(txt)
  xt = Replace(xt, txt(J), "", 1)
Next
  
  locTop = InStr(1, xt, "SELECT")
  num = Val(Mid(xt, locTop + 7))
  num = " " & Format(num) & " "
  strSQL1 = Left(xt, locTop + 7)
  xt = Right(xt, Len(xt) - (locTop + 7))
  xt = Replace(xt, num, "", 1, 1)
  strSQL2 = " " & xt
  locTop = InStr(1, strSQL2, "ORDER BY")
  If locTop = 0 Then
    MsgBox "ORDER BY Clause not found in Query.  Result may not be correct.", , "QryTopVal()"
  End If
Return

QryTopVal_Err:
MsgBox Err & " : " & Err.Description, , "QryTopVal()"
Resume QryTopVal_Exit

End Function

You may try the Code with sample Queries.