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

R

Robots

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
' (e-mail address removed)
'
'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
 
I

Ivan F Moala

Thanks Ian

That's a good one to add to my collection.
The only thing I added was to Enum, as I use Xl2000/xl2003
and I like to use intellisence ie. select the proporties values.
Xl97 doesn't support Enum.

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
' (e-mail address removed)
'
'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
Click to expand...
 
R

Robots

Ivan

Yes, I would have liked in this and many other situations to able to
use Enum but I'm aware that many people still only have access to
Excel 97 - like at my office.

Other things missing in Excel 97 class modules which can be a nuisance
at times in Office 97 class modules are:
* the inability to *raise* events
* apply the AddressOf operator (although I'm familiar with the AddrOf
workaround but can only refer to functions in standard modules)
* create default properties (except through back door for Excel 2000+)
* create VB Friend properties
* create a private enumerator property (although one can simulate
enumeration by creating an Items property which points to the hidden
collection object)
* create publicnotcreatable or even multiuse instances of class
modules
* create control arrays in a userform (although a clever workaround
does exist)
* use Implements for user defined interfaces

I know some of these have been introduced in more recent versions.
Pity also that the format for VBA UserForm and VB Form (with
associated *.frx files) are different making conversions between the
two tedious (conversion tools do exist though).
 
J

Jamie Collins

(e-mail address removed) (Robots) wrote ...
apply the AddressOf operator (although I'm familiar with
the AddrOf workaround but can only refer to functions in
standard modules)
Click to expand...

You can't use AddressOf operator to refer to functions in class
modules either. The reason is due to calling convention and COM etc
but it's a fundamental issue. Think about it: which instance of the
class would you expect e.g. the callback to apply to?

Jamie.

--
 
R

Robots

(e-mail address removed) (Robots) wrote ...


You can't use AddressOf operator to refer to functions in class
modules either. The reason is due to calling convention and COM etc
but it's a fundamental issue. Think about it: which instance of the
class would you expect e.g. the callback to apply to?

Jamie.

--
Click to expand...

Thanks Jamie. I'll remember(?) that. I presume same thing apply to VB.
 
J

Jamie Collins

(e-mail address removed) (Robots) wrote in message
Thanks Jamie. I'll remember(?) that. I presume same thing apply to VB.
Click to expand...

Yes and C++ too.

Jamie.

--
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Help raising an error from an Excel Object (e.g. Worksheet) 3
Using Application.OnTime within a class module 4
the same question, revisisted 4
Irregular Shape - Follow up 0
Read Windows Product ID in Vista from Access 0
Generic Userform class 3
John Walkenbach Color Palette (Repost) 1
Fill a multicolumn listbox with data from a range in another works 1

Top