-Поиск по дневнику

Поиск сообщений в rss_sql_ru_access_programming

 -Подписка по e-mail

 

 -Постоянные читатели

 -Статистика

Статистика LiveInternet.ru: показано количество хитов и посетителей
Создан: 16.03.2006
Записей:
Комментариев:
Написано: 4


Автофильтрующийся комбобокс

Пятница, 15 Марта 2019 г. 12:38 + в цитатник
Список фильтруется по мере ввода данных.
Удобно использовать на более менее длинных списках.
Класс взят как есть из рабочего проекта. Делалось под свои задачи, но пока особых проблем за ним не замечал. Последний раз дорабатывалось когда понадобилось расширить функционал на простые списки.
Во время написания поста нашел похожую тему: https://www.sql.ru/forum/277809/filtraciya-combobox-po-mere-vneseniya-dannyh-ado?mid=2510813#2510813
В общем,- может кому пригодится и моя поделка на эту тему..
Конструктивная критика приветствуется.
Option Compare Database
Option Explicit
'=========================
Private Const c_strModule As String = "clsAutoFilteredCombo"
'=========================
' Описание      : Класс для работы с автофильтрующимися комбобоксами.
' Версия        : 1.0.3.435244168
' Дата          : 28.02.2019 10:00:12
' Автор         : iKaRus_VLZ (KashRus@gmail.com)
' Примечания    : работает с .RowSourceType="Table/Query" и "Value List" (с оговорками, см. p_FilterList)
' v.1.0.3       : добавлена возможность фильтровать списки "Value List"
' v.1.0.2       : добавлена SelectItem для принудительного выбора значения списка по коду
'=========================
' Пример использования:
'=========================
'' объявляем класс с событиями
'Dim WithEvents lst As clsAutoFilteredCombo
'' инициализируем селектор записей
'Private Sub Form_Open(Cancel As Integer)
'' lstMyList - имя контрола комбобокса на форме
'    Set lst = New clsAutoFilteredCombo: lst.Init lstMyList
'End Sub
'' обработка выбора в списке
'Private Sub lst_ItemSelected(Key As Variant)
'' Key - ключ списка (значение связанного столбца списка)
'' здесь можно сделать переход по записи или иное действие с ключом
'End Sub
'=========================
Public Event ItemSelected(Key As Variant) ' событие при выборе значения в ComboBox
Private WithEvents mCombo As Access.ComboBox
Private strListSource As String ' источник данных ComboBox
Private strListFilter As String ' имя поля источника отображаемого в ComboBox
Private bytColVis As Byte       ' номер первой видимой колонки в ComboBox
Private aPos() As Integer       ' позиции элементов в строке strListSource для "Value List"
Private bolJustEnter As Boolean
Private Const c_strListDelim = ";"
Private Const c_strCustomProc = "[Event Procedure]"
Public Sub Init(Combo As Access.ComboBox)
    Set mCombo = Combo
    Call p_GetListParams
    With mCombo
        .OnChange = c_strCustomProc
        .OnEnter = c_strCustomProc
        .OnKeyPress = c_strCustomProc
        .OnMouseUp = c_strCustomProc
        .AfterUpdate = c_strCustomProc
        .OnNotInList = c_strCustomProc
'        Select Case .RowSourceType
'        Case "Table/Query":
'        Case "Value List":
'        Case "Field List":  ' не предусмотрено
'        End Select
    End With
End Sub
Private Sub Class_Terminate()
    Set mCombo = Nothing: Erase aPos
End Sub
Public Sub SelectItem(Key)
' выбор в списке элемента по ключу
    With mCombo
        .RowSource = p_GetSource(vbNullString) ' сброс фильтра
        .Value = Key
    End With
End Sub
Private Sub mCombo_Change()
' получаем строку фильтра и вызываем фильтрацию списка
Dim strFilter As String
    With mCombo
        strFilter = Left$(Nz(.Text, vbNullString), .SelStart)
        If Len(strFilter) > 0 Then
            .RowSource = p_GetSource(strFilter): .Dropdown
        ElseIf Len(.Text) = 0 Then
            .RowSource = p_GetSource(vbNullString)
        End If
    End With
End Sub
Private Sub mCombo_AfterUpdate()
' меняем значение контрола на выбранное в списке
    With mCombo
' если есть разница между автовыбором в поле и выделением в списке
' выбирается то что выделено в списке
        If .ListIndex < 0 Then Exit Sub
        Dim varValue As Variant: varValue = .ItemData(IIf(.Text <> .Column(1, 0), .ListIndex, 0))
        .Value = varValue: RaiseEvent ItemSelected(varValue) ' здесь переход к записи с ID=.Value
    End With
End Sub
Private Sub mCombo_KeyPress(KeyAscii As Integer)
' при нажатии ВВОД переход на следующее поле
    If KeyAscii = 13 Then SendKeys "{TAB}"
End Sub
Private Sub mCombo_Enter(): bolJustEnter = True: End Sub
Private Sub mCombo_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
' если осуществлен вход в поле щелчком мыши - курсор в начало и выделяем содержимое
    With mCombo
        If bolJustEnter And .SelStart > 0 And Not IsNull(.Value) Then
            .SelStart = 0:      .SelLength = Len(.Text)
            .RowSource = p_GetSource(vbNullString)
        End If
    End With
    bolJustEnter = False
End Sub
Private Sub mCombo_NotInList(NewData As String, Response As Integer)
    Response = acDataErrContinue
    mCombo.Undo
End Sub
Private Sub p_GetListParams()
Dim aCol() As String, i As Long, iMax As Long
Dim rst As DAO.Recordset
    With mCombo
