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
 
Hinweis
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 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Dienstag, 31. Mai 2011