Option Compare Database
Option Explicit
'=========================
Private Const c_strModule As String = "clsAutoFilteredCombo"
'=========================
' Описание      : Класс для работы с автофильтрующимися комбобоксами.
' Версия        : 1.2.6.436355522
' Дата          : 19.06.2019 13:15:10
' Автор         : Кашкин Р.В. (KashRus@gmail.com)
' Примечания    : работает с .RowSourceType="Table/Query" и "Value List" (с оговорками, см. p_FilterValueList) _
                  если GROUPPROC=True в проекте д.б. clsRelay _
                  опорный запрос должен быть оптимизирован т.к. использование автофильтра заметно замедляет его работу _
                  в тексте запроса источника строк списка следует избегать групповых функций, _
                  в частности Dlookup можно заменить на Choose, это критически влияет на производительность
' v.1.2.6       : 14.06.2019 - исправлены старые, известные ошибки,- сделаны новые, пока неизвестные..)
' v.1.2.0       : 28.05.2019 - добавлена возможность работы с рекордсетом вместо RowSource (попытка ускорить исполнение запросов)
' v.1.1.2       : 22.05.2019 - добавлена возможность групповой обработки Combobox'ов
' v.1.1.1       : 21.05.2019 - добавлена возможность ожидания завершения ввода (см.TimerProc) для ускорения работы в длинных списках
' v.1.0.3       : 28.02.2019 - добавлена возможность фильтровать списки "Value List"
' v.1.0.1       : 19.06.2018 - исходная версия
'=========================
#Const GROUPPROC = False   ' True  - используется группповая обработка списков (нужен clsRelay),
                            ' False - группповая обработка не используется
#Const USERECORDSET = False ' True  - использовать Recordset для фильтрации списка,
                            ' False - использовать RowSource для фильтрации списка.
    ' !!! где-то ошибка - при True после использования класса при закрытии Access вылетает
#Const USEDELAY = False     ' True  - примененять фильтр после завершения ввода (по событию TimerProc) есть неотлаженные косяки с потерей mCombo,
                            ' False - примененять фильтр после каждого изменения (по событию Change)
    ' хорошая идея - плохая реализация  - иногда теряет объект mCombo, что приводит к неработоспособностии кода.  место и причину пока не отловил.
    ' надо поискать другой способ организации события таймера в пользовательском классе.
'=========================
' Пример использования:
'-------------------------
' Пример использования класса для одиночных списков
'-------------------------
'Dim WithEvents lst As clsAutoFilteredCombo ' объявляем класс с событиями
'' инициализируем селектор записей
'Private Sub Form_Open(Cancel As Integer)
'' lstMyList - имя контрола комбобокса на форме
'    Set lst = New clsAutoFilteredCombo: lst.Init lstMyList
'End Sub
'Private Sub Form_Close(): Set lst = Nothing: End Sub
'' обработка выбора в списке
'Private Sub lst_ItemSelected(Key As Variant)
'' Key - ключ списка (значение связанного столбца списка)
'' здесь можно сделать переход по записи или иное действие с ключом
'End Sub
'-------------------------
' Пример использования класса для групповой обработки списков:
'-------------------------
'Private WithEvents mRelay As clsRelay   ' для ретрансляции событий группы контролов в форму
'Private colCtls As Collection           ' коллекция для хранения элементов clsAutoFilteredCombo
'
'Private Sub Form_Open(Cancel As Integer)
'   Set colCtls = New Collection: Set mRelay = New clsRelay
'End Sub
'Private Sub Form_Close()
'   Set colCtls = Nothing: Set mRelay = Nothing
'End Sub
'Private Sub mRelay_GetParent(PARENT As Object): Set PARENT = Me:End Sub
'Private Sub p_InitControl(ctl As Access.Control)
''p_InitControl необходимо вызвать для каждого списка который должен получить групповой обработчик событий
' Dim cTransf As New clsAutoFilteredCombo
'   cTransf.Init EventControl:=ctl, Relay:=mRelay, Index:=colCtls.Count: colCtls.Add cTransf
'End Sub
'Public Sub EventControl_ItemSelected(EventControl As Access.Control, Optional Key as Variant) 'As Integer
'' собственно пример группового обработчика событий
'' EventControl - содержит ссылку на контрол вызвавший событие
'End Sub
'=========================
Public Event ItemSelected(Key As Variant) ' событие при выборе значения в ComboBox
Private WithEvents mCombo As Access.ComboBox
Attribute mCombo.VB_VarHelpID = -1

