Adding textbox filter to listbox?

I have a listbox using the code form slipstick.com/developer/code-samples/outlook-vbatext-file-list/ . It populates the listbox with job numbers for saving emails to the server. I would like to add a text box to enter a keyword to filter the listbox. The only examples I can find are for excel, such as this one yoursumbuddy.com/listbox-filter-wildcards-unique-values/.

Does anyone know/have a code example for adding a filter to the listbox in Outlook?

Here is the code I'm using to populate the listbox:

Code:

---

Private Sub UserForm_Initialize()
  Dim fn As String, ff As Integer, txt As String
    fn = "H:\Software\OutlookVBA\project_list.txt" '< --- .txt file path
    txt = Space(FileLen(fn))
    ff = FreeFile
    Open fn For Binary As #ff
    Get #ff, , txt
    Close #ff
 
 Dim myArray() As String
  'Use Split function to return a zero based one dimensional array.
  myArray = Split(txt, vbCrLf)
  'Use .List method to populate listbox.
  ListBox2016.List = myArray
lbl_Exit:
  Exit Sub

---

Thanks,
Chris

You would need to add each item in the array in turn having checked it against the filter. As yoy have not said what the list items are nor how the filter relates to them then it is impossible to be specific, but something like

Code:

---

    For i = LBound(myArray) To UBound(myArray)
        If InStr(1, myArray(i), "The key text") > 0 Then
            Me.ListBox2016.AddItem myArray(i)
        End If
    Next i

---

Here is the original excel code I would like to change to work in outlook.

Code:

---

Private Sub UserForm_Activate()
'''start of what I added for my listbox
  Dim fn As String, ff As Integer, txt As String
    fn = "C:\test\project_list.txt" '< --- .txt file path contains folders on server
    txt = Space(FileLen(fn))
    ff = FreeFile
    Open fn For Binary As #ff
    Get #ff, , txt
    Close #ff
 
 Dim myArray() As String
  'Use Split function to return a zero based one dimensional array.
  myArray = Split(txt, vbCrLf)
  'Use .List method to populate listbox.
  lstDetail.List = myArray
lbl_Exit:
  Exit Sub
'''' end of what I added
'Set loActive = ActiveSheet.ListObjects(1)
Me.lstDetail.TextColumn = 2
Me.lstDetail.MatchEntry = fmMatchEntryComplete
ResetFilter
End Sub
Function ValidLikePattern(LikePattern As String) As Boolean
Dim temp As Boolean
On Error Resume Next
temp = ("A" Like "*" & LikePattern & "*")
If Err.Number = 0 Then
    ValidLikePattern = True
End If
On Error GoTo 0
End Function
Sub ResetFilter()
'Dim rngTableCol As Excel.Range 'removed from original
Dim varTableCol As Variant
Dim RowCount As Long
Dim collUnique As Collection
Dim FilteredRows() As String
Dim i As Long
Dim ArrCount As Long
Dim FilterPattern As String
Dim UniqueValuesOnly As Boolean
Dim UniqueConstraint As Boolean
Dim CaseSensitive As Boolean
'the asterisks make it match anywhere within the string
If Not ValidLikePattern(Me.txtFilter.Text) Then
    Exit Sub
End If
FilterPattern = "*" & Me.txtFilter.Text & "*"
UniqueValuesOnly = Me.chkUnique.Value
CaseSensitive = Me.chkCaseSensitive
'used only if UniqueValuesOnly is true
Set collUnique = New Collection
Set rngTableCol = loActive.ListColumns(1).DataBodyRange 'this is where things start to go wrong
note that Transpose won't work with > 65536 rows
varTableCol = Application.WorksheetFunction.Transpose(rngTableCol.Value)
RowCount = UBound(varTableCol)
ReDim FilteredRows(1 To 2, 1 To RowCount)
For i = 1 To RowCount
    If UniqueValuesOnly Then
        On Error Resume Next
        'reset for this loop iteration
        UniqueConstraint = False
        'Add fails if key isn't UniqueValuesOnly
        collUnique.Add Item:="test", Key:=CStr(varTableCol(i))
        If Err.Number <> 0 Then
            UniqueConstraint = True
        End If
        On Error GoTo 0
    End If
    'True if UniqueValuesOnly is false or if
    'UniqueValuesOnly is True and this is the
    'first occurrence of the item
    If Not UniqueConstraint Then
        'Like operator is case sensitive,
        'so need to use LCase if not CaseSensitive
        If (Not CaseSensitive And LCase(varTableCol(i)) Like LCase(FilterPattern)) _
          Or (CaseSensitive And varTableCol(i) Like FilterPattern) Then
            'add to array if ListBox item matches filter
            ArrCount = ArrCount + 1
            'there's a hidden ListBox column that stores the record num
            FilteredRows(1, ArrCount) = i
            FilteredRows(2, ArrCount) = varTableCol(i)
        End If
    End If
