ExcelBanter - Repost: ListBox Headings - customized! Class Module (warning: long post)"

I've had a request to post class module here.

Some ideas for improvement might be:

* click headings to sort list
* text align headings

I suspect these are either impossible in the current rendition or else
require some API knowledge. For example, the former can be done in VB
but there the headings in the ListBox actually work without the
following workaround and the listbox has a sort property!

'//////////////////////////////////////////////////////////////////////////////
'Name: clsListBoxHeader
'
'Purpose: Add and customize a header of a MSForms ListBox
control of Excel.
'
'Usage: Sub UserForm_Initialize()
' Dim oLB As clsListBoxHeader
' Dim aHeaders as Variant
'
' aHeaders = Array("Head1", "Head2", ...)
' Set oLB = New clsListBoxHeader
' With oLB
' .Create(Me.ListBox1, aHeaders)
' .BackColor = RGB(255,0,0)
' (etc)
' End With
' Set oLB = Nothing '(Header will remain intact)
'
' End Sub
'
' 'Me.ListBox1' is a reference to the listbox already on
the UserForm
' which has columns and properties already set.
' 'aHeaders' is a Range reference or a variant array of
text headers.
'
'Properties & Methods:
' Create - creates instances (must be called first)
' BackColor - background color (RGB)
' Bold - set font to bold (or normal)
' BorderColor - set border color (RGB)
' CloseUp - set gap between header and list (twips)
' FontSize - font size
' FontColor - font color (RGB)
' FontName - font name
' SpecialEffect - type of border effect
'
'Limitations: Tested on Excel 97, Win NT 4.0.
'
' It should work on all later versions of Excel and
Windows.
' It may work for other MS Office applications without
modification.
'
' It will not work in VB. The ListBox control is
different in its
' treatment of multiple columns and form controls cannot
be added
' programmatically.
'
' There appear to be some minor bugs in the MSForms
ListBox control
' which may be evident on usage. If you believe the
problem is with
' this code, I would be pleased to hear.
'
'Author: Ian Robinson
' CrusoeConsulting
'
'
'Disclaimer: No responsibility or warranty is implied or expressed
by me for any
' use by you of this class module. You are on your own!
'
'Copyright: You are free to use, modify or distribute this class
module as
' you wish subject only to a request that this header
description
' remain intact.
'
' Suggestions for improvement and advice on errors are
both welcome.
'
'//////////////////////////////////////////////////////////////////////////////

Option Explicit

Private m_oHeader As MSForms.ListBox
Private m_oSource As MSForms.ListBox

Const THISCLASS = "[clsListBoxHeader] "

Public Sub Create(ByVal lstSource As MSForms.ListBox, ByVal
HeadingRangeOrArray As Variant)
Dim iCol As Integer
Dim h As Variant
Const OPTION_COLWIDTH = "12" 'Initial space if source has option
column

On Error GoTo ErrorHandler

Set m_oHeader = lstSource.Parent.Controls.Add("forms.ListBox.1", ,
True)
Set m_oSource = lstSource

With m_oHeader
.Enabled = False
.ColumnHeads = False
.MultiSelect = fmMultiSelectSingle
.ListStyle = fmListStylePlain
m_oSource.ColumnHeads = False

'Inherit source column properties
If m_oSource.ListStyle = fmListStyleOption Then
.ColumnCount = 1 + m_oSource.ColumnCount
.ColumnWidths = OPTION_COLWIDTH & "," &
m_oSource.ColumnWidths
iCol = 1
Else
.ColumnCount = m_oSource.ColumnCount
.ColumnWidths = m_oSource.ColumnWidths
End If

'Inherit source dimension properties
.Width = m_oSource.Width
.Height = m_oSource.FontSize
.Left = m_oSource.Left
.Top = m_oSource.Top

'Ensures listbox redraws correctly
'Seems to be required immediately after a Width or Height
change
'Not sure why or if this is a bug?
DoEvents

'Inherit source style properties
.BorderStyle = m_oSource.BorderStyle
.BorderColor = m_oSource.BorderColor
.BackColor = m_oSource.BackColor
.FontSize = m_oSource.FontSize
.ForeColor = m_oSource.ForeColor
.SpecialEffect = m_oSource.SpecialEffect
.FontName = m_oSource.FontName

