List Box Fliter MS Access VBA
Hi there,
I currently have a list box with shows all of my tables in my Access database. However i want some kind of flitering function that limits what the list box will show e.g.
The list box currently has the following values:
MPI_CORE
MPI_IDS
MPI_IDS_ChangeLog
......
I want a fliter that all the names with "....._ChangeLog" on the end dont show in the list box, so im just end up with MPI_CORE and MPI_IDS .......
I have the following code which populates the list box, is there a way i can edit the code so it will do the above?
Private Sub Form_Open(Cancel As Integer)
' Select the first item in the list.
lstObjects.RowSourceType = "Value List"
lstObjects = 0
' Set the form's Caption.
Me.Caption = CurrentDb.Name
Call UpdateList
End Sub
------------------------------------------------------------------------------------------------------------------------
Private Sub UpdateList()
' Refill the list box, and select the first entry.
lstObjects.RowSource = GetObjectList(lstObjects)
lstObjects = 0
End Sub
------------------------------------------------------------------------------------------------------------------------
Private Function GetObjectList( _
ByVal lngType As AcObjectType) As String
' Returns a string with a semi-colon delimited list of object names.
' Parameters:
' intType -- one of acTable, acQuery, acForm,
' acReport, acDataAccessPage, acMacro or acModule
Dim intI As Integer
Dim fSystemObj As Boolean
Dim strName As String
Dim fShowHidden As Boolean
Dim fIsHidden As Boolean
Dim strOutput As String
Dim fShowSystem As Boolean
Dim objCollection As Object
Dim aob As AccessObject
On Error GoTo HandleErrors
DoCmd.Hourglass True
' Are you supposed to show hidden/system objects?
fShowHidden = _
Application.GetOption("Show Hidden Objects")
fShowSystem = _
Application.GetOption("Show System Objects")
Set objCollection = CurrentData.AllTables
For Each aob In objCollection
fIsHidden = IsHidden(aob)
strName = aob.Name
fSystemObj = IsSystemObject(aob)
' Unless this is a system object and
' you're not showing system objects...
If (fSystemObj Imp fShowSystem) Then
' If the object isn't deleted and its hidden
' characteristics match those you're
' looking for...
If Not IsDeleted(strName) And _
(fIsHidden Imp fShowHidden) Then
' If this isn't a form, just add it to
' the list. If it is, one more check:
' is this the CURRENT form? If so, and if
' the flag isn't set to include the current
' form, then skip it.
Select Case lngType
Case acForm
If Not (adhcSkipThisForm And _
(strName = Me.Name)) Then
strOutput = _
strOutput & ";" & strName
End If
Case Else
strOutput = _
strOutput & ";" & strName
End Select
End If
End If
Next aob
strOutput = Mid$(strOutput, 2)
ExitHere:
DoCmd.Hourglass False
GetObjectList = strOutput
Exit Function
HandleErrors:
HandleErrors Err.Number, "GetObjectList"
Resume ExitHere
End Function
------------------------------------------------------------------------------------------------------------------------
Private Function IsHidden( _
aob As AccessObject) As Boolean
' Determine whether or not the specified object is
' hidden in the Access database window
If Application.GetHiddenAttribute( _
aob.Type, aob.Name) Then
IsHidden = True
End If
End Function
Private Function IsSystemObject( _
aob As AccessObject) As Boolean
' Determine whether or not the specified object is
' an Access system object or not.
Const conSystemObject = &H80000000
Const conSystemObject2 = &H2
If (Left$(aob.Name, 4) = "USys") Or _
Left$(aob.Name, 4) = "~sq_" Then
IsSystemObject = True
Else
If (aob.Attributes And conSystemObject) = _
conSystemObject Then
IsSystemObject = True
Else
If (aob.Attributes And conSystemObject2) = _
conSystemObject2 Then
IsSystemObject = True
End If
End If
End If
End Function
------------------------------------------------------------------------------------------------------------------------
Private Function IsDeleted( _
ByVal strName As String) As Boolean
IsDeleted = (Left(strName, 7) = "~TMPCLP")
End Function
Private Sub HandleErrors(intErr As Integer, strRoutine As String)
MsgBox "Error: " & Error(intErr) & " (" & intErr & ")", vbExclamation, strRoutine
End Sub
------------------------------------------------------------------------------------------------------------------------
Private Sub lstObjects_Click()
Dim strSQL As String
If lstObjects.Value <> "" Then 'this checks if its <> nothing
strSQL = "SELECT * FROM [lstObjects]"
End If
------------------------------------------------------------------------------------------------------------------------
Dim mysql As String
Dim tName As String
tName = lstObjects
mysql = "Select * From [" & tName & "]"
Me.List64.RowSource = mysql
End Sub
|
