By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
425,971 Members | 907 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 425,971 IT Pros & Developers. It's quick & easy.

Virtual listbox (need to handle more than 32767 lines) How to get it to work ?

P: n/a
Hello All,

I'm trying to get a "Virtual Listbox" to work. I've currently got a form,
and used CreateWindowExA to create a ListBox with the LBS_OWNERDRAWFIXED and
LBS_NODATA flags on it. I've allso subclassed the window and do see all
kinds of WS_??? messages coming by.

But now I'm stuck :-\

I've got *no* idea what to do next, and all my searching on the web leads me
to examples that are, as far as I can see, incomplete in regard to using it
under classic VB (They're targetted at the .NET environment).

I have, to test if the whole actually worked, changed the ListBox back to a
normal one, and that went o.k (all items, added with a SendMAessage using
LB_ADDSTRING where shown).

So, can somebody please tell me how to continue ? :-)

Regards,
Rudy Wieser

Jul 17 '05 #1
Share this Question
Share on Google+
6 Replies


P: n/a
I believe Bryan has a virtual listbox demo at www.mvps.org/vbvision/

--

Randy Birch
MVP Visual Basic
http://www.mvps.org/vbnet/
Please respond only to the newsgroups so all can benefit.
"R.Wieser" <rw***************@xs4all.nl> wrote in message
news:3f*********************@dreader5.news.xs4all. nl...
: Hello All,
:
: I'm trying to get a "Virtual Listbox" to work. I've currently got a
form,
: and used CreateWindowExA to create a ListBox with the LBS_OWNERDRAWFIXED
and
: LBS_NODATA flags on it. I've allso subclassed the window and do see all
: kinds of WS_??? messages coming by.
:
: But now I'm stuck :-\
:
: I've got *no* idea what to do next, and all my searching on the web leads
me
: to examples that are, as far as I can see, incomplete in regard to using
it
: under classic VB (They're targetted at the .NET environment).
:
: I have, to test if the whole actually worked, changed the ListBox back to
a
: normal one, and that went o.k (all items, added with a SendMAessage using
: LB_ADDSTRING where shown).
:
: So, can somebody please tell me how to continue ? :-)
:
: Regards,
: Rudy Wieser
:
:
:
Jul 17 '05 #2

P: n/a
On Mon, 8 Dec 2003 23:19:00 +0100, "R.Wieser"
<rw***************@xs4all.nl> wrote:
Hello All,

I'm trying to get a "Virtual Listbox" to work. I've currently got a form,
and used CreateWindowExA to create a ListBox with the LBS_OWNERDRAWFIXED and
LBS_NODATA flags on it. I've allso subclassed the window and do see all
kinds of WS_??? messages coming by.


<snip>

One of the first things I did when I moved from VB4 to VB5 was to
build a UserControl that fronts a small ListBox and a VScrollBar
(the VScrollBar needs 'scaling' to allow values above 32766)

I simply RaiseEvent for each line of data to display, and shove it in
the small Listbox
- it could be made a little more efficient
- but I and others have been using it for years
Jul 17 '05 #3

P: n/a
J French <er*****@nowhere.com> schreef in berichtnieuws
3f**************@news.btclick.com...
On Mon, 8 Dec 2003 23:19:00 +0100, "R.Wieser"
<rw***************@xs4all.nl> wrote:


Hello J. ,
Hello All,

I'm trying to get a "Virtual Listbox" to work. I've currently got a form,and used CreateWindowExA to create a ListBox with the LBS_OWNERDRAWFIXED andLBS_NODATA flags on it. I've allso subclassed the window and do see all
kinds of WS_??? messages coming by.


<snip>

One of the first things I did when I moved from VB4 to VB5 was to
build a UserControl that fronts a small ListBox and a VScrollBar
(the VScrollBar needs 'scaling' to allow values above 32766)

I simply RaiseEvent for each line of data to display, and shove it in
the small Listbox
- it could be made a little more efficient
- but I and others have been using it for years


Maybe that's what I should do afterall ... Although the Virtual Listbox
seems to do about the same, it seems to require I handle all the displaying
of the actual data myself :-( It should have been nice if it would have
just asked me for the data, and would than display it.

Do you have any (pointer to an) example handy, preferrable in, the by you
mentioned, "classic" VB ?

Regards,
Rudy Wieser

Jul 17 '05 #4

P: n/a
On Tue, 9 Dec 2003 16:19:20 +0100, "R.Wieser"
<rw***************@xs4all.nl> wrote:

<snip>

Maybe that's what I should do afterall ... Although the Virtual Listbox
seems to do about the same, it seems to require I handle all the displaying
of the actual data myself :-( It should have been nice if it would have
just asked me for the data, and would than display it.

Do you have any (pointer to an) example handy, preferrable in, the by you
mentioned, "classic" VB ?


Here is my little 'monster'
- it is slightly inefficient, but I've never bothered with that

VERSION 5.00
Begin VB.UserControl Epl
BackStyle = 0 'Transparent
ClientHeight = 3840
ClientLeft = 0
ClientTop = 0
ClientWidth = 3930
KeyPreview = -1 'True
ScaleHeight = 3840
ScaleWidth = 3930
ToolboxBitmap = "ePL.ctx":0000
Begin VB.VScrollBar VScroll
Height = 2175
Left = 3240
TabIndex = 1
Top = 0
Width = 250
End
Begin VB.ListBox List1
Height = 2205
ItemData = "ePL.ctx":0182
Left = 0
List = "ePL.ctx":0189
TabIndex = 0
Top = 0
Width = 3255
End
End
Attribute VB_Name = "Epl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit: DefObj A-Z
' Properties : Current
' MaxRec
'
' 16/3/99 JF - version 2.00 - converted to Longs
' 1/4/99 JF - .Refill() added
' 2/4/99 JF - Refresh now performs a complete recalc/resize
' Tabs Added, Scrollbar only if large list
' 30/4/99 JF - Prevent asking for Recs over MaxRec
' Added Horiz Option - Bodge for now
' 28/10/99 JF - LinesInBox added
' 11/10/00 JF - List1.Clear moved
' THIS VERSION MOVED TO C:\DEV\AMACC
' Lock Window Update tested - no real use
' Failed experiment with Timer
' 20/07/01 JF - RightButtonPreview added - reduce flicker
' RefreshOffFlag added, Setup Added
' 7/12/03 JF - SetFixedTabs (bad parameter - Variant)

' --- Properties --
' MaxRec&
' Current&
' Setup(MaxRec&, Current&) - Does both at the same time
' DisableFlag - stops refresh via callbacks
' RefreshOffFlag - disables screen activity
' HorizOffset - Offset for Line Display - in Chars
' HorizWidth - List Width in Chars
' Enabled
' Font
' BackColor
' ForeColor
' LinesOnPage% - Get - No of Lines (may be less than LinesInBox)
' LinesInBox - Get and Set
' LineRec( LineNo )

' --- Calls ---
' Refresh
' ReDraw - Like Refill but uses internal info
' Refill( Rec& ) - Rec = 0 Refills all Rec <> 0 then
refreshes Rec
' TabsOff - Sets Tabs to every 8 Chars (Default)
' SetFixedTabs(Interval) - Interval is Chars
' SetTabWidths(T&()) - T$(0) is No of items, T(1) - T(N) tab pos
in chars

' --- Public Events ---
Public Event GetData(Rec&, DispLine$)
Public Event Selected(Rec&)
Public Event RightButtonSelected(Rec&)
Public Event LeftButtonSelected(Rec&)
Public Event RightButtonPreview(NewRec&, HandledFlag As Boolean)
Public Event DoubleClick()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event EscapeKey()
Public Event CurrentChanged(Rec&)
Public Event UserFormatLine(Rec&, Raw$, DispLine$)
Public Event MouseOver()

' --- Internal ---
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwndLock As Long) As Long
Private Declare Function UpdateWindow Lib "user32" _
(ByVal hWnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA"
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam
As Any) As Long
Private Declare Function SendMessageBynum Lib "user32" Alias
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageByString Lib "user32" Alias
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam
As Long, ByVal lParam As String) As Long