'Rejiggle source listbox size and position
m_oSource.Top = m_oSource.Top + .Height
m_oSource.Height = m_oSource.Height - .Height

'Add headings
.AddItem ""
'If headings in spreadsheet range...
If TypeName(HeadingRangeOrArray) = "Range" Then
For Each h In HeadingRangeOrArray.Rows(1)
.List(0, iCol) = h
iCol = iCol + 1
Next h
Else
'If headings supplied programmatically as an array
For Each h In HeadingRangeOrArray
.List(0, iCol) = h
iCol = iCol + 1
Next h
End If
End With

Exit Sub

ErrorHandler:
Err.Raise Err.Number, THISCLASS & "Create", Err.Description

End Sub

Public Property Let BackColor(ByVal iRGB As Long)
If iRGB = RGB(0, 0, 0) And iRGB <= RGB(255, 255, 255) Then
m_oHeader.BackColor = iRGB
Else
Err.Raise vbObjectError + 1001, THISCLASS & "BackColor",
"Invalid property setting"
End If
End Property

Public Property Let BorderColor(ByVal iRGB As Long)
If iRGB = RGB(0, 0, 0) And iRGB <= RGB(255, 255, 255) Then
m_oHeader.BorderColor = iRGB
Else
Err.Raise vbObjectError + 1001, THISCLASS & "BorderColor",
"Invalid property setting"
End If
End Property

Public Property Let BorderStyle(ByVal iBS As Integer)
'MSForms.fmBorderStyle
If iBS = 0 Or iBS = 1 Then
m_oHeader.BorderStyle = iBS
Else
Err.Raise vbObjectError + 1001, THISCLASS & "BorderStyle",
"Invalid property setting"
End If
End Property

Public Property Let ForeColor(ByVal iRGB As Long)
If iRGB = RGB(0, 0, 0) And iRGB <= RGB(255, 255, 255) Then
m_oHeader.ForeColor = iRGB
Else
Err.Raise vbObjectError + 1001, THISCLASS & "ForeColor",
"Invalid property setting"
End If
End Property

Public Property Let Bold(ByVal bBold As Boolean)
On Error Resume Next
m_oHeader.FontBold = True
End Property

Public Property Let SpecialEffect(ByVal iSE As Integer)
'If iSE 0 (not flat), Borderline is automatically set to 0 (none)
If iSE = 0 And iSE <= 6 Then
m_oHeader.SpecialEffect = iSE
Else
Err.Raise vbObjectError + 1001, THISCLASS & "SpecialEffect",
"Invalid property setting"
End If
End Property

Public Property Let CloseUp(ByVal iY As Integer)
'If iY is positive, the list boxes are closer, if negative, they
further apart
'A value of 2 seems to line them up exactly with no gaps
If iY = -10 And iY <= 2 Then
With m_oHeader
m_oSource.Top = m_oSource.Top - iY
m_oSource.Height = m_oSource.Height + iY
End With
Else
Err.Raise vbObjectError + 1001, THISCLASS & "CloseUp",
"Invalid property setting"
End If
End Property

Public Property Let FontSize(ByVal iFS As Integer)
If iFS = 8 And iFS <= 14 Then
With m_oHeader
.FontSize = iFS
.Height = .FontSize * 1.2 'add some space above and
below
.Top = m_oSource.Top - .Height
End With
Else
Err.Raise vbObjectError + 1001, THISCLASS & "FontSize",
"Invalid property setting"
End If
End Property

Public Property Let FontName(ByVal sFN As String)
Dim cbar As CommandBarComboBox
Dim bFound As Boolean
Dim i As Integer

Set cbar = Application.CommandBars.FindControl(ID:=1728)
For i = 1 To cbar.ListCount
If sFN = cbar.List(i) Then bFound = True
Next i

If bFound Then
With m_oHeader
.FontName = sFN
End With
Else
Err.Raise vbObjectError + 1001, THISCLASS & "FontName",
"Invalid property setting"
End If
End Property

Private Sub Class_Terminate()
Set m_oHeader = Nothing
Set m_oSource = Nothing
End Sub