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