Private mstrSource As String    ' источник данных ComboBox
Private mstrFieldName As String ' имя поля источника отображаемого в ComboBox

#If USERECORDSET Then       ' если для фильтрации используется Recordset
Private mrstSource As Recordset ' исходный рекордсет ComboBox
#End If

#If USEDELAY Then           ' если используется ожидание завершения ввода
Private Const c_intWait = 500   ' время ожидания нажатия клавиши до применения фильтра (в ms)
Private Const c_intPeriod = 50  ' период срабатывания таймера (в ms)

Private mobjDoc As Object       ' объект HTML в котором создается при помощи JS таймер
Private Const c_strAttribute = "VBATimerHandler" ' имя аттрибута для хранения значения таймера в объекте HTML
Private mvarTimerId As Variant  ' параметр для последующего выполнения ClearInterval
Private mlngEnterPrev As Long   ' время предыдущего ввода
Private mbolChange As Boolean   ' флаг изменения фильтра
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
#End If 'USEDELAY

#If GROUPPROC Then
Private mRelay As clsRelay
Private mIndex As Long
#End If 'GROUPPROC

Private mstrFilter As String    ' значение поля фильтра
Private mbytColVis As Byte      ' номер первой видимой колонки в ComboBox
Private marrPos() As Integer    ' позиции элементов в строке mstrSource для "Value List"
Private mbolAutoSel As Boolean  ' признак того что сработал стандартный автовыбор Combobox
Private mbolJustEnt As Boolean  ' признак что вход в поле только что осуществлен, ввода еще не было
Private Const c_strListDelim = ";"
Private Const c_strCustomProc = "[Event Procedure]"

#If GROUPPROC Then
Public Sub Init( _
    EventControl As Access.Control, _
    Optional Relay As clsRelay, _
    Optional Index As Long _
    )
' инициализация для групповой обработки
#Else   'GROUPPROC
Public Sub Init( _
    EventControl As Access.Control, _
    Optional Relay As Object, _
    Optional Index As Long _
    )
' инициализация контрола без групповой обработки
' здесь Relay и Index не используются сохранены для единства синтаксиса
#End If 'GROUPPROC
    Set mCombo = EventControl
    mbolJustEnt = False: mbolAutoSel = False
#If GROUPPROC Then
    mIndex = Index: Set mRelay = Relay
#End If 'GROUPPROC
' получаем параметры источника данных
    Call p_InitCombo
' настраиваем обработчики событий
    With mCombo
        .OnChange = c_strCustomProc
        .OnEnter = c_strCustomProc
        .OnMouseUp = c_strCustomProc
        .AfterUpdate = c_strCustomProc
        .OnNotInList = c_strCustomProc
        .OnKeyDown = c_strCustomProc
    End With
End Sub
Private Sub Class_Terminate()
#If GROUPPROC Then
    Set mRelay = Nothing
#End If 'GROUPPROC
#If USERECORDSET Then
    mrstSource.Close: Set mrstSource = Nothing
#End If 'USERECORDSET
#If USEDELAY Then
    p_TimerStop
#End If 'USEDELAY
    Set mCombo = Nothing: Erase marrPos
End Sub
#If GROUPPROC Then
Public Property Let Index(rData As Long): mIndex = rData: End Property
Public Property Get Index() As Long: Index = mIndex: End Property
#End If 'GROUPPROC
Public Sub SelectItem(Key)
' выбор в списке элемента по ключу
    With mCombo
    ' меняем значение и вызываем события
        p_SetFilter (vbNullString)                  ' сбрасываем фильтр перед выбором
        .Value = Key: RaiseEvent ItemSelected(Key)  ' здесь переход к записи с ID=.Value
