Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,779
- Office Version
- 2016
- Platform
- Windows
WorkBook example.
Hi all.
I have been working hard on this one and hopefully ,at last, I seem to have achieved some nice results :
Basically, the code creates a real ListBox Control from scratch and subclass it to make it a Drag listbox and to capture other events as well. All done in VBA !
The Class also defines some common Properties and Methods for easy use.
Class Code (CListBox)
Code in a Standard Module :
Code in the UserForm Module ( Required Labels need to be added.)
One known limitation is the ListBox not getting the KeyBoard focus if another normal listBox or TextBox happen to coexist on the userform.
I am still looking into this to see if I can fix it.
Tested on Excel 2003 Win XP only. (Seems quite stable)
Hi all.
I have been working hard on this one and hopefully ,at last, I seem to have achieved some nice results :
Basically, the code creates a real ListBox Control from scratch and subclass it to make it a Drag listbox and to capture other events as well. All done in VBA !
The Class also defines some common Properties and Methods for easy use.
Class Code (CListBox)
Code:
'// Class that creates a Drag ListBox
'// and define other custom Properties,
'// Methods and Events.
'// All done in VBA !
Option Explicit
Public Event MouseMove(ByVal X As Long, ByVal Y As Long)
Public Event Change(ByVal ItemValue As String)
Public Event DBLClick()
Public Event Click()
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type DRAGLISTINFO
uNotification As Long
hwnd As Long
ptCursor As POINTAPI
End Type
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" _
Alias "RegisterWindowMessageA" _
(ByVal lpString As String) As Long
Private Declare Function MakeDragList Lib "comctl32" _
(ByVal hLB As Long) As Boolean
Private Declare Sub DrawInsert Lib "comctl32" _
(ByVal handParent As Long, _
ByVal hLB As Long, ByVal nItem As Long)
Private Declare Function LBItemFromPt Lib "comctl32" _
(ByVal hLB As Long, ByVal X As Long, ByVal Y As Long, _
ByVal bAutoScroll As Boolean) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" _
Alias "RtlMoveMemory" _
(ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, _
ByVal lpClassName As String, _
ByVal lpWindowName As String, _
ByVal dwStyle As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hWndParent As Long, _
ByVal hMenu As Long, _
ByVal hInstance As Long, _
lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" _
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 SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function SetCursor Lib "user32" _
(ByVal hCursor As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" _
Alias "LoadCursorFromFileA" _
(ByVal lpFileName As String) As Long
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32.dll" _
(ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDc As Long, ByVal _
nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal _
hDc As Long) As Long
Private Declare Function SetFocus Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hDc As Long, ByVal nBkMode As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32" _
(ByVal hDc As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" _
(ByVal hDc As Long, ByVal crColor As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Const WM_USER = &H400
Private Const DL_BEGINDRAG = (WM_USER + 133)
Private Const DL_DRAGGING = (WM_USER + 134)
Private Const DL_DROPPED = (WM_USER + 135)
Private Const DL_CANCELDRAG = (WM_USER + 136)
Private Const DRAGLISTMSGSTRING = "commctrl_DragListMsg"
Private Const LB_GETCURSEL = &H188
Private Const LB_DELETESTRING = &H182
Private Const LB_ADDSTRING = &H180
Private Const LB_INSERTSTRING = &H181
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_GETTOPINDEX = &H18E
Private Const LB_GETCOUNT = &H18B
Private Const LB_RESETCONTENT = &H184
Private Const LB_SETCURSEL = &H186
Private Const WS_EX_CLIENTEDGE = &H200&
Private Const LBS_HASSTRINGS = &H40&
Private Const LBS_NOTIFY = &H1&
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
Private Const LB_Styles = _
(LBS_HASSTRINGS Or LBS_NOTIFY Or WS_CHILD _
Or WS_VISIBLE Or WS_VSCROLL)
Private Const WM_COMMAND = &H111
Private Const WM_PARENTNOTIFY = &H210
Private Const WM_CTLCOLORLISTBOX = &H134
Private Const WM_PAINT = &HF
Private Const WM_SETCURSOR = &H20
Private Const LBN_SELCHANGE = 1
Private Const LBN_DBLCLK = 2
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_DESTROY = &H2
Private Const GWL_WNDPROC = (-4)
Private Const GW_CHILD = 5
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const CurFile As String = "\Drag.Cur"
Private bHookSet As Boolean
Private bDragList As Boolean
Private DragIdx As Long
Private DL_Message As Long
Private lBackColor As Long
Private lTextColor As Long
Private sLBItemText As String
'===================
'Private Routines.
'===================
Private Sub Class_Initialize()
Set oLB = Nothing
Set oLB = Me
End Sub
Private Sub GetHiLoword _
(lParam As Long, ByRef loword As Long, ByRef hiword As Long)
' this is the LOWORD of the lParam:
loword = lParam And &HFFFF&
' LOWORD now equals 65,535 or &HFFFF
' this is the HIWORD of the lParam:
hiword = lParam \ &H10000 And &HFFFF&
' HIWORD now equals 30,583 or &H7777
End Sub
Private Property Get PointsPerPixelX() As Double
Dim hDc As Long
hDc = GetDC(0)
PointsPerPixelX = 72 / GetDeviceCaps(hDc, LOGPIXELSX)
ReleaseDC 0, hDc
End Property
Private Property Get PointsPerPixelY() As Double
Dim hDc As Long
hDc = GetDC(0)
PointsPerPixelY = 72 / GetDeviceCaps(hDc, LOGPIXELSY)
ReleaseDC 0, hDc
End Property
Private Sub CreateDragCursor()
Dim lPos As Long
Dim bData1() As Variant
Dim bData2() As Variant
'// Load the Drag cursor Bytes into 2 Var Arrays.
bData1 = Array(0, 0, 2, 0, 1, 0, 32, 32, 16, 0, 0, 0, 0, 0, 232, 2, 0, 0, _
22, 0, 0, 0, 40, 0, 0, 0, 32, 0, 0, 0, 64, 0, 0, 0, 1, 0, 4, 0, 0, 0, 0, _
0, 128, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 16, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 128, 0, 0, 128, 0, 0, 0, 128, 128, 0, 128, 0, 0, 0, 128, 0, _
128, 0, 128, 128, 0, 0, 192, 192, 192, 0, 128, 128, 128, 0, 0, 0, _
255, 0, 0, 255, 0, 0, 0, 255, 255, 0, 255, 0, 0, 0, 255, 0, 255, 0, _
255, 255, 0, 0, 255, 255, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 240)
bData2 = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 240, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, _
240, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 240, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 15, 240, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 15, 255, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 255, _
255, 255, 240, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 255, 255, 255, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 255, 255, 240, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 15, 255, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
15, 255, 240, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 255, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 240, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, _
0, 255, 255, 255, 255, 255, 255, 255, 255, 255, 234, 170, 191, 255, _
245, 85, 127, 255, 239, 255, 191, 255, 247, 255, 127, 255, 239, _
255, 191, 255, 247, 255, 127, 255, 239, 255, 191, 255, 247, 255, _
127, 255, 239, 255, 191, 255, 245, 85, 127, 255, 234, 170, 191, _
254, 127, 255, 255, 252, 63, 255, 255, 252, 63, 255, 255, 248, _
127, 255, 255, 120, 127, 255, 255, 48, 255, 255, 255, 16, 255, _
255, 255, 1, 255, 255, 255, 0, 31, 255, 255, 0, 63, 255, 255, _
0, 127, 255, 255, 0, 255, 255, 255, 1, 255, 255, 255, 3, 255, _
255, 255, 7, 255, 255, 255, 15, 255, 255, 255, 31, 255, 255, _
255, 63, 255, 255, 255, 127, 255, 255, 255, 255)
'- Join the arrays
lPos = UBound(bData1)
ReDim Preserve bData1(UBound(bData1) + UBound(bData2))
CopyMemory ByVal VarPtr(bData1(lPos + 1)), _
ByVal VarPtr(bData2(0)), 16 * (UBound(bData2))
'//Save the joined Array data to disk.
SaveCurToDisk ByVal bData1
End Sub
Private Sub SaveCurToDisk(ByVal Ar As Variant)
Dim X As Long
Dim FileNum As Long
Dim bytes() As Byte
ReDim bytes(LBound(Ar) To UBound(Ar))
For X = LBound(Ar) To UBound(Ar)
bytes(X) = CByte((Ar(X)))
Next
FileNum = FreeFile
Open Environ("Temp") & CurFile For Binary As #FileNum
Put #FileNum, 1, bytes
Close FileNum
End Sub
'=================================================
'Public Routines. (ListBox Properties and Methods.)
'=================================================
Public Function WinProc _
(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tPt As POINTAPI
Dim DLI As DRAGLISTINFO
Dim LB As LOGBRUSH
Dim tRect As RECT
Dim sBuffer As String
Dim CurSel As Long
Dim lRet As Long
Dim TopIndex As Long
Dim loword As Long
Dim hiword As Long
Dim hBrush As Long
Dim hDc As Long
'// Ignore errors.
On Error Resume Next
Select Case uMsg
Case WM_CTLCOLORLISTBOX '// Paint the ListBox.
If lBackColor = 0 Then lBackColor = vbWhite
LB.lbColor = lBackColor
hBrush = CreateBrushIndirect(LB)
GetClientRect lParam, tRect
SetBkMode wParam, 1
FillRect wParam, tRect, hBrush
SetTextColor wParam, lTextColor
WinProc = hBrush
DeleteObject hBrush
Exit Function
Case WM_SETCURSOR '// Catch the ListBox Mouse Events.
GetHiLoword lParam, loword, hiword
If wParam = LBhwnd Then
If hiword = WM_MOUSEMOVE Then
GetCursorPos tPt
ScreenToClient wParam, tPt
RaiseEvent MouseMove _
(tPt.X, tPt.Y)
End If
If hiword = WM_LBUTTONDOWN Then
RaiseEvent Click
End If
End If
Case WM_PARENTNOTIFY
GetHiLoword wParam, loword, hiword
If loword = WM_DESTROY Then
SetWindowLong hwnd, GWL_WNDPROC, PrevProc
PrevProc = 0
bHookSet = False
End If
Case WM_KEYUP, WM_KEYDOWN '//set KBrd focus to
SetFocus LBhwnd
Case WM_COMMAND '//Catch the DBLCLK and Change events.
hDc = GetDC(LBhwnd)
SendMessage LBhwnd, WM_PAINT, hDc, 0
ReleaseDC LBhwnd, hDc
GetHiLoword wParam, loword, hiword
If hiword = LBN_DBLCLK Then
RaiseEvent DBLClick
End If
If hiword = LBN_SELCHANGE Then
CurSel = SendMessage _
(LBhwnd, LB_GETCURSEL, 0, 0)
lRet = SendMessage _
(LBhwnd, LB_GETTEXTLEN, CurSel, ByVal 0)
sBuffer = Space(lRet) & vbNullChar
lRet = SendMessage _
(LBhwnd, LB_GETTEXT, CurSel, ByVal sBuffer)
sLBItemText = Left((sBuffer), lRet)
RaiseEvent Change(ByVal sBuffer)
End If
Case DL_Message '//Process the Dragging operation.
If bDragList Then
CopyMemory DLI, ByVal lParam, Len(DLI)
Select Case DLI.uNotification
Case DL_BEGINDRAG
'// The drag operation starts.
' Return False to cancel
' The item is being dragged
CurSel = _
SendMessage(DLI.hwnd, LB_GETCURSEL, 0, 0)
'// Get the selected item.
DragIdx = _
LBItemFromPt(DLI.hwnd, DLI.ptCursor.X, DLI.ptCursor.Y, False)
lRet = SendMessage(DLI.hwnd, LB_GETTEXTLEN, DragIdx, ByVal 0)
sBuffer = Space(lRet) & vbNullChar
lRet = _
SendMessage(DLI.hwnd, LB_GETTEXT, DragIdx, ByVal sBuffer)
sLBItemText = sBuffer
'// Continue with the drag.
WinProc = True
Case DL_DRAGGING
TopIndex = _
SendMessage(DLI.hwnd, LB_GETTOPINDEX, 0, 0)
'// Draw the insert icon.
DrawInsert lFrmChildHwnd, DLI.hwnd, _
LBItemFromPt(DLI.hwnd, DLI.ptCursor.X, DLI.ptCursor.Y, True)
SetCursor LoadCursorFromFile(Environ("Temp") & CurFile)
WinProc = 0
Case DL_DROPPED
SetCursor 0
If LBItemFromPt _
(DLI.hwnd, DLI.ptCursor.X, DLI.ptCursor.Y, True) _
<> DragIdx Then
If (sLBItemText) <> "" Then
SendMessage DLI.hwnd, LB_INSERTSTRING, _
LBItemFromPt _
(DLI.hwnd, DLI.ptCursor.X, DLI.ptCursor.Y, True) _
+ TopIndex, ByVal sLBItemText
Call SendMessage _
(DLI.hwnd, LB_DELETESTRING, _
SendMessage(DLI.hwnd, LB_GETCURSEL, 0, 0), 0)
End If
End If
End Select
End If '// IF bDragList.
Exit Function
End Select '// uMsg.
WinProc = CallWindowProc _
(PrevProc, hwnd, uMsg, wParam, lParam)
End Function
Public Sub AddItem(Item As String)
SendMessage LBhwnd, LB_ADDSTRING, 0, ByVal Item
End Sub
Public Property Let BackColor(ByVal Color As Long)
Dim hDc As Long
lBackColor = Color
hDc = GetDC(LBhwnd)
SendMessage LBhwnd, WM_PAINT, hDc, 0
ReleaseDC LBhwnd, hDc
End Property
Public Property Let TextColor(ByVal Color As Long)
Dim hDc As Long
lTextColor = Color
hDc = GetDC(LBhwnd)
SendMessage LBhwnd, WM_PAINT, hDc, 0
ReleaseDC LBhwnd, hDc
End Property
Public Sub Clear()
SendMessage LBhwnd, LB_RESETCONTENT, 0, 0
DragIdx = 0
sLBItemText = ""
End Sub
Public Sub Create _
(X As Single, Y As Single, W As Single, H As Single, _
ParentForm As Object)
If bHookSet Then Exit Sub
'// Assume the Dragging prop is set to false.
bDragList = False
lLBParentHwnd = _
FindWindow(vbNullString, ParentForm.Caption)
lFrmChildHwnd = GetWindow(lLBParentHwnd, GW_CHILD)
'//Convert coordinates to Pixels.
X = X / PointsPerPixelX
Y = Y / PointsPerPixelY
W = W / PointsPerPixelX
H = H / PointsPerPixelY
'//Create the Drag ListBox here.
LBhwnd = CreateWindowEx(WS_EX_CLIENTEDGE, "ListBox", _
vbNullString, LB_Styles, X, Y, W, H _
, lFrmChildHwnd, 0, 0, 0)
'//Subclass the Parent of the ListBox
'so we can receive drag notifications.
'and other events.
DL_Message = RegisterWindowMessage(DRAGLISTMSGSTRING)
MakeDragList LBhwnd
PrevProc = SetWindowLong _
(lFrmChildHwnd, GWL_WNDPROC, AddressOf TransitProc)
If PrevProc <> 0 Then bHookSet = True
'//create the Drag Cursor.
Call CreateDragCursor
End Sub
Public Sub Destroy()
'//CleanUp.
DestroyWindow LBhwnd
lBackColor = 0
lTextColor = 0
Kill Environ("Temp") & CurFile
End Sub
Public Property Let DragList(ByVal Value As Boolean)
If Value Then bDragList = True Else bDragList = False
'//Refresh the form screen.
InvalidateRect lFrmChildHwnd, 0, 0
End Property
Public Property Get DragList() As Boolean
DragList = bDragList
End Property
Public Property Get GetCount() As Long
GetCount = SendMessage(LBhwnd, LB_GETCOUNT, 0, 0)
End Property
Public Function GetItem(Index As Long) As String
Dim sBuffer As String
Dim lRet As Long
On Error Resume Next
lRet = SendMessage(LBhwnd, LB_GETTEXTLEN, Index, ByVal 0)
sBuffer = Space(lRet) & vbNullChar
lRet = SendMessage(LBhwnd, LB_GETTEXT, Index, ByVal sBuffer)
GetItem = sBuffer
End Function
Public Property Get Index() As Long
Index = SendMessage(LBhwnd, LB_GETCURSEL, 0, 0)
End Property
Public Sub RemoveItem(Index As Long)
SendMessage LBhwnd, LB_DELETESTRING, Index, 0
End Sub
Public Property Get TopIndex() As Long
TopIndex = SendMessage(LBhwnd, LB_GETTOPINDEX, 0, 0)
End Property
Public Property Get Value() As String
Dim sBuffer As String
Dim lRet As Long
Dim lIndex As Long
On Error Resume Next
lIndex = SendMessage(LBhwnd, LB_GETCURSEL, 0, 0)
lRet = SendMessage(LBhwnd, LB_GETTEXTLEN, lIndex, ByVal 0)
sBuffer = Space(lRet) & vbNullChar
lRet = SendMessage(LBhwnd, LB_GETTEXT, lIndex, ByVal sBuffer)
Value = sBuffer
End Property
Public Sub SlelectItem(Index As Long)
Dim hDc As Long
SendMessage LBhwnd, LB_SETCURSEL, Index, 0
hDc = GetDC(LBhwnd)
SendMessage LBhwnd, WM_PAINT, hDc, 0
ReleaseDC LBhwnd, hDc
End SubCode in a Standard Module :
Code:
Option Explicit
Public lLBParentHwnd As Long
Public lFrmChildHwnd As Long
Public LBhwnd As Long
Public PrevProc As Long
Public oLB As CListBox
Public Function TransitProc( _
ByVal hwnd As Long, ByVal MSG As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
TransitProc = CallByName _
(oLB, "WinProc", VbMethod, hwnd, MSG, wParam, lParam)
End FunctionCode in the UserForm Module ( Required Labels need to be added.)
Code:
Option Explicit
Private WithEvents LB As CListBox
'---------------------------
'// UserForm Default Events.
'---------------------------
Private Sub UserForm_Initialize()
Dim i As Long
'// create our Drag ListBox.
Set LB = New CListBox
With LB
.Create 20, Label1.Top, _
90, 150, Me
'// Populate the ListBox.
For i = 0 To 39
.AddItem "Item: " & CStr(i)
Next
'// Set some of its Properties.
.AddItem "Driss Cherkaoui"
'.BackColor = vbYellow
.TextColor = vbRed
.DragList = True
If .DragList Then Me.CkBDragList = True
End With
End Sub
Private Sub CkBDragList_Change()
LB.DragList = Me.CkBDragList.Value
End Sub
Private Sub UserForm_QueryClose _
(Cancel As Integer, CloseMode As Integer)
LB.Destroy
End Sub
'---------------------------
'// Drag ListBox Events.
'---------------------------
Private Sub LB_DBLClick()
MsgBox "You Double Clicked."
End Sub
Private Sub LB_Click()
'// Do stuff here...
End Sub
Private Sub LB_Change(ByVal ItemValue As String)
LblCurSel.Caption = ItemValue
LblTopIndex.Caption = LB.TopIndex
LblCurIndex.Caption = LB.Index
End Sub
Private Sub LB_MouseMove(ByVal X As Long, ByVal Y As Long)
LblX.Caption = X
LblY.Caption = Y
End SubOne known limitation is the ListBox not getting the KeyBoard focus if another normal listBox or TextBox happen to coexist on the userform.
I am still looking into this to see if I can fix it.
Tested on Excel 2003 Win XP only. (Seems quite stable)
Last edited:
