Hi,
thanks for the quick reply!
I'm afraid I cannot post the whole workbook as it's over 3 MB but here are 2 screenshots one done with AddITem and the other using the List() -method. A bit more info:
I've used a CListBoxHeader ClassModule to control the listbox headers and I also have a MouseScroll function implemented in the ListBox. Maybe these have an adverse affect. I'll attach these as well.
Another reason for not attaching the whole workbook is that you wouldn't be able to use it as it's a NW-application and won't start if all external modules aren't present. The Array used is actually compiled from several different workbooks...
This is my complete Init-sequence:
Private Sub UserForm_Initialize()
HideX EAluettelo
LuetteloNimi = "EAKoulutus"
Dim EAFields As Variant
Dim Errori As Boolean
Dim oLB As clsListBoxHeader
Dim aHeaders As Variant
Dim Apuarray As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Hnumber As String
Dim Staffields As Variant
Dim BirthDay As Integer
Dim Kustpaikka As Integer
Me.ListBoxEAlista.ColumnCount = 8
Me.ListBoxEAlista.ColumnWidths = "40;170;72;40;42;0;72" ' Kouluttaja mukana, piilossa
aHeaders = Array("Hnro", "Nimi", "Synt", "Kust", "Kurssi", "Kouluttaja", "Aika", "Kertaus")
Set oLB = New clsListBoxHeader
oLB.Create Me.ListBoxEAlista, aHeaders
oLB.BackColor = RGB(0, 255, 255)
oLB.BorderColor = RGB(0, 0, 255)
oLB.BorderStyle = 1
oLB.ForeColor = RGB(0, 0, 255)
oLB.Bold = True
oLB.SpecialEffect = 0 '1
oLB.CloseUp = -5
oLB.FontSize = 8
oLB.FontName = "MS Reference Sans Serif" '"Arial"
Set oLB = Nothing
Me.Lukum??r?.BackColor = RGB(0, 255, 255)
Me.Lukum??r?.ForeColor = RGB(0, 0, 255)
Me.Lukum??r?.SpecialEffect = fmSpecialEffectBump
On Error GoTo VIRHE
EAFields = Array("Hnro", "Nimi", "Kurssi", "Kouluttaja", "Aika", "Kertaus", _
"S?hk?mies", "EaKurssiehdotus", "Kurssin parannustavoite")
If FilterOn Then
LueSuojeluData EAArray, EAFields, "EA-Koulutus.xls", "Poimitut", Errori
Else
LueSuojeluData EAArray, EAFields, "EA-Koulutus.xls", "Taulukko", Errori
End If
If Errori Then GoTo VIRHE
If EAArray(0, 0) = "Otsikko" Then
Me.ListBoxEAlista.Clear
Exit Sub
End If
LueTy?kirjanOtsikkorivi Staffields, "Henkil?kunta.xls", "Taulukkosivu"
BirthDay = Kentt?Nro(Staffields, "Syntym?aika")
Kustpaikka = Kentt?Nro(Staffields, "Kustannuspaikka")
Apuarray = EAArray
ReDim EAArray(LBound(Apuarray, 1) To UBound(Apuarray, 1), LBound(Apuarray, 2) _
To UBound(Apuarray, 2) + 2) As Variant
ArrayPituus = UBound(EAArray, 1)
For i = LBound(EAArray, 1) To UBound(EAArray, 1)
For j = 0 To 10
Select Case j
Case 0 To 1
EAArray(i, j) = Apuarray(i, j)
Case 2 ' syntym?aika
Hnumber = Apuarray(i, 0)
EAArray(i, j) = TietoHenkil?kuntataulukosta(Hnumber, BirthDay - 1)
Case 3 'kustannuspaikka
Hnumber = Apuarray(i, 0)
EAArray(i, j) = TietoHenkil?kuntataulukosta(Hnumber, Kustpaikka - 1)
Case Else
EAArray(i, j) = Apuarray(i, j - 2)
End Select
Next j
Next i
Me.ListBoxEAlista.Clear
'For i = LBound(EAArray, 1) To UBound(EAArray, 1)
' Me.ListBoxEAlista.AddItem (EAArray(i, 0))
' For j = 1 To 7
' Me.ListBoxEAlista.List(i, j) = (EAArray(i, j))
' Next j
'Next i
Me.ListBoxEAlista.List() = EAArray
SuljeTy?kirja "Henkil?kunta.xls"
Me.ListBoxEAlista.ListIndex = 0 ' Focus listan ekaan riviin.
Me.CB_Talleta.Visible = False
Me.CB_Sulje.Caption = "Sulje"
Application.ScreenUpdating = True
Exit Sub
VIRHE:
SuljeTy?kirja "Henkil?kunta.xls"
MsgBox "Ohjelman suoritus keskeytyy!", vbCritical, "Virhe: (Init EAluettelo)"
Application.ScreenUpdating = True
End Sub
Using AddItem:
https://cid-61528c132cbea9f2.skydriv...ic/AddItem.jpg
Using List-methid:
https://cid-61528c132cbea9f2.skydriv...c/ArrayAdd.jpg
HTH
Petri
MouseScroll:
Option Explicit
'To be able to scroll with mouse wheel within Userform
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'To get hWnd long value of the UserForm
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim MyForm As UserForm
Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'To handle mouse events
Dim MouseKeys As Long
Dim Rotation As Long
Select Case LuetteloNimi
Case "EAKoulutus"
If Lmsg = WM_MOUSEWHEEL Then
MouseKeys = wParam And 65535
Rotation = wParam / 65536
'My Form s MouseWheel function
EAluettelo.MouseWheel Rotation
End If
Case "Tulity?"
If Lmsg = WM_MOUSEWHEEL Then
MouseKeys = wParam And 65535
Rotation = wParam / 65536
'My Form s MouseWheel function
Tulity?luettelo.MouseWheel Rotation
End If
Case Else
End Select
WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, wParam, lParam)
End Function
Public Sub WheelHook(PassedForm As UserForm)
'To get mouse events in userform
On Error Resume Next
Set MyForm = PassedForm
LocalHwnd = FindWindow("ThunderDFrame", MyForm.Caption)
LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook()
'To Release Mouse events handling
Dim WorkFlag As Long
On Error Resume Next
WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
Set MyForm = Nothing
End Sub
Public Function LeftString(ByVal sText As String, ByVal sSeparator As String) As String
If Len(sText) > 2 Then
LeftString = Left(sText, InStr(1, sText, sSeparator) - 1)
End If
End Function
Public Function RightString(ByVal sText As String, ByVal sSeparator As String) As String
If Len(sText) > 2 Then
RightString = Right(sText, Len(sText) - InStr(1, sText, sSeparator))
End If
End Function
clsListBoxHeader:
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
''' Voi Voi! Leveys on numerotavaraa!!! (Ainakin nyky??...)
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
Reply With Quote