#If GROUPPROC Then
    On Error GoTo HandleError
        Call mRelay.Parent.EventControl_ItemSelected(mCombo, Key)
#End If 'GROUPPROC
    End With
HandleExit:
    Exit Sub
HandleError:
    Err.Clear: Resume HandleExit
End Sub
' обработка событий контрола
Private Sub mCombo_Enter(): mbolJustEnt = True: End Sub ' ставим признак входа в поле
Private Sub mCombo_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If mbolJustEnt Then
' если осуществлен вход в поле щелчком мыши или табом
        With mCombo
            If IsNull(.Value) Then
            Else
' если в поле есть выбор
    ' проверяем был ли вход по щелчку на кнопке выпадающего меню
        ' опытным путем подобрал такое условие.
        ' почему так - не понятно. условие некорректно, но лучше пока не придумал
        ' если бы был выбор в поле нулевой позиции, то д.б. .SelLength = 0
                If .SelStart = 0 And .SelLength = Len(.Text) Then
        ' если да - при установке фильтра происходит срыв списка, поэтому - пропуск
                Else
        ' если нет - курсор в начало и выделяем содержимое
                    .SelStart = 0:  .SelLength = Len(.Text)
                    p_SetFilter (vbNullString): mbolJustEnt = False
                End If
            End If
        End With
    End If
HandleExit:
    Exit Sub
HandleError:
    Err.Clear: Resume HandleExit
End Sub
Private Sub mCombo_NotInList(NewData As String, Response As Integer)
    Response = acDataErrContinue: mCombo.Undo
End Sub
Private Sub mCombo_Change()
' получаем строку фильтра
    With mCombo
On Error Resume Next
' !!! Внимание !!!
' если есть совпадение сначала строки - срабатывает автовыбор комбобокса > меняется ListIndex

' .Text меняется:
        mbolJustEnt = False
        mbolAutoSel = .Text = .Column(mbytColVis, .ListIndex)
        If mbolAutoSel Then
'   - при срабатывании автовыбора списка
    ' если выделена вся строка (например при перемещении стрелками по списку) - не применяем фильтр
            If .SelStart = 0 And .SelLength = Len(.Text) Then GoTo HandleExit
    ' если выделен хвост предложенный автовыбором (идет ввод) - применяем фильтр, - берём левую часть ввода от выделения
            mstrFilter = VBA.Left$(.Text, .SelStart)
        Else
'   - при вводе/удалении символа - применяем фильтр
            mstrFilter = .Text ': If Err Then mstrFilter = .Value: Err.Clear
'If Len(mstrFilter) = 0 Then Stop
        End If
' если применять фильтр после каждого изменения длинные списки будут очень тормозить
' нужно дать пользователю возможность завершить ввод
        mstrFilter = VBA.Trim$(mstrFilter)
#If USEDELAY Then
' если используется задержка ввода - фиксируем время, устанавливаем флаг изменения и ждем события таймера
        mlngEnterPrev = GetTickCount     ' запоминаем таймер текущего ввода
        mbolChange = True          ' устанавливаем флаг фильтр изменился
#Else  'USEDELAY
' если не используется задержка - применяем фильтр сразу
        If Len(mstrFilter) > 0 Then
            p_SetFilter (mstrFilter): .Dropdown
        Else
            p_SetFilter (vbNullString)
        End If
#End If 'USEDELAY
    End With
HandleExit:
    Exit Sub
HandleError:
    Err.Clear: Resume HandleExit
End Sub
Private Sub mCombo_KeyDown(KeyCode As Integer, Shift As Integer)
' при нажатии ТАБ/ВВОД
    ' при закрытом списке происходит выбор
    ' при открытом списке происходит срыв выьбора
    Select Case KeyCode
    Case vbKeyTab:      If Shift = 0 Then SelectItem p_GetSelectedKey
    Case vbKeyReturn:   SelectItem p_GetSelectedKey
    End Select
HandleExit:
    Exit Sub