Private Const LB_ADDSTRING = &H180
Private Const LB_INSERTSTRING = &H181
Private Const LB_DELETESTRING = &H182
Private Const LB_SELITEMRANGEEX = &H183
Private Const LB_RESETCONTENT = &H184
Private Const LB_SETSEL = &H185
Private Const LB_SETCURSEL = &H186
Private Const LB_GETSEL = &H187
Private Const LB_GETCURSEL = &H188
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_GETCOUNT = &H18B
Private Const LB_SELECTSTRING = &H18C
Private Const LB_DIR = &H18D
Private Const LB_GETTOPINDEX = &H18E
Private Const LB_FINDSTRING = &H18F
Private Const LB_GETSELCOUNT = &H190
Private Const LB_GETSELITEMS = &H191
Private Const LB_SETTABSTOPS = &H192
Private Const LB_GETHORIZONTALEXTENT = &H193
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const LB_SETCOLUMNWIDTH = &H195
Private Const LB_ADDFILE = &H196
Private Const LB_SETTOPINDEX = &H197
Private Const LB_GETITEMRECT = &H198
Private Const LB_GETITEMDATA = &H199
Private Const LB_SETITEMDATA = &H19A
Private Const LB_SELITEMRANGE = &H19B
Private Const LB_SETANCHORINDEX = &H19C
Private Const LB_GETANCHORINDEX = &H19D
Private Const LB_SETCARETINDEX = &H19E
Private Const LB_GETCARETINDEX = &H19F
Private Const LB_SETITEMHEIGHT = &H1A0
Private Const LB_GETITEMHEIGHT = &H1A1
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_SETLOCALE = &H1A5
Private Const LB_GETLOCALE = &H1A6
Private Const LB_SETCOUNT = &H1A7
Private Const LB_MSGMAX = &H1A8

Private Const LB_INITSTORAGE = &H1A8
Private Const LB_ITEMFROMPOINT = &H1A9

Private Const WM_SETREDRAW = &HB
Private mNewListIndex%, mTopRec&, mListBoxLines!, mMaxRec&
Private mWithScrollWidth%, mNoScrollWidth%
Private mListLineHeight!, mRealListBoxLines!
Private mVSB_Min&, mVSB_Max&, mVSB_Value&, mVSB_Factor#
Private mInRoutineFlag As Boolean
Private mInVSBChangeFlag As Boolean
Private mDisableFlag As Boolean
Private mHorizOffset As Integer
Private mLine$()
Private mInitializedFlag As Boolean
Private mRefreshOffFlag As Boolean

'
================================================== =============================
'
' Public Properties Specific to This Control
'
'
################################################## #############################
'
'
'
Public Sub Setup(MaxRec&, Current&)
Dim H As Boolean

H = mRefreshOffFlag
mRefreshOffFlag = True
If List1.ListCount = 0 Then List1.AddItem "" ' very first time in
Me.MaxRec = MaxRec
mRefreshOffFlag = H
Me.Current = Current

End Sub
'
################################################## #############################
'
' Get/Set the Number of Items in the Pick List
'
Public Property Let MaxRec(Value&)
mMaxRec = Value
Call m_EplSetVsbMax
End Property
Public Property Get MaxRec() As Long
MaxRec = mMaxRec
End Property

'
################################################## #############################
'
' Get/Set the Current (Active) Record in the Pick List
'
Public Property Get Current() As Long
Current = mTopRec + List1.ListIndex
End Property

Public Property Let Current(Value As Long)
Dim Rec&, V&, Q&

V = Value
If V < 1 Or V > mMaxRec Then
MsgBox ("Invalid Epl.Current =" + Str$(V))
If V < 1 Then V = 1
If V > MaxRec Then V = MaxRec
End If
Rec = V

' --- Simpy a check that there is a ListIndex - Debug
If List1.ListIndex < 0 Then
If List1.ListCount > 0 Then
If mRefreshOffFlag = False Then
MsgBox ("EPL1 - Set Current - NO LIST INDEX")
End If
List1.ListIndex = 0 ' make something selected
End If
End If

mNewListIndex = List1.ListIndex

' handle a move past highest top
If V > mVSB_Max Then
V = mVSB_Max
mNewListIndex = Rec - V
End If

' handle a small move on the same page
Q = V - mVSB_Value
If Q >= 0 And Q < mListBoxLines Then
V = mVSB_Value
End If

V = Rec - mNewListIndex
If V < mVSB_Min Then
V = mVSB_Min
mNewListIndex = Rec - V
End If

mTopRec = 0
Q = mVSB_Value
mVSB_Value = V
Call mVSB_Change
End Property

