Option Compare Database\nOption Explicit\n \' (с) Козин Алексей, Удалов Георгий\n 
\nPublic Function OrderByAcs()\n  Dim ctl As Access.Control\n  Dim bt As Boolean\n  Dim frm\n  \n  If Screen.ActiveControl.ControlType = acComboBox Then\n    On Error Resume Next\n    Set ctl = Screen.ActiveControl\n    Set frm = ctl.Parent\n    If Err.Number <>  0  Then Exit Function\n    If frm.Form.Name = "" Then\n    End If\n    Do While Err.Number <>  0  And Len(frm.Name) >  0   \' в frm находится, например, ссылка на вкладку\n 
      Set frm = frm.Parent\n      Err.Clear\n      If frm.Form.Name = "" Then\n      End If\n    Loop\n    \n    Err.Clear\n    If frm.RecordsetClone.Fields("~" & ctl.Name).Name = "" Then\n    End If\n    If Err.Number =  0  Then bt = True  \' Есть поле, по которому можно сортировать\n 
    On Error GoTo  0 \n    \n    If bt Then\n      frm.OrderBy = "~" & ctl.Name & ""\n      frm.OrderByOn = True\n    Else\n      RunCommand acCmdSortAscending\n    End If\n  Else\n    RunCommand acCmdSortAscending\n  End If\nEnd Function\n\nPublic Function OrderByDesc()\n  Dim ctl As Access.Control\n  Dim bt As Boolean\n  Dim frm\n  \n  If Screen.ActiveControl.ControlType = acComboBox Then\n    On Error Resume Next\n    Set ctl = Screen.ActiveControl\n    Set frm = ctl.Parent\n    If Err.Number <>  0  Then Exit Function\n    If frm.Form.Name = "" Then\n    End If\n    Do While Err.Number <>  0  And Len(frm.Name) >  0   \' в frm находится, например, ссылка на вкладку\n 
      Set frm = frm.Parent\n      Err.Clear\n      If frm.Form.Name = "" Then\n      End If\n    Loop\n    \n    Err.Clear\n    If frm.RecordsetClone.Fields("~" & ctl.Name).Name = "" Then\n    End If\n    If Err.Number =  0  Then bt = True  \' Есть поле, по которому можно сортировать\n 
    On Error GoTo  0 \n    \n    If bt Then\n      frm.OrderBy = "[~" & ctl.Name & "] DESC"\n      frm.OrderByOn = True\n    Else\n      RunCommand acCmdSortDescending\n    End If\n  Else\n    RunCommand acCmdSortDescending\n  End If\nEnd Function\n\nPublic Function SetServerFilterBySel()\n  Dim ctl As Access.Control\n  Dim sf\n  Dim frm, findtext\n\n  On Error Resume Next\n  Set ctl = Screen.ActiveControl\n  Set frm = ctl.Parent\n  If Err.Number <>  0  Then Exit Function\n  If frm.Form.Name = "" Then\n  End If\n  Do While Err.Number <>  0  And Len(frm.Name) >  0   \' в frm находится, например, ссылка на вкладку\n 
    Set frm = frm.Parent\n    Err.Clear\n    If frm.Form.Name = "" Then\n    End If\n  Loop\n  On Error GoTo  0 \n  \n  Select Case ctl.ControlType\n  Case acTextBox:\n    Select Case VarType(ctl.Value)\n      Case  2  To  6 ,  14 ,  17 :\n        findtext = ctl.Value\n        sf = "[" & ctl.ControlSource & "]=" & findtext\n      Case Else\n        If ctl.SelText = "" Then\n          findtext = ctl.Text\n        Else\n          findtext = ctl.SelText\n        End If\n        findtext = Replace(findtext, "\'", "\'\'", , , vbTextCompare)\n        findtext = Replace(findtext, """", "\' + char(34) + \'", , , vbTextCompare)\n        If ctl.SelText = ctl.Text Or Len(Nz(ctl.SelText)) =  0  Then\n          If Len(Nz(findtext)) =  0  Then\n            sf = "([" & ctl.ControlSource & "] = \'\' OR [" & ctl.ControlSource & "] IS NULL)"\n          Else\n            sf = "[" & ctl.ControlSource & "] = \'" & findtext & "\'"\n          End If\n        Else\n          sf = "[" & ctl.ControlSource & "] like  \'%" & findtext & "%\'"\n        End If\n    End Select\n  Case acComboBox, acListBox:\n     \' В полях со списками надо брать value, т.к. отображаемый столбец м.б. несвязанным\n 
     \' Перед фильтрацией надо обновить содержимое поля\n 
    findtext = Nz(ctl.Value)\n    findtext = Replace(findtext, "\'", "\'\'", , , vbTextCompare)\n    findtext = Replace(findtext, """", "\' + char(34) + \'", , , vbTextCompare)\n    If Len(findtext) =  0  Then\n      sf = "[" & ctl.ControlSource & "] is null"\n    Else\n      sf = "[" & ctl.ControlSource & "] = \'" & findtext & "\'"\n    End If\n  Case acCheckBox:\n    If ctl.Value =  0  Then\n      sf = "[" & ctl.ControlSource & "]=0"\n    Else\n      sf = "[" & ctl.ControlSource & "]<>0"\n    End If\n  End Select\n  \n  If Len(Nz(frm.ServerFilter)) =  0  Then\n    If Len(Nz(sf)) <>  0  Then\n      frm.ServerFilter = sf\n      frm.RecordSource = frm.RecordSource\n    End If\n  Else\n    If sf <> "" Then\n      frm.ServerFilter = frm.ServerFilter & " AND " & sf\n      frm.RecordSource = frm.RecordSource\n    End If\n  End If\nEnd Function\n\nPublic Function ClearServerFilter()\n  Dim ctl As Access.Control\n  Dim frm\n  \n  On Error Resume Next\n  Set ctl = Screen.ActiveControl\n  If ctl.ControlType = acSubform Then\n    Set frm = ctl.Form\n  Else\n    Set frm = ctl.Parent\n  End If\n  If Err.Number <>  0  Then Exit Function\n  If frm.Form.Name = "" Then\n  End If\n  Do While Err.Number <>  0  And Len(frm.Name) >  0   \' в frm находится, например, ссылка на вкладку\n 
    Set frm = frm.Parent\n    Err.Clear\n    If frm.Form.Name = "" Then\n    End If\n  Loop\n  On Error GoTo  0 \n  \n  frm.ServerFilter = ""\n  frm.RecordSource = frm.RecordSource\nEnd Function