' получаем номер отображаемой колонки
        aCol = Split(.ColumnWidths, c_strListDelim): i = LBound(aCol): iMax = UBound(aCol)
        Do While i <= iMax
            If Len(aCol(i)) = 0 Then Exit Do
            If CLng(aCol(i)) > 0 Then Exit Do
            i = i + 1
        Loop
        bytColVis = i
        If .ColumnCount <= i Then .ColumnCount = i + 1
' получаем источник данных списка и необходимые вспомогательные данные
        strListSource = Trim$(.RowSource)
        Select Case .RowSourceType
        Case "Table/Query"
    ' для запроса получаем имя первого отображаемого в списке поля
            If Right$(strListSource, 1) = ";" Then strListSource = Left$(strListSource, Len(strListSource) - 1)
            Set rst = CurrentDb.OpenRecordset(strListSource, dbOpenForwardOnly)
            strListFilter = rst.Fields(bytColVis).name
            rst.Close: Set rst = Nothing
        Case "Value List"
    ' для списка формируем массив с позициями разделителей элементов списка
            Dim n As Long: n = 0
            i = 1: iMax = Len(strListSource)
            Do While i <= iMax
                i = InStr(i, strListSource, c_strListDelim)
                If i = 0 Then Exit Do Else i = i + 1
                ReDim Preserve aPos(n): aPos(n) = i: n = n + 1
            Loop
        Case "Field List"
    ' не предусмотрено
        End Select
    End With
End Sub
Private Function p_GetSource(strFilter As String) As String
' получаем значение для RowSourse с учетом заданного фильтра
Const c_strProcedure = "p_GetSource"
Dim Result As String

    Result = strListSource
    On Error GoTo HandleError
    strFilter = Trim(strFilter)
    If Len(strFilter) = 0 Then GoTo HandleExit
    Select Case mCombo.RowSourceType
    Case "Table/Query": Result = p_FilterQuery(strFilter)
    Case "Value List":  Result = p_FilterList(strFilter)
    Case "Field List":  Result = strListSource ' не предусмотрено
    End Select
HandleExit:
    p_GetSource = Result
    Exit Function
HandleError:
    Result = strListSource
    Err.Clear
    Resume HandleExit
End Function
Private Function p_FilterQuery(FilterString As String) As String
' создает запрос с заданным фильтром и возвращает результат
Const c_strProcedure = "p_FilterQuery"
' отбор значений при помощи LIKE
' строки содержащие символы: *, ?, # и т.п. могут отработать некорректно
    p_FilterQuery = sqlSelectAll & "(" & strListSource & ")" & sqlWhere & strListFilter & sqlLike & """*" & FilterString & "*"""
End Function
Private Function p_FilterList(FilterString As String) As String
' создает список с разделителями отфильтрованный заданный строкой и возвращает результат
Const c_strProcedure = "p_FilterList"
' !!! необходимо оптимизировать !!!

' отбор по списку при помощи InStr
' не учитывает наличие кавычек у текстовых значений, также не проверяет символ разделителя списка
' строки поиска содержащие кавычки или разделитель могут отработать некорректно
' при необходимости несложно доработать
Dim Result As String
    On Error GoTo HandleError
    Result = strListSource
    If Len(FilterString) = 0 Then GoTo HandleExit
Dim i As Long, iMax As Long ', iMin As Long
Dim s As Long, sMax As Long, sBeg As Long, sEnd As Long
Dim r As Long, cMax As Long
    Result = vbNullString
    cMax = mCombo.ColumnCount
    s = 1: sMax = Len(strListSource)
    i = LBound(aPos): iMax = UBound(aPos) ': iMin = iMin
    Do While s <= sMax
        s = InStr(s, strListSource, FilterString): If s = 0 Then Exit Do
    ' совпадение найдено - проверяем в какой колонке
        Do While i <= iMax
            If s < aPos(i) Then Exit Do
            i = i + 1
        Loop
        ' индекс следующего анализируемого символа - первый символ колонки следующей после той в которой найдено совпадение
        If i <= iMax Then s = aPos(i) Else s = sMax + 1
    ' если это видимая колонка добавляем всю строку в результат
        If i Mod cMax = bytColVis Then ' If (i - iMin) Mod cMax = bytColVis Then ' если iMin<>0
            ' получаем первый и последний символ строки r
            ' в aPos отсутствует нижняя (1) и верхняя  (sMax) границы строки
            r = i \ cMax     ' номер строки списка в которой найдено совпадение
'            r = (i - iMin) \ cMax    ' если iMin<>0
            If r = 0 Then sBeg = 1 Else sBeg = aPos(r * cMax - 1)
            If ((r + 1) * cMax - 1) > iMax Then sEnd = sMax Else sEnd = aPos((r + 1) * cMax - 1) - Len(c_strListDelim) - 1
            Result = Result & c_strListDelim & Mid$(strListSource, sBeg, sEnd - sBeg + 1)
        End If
    Loop
    If Left(Result, Len(c_strListDelim)) = c_strListDelim Then Result = Mid$(Result, Len(c_strListDelim) + 1)
HandleExit:
    p_FilterList = Result
    Exit Function
HandleError:
    Result = strListSource
    Err.Clear: Resume HandleExit
End Function

https://www.sql.ru/forum/1310230/avtofiltruushhiysya-komboboks


 

Добавить комментарий:
Текст комментария: смайлики

Проверка орфографии: (найти ошибки)

Прикрепить картинку:

 Переводить URL в ссылку
 Подписаться на комментарии
 Подписать картинку