Here is the original excel code I would like to change to work in outlook.I ran the debug and rem out invalid items and then tried to fix the code to work with outlook.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
Any help would be appreciated.