Автофильтрующийся комбобокс |
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
Комментировать | « Пред. запись — К дневнику — След. запись » | Страницы: [1] [Новые] |