Aplicar filtro a un formulario según criterios

adminoctubre 17, 2024

0 1 2 minutos de lectura

Vba

'*************** Code Start *****************************************************
' code: cmd_ApplyFilter_Click
'-------------------------------------------------------------------------------
' Purpose  : VBA for a command button Click event to apply a filter to a form
'              this example applies the filter to a subform
' Author   : crystal (strive4peace)
' Code List: www.MsAccessGurus.com/code.htm
' This code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------

   
Private Sub cmd_ApplyFilter_Click() 
'221101...09, 221123 comment

   'dimension variables
   Dim sText As String _ 
      ,vWhere As Variant 
      
   'initialize variables
   vWhere = Null 
   
   'construct WHERE clause
   'sText is temporarily used in multiple places
   
   '---------------- Category is Built-in, Custom
   'construct criteria value for Cat
   Select Case Me.fltr_BC 
      Case 1: sText =  "C" 'custom
      Case 2: sText =  "B" 'built-in
      Case Else: sText =  "" 'not specified
   End Select 
   
   If sText   "" Then 
      'even though this is the first criteria for now,
      'consider that order might be changed for better performance
      vWhere = (vWhere +  " AND ") _ 
         &  "(Cat="" & sText &  "")"
   End If 
   
   '---------------- Data Type
   'construct full criteria clause to add
   '     uses = or IN
   sText =  ""
               
   With Me.fltr_DataTypi 
      If Not IsNull(.Value) Then 
         Select Case .Value 
         Case -10,-8,-1  'TEXT, DATE, YES/NO
             sText =  "DataTypi = " & Abs(.Value) 
         Case -9  'NUMBER - byte, int, long, cur, sgl, dbl
            sText =  "DataTypi IN (2,3,4,5,6,7)"
          Case 1 To 10  'mostly Standard data types
            sText =  "DataTypi = " & .Value 
         End Select 
      End If 
   End With 
   
   If sText   "" Then 
      vWhere = (vWhere +  " AND ") _ 
         &  "(" & sText &  ")"
   End If 
   
   '---------------- Pattern
   With Me.fltr_Pattern 
      If Not IsNull(.Value) Then 
         'problem if value has a double quote "
         'replace one double quote with 2
         ' use 2 double quotes inside string delimited with "
         vWhere = (vWhere +  " AND ") _ 
            &  "(PropName LIKE ""*" _ 
               & Replace(.Value, """", """""") _ 
               &  "*"")"
      End If 
   End With 
   
   '---------------- HasValue
   With Me.fltr_HasValue 
      If Not IsNull(.Value) Then 
         vWhere = (vWhere +  " AND ") _ 
            &  "(ActiveValue Is " _ 
            & IIf(.Value, "Not ", "") _ 
            &  "Null )"
      End If 
   End With 
   
   '---------------- ChangedValue
   With Me.fltr_ChangedValue 
      If Not IsNull(.Value) Then 
         vWhere = (vWhere +  " AND ") _ 
            &  "(NewValue " _ 
            & IIf(.Value, " 0)", " =0)") 
      End If 
   End With 
   
   '----------------
   'apply filter to subform
   '  or show all records
   
   With Me.dm_f_PropertyList.Form  'form to apply filter
      If Not IsNull(vWhere) Then 
         .Filter = vWhere 
         .FilterOn = True 
      Else 
         .FilterOn = False 
      End If 
   End With 
   
End Sub 
'*************** Code End *******************************************************