I have the following code and it worked when my tables were in Access, however the tables have been migrated to our Teradata server and I ODBC with Access. My tables are now named for example DL_QPT_CQE_Measures. I tried changing my code to DL_QPT_CQE_Measures.hedis_measures, however it does not work. I am not sure how to alter this code to make it work.
Code:
Option Compare Database
Option Explicit
Global GlobalID As Long 'used to hold an ID for a short time (after a record is added)
Public Sub sSortListBox(anyListbox As Control, Button As Integer, Shift As Integer, X As Single)
Dim strSql As String
Dim vGetWidths As Variant
Dim vArWidths() As Variant
Dim iColCount As Integer, iColNumber As Integer
Dim iLoop As Integer
Dim iColWidthSum As Integer
Dim iUndefined As Integer
Dim iDefaultWidth As Integer
Dim strOrderBy As String
Const strListSeparator As String = ";" 'list Separator
'If your list separator is not a ";"
'you will need to change the ";" to your list separator
On Error GoTo ERROR_sSortListBox
If Button <> acRightButton Then
'only sort based on right button being clicked
ElseIf anyListbox.RowSourceType <> "table/query" Then
'only sort listbox based on queries
msgbox "List box must use a query as it's row source"
ElseIf Len(anyListbox.RowSource) = 0 Then
'Nothing there, so ignore the click
ElseIf Not (InStr(1, Trim(anyListbox.RowSource), "Select", vbTextCompare) = 1 _
Or InStr(1, Trim(anyListbox.RowSource), "Parameters", vbTextCompare) = 1) Then
'If rowsource does not start with SELECT or PARAMETERS then
'assume it is a table not a query
msgbox "List box must use a query as its row source"
ElseIf anyListbox.ColumnCount <> DBEngine(0)(0).CreateQueryDef("", anyListbox.RowSource).Fields.Count Then
'Column count must be correctly set, otherwise this routine
'could cause errors. Column count set less than actual field count
'will cause subscript errors. Column count set higher than actual
'field count can cause listbox to display nothing if "Extra" column
'is clicked.
msgbox "List box column count does not match query field count!"
Else 'passed the error checks
With anyListbox
'Column count must be correctly set, otherwise this routine
'could cause errors. Column count set less than actual column Count
'will cause subscript errors. Column count set higher than actual
'column count can cause listbox to display nothing if "Extra" Column
'is clicked.
iColCount = .ColumnCount
ReDim vArWidths(iColCount - 1, 0 To 1)
vGetWidths = Split(.ColumnWidths, strListSeparator, -1, vbTextCompare)
'Assign values to array that holds length and running sum of Length
For iLoop = 0 To UBound(vGetWidths)
iColWidthSum = iColWidthSum + Val(vGetWidths(iLoop))
vArWidths(iLoop, 1) = iColWidthSum
vArWidths(iLoop, 0) = vGetWidths(iLoop)
Next iLoop
'Adjust any colwidths that are unspecified:
'The minimum is the larger of 1440
'or the remaining available width of the list box
'divided by number of columns
'with unspecified lengths.
For iLoop = 0 To iColCount - 1
If Len(vArWidths(iLoop, 0) & vbNullString) = 0 Then
iUndefined = iUndefined + 1
End If
Next iLoop
If iUndefined <> 0 Then
iDefaultWidth = (.Width - iColWidthSum) / iUndefined
End If
If iDefaultWidth > 0 And iDefaultWidth < 1440 Then
msgbox "Sorry! Can't process listboxes with horizontal ScrollBars "
Exit Sub 'Horizontal scroll bar present
Else
'recalculate widths and running sum of column widths
iColWidthSum = 0
For iLoop = 0 To iColCount - 1
If Len(vArWidths(iLoop, 0) & vbNullString) = 0 Then
vArWidths(iLoop, 0) = iDefaultWidth
End If
iColWidthSum = iColWidthSum + Val(vArWidths(iLoop, 0))
vArWidths(iLoop, 1) = iColWidthSum
Next iLoop
End If
'Set right edge of last column equal to width of listbox
vArWidths(iColCount - 1, 1) = .Width
'Determine which column was clicked
For iLoop = 0 To iColCount - 1
'If X - .Left <= vArWidths(iLoop, 1) Then
If X <= vArWidths(iLoop, 1) Then
iColNumber = iLoop
Exit For
End If
Next iLoop
iColNumber = iColNumber + 1 'adjust since iLoop is 0 to n-1
'rebuild sql statement
If iColNumber > 0 And iColNumber <= iColCount Then
strSql = Trim(.RowSource)
If Right(strSql, 1) = ";" Then strSql = Left(strSql, Len(strSql) - 1)
iLoop = InStr(1, strSql, "Order by", vbTextCompare)
If iLoop > 0 Then
strOrderBy = Trim(Mid(strSql, iLoop + Len("Order by")))
strSql = Trim(Left(strSql, iLoop - 1))
End If
'Build the appropriate ORDER BY clause
If Shift = acShiftMask Then
'If shift key is down force sort to desc on selected column
strOrderBy = " Order By " & iColNumber & " Desc"
ElseIf Len(strOrderBy) = 0 Then
'If no prior sort then sort this column ascending
strOrderBy = " Order by " & iColNumber & " Asc"
ElseIf InStr(1, strOrderBy, iColNumber & " Asc", vbTextCompare) > 0 Then
'If already sorted asc on this column then sort descending
strOrderBy = " Order By " & iColNumber & " Desc"
ElseIf InStr(1, strOrderBy, iColNumber & " Desc", vbTextCompare) > 0 Then
'If already sorted desc on this column then sort Ascending
strOrderBy = " Order By " & iColNumber & " Asc"
Else
strOrderBy = " Order by " & iColNumber & " Asc"
End If
strSql = strSql & strOrderBy
.RowSource = strSql
End If 'Rebuild SQL if col number is in range 1 to number of columns
End With 'current list
End If 'Passed error checks
EXIT_sSortListBox:
Exit Sub
ERROR_sSortListBox:
Select Case Err.Number
Case 9 'Subscript out of range
msgbox Err.Number & ": " & Err.Description & _
vbCrLf & vbCrLf & "Check column count property of list box.", _
vbInformation, "ERROR: sSortListBox"
Case Else 'unexpected error
msgbox Err.Number & ": " & Err.Description, vbInformation, _
"ERROR: sSortListBox"
End Select
Resume EXIT_sSortListBox
End Sub
Public Function BuildFilteredSQL(filtertext As String, filterType As String, sqltext As String) As String
On Error GoTo Err_BuildFilteredSQL
'Builds a sql statement using the filtertext, filtertype and sqltext
'The filtertext is the string to filter on
'The filterType determines what fields are used to do the filtering on
'Note: these are hardcoded in this routine
'the sqltext determines the base sql query to modify
Dim sql As String
Dim fff As Integer
Dim sqlwhere As String
Dim doneFlag As Integer
sql = sqltext
'good for debugging
'MsgBox sql & "||"
'take off extra spaces and ";" if they exist
sql = RTrim(sql)
If (Right(sql, 1) = ";") Then
sql = Left(sql, Len(sql) - 1)
End If
'Build a new WHERE clause based on passed in parameters
If (filtertext <> "") And (filterType <> "") Then
Select Case filterType
Case "Quality"
'*****This is where the Select is located to find things easily********
sqlwhere = "WHERE ((MEASURES.HEDIS_MEASURE Like '*" & filtertext & "*') OR (PROGRAM.Prog_NM Like '*" & filtertext & "*') OR (CONTACTS.ContacT Like '*" & filtertext & "*') OR (MEASURES.CONDITION_CATEGORY LIKE '*" & filtertext & "*') OR (COMMUNICATION.Comm_type Like '*" & filtertext & "*') OR (BUS_UNIT.bus_unit Like '*" & filtertext & "*') OR (LOB.lob Like '*" & filtertext & "*') OR (PRODUCT.prod_nm Like '*" & filtertext & "*') OR (COMM_LVL.comm_lvl Like '*" & filtertext & "*')OR (STATE.stcd Like '*" & filtertext & "*')OR (COMM_LVL.comm_lvl Like '*" & filtertext & "*') OR (YEAR_TABLE.yr Like '*" & filtertext & "*')OR (MONTH_TABLE.mth Like '*" & filtertext & "*') or (funding.fund_cd line '*" & filtertest & "*'))"
Case "Resource"
sqlwhere = "WHERE ((tblResource.hedis_measure Like '*" & filtertext & "*') OR (tblResource.prog_nm Like '*" & filtertext & "*') OR (tblResource.contacT Like '*" & filtertext & "*') OR (TBLRESOURCE.CONDITION_CATEGORY LIKE '*" & filtertext & "*') OR (tblResource.comm_type Like '*" & filtertext & "*') OR (tblResource.bus_unit Like '*" & filtertext & "*') OR (tblResource.lob Like '*" & filtertext & "*') OR (tblResource.prod_nm Like '*" & filtertext & "*') OR (tblResource.comm_lvl Like '*" & filtertext & "*') OR (tblResource.stcd Like '*" & filtertext & "*') OR (tblResource.comm_lvl Like '*" & filtertext & "*')OR (tblResource.yr Like '*" & filtertext & "*')OR (tblResource.mth Like '*" & filtertext & "*') or (tblResource.fund_cd like '*" & filtertext & "*'))"
End Select
End If
'modify existing HAVING or WHERE clauses (modifies having if sqlwhere starts with "HAVING")
doneFlag = 0
'look for GROUP BY clause (if so use HAVING instead of WHERE)
fff = InStr(1, sqlwhere, "HAVING")
If (fff <> 0) Then
'look for existing HAVING clause in sql
fff = InStr(1, sql, "HAVING ")
If (fff <> 0) Then ' found a HAVING clause
'Merge in new criteria into HAVING clause
sql = Left(sql, fff - 1) & sqlwhere & " AND " & Right(sql, Len(sql) - fff - 6)
doneFlag = 1
End If
Else
'look for existing WHERE clause
fff = InStr(1, sql, "WHERE ")
If (fff <> 0) Then ' found a WHERE clause
'Merge in new criteria into WHERE clause
sql = Left(sql, fff - 1) & sqlwhere & " AND " & Right(sql, Len(sql) - fff - 5)
doneFlag = 1
End If
End If
'no HAVING or WHERE clause so add a new one (either before ORDER BY or at end of sql)
'Note:routine needs to be modified to work with filtering sql on the where clause when the sql has both where and having clauses
If (doneFlag = 0) Then
fff = InStr(1, sql, "ORDER BY")
If (fff <> 0) Then 'found an ORDER BY clause
sql = Left(sql, fff - 1) & sqlwhere & Right(sql, Len(sql) - fff + 1)
Else
sql = sql & " " & sqlwhere
End If
End If
' good for debugging
'MsgBox sql
BuildFilteredSQL = sql
Exit_BuildFilteredSQL:
Exit Function
Err_BuildFilteredSQL:
msgbox Err.Description
Resume Exit_BuildFilteredSQL
End Function
Public Function GetFilterFromListBoxes() As String
Dim lst As Access.ListBox
Dim ctrl As Access.Control
Dim fieldName As String
Dim fieldType As String
Dim TotalFilter As String
Dim ListFilter As String
Dim itm As Variant
'Each listbox needs a tag property with the field name and the field type
'Seperate these with a ;
'The types are Text, Numeric, or Date
For Each ctrl In Me.Controls
If ctrl.ControlType = acListBox Then
fieldName = Split(ctrl.tag, ";")(0)
fieldType = Split(ctrl.tag, ";")(1)
For Each itm In ctrl.ItemsSelected
If ListFilter = "" Then
ListFilter = GetProperType(ctrl.ItemData(itm), fieldType)
Else
ListFilter = ListFilter & "," & GetProperType(ctrl.ItemData(itm), fieldType)
End If
Next itm
If Not ListFilter = "" Then
ListFilter = fieldName & " IN (" & ListFilter & ")"
End If
If TotalFilter = "" And ListFilter <> "" Then
TotalFilter = ListFilter
ElseIf TotalFilter <> "" And ListFilter <> "" Then
TotalFilter = TotalFilter & " AND " & ListFilter
End If
ListFilter = ""
End If
Next ctrl
GetFilterFromListBoxes = TotalFilter
End Function
Public Function GetProperType(varitem As Variant, fieldType As String) As Variant
If fieldType = "Text" Then
GetProperType = sqlTxt(varitem)
ElseIf fieldType = "Date" Then
GetProperType = SQLDate(varitem)
Else
GetProperType = varitem
End If
End Function
Public Function sqlTxt(varitem As Variant) As Variant
If Not IsNull(varitem) Then
varitem = Replace(varitem, "'", "''")
sqlTxt = "'" & varitem & "'"
End If
End Function
Function SQLDate(varDate As Variant) As Variant
If IsDate(varDate) Then
If DateValue(varDate) = varDate Then
SQLDate = Format$(varDate, "\#mm\/dd\/yyyy\#")
Else
SQLDate = Format$(varDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#")
End If
End If
End Function