Next i
If ArrCount > 0 Then
    'delete empty array items
    'a ListBox cannot contain more than 65536 items
    ReDim Preserve FilteredRows(1 To 2, 1 To Application.WorksheetFunction.Min(ArrCount, 65536))
Else
    're-initialize the array
    Erase FilteredRows
End If
If ArrCount > 1 Then
    Me.lstDetail.List = Application.WorksheetFunction.Transpose(FilteredRows)
Else
    Me.lstDetail.Clear
    'have to add separately if just one match
    'or we get two rows, not two columns, in ListBox
    If ArrCount = 1 Then
        'Me.lstDetail.AddItem FilteredRows(1, 1)
        Me.lstDetail.List(0, 1) = FilteredRows(2, 1)
    End If
End If
End Sub
Private Sub txtFilter_Change()
ResetFilter
End Sub
Private Sub chkCaseSensitive_Click()
ResetFilter
End Sub
Private Sub chkUnique_Click()
ResetFilter
End Sub

''removed from original
'Private Sub lstDetail_Change()
'GoToRow
'End Sub
''removed from original
'Sub GoToRow()
'If Me.lstDetail.ListCount > 0 Then
'    Application.GoTo loActive.ListRows(Me.lstDetail.Value).Range.Cells(1), True
'End If
'End Sub

---

I ran the debug and rem out invalid items and then tried to fix the code to work with outlook.
Any help would be appreciated.

Outlook is not Excel, and you still haven't explained what you are trying to do. The suggested code will work in Outlook, but you are going to have to explain what you wish to filter and what EXACTLY is in the text file.

The listbox is populated from a text file with the folder paths to over 500 jobs we are working on such as:Z:\jobs\15001 xyz company\office\email
Z:\jobs\15002 abc company\office\email
Z:\jobs\15003 fred company\office\email
Z:\jobs\15004 aaa company\office\email
Z:\jobs\15005 etc company\office\email
Z:\jobs\15006 zzz company\office\email
Z:\jobs\15007 *** company\office\email
Z:\jobs\15008 yyy company\office\email

I would like to be able to use the textbox to type in a keyword and update the listbox with all jobs that contain the keyword. Then I would select one of the jobs from the listbox and click on of the three buttons to save the selected emails to that folder.

I have everything working except the textbox filter. The idea for the text box came from this website: yoursumbuddy.com/listbox-filter-wildcards-unique-values/ (forum will not allow me to post a link). The example shown on that web site looks perfect but was designed for excel.

Thanks,
Chris

Assuming that you have a textbox - here Textbox1 on the form, the list will be filtered by whatever you type in the textbox

Code:

---

Option Explicit
Private myArray() As String

Private Sub TextBox1_Change()
Dim i As Long
    If Not TextBox1.Text = "" Then
        ListBox2016.Clear
        myArray = GetList
        For i = LBound(myArray) To UBound(myArray)
            If InStr(1, LCase(myArray(i)), LCase(TextBox1.Text)) > 0 Then
                Me.ListBox2016.AddItem myArray(i)
            End If
        Next i
    End If
lbl_Exit:
    Exit Sub
End Sub

Private Sub UserForm_Initialize()
    ListBox2016.List = GetList
lbl_Exit:
Exit Sub
End Sub

Function GetList() As Variant
Dim fn As String, ff As Integer, txt As String

    fn = "C:\test\project_list.txt"
    txt = Space(FileLen(fn))
    ff = FreeFile
    Open fn For Binary As #ff
    Get #ff, , txt
    Close #ff
    myArray = Split(txt, vbCrLf)
    GetList = myArray
lbl_Exit:
    Exit Function
End Function

---

Graham Mayor,
:friends:
I needed to set the column widths for the listbox to "20 pt;0 pt" where the excel code had it the opposite. I then added "TextBox1.SetFocus" right after the "GetList = myArray".

The code seems to work perfect on my home computer with limited number of folders in the list. When I get to work tomorrow, I will update the code.

FYI, I had been searching the internet for over two weeks looking some sort of code that would help with this.
I want to thank you for help,
Chris

The array makes only one column in the list box? You shouldn't need to set the column widths. With one column it will display at the width you have the list box set as.

I just noticed that and set it back to one column.

Thanks,
Chris

I got to work and all is good except I needed to remove the "TextBox1.SetFocus" and change the textbox1 tab index to 0. The SetFocus made it impossible to select an email(s) to run the macro on.