HandleError:
    Err.Clear: Resume HandleExit
End Sub
Private Sub mCombo_AfterUpdate(): SelectItem p_GetSelectedKey: End Sub
Private Function p_GetSelectedKey() 'As Long
Dim Result 'As Long
On Error GoTo HandleError
Dim i As Long: i = 0 ' индекс возвращаемого элемента
    With mCombo
' ListIndex не всегда выдает ожидаемое значение -
    ' при установке RowSource список меняется, а ListIndex остается прежний.
    ' и может не соответствовать автовыбору в поле или вовсе оказаться за пределами списка
        If .Column(mbytColVis, .ListIndex) = .Text Then
            i = .ListIndex
        Else
' есть очевидное плохое решение - поиск перебором в списке
    ' или его аналоги - поиск в источнике и возврат резульатата не из Combo, а из источника данных Combo
            i = .ListCount - 1
            Do While i > 0
                If .Column(mbytColVis, i) = .Text Then Result = .Column(.BoundColumn - 1, i): Exit Do
                i = i - 1
            Loop
        End If
        Result = .Column(.BoundColumn - 1, i)
        
' есть некорректное, но не требующее перебора а значит более быстрое на длинных списках
    ' в таком случае после фильтрации нужно мышью либо стрелками выбрать в списке нужный пункт
    ' иначе (по выходу из поля может произойти выбор неверного значения)
'        Select Case .ListIndex
'        Case 0 To .ListCount - 1: Result = .Column(.BoundColumn - 1, .ListIndex)
'        Case Else:                Result = .Column(.BoundColumn - 1, 0)
'        End Select
    End With
HandleExit:
'If Result = 0 Or IsNull(Result) Then Stop
    p_GetSelectedKey = Result
    Exit Function
HandleError:
    Err.Clear: Resume HandleExit
End Function
Private Sub p_InitCombo()
' получает все необходимые для работы класса параметры списка
Dim aCol() As String, i As Long, iMax As Long
    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
        mbytColVis = i
        If .ColumnCount <= i Then .ColumnCount = i + 1
' получаем источник данных списка и необходимые вспомогательные данные
        mstrSource = Trim$(.RowSource)

        Select Case .RowSourceType
        Case "Table/Query"
            If Right$(mstrSource, 1) = ";" Then mstrSource = Left$(mstrSource, Len(mstrSource) - 1)
#If USERECORDSET Then
            If .Recordset Is Nothing Then .Requery
            Set mrstSource = .Recordset.Clone 'исходный запрос
            mstrFieldName = mrstSource.Fields(mbytColVis).NAME
#Else  'USERECORDSET
    ' для запроса получаем имя первого отображаемого (фильтруемого) поля списка
            Dim strSQL As String: strSQL = sqlSelect1st & "(" & mstrSource & ")"
            Dim rst As Recordset: Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenForwardOnly)
            mstrFieldName = rst.Fields(mbytColVis).NAME
            rst.Close: Set rst = Nothing
#End If 'USERECORDSET
        Case "Value List"
    ' для списка формируем массив с позициями разделителей элементов списка
            Dim n As Long: n = 0
            i = 1: iMax = Len(mstrSource)
            Do While i <= iMax
                i = InStr(i, mstrSource, c_strListDelim)
                If i = 0 Then Exit Do Else i = i + 1
                ReDim Preserve marrPos(n): marrPos(n) = i: n = n + 1
            Loop
        Case "Field List"
    ' не предусмотрено
        End Select
    End With
#If USEDELAY Then
' запускаем таймер
    mbolChange = False
    mlngEnterPrev = GetTickCount(): p_TimerStart
#End If 'USEDELAY
End Sub
Private Function p_SetFilter(FilterText As String) As Boolean
' устанавливает текстовой фильтр на источник
Const c_strProcedure = "p_SetFilter"
' !!! при замене RowSource ListIndex остается прежним !!!
Dim Result As Boolean

    Result = True
    On Error GoTo HandleError
    DoCmd.Echo False
    FilterText = VBA.Trim$(FilterText)
    With mCombo
    ' выбираем способ фильтрации
        Select Case .RowSourceType
        Case "Table/Query":
    ' источник - запрос
