**Beta .5**

Jan. 01, 2001

Finally, here is a working version of an Enhanced ListBox control. This is an early BETA version with minimal functionality. It merely Paints each row of the ListBox with a separate color. 

This originally existed as a subclassing project but I am releasing this first version for A97 without subclassing. I am able to do this by using a Timer when the ListBox has the focus. The subclassed version will be released shortly.

ListBoxEnhanced.zip is a database containing a class that adds new Methods and Properties to a standard ListBox control.

Version History

Version .5

Added functionality to Highlight Row code.

Fixed overflow on coordinate array.

Increased speed the user interface to more closely resemble a standard ListBox control. 

Version .12

Remove restriction to open from Design view only.

Fixed hard coded Scrollbar width.

Added support to Repaint window when switching between Applications.

' Below is the older non working version of Enhanced ListBox. It's main use is to explain and show how the custom row source list fill functions work, from the inside out!

Your system display settings must be set to Large Fonts for this to work!

OLDListBoxEnhanced.zip is a database containing an example of using a custom function  to fill ListBox control. It was actually my second attempt to try and produce an entirely native VBA solution to build a better ListBox.

It almost works! :-(

The code is very raw. I have left all of the logic I tried to make it work commented out in the function. This is to aid the next person that decides to try this.

Demonstrates using the API's to create a window and get the current ScrollBar postition all from within an Access callback function...sort of :-)

Here's the custom function to fill the ListBox. I've mangled it many times from the original source. I lived inside this function for several days and learned what you can/cannot do from inside the code. Quite an experience!

' This function is Copyright Ian Hinson and Lebans Holdings 1999 Ltd.
' May not be resold in whole or part, or as a member of a collection.
' You may use any code contained within in you own
' projects without obligation or cost.

' Ian wrote all of the good stuff. Any Static and Global Var stuff is me.
' No reflection on Ian. :-)
' Ian's Function really brought me quickly up to speed on the design
' and implementation of the functions required for a UDT RowSource.
' Stephen Lebans September 1, 1999

' This function is diiferent from a standard UDT RowSource Function
' in several ways.
' It can be called from more than 1 ListBox.
' It calls a function directly on a Form.
' .frmParent.printLB ctl, .vntCurrentRow, .currentrowno
' It caches the current row so as not to have to go back to
' the row source as the ListBox calls for each row,Column
' seperately.
' I have made it slightly reentrant by using a Global Flag set
' in my Main Form to allow it to call this Function directly to
' get field data but not ending up calling itslef recursively.
' I had other code in here to cache the local static vars but it was
' easier to use the Global Busy Flag as the vars weren't required
' if you just want Row.Column Data.

' I hope Ian will post his original functions. They belong on
' Dev's site. A great starting point for learning how to develop and
' implement on of these callback's for List and Combo's.

' Enjoy, Stephen Lebans


Private Type ListRecord
dbs As Database
rstRowSource As Recordset
lngDisplayID As Long
lngColCount As Long
lngRowCount As Long
colwidth() As Integer
colformat() As String
strTag As String
blnColumnHeads As Boolean
colHeads() As String
vntCurrentRow As Variant
currentrowno As Long
frmParent As Form
End Type

Private listinfo() As ListRecord
Private listcounter As Integer

Function CustomList(ctl As Control, lngID As Long, lngRow As Long, _
lngCol As Long, intCode As Integer) As Variant
Dim colno As Integer
Dim strText As String
Dim lngWidth As Long, lngHeight As Long
Dim intOK As Integer
' Dim lngScrollBarWidth As Long
Dim strRight As String
Dim listno As Integer
Dim lst As Access.ListBox

Static SLtemp As Long
Static lngPrevRow As Long
Static SLreEntrant As Long
Static SlreEntrantRow As Long
Static ctlValuePrev As Variant
Static lngMaxListDisplayRows As Long

On Error GoTo Err_CustomList
If intCode = acLBInitialize Then
'create new listrecord
ReDim Preserve listinfo(listcounter)
listno = listcounter
listcounter = listcounter + 1
Else
'find the index to the array containing the list we want
While listinfo(listno).lngDisplayID <> lngID
listno = listno + 1
Wend
'Could've included an extra test in the above loop in case list wasnt found
'(listno < listcounter) - but its gotta be in there somewhere.
End If

Select Case intCode
Case acLBInitialize
With listinfo(listno)
Set .frmParent = ctl.Parent
.blnColumnHeads = ctl.ColumnHeads

' Open the recordset which will be returned to list
Set .dbs = CurrentDb
Set .rstRowSource = .dbs.OpenRecordset(ctl.RowSource)
'Get column info
.lngColCount = .rstRowSource.Fields.Count
If ctl.ColumnCount < .lngColCount Then
.lngColCount = ctl.ColumnCount
End If
ReDim .colformat(.lngColCount - 1)
'Get field formats that have already been specified (ie. designed
' into) the underlying fields of the query or table
On Error Resume Next 'probable Err 3270 Property not found for some columns
For colno = 0 To .lngColCount - 1
.colformat(colno) = .rstRowSource.Fields(colno).Properties("Format")
Next colno

'Extract individual column widths from ColumnWidths property
ReDim .colwidth(.lngColCount - 1)
ResolveColumnWidths ctl, .colwidth

If .blnColumnHeads Then
ReDim .colHeads(.lngColCount - 1)
For colno = 0 To .lngColCount - 1
.colHeads(colno) = .rstRowSource.Fields(colno).name
Next colno
End If

' Record and return the lngID for this function.
.lngDisplayID = listcounter
CustomList = .lngDisplayID
End With

' Init my static var to track last Row output
' We need this to flag when user has pagedown/Up
' or used Scroll Thumb to move more than MaxDisplay ROws
lngPrevRow = 0
SLtemp = 0
lngPrevRow = 0
ctlValuePrev = 0
' We need a GLobal or a property for this var
' It's the total number of DISPLAY Rows in the ListBox
lngMaxListDisplayRows = 13
'Keeps the Bottom or Top row when we Page Up/Down



Case acLBOpen
CustomList = listinfo(listno).lngDisplayID

Case acLBGetRowCount
' Return number of rows in recordset.
With listinfo(listno).rstRowSource
If .EOF Then
If listinfo(listno).blnColumnHeads Then
CustomList = 1
Else
CustomList = 0
End If
Else
.MoveLast
If listinfo(listno).blnColumnHeads Then
CustomList = .RecordCount + 1
Else
CustomList = .RecordCount
End If
End If
.MoveFirst
listinfo(listno).vntCurrentRow = .GetRows(1)
End With

Case acLBGetColumnCount
' Return number of fields (columns) in recordset.
CustomList = listinfo(listno).lngColCount

Case acLBGetColumnWidth
'Return "as designed" default using -1
'Returning a custom value here provides scope for tweaking
'the column width if required
CustomList = -1

Case acLBGetValue
With listinfo(listno)
'Get required row if not currently stored in vntCurrentRow
If (lngRow > 0) And .blnColumnHeads Then
If .currentrowno <> (lngRow - 1) Then
Set .vntCurrentRow = Nothing 'erase contents
.rstRowSource.AbsolutePosition = lngRow - 1
.vntCurrentRow = .rstRowSource.GetRows(1)
.currentrowno = lngRow - 1
'.frmParent.printLB ctl, .vntCurrentRow, .currentrowno
End If
Else
If .currentrowno <> lngRow Then
Set .vntCurrentRow = Nothing
.rstRowSource.AbsolutePosition = lngRow
.vntCurrentRow = .rstRowSource.GetRows(1)
.currentrowno = lngRow
'.frmParent.printLB ctl, .vntCurrentRow, .currentrowno
End If
End If

'Return value of requested column from row
If (lngRow = 0) And .blnColumnHeads Then
CustomList = .colHeads(lngCol)
Else
CustomList = .vntCurrentRow(lngCol, 0) 'simple return value
End If
' Trigger print routine
If .frmParent.blBusy <> True Then

'Put this back Aug 29, 2:44
'Debug.Print "SLTEMP:" & SLtemp
'Debug.Print "Current Row:" & .currentrowno
'Debug.Print "Previous Row:" & lngPrevRow
If lngPrevRow > .currentrowno Then
'If lngPrevRow - .currentrowno >= lngMaxListDisplayRows + 1 Then SLtemp = 99999 '14
If lngPrevRow - .currentrowno >= 4 Then SLtemp = 99999 '14

Else
If lngPrevRow < .currentrowno Then
'If .currentrowno - lngPrevRow >= lngMaxListDisplayRows + 1 Then SLtemp = 99999 '14
If .currentrowno - lngPrevRow >= 4 Then SLtemp = 99999 '14

Else
'Don't do anything. Either smaller than 1 page up/down
' or same row number.
End If
End If

If ctl.Value <> ctlValuePrev Then
'Debug.Print "called printLB"
ctlValuePrev = ctl.Value
.frmParent.printLB .vntCurrentRow, .currentrowno
SLtemp = 1
End If
If SLtemp >= lngMaxListDisplayRows Then
'Debug.Print "called printLB"
ctlValuePrev = ctl.Value
.frmParent.printLB .vntCurrentRow, .currentrowno
'SLTEMP = GetCurrentScrollPos(ctl, -1)
'.frmParent.txtTop2Rows = SLTEMP
End If

' used exit function instead at calling line above End If
' Of we just determined we've Jumped at least a page
' setup our counters for next loop through
ctlValuePrev = ctl.Value

If SLtemp = 99999 Then SLtemp = 0
SLtemp = SLtemp + 1
'Debug.Print "SLTEMP + 1:" & SLtemp

' Save currentrownum into Previos var
'
lngPrevRow = .currentrowno

' If we jumped to here than blBusy was TRUE
End If
End With


Case acLBGetFormat
If Len(listinfo(listno).colformat(lngCol)) = 0 Then
'no custom format set for this string
CustomList = -1
Else
CustomList = listinfo(listno).colformat(lngCol)
End If

Case acLBEnd
With listinfo(listno)
.rstRowSource.Close
.dbs.Close
End With

While listno < (listcounter - 1) 'not last list
'move higher lists down by one record
listinfo(listno) = listinfo(listno + 1)
listno = listno + 1
Wend

listcounter = listcounter - 1
If listcounter > 0 Then
ReDim Preserve listinfo(listcounter - 1)
Else
Erase listinfo
End If

End Select

Bye_CustomList:
Exit Function

Err_CustomList:
MsgBox Err.Description, vbOKOnly + vbCritical, "CustomList"
CustomList = Null
Resume Bye_CustomList
End Function

Private Sub ResolveColumnWidths(ctl As Control, colwidth() As Integer)
'This sub fills the colwidth array
'ColumnWidths string looks like "1440;2880;3935" or "0;1440;" or ";0" etc
' or is "" if widths have not been setup in design mode.
'Access divides unused available width of control between columns with
'unspecified widths (available = totalwidth - Sum of specified widths)
Dim lngScrollBarPixels As Long
Dim lngScrollBarTwips As Long
Dim intControlWidth As Integer
Dim strColumnWidths As String
Dim maxcol As Integer
Dim resolved() As Boolean
Dim colno As Integer, separator_posn As Integer, fldstart As Integer
Dim resolvedcount As Integer, unresolved As Integer
Dim usedwidth As Integer, unusedwidth As Integer
Dim specified_width As Integer

Const lngFudge = 50&
On Error GoTo Err_ResolveColumnWidths
strColumnWidths = ctl.ColumnWidths
maxcol = UBound(colwidth)
ReDim resolved(maxcol) 'array of booleans
fldstart = 1
If Len(strColumnWidths) > 0 Then
Do
specified_width = 0 'initialiser each column
separator_posn = InStr(fldstart, strColumnWidths, ";")
If (separator_posn > fldstart) Then
specified_width = CInt(Mid$(strColumnWidths, fldstart, _
separator_posn - fldstart))
resolved(colno) = True
resolvedcount = resolvedcount + 1
ElseIf (separator_posn = 0) Then 'is last value specified by user
specified_width = CInt(Mid$(strColumnWidths, fldstart))
resolved(colno) = True
resolvedcount = resolvedcount + 1
End If
If specified_width > 0 Then
colwidth(colno) = specified_width - lngFudge
usedwidth = usedwidth + specified_width
End If
fldstart = separator_posn + 1
colno = colno + 1
Loop Until (separator_posn = 0) Or (fldstart > Len(strColumnWidths)) _
Or (colno > maxcol)
End If

'Determine total available control width (intControlWidth)
If (ctl.ControlType = acComboBox) Then
If (ctl.ListWidth > ctl.Width) Then
intControlWidth = ctl.ListWidth
Else
intControlWidth = ctl.Width
End If
Else 'is a listbox
intControlWidth = ctl.Width
End If

unresolved = (maxcol + 1) - resolvedcount
If unresolved = 0 Then
'This bit implements the (MS Access) rule that if all column widths have
'been specified, and the sum of those widths is less than the total
'available width, then the last column is allocated all the spare width
'(unless its specified value is 0, then the previous column gets extra)
If intControlWidth > usedwidth Then
colno = maxcol 'find righmost (non-zero width) column
Do While colwidth(colno) = 0 And (colno > 0)
colno = colno - 1
Loop
colwidth(colno) = intControlWidth - usedwidth + colwidth(colno)
End If
Else 'unresolved > 0
'Allocate that remaining unallocated width equally between columns
'not having specified widths
unusedwidth = intControlWidth - usedwidth
If unusedwidth > 0 Then
'spread unused width among columns without specified widths
For colno = 0 To maxcol
If Not resolved(colno) Then _
colwidth(colno) = unusedwidth \ unresolved - lngFudge
Next colno
End If
'unresolved column widths default to 0 if no unused width is available
End If

Exit_ResolveColumnWidths:
Exit Sub

Err_ResolveColumnWidths:
MsgBox Err.Description
Resume Next
End Sub