'
################################################## #############################
'
'
Public Property Get RefreshOffFlag() As Boolean
RefreshOffFlag = mRefreshOffFlag
End Property

Public Property Let RefreshOffFlag(Value As Boolean)
mRefreshOffFlag = Value
End Property
'
################################################## #############################
'
' Get/Set the Disable Flag - Goes not Callback GetData
'
Public Property Get DisableFlag() As Boolean
DisableFlag = mDisableFlag
End Property

Public Property Let DisableFlag(Value As Boolean)
mDisableFlag = Value
End Property
'
################################################## #############################
'
'
Public Property Get HorizOffset() As Integer
HorizOffset = mHorizOffset
End Property
Public Property Let HorizOffset(Value As Integer)
Dim L9%

If Value < 0 Then _
Value = 0
If mHorizOffset <> Value Then
mHorizOffset = Value
For L9 = 0 To List1.ListCount - 1
List1.List(L9) = LF_FormatLine(mTopRec + L9, mLine$(L9))
Next
End If
End Property
'
################################################## #############################
'
'
Public Property Get HorizWidth() As Integer
Dim Q%
If VScroll.Visible Then _
Q = VScroll.Width
HorizWidth = (List1.Width - Q) \ TextWidth("X")
End Property

'
################################################## #############################
'
'
Public Property Get LinesOnPage() As Long
LinesOnPage = Int(mListBoxLines)
End Property

'
################################################## #############################
'
'
Public Property Get LinesInBox() As Long
LinesInBox = Int(mRealListBoxLines)
End Property
'
################################################## #############################
'
'
Public Property Let LinesInBox(Value&)

Dim N%

N% = TextHeight("X") / 3

While mRealListBoxLines < Value
Height = Height + N%
DoEvents
Wend
N = N / 2
While mRealListBoxLines > Value
Height = Height - N
DoEvents
Wend
MaxRec = MaxRec ' Force Recalc and Current to 1

End Property

'
################################################## #############################
'
'
Public Property Get LineRec(LineNo As Long) As Long
LineRec = mTopRec + LineNo - 1
If LineRec > mMaxRec Then _
LineRec = 0
End Property

'
================================================== =============================
'
' VB ONLINE RECOMMENDED FUNCTIONS
'
'
################################################## #############################
'
' This is recommended by VB Book Online
'
' Select: Tools, Proceedure Attributes
' Enabled, Advanced - set Proc ID to Enabled
'
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_UserMemId = -514
Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal Value As Boolean)
UserControl.Enabled = Value
PropertyChanged "Enabled"
End Property
'
################################################## #############################
'
' This is recommended by VB Book Online
'
Public Sub Refresh()
Dim H&
List1.Refresh
VScroll.Refresh
H = Current
Call UserControl_Resize
If H > 0 And H <= mMaxRec Then _
Current = H
End Sub

'
################################################## #############################
'
'
'
Sub SetFixedTabs(Interval%)
Dim Q&(1)
Q(0) = Interval * 2 ' Every N Chars
Call SendMessage(List1.hWnd, LB_SETTABSTOPS, 1, Q&(0))
List1.Refresh
End Sub

'
################################################## #############################
'
'
'
Sub TabsOff()
Dim Q&(1)
Q(0) = 32 ' Every 8 Chars
Call SendMessage(List1.hWnd, LB_SETTABSTOPS, 1, Q&(0))
List1.Refresh
End Sub

'
################################################## #############################
'
' TabWidth(0) = Number of Tabs
' TabWidth(1 to n) = Width of Each Field in Bytes
'
Sub SetTabWidths(TabWidth() As Long)
Dim Max&, L9%
If TabWidth(0) < 1 Or TabWidth(0) > UBound(TabWidth) Then
MsgBox ("EPL.OCX - Bad TabWidth(0) in TabSetWidths")
End If
Max = TabWidth(0)
ReDim Q&(Max + 1)
For L9 = 1 To Max
Q(L9) TabWidth(L9) * 4 ' 4 Dialog Units Per Char
Q(L9) = Q(L9 - 1) + Q(L9)
Next
Call SendMessage(List1.hWnd, LB_SETTABSTOPS, Max, Q&(1))
End Sub

