Private Sub SetFilter()
  ' Filter auf Recordset anwenden
  Dim i As Long
  Dim sOp As String
  Dim sValue As String
  Dim sOrder As String
  Dim bText As Boolean
  Dim nScrollPos As Long
  Dim sText As String
  Dim oRs As DAO.Recordset
 
  On Error GoTo ErrHandler
 
  sWHERE = ""
  With Grid1
    .LockUpdate True
 
    For i = 1 To .Cols
      sText = .Columns(i).Filter
      sFilter(i) = sText
 
      If Not .Columns(i).FilterShowDisabled And Len(sText) > 0 Then
        .Columns(i).ImageAlign = ALIGNMENT_RIGHT
        .Columns(i).Image = 3
 
        ' handelt es sich um ein Text- oder um ein numerisches Feld?
        Select Case .Columns(i).DataType
          Case dtText, dtMemo, dtHyperlink
            bText = True
          Case Else
            bText = False
        End Select
 
        ' Falls Inhalt-Spalte -> gemerkte ID verwenden
        If i = .GetCol("Inhalt") Then sText = CStr(.Columns(i).Tag)
        ' Falls Artikelgruppe-Spalte -> gemerkte ID verwenden
        If i = .GetCol("Artikelgruppe") Then sText = CStr(.Columns(i).Tag)
        ' Falls LieferantNr-Spalte -> gemerkte ID verwenden
        If i = .GetCol("LieferantNr") Then sText = CStr(.Columns(i).Tag)
 
        ' Filterbedingung zusammenstellen
        If Left$(sText, 2) = "<>" Then
          sOp = "<>"
          sValue = LTrim$(Mid$(sText, 3))
        ElseIf UCase$(Left$(sText, 9)) = "NOT LIKE " Then
          sOp = "NOT LIKE"
          sValue = LTrim$(Mid$(sText, 10))
        ElseIf UCase$(Left$(sText, 4)) = "NOT " Then
          sOp = "NOT"
          sValue = LTrim$(Mid$(sText, 5))
        ElseIf Left$(sText, 2) = ">=" Or Left$(sText, 2) = "=>" Then
          sOp = ">="
          sValue = LTrim$(Mid$(sText, 3))
        ElseIf Left$(sText, 2) = "<=" Or Left$(sText, 2) = "=<" Then
          sOp = "<="
          sValue = LTrim$(Mid$(sText, 3))
        ElseIf InStr("<>=", Left$(sText, 1)) > 0 Then
          sOp = Left$(sText, 1)
          sValue = LTrim$(Mid$(sText, 2))
        Else
          sOp = IIf(bText, "LIKE", "=")
          sValue = sText
          If sValue = "''" Or sValue = String$(2, Chr$(34)) Then sValue = ""
          If bText Then
            If Right$(sValue, 1) = "%" Then
              sValue = Left$(sValue, Len(sValue) - 1) & "*"
            ElseIf Right$(sValue, 1) <> "*" Then
              sValue = sValue & "*"
            End If
          End If
        End If
 
        If sValue = "''" Or sValue = String$(2, Chr$(34)) Then sValue = ""
        If bText And Left$(sValue, 1) <> "'" And Len(sValue) > 0 Then
          If .Columns(i).DataType = dtHyperlink Then sValue = "#" & sValue
          sValue = "'" & sValue & "'"
        Else
          If .Columns(i).DataType = dtBoolean Then
            sValue = IIf(sValue = "ja", "True", "False")
          ElseIf .Columns(i).DataType = dtDate Then
            If IsDate(sValue) Then
              sValue = "#" & Format$(CDate(sValue), "m-d-yy") & "#"
            End If
          End If
        End If
 
        ' WHERE-Bedingung zusammenbauen
        sWHERE = sWHERE & "([" & .Recordset.Fields(i - 1).Name & "] " & sOp & "" & _
          "" & sValue & ") AND "
      Else
        .Columns(i).Image = 0
      End If
    Next i
 
    ' aktuell eingestellte Sortierung merken
    sOrder = .SortOrder
 
    ' horizontale Scroll-Position merken
    nScrollPos = .HScrollPos
 
    If sWHERE = "" Then
      ' Filter ausschalten
      Set oRs = oDB.OpenRecordset(sSQL)
      bIsFilterSet = False
    Else
      ' Filter einschalten
      sWHERE = Left$(sWHERE, Len(sWHERE) - 5)
      Set oRs = oDB.OpenRecordset(sSQL & " WHERE " & sWHERE)
      bIsFilterSet = True
    End If
    Set .Recordset = oRs
 
    ' Sortierung einstellen
    .DoSort sOrder
 
    ' horizontale Scrollposition wiederherstellen
    .HScrollPos = nScrollPos
 
    ' Summe der Beträge ermitteln
    'ShowSumme
 
    .LockUpdate False
    .Refresh
 
  End With
  oRs.Close
 
ErrEnd:
  Set oRs = Nothing
  Exit Sub
 
ErrHandler:
  MsgBox "Fehler beim Setzen des Filters!" & vbCrLf & CStr(Err.Number) & " - " _
    & Err.Description
  Grid1.LockUpdate False
  Resume ErrEnd
End Sub