Very Cool DragListBox that enables the user to move Items from one Position to another !

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,728
Office Version
  1. 2016
Platform
  1. 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 :

DragList-1.jpg


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 Sub


Code 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 Function

Code 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 Sub

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)
 
Last edited:

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
OMG - threads get buried so quickly here !

Can anyone please confirm if this works on other than Excel 2003 / Win XP ?

Thanks.
 
Upvote 0
Workbook Example.

At last, I have suceeded in overcoming the KeyBoard Focus problem which was a major limitation !

Now the DragList works smoothly even if there happens to be TextBox or ComboBox Controls on the UserForm.

DragListEx-2.jpg



The secret was to put the DragList inside an invisible Frame Control . This change has impacted the whole code flow so I'll post the new code here for future reference.

Also, I have added some more useful Properties,Methods and events to the DragList Class to make it even more robust.

Class Code : (CListBox)

Code: 
'// Written by Jaafar Tribak 22/07/2010.
'// Class that creates a Drag ListBox
'// and define other custom Properties,
'// Methods and Events.
'// All done in VBA !
'// Focus problem now fixed.
 
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()
Public Event OnDrag()
Public Event OnDrop()
Public Event OnCancelDrag()
 
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 FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 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 LB_SELECTSTRING = &H18C
Private Const LB_ERR = (-1)
 
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 GW_HWNDNEXT = 2
 
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 oFrameCtl As Object
Private lFormHwnd As Long
Private lLBParentHwnd As Long
Private LBhwnd As Long
Private PrevProc As Long
Private lFrameCtlHwnd As Long
 
'===================
'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 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
 
Private Function ContainerFrameHwnd _
(X As Single, Y As Single, W As Single, H As Single, _
ParentForm As Object) As Long
 
    Dim lCtlsWithHwndCounter As Long
    Dim i As Long
 
    lFrameCtlHwnd = GetWindow(lLBParentHwnd, GW_CHILD)
 
    Do While Not IsNull(lFrameCtlHwnd) And (lFrameCtlHwnd <> 0)
 
        lFrameCtlHwnd = FindWindowEx _
        (lLBParentHwnd, lFrameCtlHwnd, vbNullString, vbNullString)
        lCtlsWithHwndCounter = lCtlsWithHwndCounter + 1
 
    Loop
 
    Set oFrameCtl = ParentForm.Controls.Add("Forms.Frame.1")
 
    With oFrameCtl
        .Left = X
        .Top = Y
        .Width = W
        .Height = H
        .SpecialEffect = fmSpecialEffectFlat
    End With
 
    lFrameCtlHwnd = GetWindow(lLBParentHwnd, GW_CHILD)
 
    For i = 1 To lCtlsWithHwndCounter
        lFrameCtlHwnd = FindWindowEx _
        (lLBParentHwnd, lFrameCtlHwnd, vbNullString, vbNullString)
    Next
 
    ContainerFrameHwnd = lFrameCtlHwnd
 
End Function
 
'=================================================
'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
 
            oFrameCtl.SetFocus
 
            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
 
 
        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
 
                       '// raise the OnDrag event.
                       RaiseEvent OnDrag
                        TopIndex = _
                        SendMessage(DLI.hwnd, LB_GETTOPINDEX, 0, 0)
                        '// Draw the insert icon.
                        DrawInsert lFrameCtlHwnd, DLI.hwnd, _
                        LBItemFromPt(DLI.hwnd, DLI.ptCursor.X, DLI.ptCursor.Y, True)
                        SetCursor LoadCursorFromFile(Environ("Temp") & CurFile)
                        WinProc = 0
 
                    Case DL_CANCELDRAG
 
                        InvalidateRect hwnd, 0, 0
                         '// raise the CancelDrop event.
                         RaiseEvent OnDrop
 
                    Case DL_DROPPED
 
                        SetCursor 0
 
                         InvalidateRect hwnd, 0, 0
                         '// raise the OnDrop event.
                         RaiseEvent OnDrop
 
                        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)
 
    Dim tRect As RECT
 
    If bHookSet Then Exit Sub
 
 
    '// Assume the Dragging prop is set to false.
    bDragList = False
 
    lFormHwnd = _
    FindWindow(vbNullString, ParentForm.Caption)
    lLBParentHwnd = GetWindow(lFormHwnd, GW_CHILD)
 
    '// add the LB container Frame Ctl and return its HWND.
    lFrameCtlHwnd = ContainerFrameHwnd(X, Y, W, H, ParentForm)
 
    '// retrieve the Frame dims.
    GetClientRect lFrameCtlHwnd, tRect
 
    With tRect
        '//Create the Drag ListBox to fit the size of the Frame Ctl.
        LBhwnd = CreateWindowEx(WS_EX_CLIENTEDGE, "ListBox", _
        vbNullString, LB_Styles, .Left + 20, .Top, _
        (.Right - .Left) - 20, .Bottom - .Top _
        , lFrameCtlHwnd, 0, 0, 0)
    End With
 
    '//Subclass the Parent of the ListBox
    'so we can receive drag notifications.
    'and other events.
    DL_Message = RegisterWindowMessage(DRAGLISTMSGSTRING)
    MakeDragList LBhwnd
    PrevProc = SetWindowLong _
    (lFrameCtlHwnd, 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 lLBParentHwnd, 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 Sub
 
Public Function SelectItemByString(ByVal Text As String) As Boolean
 
    Dim hdc As Long
    Dim lRet As Long
 
    hdc = GetDC(LBhwnd)
    lRet = SendMessage(LBhwnd, LB_SELECTSTRING, -1, ByVal Text)
    If lRet <> LB_ERR Then SelectItemByString = True
    SendMessage LBhwnd, WM_PAINT, hdc, 0
    ReleaseDC LBhwnd, hdc
 
End Function


Code in a Standard Module :

Code: 
Option Explicit
 
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 Function

Code in the UserForm Module (Obviously the required labels ,TextBox and CheckBox are required)

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 10, LablMouseCoord.Top, _
        100, 150, Me
        '// Populate the ListBox.
        For i = 1 To 100
            .AddItem "Item:" & CStr(i)
        Next
        '// Set some of its Properties.
        '.BackColor = vbYellow
        .TextColor = vbRed
        .DragList = True
 
        '// Display the cur Property values.
        Call UpdateLabels
 
       If .DragList Then CkBDragList = True
    End With
 
End Sub
 
Private Sub UserForm_QueryClose _
(Cancel As Integer, CloseMode As Integer)
 
    '// Important to cleanUp before closing the Form !!!!!
    LB.Destroy
 
End Sub
 
Private Sub CkBDragList_Change()
 
    LB.DragList = Me.CkBDragList.Value
 
End Sub
 
Private Sub btnGo_Click()
 
    If LB.SelectItemByString(Me.txtFindItem) Then
        Call UpdateLabels
    Else
        MsgBox "Item: '" & _
        Me.txtFindItem & "' not found."
    End If
 
    btnGo.Default = False
'    btnClose.SetFocus
 
End Sub
 
Private Sub btnClose_Click()
 
        Unload Me
 
End Sub
 
Private Sub txtFinditem_Enter()
 
    btnGo.Default = True
 
End Sub
 
Private Sub txtFinditem_Exit _
(ByVal Cancel As MSForms.ReturnBoolean)
 
    btnGo.Default = False
 
End Sub
 
Private Sub UpdateLabels()
 
    LblCurSel.Caption = LB.Value
    LblTopIndex.Caption = LB.TopIndex
    LblCurIndex.Caption = LB.Index
 
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)
 
    Call UpdateLabels
 
