Tipp 0424
|
ListBox - Spaltenüberschriften in 2. ListBox
|
|
|
Autor/Einsender: Datum: |
|
Angie 19.11.2004 |
|
Entwicklungsumgebung: |
|
Word 2000 |
|
|
ListBox-Spaltenüberschriften in 2. ListBox anzeigen
|
Im Gegensatz zu Excel, wo es möglich ist, mit der ColumnHeads-Eigenschaft in
Verbindung mit der RowSource-Eigenschaft
Spaltenüberschriften in einer ListBox und ComboBox
anzuzeigen, muss dafür in Word und PowerPoint eine andere Lösung gefunden werden.
Eine Lösungsmöglichkeit ist eine zusätzliche ListBox zur UserForm hinzuzufügen,
in der die Spaltenüberschriften angezeigt werden.
|
In diesem Beispiel wurde ein Klassenmodul CListColumnHeads hinzugefügt, in der
sich u. a. der Code für die Erstellung der ListBox für die Spaltenüberschriften befindet.
|
In der Initialisierungsprozedur InitListBoxHeader wird die neue ListBox erstellt und
deren Eigenschaften zunächst im Großen und Ganzen denen der entsprechenden ListBox mit Daten
gleichgesetzt. Es ist jedoch nachträglich möglich (optional), verschiedene Eigenschaften,
wie Darstellung, Hintergrundfarbe, Schriftart, -größe und -Farbe usw. zu verändern.
|
Die Klasse dient als Vorlage, aus der eine Objektinstanz zur Laufzeit erzeugt wird. Es kann
für jede ListBox auf einer beliebigen UserForm eine Objektinstanz erstellt werden.
|
Anmerkung zum Code
|
Ist die Summe der Breiten der sichtbaren Spalten in der ListBox, plus die Breite der ggf. vorhandenen
Optionsfelder oder Kontrollkästchen und vertikaler ScrollBar, größer als die Gesamtbreite der ListBox,
wird automatisch die horizontale ScrollBar der ListBox angezeigt. Da die ListBox kein Scroll-Ereignis
besitzt, und somit das "Mit-Scrollen" der ListBox mit den Spaltenüberschriften nicht möglich ist,
muss in diesem Beispiel darauf geachtet werden, dass die Summe der zu berücksichtigenden Elemente
(sichtbare Spalten, ListStyle und ScrollBar) nicht die Gesamtbreite der ListBox überschreitet.
|
|
Code im Codebereich des Klassenmoduls CListColumnHeads |
|
|
Option Explicit
Private Const mc_OptWdth As Single = 12
Private m_lstData As MSForms.ListBox
Private m_lstHeader As MSForms.ListBox
Private m_blnInitError As Boolean
Private m_OldHeight As Single
Private Sub Class_Terminate()
Set m_lstData = Nothing
Set m_lstHeader = Nothing
End Sub
Public Sub InitListBoxHeader(ByVal lstData As MSForms.ListBox, _
ByRef astrHeaders() As String)
Dim sngPosTop As Single
Dim nCol As Long
On Error GoTo err_Init
Set m_lstData = lstData
m_OldHeight = m_lstData.Height
sngPosTop = m_lstData.Top
Set m_lstHeader = m_lstData.Parent.Controls.Add( _
"Forms.ListBox.1", , True)
With m_lstHeader
.IntegralHeight = False
.Locked = True
.ListStyle = fmListStylePlain
.MultiSelect = fmMultiSelectSingle
.SpecialEffect = m_lstData.SpecialEffect
.BackColor = m_lstData.BackColor
.BorderStyle = m_lstData.BorderStyle
.BorderColor = m_lstData.BorderColor
.Font.Bold = m_lstData.Font.Bold
.Font.Name = m_lstData.Font.Name
.Font.Size = m_lstData.Font.Size
.ForeColor = m_lstData.ForeColor
.ColumnHeads = False
.ColumnCount = m_lstData.ColumnCount
.ColumnWidths = m_lstData.ColumnWidths
If m_lstData.ListStyle = fmListStyleOption Then
.ColumnCount = 1 + .ColumnCount
.ColumnWidths = mc_OptWdth & ";" & .ColumnWidths
nCol = 1
End If
Dim nItemsCnt As Long
Dim varH As Variant
nItemsCnt = UBound(astrHeaders)
If nItemsCnt > nCol + .ColumnCount Then
ReDim Preserve astrHeaders(.ColumnCount)
End If
.Clear
.AddItem ""
For Each varH In astrHeaders
.Column(nCol, 0) = varH
nCol = nCol + 1
Next
.Left = m_lstData.Left
.Top = m_lstData.Top
Call SetHeaderHeight
.Width = m_lstData.Width
DoEvents
End With
m_lstData.ZOrder 0
exit_Sub:
On Error GoTo 0
Exit Sub
err_Init:
m_blnInitError = True
If Not m_lstHeader Is Nothing Then
m_lstData.Parent.Controls.Remove m_lstHeader.Name
Set m_lstHeader = Nothing
End If
If Not m_lstData Is Nothing Then
With m_lstData
If .Top <> sngPosTop Then
.Top = sngPosTop
.IntegralHeight = False
.Height = m_OldHeight
.IntegralHeight = True
End If
End With
Set m_lstData = Nothing
End If
Resume exit_Sub
End Sub
Private Sub SetHeaderHeight()
Dim sngHeaderHght As Single
With m_lstHeader
Select Case .SpecialEffect
Case 1, 2
sngHeaderHght = .Font.Size * 1.25
Case Else
sngHeaderHght = .Font.Size * 1.2
End Select
.Height = sngHeaderHght * 2
End With
With m_lstData
.Top = m_lstHeader.Top + sngHeaderHght
.IntegralHeight = False
.Height = m_OldHeight - sngHeaderHght
.IntegralHeight = True
End With
End Sub
Public Property Let InitError(ByVal vNewValue As Boolean)
m_blnInitError = vNewValue
End Property
Public Property Get InitError() As Boolean
InitError = m_blnInitError
End Property
Public Property Let BackColor(ByVal nColor As Long)
m_lstHeader.BackColor = nColor
End Property
Public Property Let SpecialEffect(ByVal fmEffect As Long)
m_lstHeader.SpecialEffect = fmEffect
End Property
Public Property Let FontName(ByVal sFontName As String)
If IsFontInstalled(sFontName) Then
m_lstHeader.Font.Name = sFontName
End If
End Property
Public Property Let FontSize(ByVal nFontSize As Single)
If nFontSize >= 8 And nFontSize <= 14 Then
m_lstHeader.Font.Size = nFontSize
Call SetHeaderHeight
End If
End Property
Public Property Let FontBold(ByVal bFontBold As Boolean)
m_lstHeader.Font.Bold = bFontBold
End Property
Public Property Let ForeColor(ByVal nColor As Long)
m_lstHeader.ForeColor = nColor
End Property
Private Function IsFontInstalled(ByVal sFontName As String) _
As Boolean
Dim cbrBar As CommandBar
Dim cbcFont As CommandBarControl
Dim nCnt As Integer
Set cbcFont = Application.CommandBars.FindControl(ID:=1728)
If cbcFont Is Nothing Then
Set cbrBar = Application.CommandBars.Add( _
"MyDummy", msoBarFloating, False, True)
Set cbcFont = cbrBar.Controls.Add(ID:=1728)
End If
For nCnt = 1 To cbcFont.ListCount
If UCase$(sFontName) = UCase$(cbcFont.List(nCnt)) Then
IsFontInstalled = True
Exit For
End If
Next
If Not cbrBar Is Nothing Then cbrBar.Delete
Set cbrBar = Nothing
Set cbcFont = Nothing
End Function
|
|
|
Code im Codebereich der UserForm |
|
|
Option Explicit
Private Const mc_Title As String = _
"VB-fun-Demo - ListBox mit Spaltenüberschriften"
Private Const mc_OptWdth As Single = 12
Private Const mc_SbrWdth As Single = 15
Private Sub UserForm_Initialize()
Dim objListBox As CListColumnHeads
Dim astrHeaders() As String
Dim astrData() As String
Dim nColsCnt As Long
Dim nColsVisible As Long
Dim aColsVisible() As Long
Dim strColWdths As String
Dim fmListStyle As Long
Dim fmMultiSel As Long
Dim n As Long
nColsCnt = 4
ReDim aColsVisible(0 To nColsCnt)
ReDim astrHeaders(0 To nColsCnt)
nColsVisible = 0
astrHeaders(1) = "Nachname"
aColsVisible(1) = -1: nColsVisible = nColsVisible + 1
astrHeaders(2) = "Vorname"
aColsVisible(2) = -1: nColsVisible = nColsVisible + 1
astrHeaders(3) = "Ort"
aColsVisible(3) = -1: nColsVisible = nColsVisible + 1
Dim nRowsCnt As Long
nRowsCnt = 3
ReDim astrData(0 To nColsCnt, 0 To nRowsCnt)
astrData(1, 0) = "Luftikuss": astrData(2, 0) = "Michi"
astrData(1, 1) = "Muster": astrData(2, 1) = "Lars"
astrData(1, 2) = "Mustermann": astrData(2, 2) = "Hans"
astrData(1, 3) = "Müller": astrData(2, 3) = "Franz"
astrData(3, 0) = "Lüddelhausen": astrData(4, 0) = "001"
astrData(3, 1) = "Bonsai": astrData(4, 1) = "003"
astrData(3, 2) = "Musterhausen": astrData(4, 2) = "006"
astrData(3, 3) = "Mühlhausen": astrData(4, 3) = "007"
With Me.lstData1
fmListStyle = fmListStyleOption
fmMultiSel = fmMultiSelectMulti
.ListStyle = fmListStylePlain
.MultiSelect = fmMultiSelectSingle
.Font.Name = "Arial"
.Font.Size = 10
.ColumnHeads = False
.ColumnCount = nColsCnt
strColWdths = GetColumnWidths(Me.lstData1, fmListStyle, _
nColsVisible, aColsVisible())
.ColumnWidths = strColWdths
.BoundColumn = nColsCnt
If nRowsCnt > 0 Then .Column() = astrData
.ListStyle = fmListStyle
.MultiSelect = fmMultiSel
End With
Set objListBox = New CListColumnHeads
With objListBox
.InitListBoxHeader Me.lstData1, astrHeaders
If .InitError Then
MsgBox "Uuuuppppss, es ist ein Fehler aufgetreten !"
Else
.BackColor = vbButtonFace
.FontBold = True
.FontName = "Times New Roman"
.FontSize = Me.lstData1.Font.Size + 2
.ForeColor = vbRed
.SpecialEffect = fmSpecialEffectRaised
End If
End With
Set objListBox = Nothing
End Sub
Private Function GetColumnWidths(ByVal lstListBox As _
MSForms.ListBox, ByVal fmListStyle As Long, ByVal _
nColsVisible As Long, ByRef aColsVisible() As Long) _
As String
Dim lngColWdth As Long
Dim strColWdths As String
Dim n As Long
With lstListBox
If fmListStyle = fmListStyleOption Then
lngColWdth = _
(.Width - mc_OptWdth - mc_SbrWdth) \ nColsVisible
Else
lngColWdth = (.Width - mc_SbrWdth) \ nColsVisible
End If
End With
For n = LBound(aColsVisible) To UBound(aColsVisible)
If aColsVisible(n) = 0 Then
strColWdths = strColWdths & "0;"
Else
strColWdths = strColWdths & lngColWdth & ";"
End If
Next
strColWdths = Left$(strColWdths, Len(strColWdths) - 1)
GetColumnWidths = strColWdths
End Function
|
|
|
|
Die im Download befindlichen *.frm- und *.cls-Dateien können für
Excel und PowerPoint im jeweiligen Programm im VB-Editor importiert werden.
|
|
Windows-Version |
95 |
|
|
98/SE |
|
|
ME |
|
|
NT |
|
|
2000 |
|
|
XP |
|
|
Vista |
|
|
Win
7 |
|
|
|
Anwendung/VBA-Version |
Access 97 |
|
Access 2000 |
|
Access XP |
|
Access 2003 |
|
Access 2007 |
|
Access 2010 |
|
|
Excel 97 |
|
Excel 2000 |
|
Excel XP |
|
Excel 2003 |
|
Excel 2007 |
|
Excel 2010 |
|
|
Word 97 |
|
Word 2000 |
|
Word XP |
|
Word 2003 |
|
Word 2007 |
|
Word 2010 |
|
|
PPT 97 |
|
PPT 2000 |
|
PPT XP |
|
PPT 2003 |
|
PPT 2007 |
|
PPT 2010 |
|
|
Outlook 97 |
|
Outlook 2000 |
|
Outlook XP |
|
Outlook 2003 |
|
Outlook 2007 |
|
Outlook 2010 |
|
|
|
|
Download (70 kB)
|
Downloads bisher: [ 1305 ]
|
|
|