'
================================================== =============================
'
' Appearance Properties
'
'
################################################## #############################
'
' Explicitly Setting Colors Appears to be ESSENTIAL
' Otherwise it takes the Container's Colours
'
Private Sub UserControl_Initialize()
ForeColor = vbWindowText
BackColor = vbWindowBackground
' ---
mNewListIndex = 0
VScroll.Min = 0
VScroll.Max = 32000
mVSB_Min = 1
mVSB_Factor = 1
mMaxRec = 0
mTopRec = 0
If List1.ListCount = 1 Then _
List1.ListIndex = 0

End Sub
'
################################################## #############################
'
' Refill the Box - 0 refills all
'
Public Sub Refill(Rec&)
Dim S$, LineIndex&
If Rec < 1 Then
mTopRec = 0
Call VScroll_Change
GoTo QUIT
End If
LineIndex = Rec& - mTopRec
If (LineIndex < 0) _
Or (LineIndex > List1.ListCount - 1) _
Or (Rec > mMaxRec) Then
GoTo QUIT
End If
Call LS_GetData(Rec&, mLine(LineIndex))
List1.List(LineIndex) = LF_FormatLine(Rec&, mLine$(LineIndex))
QUIT:
End Sub

'
################################################## #############################
'
' ReDraws the lines - Like Refill but uses internal data
'
Public Sub ReDraw()
Dim L9%

For L9 = 0 To List1.ListCount - 1
List1.List(L9) = LF_FormatLine(mTopRec + L9, mLine$(L9))
Next
End Sub
'
################################################## #############################
'
'
'
Public Property Get Font() As StdFont
Set Font = UserControl.Font
End Property

Public Property Set Font(F As StdFont)
Set UserControl.Font = F
Set List1.Font = F
PropertyChanged "Font"
Call UserControl_Resize
End Property
'
################################################## #############################
'
'
'
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(Q As OLE_COLOR)
UserControl.BackColor = Q
List1.BackColor = Q
PropertyChanged "BackColor"
Call Refresh
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property

Public Property Let ForeColor(Q As OLE_COLOR)
UserControl.ForeColor = Q
List1.ForeColor = Q
PropertyChanged "ForeColor"
Call Refresh
End Property
'
################################################## #############################
'
'
'
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

mInitializedFlag = True
Set Font = PropBag.ReadProperty("Font", Ambient.Font)
ForeColor = PropBag.ReadProperty("ForeColor", vbWindowText)
BackColor = PropBag.ReadProperty("BackColor", vbWindowBackground)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Font", Font, Ambient.Font)
Call PropBag.WriteProperty("ForeColor", ForeColor, vbWindowText)
Call PropBag.WriteProperty("BackColor", BackColor,
vbWindowBackground)
End Sub
'
================================================== =============================
'
' MAIN ROUTINES FOLLOW
'
'
################################################## #############################
'
'
'
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y As Single)
RaiseEvent MouseOver
End Sub
'
################################################## #############################
'
'
'
Private Sub m_EplSetVsbMax()
Call UserControl_Resize
' --- and refresh the listbox
mNewListIndex = 0
mVSB_Value = 0
mTopRec = 0
Call mVSB_Change
End Sub

'
################################################## #############################
'
'
'
Private Sub UserControl_Resize()

Dim H&

H = Current

Set List1.Font = UserControl.Font
List1.Top = 0
VScroll.Top = 0
If Width > 250 Then
VScroll.Width = 250
Else
VScroll.Width = Width \ 2
End If

mWithScrollWidth = ScaleWidth - VScroll.Width
mNoScrollWidth% = ScaleWidth

List1.Width = ScaleWidth - VScroll.Width
List1.Height = ScaleHeight
VScroll.Height = List1.Height
List1.Left = 0
VScroll.Left = ScaleWidth - VScroll.Width

' all this finds the number of lines in the ListBox
mListLineHeight = TextHeight("XXX")
mRealListBoxLines = List1.Height \ mListLineHeight
mListBoxLines = mRealListBoxLines

' --- this resets mRealListboxLines
If mListBoxLines > mMaxRec Then _
mListBoxLines = mMaxRec

' --- we need to reset the VSB max
Call LS_DoVsbCalcs

If H > 1 Then _
If H <= MaxRec Then _
Current = H