End Sub
 
Private Sub LB_MouseMove _
(ByVal X As Long, ByVal Y As Long)
 
    LblX.Caption = X
    LblY.Caption = Y
 
End Sub
 
Private Sub LB_OnCancelDrag()
 
    LblStatus = ""
 
End Sub
 
Private Sub LB_OnDrag()
 
    LblStatus = "Dragging..."
 
End Sub
 
Private Sub LB_OnDrop()
 
    LblStatus = ""
 
End Sub


Hope this works well accross different Excel versions and platforms.
 
Upvote 0
Last edited:
Upvote 0
tusharm said:
I don't know if you are interested in doing this but you may want to also post your very cool solutions (though some may not be very robust {grin}) in
Microsoft Office Customization and Programming
http://social.answers.microsoft.com...ilter=mf:33716c22-2433-4d9b-8ce0-047e4781dcf4

And, another place to consider is www.dailydoseofexcel.com. If you are interested, I can check with **** Kusleika if he will grant you author privileges.
Click to expand...

Thanks for the suggestions Tushar. I never thought about that but now that you say it I wouldn't mind.

As for the Microsoft link above, I am surprised I never came accross it .
 
Upvote 0
Hi all

Has anyone used this draglistbox in their userforms???

One thing I have found with this draglistbox is that you can not select all the items in it and then write those items to a spreadsheet.

You can additems, deleteitems, drag and drop items, but what is the use if you can not then select all items and place them into a spreadsheet???

Does anyone have an answer to this???

This would be an increadibly useful tool then. Great little demo though.


Thanks
John
 
Upvote 0
This Custom LitBox has a GetItem and Value Properties which you can use to retrieve the Listbox Items and place them into the spreadsheet cells or wherever. It doesn't allow multiselecting though.

When I first created the ListBox, I did it on excel 2003. I have excel 2007 at the moment and when trying the code, I got an error which i'll need to investigate before I can post an example with what you want. I'll keep you posted.
 
Upvote 0
Thanks for your quick response Jaafar,

I am using excel 2003.

I can add items to the listbox, I can delete items from the listbox as well as the functional drag and drop. Simply brilliant.

But as in a standard list box I can add code to go through it and copy all the items from the list box to a spreadsheet.

Is it possible to add this functionality into the class module as a public function or public property??

If this is not possible, what option do I have to take 10 to 20 items from the draglistbox to a spreadsheet??

Thanks
John
 
Upvote 0
John,

As I said, you could use the already defined Properies GetCount and GetItem to easily achieve what you want.

A little code like the following will populate Column A with all the Items in the ListBox.

Code: 
Private Sub btnPopSht_Click()

    Dim item As Long
    
    For item = 1 To LB.GetCount
       Cells(item, 1) = LB.GetItem(item - 1)
    Next item

End Sub
here is a Workbook demo where I have added a commandbutton ( btnPopSht ) that carries out the above code.

I have also edited the code so that it works in excel 2007 as well.
 
Upvote 0
Hi Jaafar,

That is fantastic. That was the missing peice of the puzzle. I was nowhere near that solution with that code.

Thankyou so much
John
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Please help me to correct Excel VBA code!
Replies
1
Views
212
Minh Tuan VN
M
Jaafar Tribak
  • Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
645
Jaafar Tribak
Jaafar Tribak
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
463
tigger_na
T
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
646
huiettcm
H
A
  • Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
1K
RoryA
RoryA

Forum statistics

Threads
1,221,310
Messages
6,159,176
Members
451,543
Latest member
cesymcox

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top