Option Compare Database
Option Explicit
Option Base 1
Dim rst As Recordset
Dim sNaam As String, sTag As String, tmp As String, sWaarde As String
Dim x As Integer, i As Integer
Private Sub Bedrijfsnaam_BeforeUpdate(Cancel As Integer)
End Sub
Private Sub Form_Current()
CheckScrollbar
End Sub
Private Sub Form_Load()
CheckScrollbar
End Sub
Private Sub cmdFilterLeeg_Click()
Dim sControl As String
''MsgBox TypeName(sControl)
sControl = Screen.PreviousControl.Name
For i = 1 To 4
Me("txtFilter" & i).Value = ""
Next i
Me.Filter = ""
Me.FilterOn = False
Me.Requery
Me.Repaint
Me(sControl).SetFocus
CheckScrollbar
'' Form_Current
End Sub
Private Sub fraOptie_AfterUpdate()
CheckFilter
End Sub
Private Sub txtFilter1_Change()
sNaam = Screen.ActiveControl.Name
sTag = Screen.ActiveControl.Tag
sWaarde = Me(sNaam).Text
CheckFilter sNaam, sWaarde
Me.txtFilter1 = sWaarde
Me.txtFilter1.SelStart = Me.txtFilter1.SelLength
End Sub
Private Sub txtFilter2_Change()
sNaam = Screen.ActiveControl.Name
sTag = Screen.ActiveControl.Tag
sWaarde = Me(sNaam).Text
CheckFilter sNaam, sWaarde
Me.txtFilter2 = sWaarde
Me.txtFilter2.SelStart = Me.txtFilter2.SelLength
End Sub
Private Sub txtFilter3_Change()
sNaam = Screen.ActiveControl.Name
sTag = Screen.ActiveControl.Tag
sWaarde = Me(sNaam).Text
CheckFilter sNaam, sWaarde
Me.txtFilter3 = sWaarde
Me.txtFilter3.SelStart = Me.txtFilter3.SelLength
End Sub
Private Sub txtFilter4_Change()
sNaam = Screen.ActiveControl.Name
sTag = Screen.ActiveControl.Tag
sWaarde = Me(sNaam).Text
CheckFilter sNaam, sWaarde
Me.txtFilter4 = sWaarde
Me.txtFilter4.SelStart = Me.txtFilter4.SelLength
End Sub
Private Function CheckFilter(Optional Zoekveld As String, Optional Waarde As String)
Dim sFilter As String
Dim sFilters() As String, sTekst() As String
Dim ctl As Control
Dim sAndOr As String
Dim tmpMatrix
Dim tmp
Dim rst As Recordset
Dim iFltr As Integer, iLst As Integer
Dim skeuze As String
Dim itm As String 'WERKTniet
'-----------------------------------------------------------------------------------------------------------
'Eerst de grootte van de matrix bepalen....
'Dat doen we door alle filters door te lopen, en de inhoud in een matrix te zetten.
'We lopen door de controls heen op basis van het ControlType.
'-----------------------------------------------------------------------------------------------------------
x = 0
iFltr = 0
iLst = 0
For Each ctl In Controls
With ctl
Select Case .ControlType
Case acTextBox
If LCase(Left(.Name, 9)) = "txtFilter" Then
.SetFocus
iFltr = iFltr + 1
On Error Resume Next
If Not .Text = "" Then
x = x + 1
If x = 1 Then
ReDim sTekst(x)
Else
ReDim Preserve sTekst(x)
End If
'-----------------------------------------------------------------------------------
'De matrix wordt gevuld met de Veldnaam, de Filternaam en het Filterveld.
'Deze worden met een scheidingsteken in één string gezet die later gesplitst wordt.
'-----------------------------------------------------------------------------------
sTekst(x) = .Tag & "|" & .Text & "|" & .Name
End If
End If
Case acListBox
'-------------------------------------------------------------------------------------------
'Een listbox kan meerdere items bevatten die geselecteerd worden.
'Die moeten allemaal apart worden uitgelezen.
'-------------------------------------------------------------------------------------------
If LCase(Left(.Name, 9)) = "lstFilter" Then
skeuze = ""
.SetFocus
iFltr = iFltr + 1
iLst = iLst + 1
On Error Resume Next
If Me("lstFilter" & iLst).ItemsSelected.Count >= 1 Then
x = x + 1
If x = 1 Then
ReDim sTekst(x)
Else
ReDim Preserve sTekst(x)
End If
hier gaat het fout---->> [COLOR="#FF0000"] For Each itm In Me("lstFilter" & iLst).ItemsSelected[/COLOR]
skeuze = skeuze & Me("lstFilter" & iLst).ItemData(itm) & "\"
Next itm
Do While Right(skeuze, 1) = "\"
skeuze = Left(skeuze, Len(skeuze) - 1)
Loop
'-----------------------------------------------------------------------------------
'Ook hier wordt een samengestelde string gemaakt van de filterwaarden.
'-----------------------------------------------------------------------------------
sTekst(x) = .Tag & "|" & skeuze & "|" & .Name
End If
End If
Case acComboBox
If LCase(Left(.Name, 9)) = "cboFilter" Then
.SetFocus
iFltr = iFltr + 1
On Error Resume Next
If Not .Value = "" Then
x = x + 1
If x = 1 Then
ReDim sTekst(x)
Else
ReDim Preserve sTekst(x)
End If
sTekst(x) = .Tag & "|" & .Text & "|" & .Name
End If
End If
End Select
End With
Next ctl
'-----------------------------------------------------------------------------------------------------------
'Als de tekstfilters leeg zijn, dan filter leegmaken en stoppen....
'-----------------------------------------------------------------------------------------------------------
If x = 0 Then GoTo LeegFilter
'...... anders doorgaan, en matrix herdefiniëren.
'===========================================================================================================
'-----------------------------------------------------------------------------------------------------------
'Dan de variabelen vullen met gegevens
'We doen dat door een extra matrix te maken op basis van het filter
'-----------------------------------------------------------------------------------------------------------
ReDim sFilters(x, 3)
For i = LBound(sFilters) To UBound(sFilters)
tmpMatrix = Split(sTekst(i), "|")
For x = LBound(tmpMatrix) To UBound(tmpMatrix)
sFilters(i, x + 1) = tmpMatrix(x)
Next x
Next i
i = 0
x = 0
'===========================================================================================================
'-----------------------------------------------------------------------------------------------------------
'Dan op basis van de variabelen het filter opbouwen
'-----------------------------------------------------------------------------------------------------------
Select Case Me.fraOptie.Value
Case 1
sAndOr = " AND "
Case 2
sAndOr = " OR "
End Select
sFilter = ""
For i = LBound(sFilters) To UBound(sFilters)
If LBound(sFilters) = UBound(sFilters) Then
If InStr(sFilters(i, 2), "\") > 0 Then
tmpMatrix = Split(sFilters(i, 2), "\")
For x = LBound(tmpMatrix) To UBound(tmpMatrix)
'-------------------------------------------------------------------------------------------
'Eerst controleren of er getallen in het spel zijn, of tekst.
'-------------------------------------------------------------------------------------------
If IsNumeric(tmpMatrix(x)) Then
sFilter = sFilter & "[" & sFilters(i, 1) & "] = " & tmpMatrix(x)
Else
sFilter = sFilter & "[" & sFilters(i, 1) & "] Like ""*" & tmpMatrix(x) & "*"""
End If
If x < UBound(tmpMatrix) Then sFilter = sFilter & " OR "
Next x
Else
sFilter = sFilter & "[" & sFilters(i, 1) & "] Like ""*" & sFilters(i, 2) & "*"""
End If
Else
'---------------------------------------------------------------------------------------------------
'Vervolgens controleren of de listbox meerdere items bevat, die gesplitst moeten worden.
'Die worden dan allemaal apart worden uitgelezen en in het filter gezet.
'---------------------------------------------------------------------------------------------------
If InStr(sFilters(i, 2), "\") > 0 Then
tmpMatrix = Split(sFilters(i, 2), "\")
For x = LBound(tmpMatrix) To UBound(tmpMatrix)
'-------------------------------------------------------------------------------------------
'Uiteraard ook hier weer controleren of er getallen in het spel zijn, of tekst.
'-------------------------------------------------------------------------------------------
If IsNumeric(tmpMatrix(x)) Then
sFilter = sFilter & "[" & sFilters(i, 1) & "] = " & tmpMatrix(x)
Else
sFilter = sFilter & "[" & sFilters(i, 1) & "] Like ""*" & tmpMatrix(x) & "*"""
End If
If x < UBound(tmpMatrix) Then sFilter = sFilter & " OR "
Next x
Else
If IsNumeric(sFilters(i, 2)) Then
sFilter = sFilter & "[" & sFilters(i, 1) & "] = " & sFilters(i, 2)
Else
sFilter = sFilter & "[" & sFilters(i, 1) & "] Like ""*" & sFilters(i, 2) & "*"""
End If
If i < UBound(sFilters) Then
sFilter = sFilter & sAndOr
End If
End If
End If
Next i
'===========================================================================================================
'-----------------------------------------------------------------------------------------------------------
'Filter vervolgens op formulier toepassen.
'-----------------------------------------------------------------------------------------------------------
Me.Filter = sFilter
Me.FilterOn = True
If Not Zoekveld = "" Then
Me(Zoekveld).SetFocus
End If
'===========================================================================================================
'-----------------------------------------------------------------------------------------------------------
'En als laatste functie om de verticale scrollbar aan- of uit te zetten.
'-----------------------------------------------------------------------------------------------------------
CheckScrollbar
'===========================================================================================================
Exit Function
LeegFilter:
Me.Filter = ""
Me.FilterOn = False
On Error Resume Next
Me(Zoekveld).SetFocus
End Function
Function CheckScrollbar()
Set rst = Me.RecordsetClone
If Me.NewRecord Then
Me!lblNavigate.Caption = "New Record"
Else
With rst
.Bookmark = Me.Bookmark
Me!lblNavigate.Caption = "Record " & _
.AbsolutePosition _
& " of " & .RecordCount
End With
End If
On Error GoTo Stoppen
rst.MoveLast
rst.MovePrevious
If rst.RecordCount < 26 Then
Me.ScrollBars = 0
Else
Me.ScrollBars = 2
End If
Stoppen:
End Function