' --- If in Design Mode - And Control is Initialized
If mInitializedFlag Then
If Ambient.UserMode = False Then
List1.Clear
List1.AddItem "EPL ISS Easy Pick List"
List1.ListIndex = 0
End If
End If
End Sub
'
################################################## #############################
'
'
'
Private Sub LS_DoVsbCalcs()
Dim Q&

If mListBoxLines >= mMaxRec Then
List1.Width = mNoScrollWidth
VScroll.Visible = False
Else
List1.Width = mWithScrollWidth
VScroll.Visible = True
End If

mVSB_Min = 1
mVSB_Max = mMaxRec - mListBoxLines + 1

mVSB_Factor = mVSB_Max / 32000
Q = 32000 / mVSB_Max
If Q < 1 Then _
Q = 1
VScroll.SmallChange = Q
VScroll.LargeChange = Q

' --- and refresh the listbox
' mNewListIndex = 0
' mVSB_Value = 0
' mTopRec = 0
' Call mVSB_Change
End Sub

'
################################################## #############################
'
' Trap a Right Mouse Click
'
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim V#, Item%, HandledFlag As Boolean

V# = Y / List1.Height ' %age of total height
V# = mRealListBoxLines * V# ' convert to line
Item = Int(V# + 0.1)
List1.SetFocus
If Item < mListBoxLines Then
If Button = vbRightButton Then
RaiseEvent RightButtonPreview(mTopRec + Item, HandledFlag)
If HandledFlag Then Exit Sub
End If
mNewListIndex = Item
Call mVSB_Change
If Button = vbRightButton Then
RaiseEvent RightButtonSelected(Current) ' Current is a
property
Else
RaiseEvent LeftButtonSelected(Current)
End If
End If
' End If
End Sub
'
################################################## #############################
'
'
'
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
If KeyCode Then _
Call OverrideKeyHandler(KeyCode, Shift)
End Sub

'
################################################## #############################
'
'
'
Private Sub OverrideKeyHandler(KeyCode%, Shift%)

Dim lMove%, vMove%, Q&

mNewListIndex = List1.ListIndex

Select Case KeyCode
Case vbKeyUp, vbKeyLeft: lMove = -1
Case vbKeyDown, vbKeyRight: lMove = 1
Case vbKeyHome: mVSB_Value = mVSB_Min: mNewListIndex = 0
Case vbKeyEnd: mVSB_Value = mVSB_Max: mNewListIndex =
mListBoxLines - 1
Case vbKeyPageUp: vMove = -mListBoxLines
Case vbKeyPageDown: vMove = mListBoxLines
Case vbKeyEscape: RaiseEvent EscapeKey: GoTo QUIT
Case vbKeyReturn: Call List1_DblClick: GoTo QUIT
Case Else: GoTo QUIT
End Select
' moves within the list box
If lMove Then
Q = mNewListIndex + lMove
If Q >= mListBoxLines Then
lMove = 0
vMove = 1
End If
If Q < 0 Then
lMove = 0
vMove = -1
End If
mNewListIndex = mNewListIndex + lMove
End If

' --- VSB Moves
If vMove Then
Q = mVSB_Value + vMove
mVSB_Value = Us_MinMax(Q, mVSB_Min, mVSB_Max)
End If

' --- Call the mover even though
' we only moved within the box
' as we need to set the VScroll Bar & may refresh box
' also we need to set List1.ListIndex

Call mVSB_Change

KeyCode = 0

QUIT:

End Sub
'
################################################## #############################
'
' This is triggered by : 1) A Click
' 2) Any Change in List1.ListIndex
'
Private Sub List1_Click()
If mInRoutineFlag = False Then
mNewListIndex = List1.ListIndex
Call mVSB_Change
End If
End Sub

'
################################################## #############################
'
'
'
Private Sub List1_DblClick()
RaiseEvent Selected(Current) ' Current is a property
End Sub

'################################################# ###################################
'
' This is the MAIN routine for triggering any moves
'
Private Sub mVSB_Change()
Dim Q%, H%
mInVSBChangeFlag = True ' Suppress a later recalc of
mVSB_Value

mVSB_Value = Us_MinMax(mVSB_Value, mVSB_Min, mVSB_Max)
Q = mVSB_Value / mVSB_Factor ' Q may be Zero
H = VScroll.Value
VScroll.Value = Q ' this may NOT trigger VScroll_Change
If H = VScroll.Value Then
Call VScroll_Change
End If

mInVSBChangeFlag = False
End Sub

'
################################################## ##########################################
'
' This is called ONLY by all VScroll Bar Moves
' - Changing: VScroll.Value triggers this
'
' Enter with : mNewListIndex ( if List1.ListIndex is to change )
' mInVSBChangeFlag ( suppress recalc of mVSB_Value )
'
Private Sub VScroll_Change()
Dim Q&

mInRoutineFlag = True ' prevent List1.Click launching calls

If mInVSBChangeFlag = False Then
Q = VScroll.Value * mVSB_Factor
mVSB_Value = Us_MinMax(Q, mVSB_Min, mVSB_Max)
End If
With List1

While mTopRec <> mVSB_Value
mTopRec = mVSB_Value
Call m_EplFillListBox
Wend
If .ListCount > 0 Then ' Set position in list
' Trap For Resize - 2/4/99 JF
If mNewListIndex >= .ListCount Then _
mNewListIndex = .ListCount - 1
' Set Position in List
.ListIndex = mNewListIndex
End If
End With
mInRoutineFlag = False

Static LastCurrent&
If LastCurrent <> Current Then
LastCurrent = Current
RaiseEvent CurrentChanged(Current)
End If
End Sub
'
################################################## ##########################################
'
'
'
'
Private Sub m_EplFillListBox()
Dim S$, Q&, Count%

If mRefreshOffFlag Then Exit Sub ' Disabled Screen

'LockWindowUpdate List1.hWnd
'LockWindowUpdate UserControl.hwnd
' ---
ReDim mLine$(mRealListBoxLines)

With List1
.Clear
While .ListCount < mListBoxLines
Q& = mTopRec + .ListCount ' ie: 0 to mListBoxLines -
1
Call LS_GetData(Q&, mLine$(Count))
.AddItem LF_FormatLine(Q&, mLine$(Count))
Count = Count + 1

Wend
End With

' ---
'LockWindowUpdate 0
'LockWindowUpdate 0
'UpdateWindow List1.hWnd
End Sub
'
################################################## ##########################################
'
'
'
'
Private Sub VScroll_GotFocus()
List1.SetFocus
End Sub
'
################################################## ##########################################
'
'
'
'
Private Sub LS_GetData(Q&, S$)
If Q& > 0 Then
If Q& <= mMaxRec Then
If mDisableFlag = False Then
RaiseEvent GetData(Q&, S$)
End If
End If
End If
End Sub
'
################################################## ##########################################
'
'
'
'
Private Function LF_FormatLine$(Rec&, Raw$)
Dim S$
S$ = Raw$
RaiseEvent UserFormatLine(Rec&, Raw$, S$)
LF_FormatLine = Mid$(S$, mHorizOffset + 1)
End Function
Public Sub LocalTerminate()
' Local Terminate From US_Severe
End Sub

'Call SendMessageBynum(List1.hwnd, WM_SETREDRAW, False, 0)
'Call SendMessageBynum(List1.hwnd, LB_RESETCONTENT, 0, 0)
'Call SendMessageByString(List1.hwnd, LB_ADDSTRING, 0, S$)
'Call SendMessageBynum(List1.hwnd, LB_SETCURSEL, mNewListIndex, 0)
'Call SendMessageBynum(List1.hwnd, WM_SETREDRAW, True, 0)

Jul 17 '05 #5

P: n/a
J French <er*****@nowhere.com> schreef in berichtnieuws
3f**************@news.btclick.com...

Hello J,
On Tue, 9 Dec 2003 16:19:20 +0100, "R.Wieser"
<rw***************@xs4all.nl> wrote:


<snip>
Do you have any (pointer to an) example handy, preferrable in, the by you
mentioned, "classic" VB ?


Here is my little 'monster'
- it is slightly inefficient, but I've never bothered with that


Thanks. I think I can use it :-)

Regards,
Rudy Wieser

Jul 17 '05 #6

P: n/a
On Wed, 10 Dec 2003 22:48:18 +0100, "R.Wieser"
<rw***************@xs4all.nl> wrote:

<snip>
Here is my little 'monster'
- it is slightly inefficient, but I've never bothered with that


Thanks. I think I can use it :-)


Just don't OCX it .... Please .... there are enough OCXes
Jul 17 '05 #7

This discussion thread is closed

Replies have been disabled for this discussion.