VBA, MS Access MS Access в примерах

Фильтрация Ленточной формы по различным полям и по диапазону дат (+ Пример)

Код из формы :

Private Sub cbxДолжность_AfterUpdate() 'Событие : "После Обновления"
    FormRefilter
End Sub

Private Sub cbxСотрудник_AfterUpdate() 'Событие : "После Обновления"
    FormRefilter
End Sub

Private Sub cmdRemoveFilter_Click()
'Зачистка фильтра:
    Me!txtДатаС = Null
    Me!txtДатаПо = Null
    Me!cbxДолжность = Null
    Me!cbxСотрудник = Null
    Me!txtПримечание = Null
    FormRefilter
End Sub

Private Sub FormRefilter()
'Построение фильтра по полям (если не пустые):
Dim sFilter$, sTemp$

'Даты c - по (Поле:"ДатаНач"):
    If IsNull(Me!txtДатаС) = False Or IsNull(Me!txtДатаПо) = False Then
        sFilter = sFilter & _
        " AND ДатаНачала Between " & Format$(Nz(Me!txtДатаС, 0), "\#mm\/dd\/yyyy\#") & _
        " AND " & Format$(Nz(Me!txtДатаПо, 999999), "\#mm\/dd\/yyyy\#")
        '0 = 30.12.1899 и 999999 = 25.11.4637! :)
    End If
    
'Должность (Поле:"ДолжностьКод"):
    If Me!cbxДолжность.ListIndex > -1 Then 'Значение выбрано
        sFilter = sFilter & " AND ДолжностьКод = " & Me!cbxДолжность 
    End If
    
'Сотрудник (Поле:"СотрудникКод"):
    If Me!cbxСотрудник.ListIndex > -1 Then 'Значение выбрано
        sFilter = sFilter & " AND СотрудникКод = " & Me!cbxСотрудник
    End If
    
'Примечание (Text! - Поле:"Примечание" - интерактивно)
    If Me.ActiveControl.Name = "txtПримечание" Then
        sTemp = Trim(Me!txtПримечание.Text)
    Else
        sTemp = Me!txtПримечание & ""
    End If
    If Len(sTemp) > 0 Then
        sTemp = Replace(sTemp, " ", "*")
        sFilter = sFilter & " AND Примечание Like '*" & sTemp & "*'"
    End If

'Применение фильтра или его отмена     
    If sFilter <> "" Then 'Фильтр задан
        sFilter = Mid(sFilter, 6) 'Обрезаем первый " AND "
        Me.Filter = sFilter
        Me.FilterOn = True
        Me.txtFilter = sFilter
    Else 'Отмена фильтра
        Me.Filter = ""
        Me.FilterOn = False
        Me.txtFilter = Null
    End If
End Sub

Private Sub Form_Error(DataErr As Integer, Response As Integer)
    If DataErr = 3314 Then 'Не заполнено обязательное поле
        MsgBox "Поле является обязательным для заполнения, " & vbCrLf & _
            "Вы не можете оставить его пустым!", vbExclamation, "Заполните поле"
        Response = acDataErrContinue 'Заглушка на стандартное сообщение
    Else
        Debug.Print "Form_Error - DataErr: " & DataErr & " - " & Error(DataErr)
    End If
End Sub

Private Sub txtПримечание_AfterUpdate()
    FormRefilter
End Sub

Private Sub txtПримечание_Change()
Dim iSelStart%, iSelLen%
'Фильтрация "на лету" (по мере ввода данных в поле)
    If Right(Me!txtПримечание.Text, 1) = " " Then Exit Sub 'Заглушка на пробел в конце
    iSelStart = Me!txtПримечание.SelStart
    iSelLen = Me!txtПримечание.SelLength
    FormRefilter
    Me!txtПримечание.SetFocus
    Me!txtПримечание.SelStart = iSelStart
    Me!txtПримечание.SelLength = iSelLen
End Sub

Private Sub txtДатаПо_AfterUpdate(): FormRefilter: End Sub 'Событие : "После Обновления"
Private Sub txtДатаС_AfterUpdate(): FormRefilter: End Sub  'Событие : "После Обновления"

Private Sub txtДатаПо_Change() 'Событие : Изменение
    DateFieldsUPD
End Sub
 
Private Sub txtДатаС_Change() 'Событие : Изменение
    DateFieldsUPD
End Sub
 
Private Sub DateFieldsUPD()
' Обработка события : "Изменение " в полях "txtДатаС" и "txtДатаПо"
Dim iStart%, iLen%
Dim objCtrl As Control
    
    Set objCtrl = Me.ActiveControl
    
    iStart = objCtrl.SelStart
    iLen = objCtrl.SelLength
    
    If Len(objCtrl.Text) = 10 And IsDate(objCtrl.Text) Then
        'Ввведена полная дата длинной 10 символов
        objCtrl.Value = CDate(objCtrl.Text)
    Else
        If Len(objCtrl.Text) = 0 Then 'Пусто
            objCtrl.Value = Null
        Else
            Exit Sub 'Не дата и не пусто - ничего не делаем
        End If
    End If
 
    FormRefilter 'Построройка фильтра по полям и фильтрация
    
    objCtrl.SetFocus
    objCtrl.SelStart = iStart
    objCtrl.SelLength = iLen
    
    Set objCtrl = Nothing
    
End Sub






Picture




Скачать

MSA-2007 и выше ( 159 kB) Пример


Назад ToTop
L.E. 16.08.2024
Рейтинг@Mail.ru