#If USERECORDSET Then
        ' для фильтрации используется Recordset
            If Len(FilterText) = 0 Then Set .Recordset = mrstSource: GoTo HandleExit
            Dim strFilter As String:  strFilter = mstrFieldName & sqlLike & """*" & VBA.Replace(FilterText, " ", "*") & "*"""
            Dim rst As Recordset: Set rst = mrstSource.Clone: rst.Filter = strFilter
            Set .Recordset = rst.OpenRecordset: rst.Close: Set rst = Nothing
#Else  'USERECORDSET
        ' для фильтрации используется RowSource
        ' отбор значений при помощи LIKE. Cтроки содержащие символы: *, ?, # и т.п. могут отработать некорректно
            If Len(FilterText) = 0 Then .RowSource = mstrSource: GoTo HandleExit
            Dim strFilter As String:  strFilter = mstrFieldName & sqlLike & """*" & VBA.Replace(FilterText, " ", "*") & "*"""
            .RowSource = sqlSelectAll & "(" & mstrSource & ")" & sqlWhere & strFilter
#End If 'USERECORDSET
        Case "Value List"
    ' источник - список с разделителями
            If Len(FilterText) = 0 Then .RowSource = mstrSource: GoTo HandleExit
            .RowSource = p_FilterValueList(FilterText)
        'Case "Field List": ' не предусмотрено
        End Select
    ' восстанавливаем предложенное автовыбором значение в списке и выделение
        ' ListIndex вопреки хелпу можно менять, но получишь ошибку #7777
    End With
HandleExit:
    DoCmd.Echo True
    p_SetFilter = Result
    Exit Function
HandleError:
    
    Select Case Err.Number
    Case 7777: Err.Clear: Resume Next       ' ошибка ListIndex - продолжить исполнение
    Case Else: Result = False: Err.Clear: Resume HandleExit
    End Select
    Err.Clear: Resume HandleExit
End Function
Private Function p_FilterValueList(FilterString As String) As String ', Optional lIdx As Long) As String
' создает список с разделителями отфильтрованный заданный строкой и возвращает результат
Const c_strProcedure = "p_FilterValueList"
' !!! необходимо оптимизировать !!!

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

#If USEDELAY Then
Public Sub TimerProc()
' имитирует событие Таймера. срабатывает каждые c_intPeriod милисекунд
    If Not mbolChange Then Exit Sub
    If (GetTickCount() - mlngEnterPrev) < c_intWait Then Exit Sub
' если со времени последнего ввода прошло больше c_intWait милисекунд
' и фильтр изменился - устанавливаем фильтр
    With mCombo
        If Len(mstrFilter) > 0 Then
            p_SetFilter (mstrFilter): .Dropdown
        ElseIf Len(.Text) = 0 Then
            p_SetFilter (vbNullString)
        End If
    End With
    mbolChange = False ' сброс флага необходимости установки фильтра
End Sub
Private Sub p_TimerStart()
' запускает локальный таймер с интервалом срабатывания c_intPeriod
' каждые c_intPeriod милисекунд будет вызываться проседура TimerProc
Const cstrScript = "document.documentElement.getAttribute('" & c_strAttribute & "').TimerProc()"
    p_TimerStop
    Set mobjDoc = CreateObject("htmlfile")
    mobjDoc.DocumentElement.setAttribute c_strAttribute, Me
    mvarTimerId = mobjDoc.parentWindow.setInterval(cstrScript, c_intPeriod)
End Sub
Private Sub p_TimerStop()
' останавливает таймер
    If mobjDoc Is Nothing Then Exit Sub
    If Not IsEmpty(mvarTimerId) Then
        mobjDoc.parentWindow.clearInterval mvarTimerId
        mvarTimerId = Empty
    End If
    mobjDoc.DocumentElement.removeAttribute c_strAttribute
    Set mobjDoc = Nothing
End Sub
#End If 'USEDELAY