MultiColor + Drag N Drop ListBox Class (Win32)

[Jaafar Tribak]

Hi all,

MultiColorDragList.xlsm

I have been experimentng with the Comctl32 Listbox control in the last few days. The final result looks good BUT there are two major limitations which I should mention upfront beofre getting too excited.

1- ListBoxes can only be added to MODAL UserFoms.
2- No errors are allowed to happen inside the ListBox Event handler routines otherwise excel will crash. This means careful event coding !!

The above limitations are both due to the the fact that the ListoBox Frame container is subclassed.

At the moment, the Class only caters for single column listboxes and on one userform at a time. I will look into upgrading this if worth it.

With that said, here is a preview of the Listboxes :


The Listbox class provides most of the Properties, Methods and Events provided by the standard ActiveX Listbox control. Plus a handy AutoSize Tooltip which is ideal to get item info in the mousemove event.


1- Class Module CListBox

Option Explicit

Implements ISecret

Event Change(ByVal ItemIndex As Long)
Event Click(ByVal ItemIndex As Long)
Event DblClick(ByVal ItemIndex As Long)
Event RightClick(ByVal ItemIndex As Long, ByRef bSelect As Boolean)
Event MouseMove(ByVal ItemIndex As Long, ByVal X As Single, ByVal Y As Single, ByVal Ctrl As Long)
Event OnDrag(ByVal StartDragIdx As Long, ByVal EndDragIdx As Long)
Event OnDrop(ByVal StartDragIdx As Long, ByVal EndDragIdx As Long)
Event OnCancelDrag(ByVal StartDragIdx As Long)
Event KeyPress(ByVal KeyAscii As Integer)
Event KeyDown(ByVal KeyCode As Integer)
Event VScroll(ByVal Direction As Long)

Private WithEvents oForm As MSForms.UserForm
Private oFrameCtrl As MSForms.Frame

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type DRAGLISTINFO
    uNotification As Long
    #If Win64 Then
        hwnd As LongLong
    #Else
        hwnd As Long
    #End If
    ptCursor As POINTAPI
End Type

Private Type LongToInteger
    Low As Integer
    High As Integer
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type CWPSTRUCT
    #If Win64 Then
        lParam As LongLong
        wParam As LongLong
        Message As Long
        hwnd As LongLong
    #Else
        lParam As Long
        wParam As Long
        Message As Long
        hwnd As Long
    #End If
End Type

Private Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    #If Win64 Then
        hwndItem As LongLong
        hDc As LongLong
    #Else
        hwndItem As Long
        hDc As Long
    #End If
    rcItem As RECT
    #If Win64 Then
        itemData As LongLong
    #Else
        itemData As Long
    #End If
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function LBItemFromPt Lib "comctl32" (ByVal hLB As LongLong, ByVal Point As LongLong, ByVal bAutoScroll As Boolean) As Long
    #Else
        Private Declare PtrSafe Function LBItemFromPt Lib "comctl32" (ByVal hLB As Long, ByVal X As Long, ByVal Y As Long, ByVal bAutoScroll As Boolean) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe 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 LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, Col As Long) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As LongPtr
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal flags As Long) As LongPtr
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
    Private Declare PtrSafe Function MakeDragList Lib "comctl32" (ByVal hLB As LongPtr) As Boolean
    Private Declare PtrSafe Sub DrawInsert Lib "comctl32" (ByVal handParent As LongPtr, ByVal hLB As LongPtr, ByVal nItem As Long)
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal Punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal PunkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr)
    Private Declare PtrSafe Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr
    Private Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare PtrSafe Function RedrawWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal lprcUpdate As Long, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As LongPtr, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As LongPtr) As Long
    Private Declare PtrSafe Function AccessibleObjectFromEvent Lib "oleacc.dll" (ByVal hwnd As LongPtr, ByVal dwObjectId As Long, ByVal dwChildID As Long, ppacc As IAccessible, pVarChild As Variant) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

    Private hForm As LongPtr, hFormClient As LongPtr, hFrame As LongPtr, hLbx As LongPtr, hToolTip As LongPtr
#Else
    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 Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" 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" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) 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 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 ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) 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 ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal Punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal PunkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
    Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
    Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As Long) As Long
    Private Declare Function AccessibleObjectFromEvent Lib "oleacc.dll" (ByVal hwnd As Long, ByVal dwObjectId As Long, ByVal dwChildID As Long, ppacc As IAccessible, pVarChild As Variant) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

    Private hForm As Long, hFormClient As Long, hFrame As Long, hLbx As Long, hToolTip As Long
#End If



Private bDragList As Boolean, bTabStop As Boolean, bDisableTabStop As Boolean
Private bHasTTip As Boolean
Private bVisible As Boolean, bHidden As Boolean
Private bEnabled As Boolean, bDisabled As Boolean
Private bEnableEvents As Boolean, bEventsDisabled As Boolean
Private bMultiColor As Boolean, bBoolTabIndex As Boolean, bSortContent As Boolean
Private bLoadingList As Boolean, bBoolBackColor As Boolean
Private lTabIndx As Long, lBackColor As OLE_COLOR, lTextColor As OLE_COLOR
Private sName As String
Private snLeft As Single, snTop As Single, snWidth As Single, snHeight As Single
Private lCookie As Long, DL_Message As Long
Private lItemBackColor As OLE_COLOR
Private sToolTipText As String
Private sAddedItemsList() As String





 '___________________________________________Class Init_______________________________________________________
Private Sub Class_Initialize()
    Set oInterface = Me
End Sub
 
 
 '___________________________________________Class Methods____________________________________________
 
Public Sub AddItem(ByVal Item As String, Optional ByVal ItemColor As OLE_COLOR = vbWhite)
    Static i As Long
    ReDim Preserve sAddedItemsList(i)
    sAddedItemsList(i) = "  " & Item & "||*||" & ItemColor
    i = i + 1
End Sub

Public Sub Clear()
    Const LB_RESETCONTENT = &H184
    SendMessage hLbx, LB_RESETCONTENT, 0, ByVal 0
End Sub

 
Public Sub Create(ByVal Form As Object)

    Const WS_EX_NOACTIVATE = &H8000000
    Const WS_EX_CLIENTEDGE = &H200&
    Const WS_EX_CONTROLPARENT = &H10000
    Const WS_CHILD = &H40000000
    Const WS_VISIBLE = &H10000000
    Const WS_VSCROLL = &H200000
    Const WS_HSCROLL = &H100000
    Const LBS_OWNERDRAWVARIABLE = &H20&
    Const LBS_WANTKEYBOARDINPUT = &H400&
    Const LBS_SORT = &H2&
    Const LBS_HASSTRINGS = &H40&
    Const LBS_NOTIFY = &H1&
    Const LB_INITSTORAGE = &H1A8
    Const LB_ADDSTRING = &H180
    Const LB_SETITEMDATA = &H19A
    Const SWP_FRAMECHANGED = &H20
    Const SWP_HIDEWINDOW = &H80
    Const SWP_NOSIZE = &H1
    Const SWP_NOMOVE = &H2
    Const GW_CHILD = 5
  
    Dim tFrameRect As RECT
    Dim lSTYLES  As Long, lEXSTYLES  As Long, i As Long
    Dim sItemText As String, lItemCol As Long
  

    Set oForm = Form
  
    Call IUnknown_GetWindow(Form, VarPtr(hForm))
    hFormClient = GetWindow(hForm, GW_CHILD)
    hFrame = ContainerFrameHwnd(snLeft, snTop, snWidth, snHeight, Form)

    If Not oFrameCtrl Is Nothing Then
 
        If bHidden Then
            Call SetWindowPos(hFrame, 0, 0, 0, 0, 0, _
                SWP_HIDEWINDOW + SWP_FRAMECHANGED + SWP_NOMOVE + SWP_NOSIZE)
        End If
        If bDisabled Then
            Call EnableWindow(hFrame, 0)
        End If
      
        lSTYLES = LBS_HASSTRINGS Or LBS_NOTIFY Or WS_CHILD _
            Or WS_VISIBLE Or WS_VSCROLL Or WS_HSCROLL Or IIf(bSortContent, LBS_SORT, 0) _
            Or LBS_OWNERDRAWVARIABLE Or LBS_WANTKEYBOARDINPUT
          
        lEXSTYLES = WS_EX_NOACTIVATE + WS_EX_CONTROLPARENT + WS_EX_CLIENTEDGE
          
        Call GetClientRect(hFrame, tFrameRect)
        With tFrameRect
            hLbx = CreateWindowEx(lEXSTYLES, "ListBox", vbNullString, lSTYLES, _
                .Left, .Top, .Right - .Left, .Bottom - .Top, hFrame, 0, 0, 0)
        End With
 
        '2000 items * 10 bytes per item = 20 kb reserved memeory.
        Call SendMessage(hLbx, LB_INITSTORAGE, &H7D0, ByVal &H4E20)
      
        If Not Not sAddedItemsList Then
            Me.Clear
            For i = LBound(sAddedItemsList) To UBound(sAddedItemsList)
                If bMultiColor Then
                    sItemText = Split(CStr(sAddedItemsList(i)), "||*||")(0)
                    If InStr(sAddedItemsList(i), "||*||") Then
                        lItemCol = Split(CStr(sAddedItemsList(i)), "||*||")(1)
                    Else
                        lItemCol = vbWhite
                    End If
                    Call SendMessage(hLbx, LB_ADDSTRING, i, ByVal sItemText)
                    Call SendMessage(hLbx, LB_SETITEMDATA, i, ByVal lItemCol)
                Else
                    sItemText = Split(CStr(sAddedItemsList(i)), "||*||")(0)
                    Call SendMessage(hLbx, LB_ADDSTRING, i, ByVal sItemText)
                End If
            Next
        End If
 
        DL_Message = RegisterWindowMessage("commctrl_DragListMsg")
        Call MakeDragList(hLbx)
      
        bEnableEvents = True
  
        If bDragList Then
            If GetProp(Application.hwnd, "CUR") = 0 Then
                Call SetProp(Application.hwnd, "CUR", BuildDragCursor)
            End If
        End If
    
        If bBoolTabIndex = False Then
            oFrameCtrl.TabIndex = oForm.Controls.Count
        Else
            oFrameCtrl.TabIndex = lTabIndx
        End If
      
        oFrameCtrl.TabStop = True: bTabStop = True
        If bDisableTabStop = False Then
            If oFrameCtrl.TabIndex = 0 Then
                bLoadingList = True
                oFrameCtrl.SetFocus
            End If
        Else
            oFrameCtrl.TabStop = False
        End If
      
        Call SubclassFrame
        Call MonitorErrorsHook
        DoEvents
    End If
 
End Sub

Public Function GetItemValue(ByVal Index As Long) As String
    Const LB_GETTEXT = &H189
    Const LB_GETTEXTLEN = &H18A
    Const LB_ERR = (-1)
    Dim sBuffer As String
    Dim lRet As Long
  
    On Error Resume Next
    lRet = SendMessage(hLbx, LB_GETTEXTLEN, Index, ByVal 0)
    If lRet <> LB_ERR Then
        sBuffer = Space(lRet) & vbNullChar
        lRet = SendMessage(hLbx, LB_GETTEXT, Index, ByVal sBuffer)
        GetItemValue = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        GetItemValue = Right(GetItemValue, Len(GetItemValue) - 2)
    End If
End Function

Public Sub InsertItem(ByVal Item As String, Index As Long, Optional ByVal ItemColor As OLE_COLOR = vbWhite)
    Const LB_INSERTSTRING = &H181
  
    If hLbx = 0 Then Exit Sub
    Item = "  " & Item
    Call SendMessage(hLbx, LB_INSERTSTRING, Index, ByVal Item)
    ReDim Preserve sAddedItemsList(Me.GetItemsCount)
    sAddedItemsList(Index) = Item & "||*||" & ItemColor
    lItemBackColor = ItemColor
    Call RefreshData
End Sub

Public Sub RemoveItem(ByVal Index As Long)
    Const LB_DELETESTRING = &H182
    Call SendMessage(hLbx, LB_DELETESTRING, Index, ByVal 0)
End Sub

Public Function SelectItem(ByVal Index As Long) As Boolean
    Const LB_SETCURSEL = &H186
    Const LB_ERR = (-1)
    Dim lRet As Long
  
    With oFrameCtrl
        If .Visible And .Enabled Then
            lRet = SendMessage(hLbx, LB_SETCURSEL, Index, ByVal 0)
            If lRet <> LB_ERR Then
                SelectItem = True
                .SetFocus
                Call SetFocus(hLbx)
            End If
        End If
    End With
End Function
 
Public Function SelectItemByString(ByVal Text As String) As Boolean
    Const LB_SELECTSTRING = &H18C
    Const LB_ERR = (-1)
    Dim lRet As Long
  
    With oFrameCtrl
        If .Visible And .Enabled Then
            Text = "  " & Text
            lRet = SendMessage(hLbx, LB_SELECTSTRING, -1, ByVal Text)
            If lRet <> LB_ERR Then
                SelectItemByString = True
                oFrameCtrl.SetFocus
                Call SetFocus(hLbx)
            End If
        End If
    End With
End Function

Public Sub SortContent()
    bSortContent = True
End Sub

Public Sub zDO_NOT_USE_THIS_METHOD()

    'Attribute zDO_NOT_USE_THIS_METHOD.VB_UserMemId = -2147384830
  
    'This routine is the 'Enter' Event Handler of the run-time frame ctrl.
  
    Const WM_LBUTTONUP = &H202
    Const WM_LBUTTONDOWN = &H201
    Const LB_GETITEMRECT = &H198
    Dim tItemRect As RECT
  
    Call SetFocus(hLbx)
    Call SendMessage(hLbx, LB_GETITEMRECT, Me.Index, tItemRect)
    Call PostMessage(hLbx, WM_LBUTTONDOWN, 1, ByVal MakeDWord(CInt(tItemRect.Left), CInt(tItemRect.Top)))
    Call PostMessage(hLbx, WM_LBUTTONUP, 0, ByVal MakeDWord(CInt(tItemRect.Left), CInt(tItemRect.Top)))

End Sub



 '___________________________________________Class Properties____________________________________________


Public Property Let EnableDragNDrop(ByVal vNewValue As Boolean)
    bDragList = vNewValue
    Call InvalidateRect(hFormClient, 0, 0)
End Property
 
Public Property Get EnableDragNDrop() As Boolean
    EnableDragNDrop = bDragList
End Property

Public Property Let TabStop(ByVal vNewValue As Boolean)
    On Error Resume Next
    If vNewValue = False Then
        bDisableTabStop = True
    End If
    oFrameCtrl.TabStop = vNewValue
    bTabStop = vNewValue
End Property

Public Property Get TabStop() As Boolean
    TabStop = bTabStop
End Property

Public Property Let TabIndex(ByVal vNewValue As Long)
    On Error Resume Next
    bBoolTabIndex = True
    oFrameCtrl.TabIndex = vNewValue
    lTabIndx = vNewValue
End Property

Public Property Get TabIndex() As Long
    TabIndex = lTabIndx
End Property

Public Property Let BackColor(ByVal vNewValue As OLE_COLOR)
    bBoolBackColor = True
    Call TranslateColor(vNewValue, 0, vNewValue)
    lBackColor = vNewValue
End Property

Public Property Get BackColor() As OLE_COLOR
    BackColor = lBackColor
End Property
 
Public Property Let TextColor(ByVal vNewValue As OLE_COLOR)
    Call TranslateColor(vNewValue, 0, vNewValue)
    lTextColor = vNewValue
End Property

Public Property Get TextColor() As OLE_COLOR
    TextColor = lTextColor
End Property

Public Property Get Visible() As Boolean
    Visible = bVisible
End Property

Public Property Let Visible(ByVal vNewValue As Boolean)
    Const SWP_FRAMECHANGED = &H20
    Const SWP_SHOWWINDOW = &H40
    Const SWP_HIDEWINDOW = &H80
    Const SWP_NOSIZE = &H1
    Const SWP_NOMOVE = &H2

    If vNewValue = False Then
        bHidden = True
    End If
    Call SetWindowPos(hFrame, 0, 0, 0, 0, 0, _
        IIf(vNewValue, SWP_SHOWWINDOW, SWP_HIDEWINDOW) + SWP_FRAMECHANGED + SWP_NOMOVE + SWP_NOSIZE)
    Call SetWindowPos(hLbx, 0, 0, 0, 0, 0, _
        IIf(vNewValue, SWP_SHOWWINDOW, SWP_HIDEWINDOW) + SWP_FRAMECHANGED + SWP_NOMOVE + SWP_NOSIZE)
    bVisible = vNewValue
End Property

Public Property Get Enabled() As Boolean
    Enabled = bEnabled
End Property

Public Property Let Enabled(ByVal vNewValue As Boolean)
    If vNewValue = False Then
        bDisabled = True
    End If
    Call EnableWindow(hFrame, IIf(vNewValue, vNewValue, 0))
    bEnabled = vNewValue
End Property

Public Property Get GetItemsCount() As Long
    Const LB_GetItemsCount = &H18B
    GetItemsCount = SendMessage(hLbx, LB_GetItemsCount, 0, ByVal 0)
End Property

Public Property Get Index() As Long
    Const LB_GETCURSEL = &H188
    Index = SendMessage(hLbx, LB_GETCURSEL, 0, ByVal 0)
End Property
 
Public Property Get Value() As String
    Const LB_GETCURSEL = &H188
    Const LB_GETTEXT = &H189
    Const LB_GETTEXTLEN = &H18A
    Const LB_ERR = (-1)
    Dim sBuffer As String
    Dim lRet As Long
    Dim lIndex As Long
  
    On Error Resume Next
    lIndex = SendMessage(hLbx, LB_GETCURSEL, 0, ByVal 0)
    lRet = SendMessage(hLbx, LB_GETTEXTLEN, lIndex, ByVal 0)
    If lRet <> LB_ERR Then
        sBuffer = Space(lRet) & vbNullChar
        lRet = SendMessage(hLbx, LB_GETTEXT, lIndex, ByVal sBuffer)
        Value = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        Value = Right(Value, Len(Value) - 2)
    End If
End Property

Public Property Get VisibleItemsCount() As Long
    Const LB_ITEMFROMPOINT = &H1A9
    Dim tWinRect As RECT, tPt As POINTAPI, lp As Long, lRet As Long
  
    Call GetWindowRect(hLbx, tWinRect)
    tPt.X = tWinRect.Left + 10
    tPt.Y = tWinRect.Bottom - 10
    Call ScreenToClient(hFrame, tPt)
    lp = MAKELPARAM(tPt.X, tPt.Y)
    lRet = SendMessage(hLbx, LB_ITEMFROMPOINT, 0, ByVal lp)
    If lRet Then
        VisibleItemsCount = lRet - Me.TopIndex + 1
    End If
End Property

Public Property Get SortedContent() As Boolean
    SortedContent = bSortContent
End Property

Public Property Get FrameParent() As MSForms.Frame
    Set FrameParent = oFrameCtrl
End Property

Public Property Get Left() As Single
    Left = snLeft
End Property

Public Property Let Left(ByVal vNewValue As Single)
    snLeft = vNewValue
    If Not oFrameCtrl Is Nothing Then
        oFrameCtrl.Left = vNewValue
    End If
End Property

Public Property Get Top() As Single
    Top = snTop
End Property

Public Property Let Top(ByVal vNewValue As Single)
    snTop = vNewValue
    If Not oFrameCtrl Is Nothing Then
        oFrameCtrl.Top = vNewValue
    End If
End Property

Public Property Get Width() As Single
    Width = snWidth
End Property

Public Property Let Width(ByVal vNewValue As Single)
    Const SWP_NOMOVE = &H2
    Const SWP_SHOWWINDOW = &H40
    Const SWP_FRAMECHANGED = &H20
  
    snWidth = vNewValue
    If Not oFrameCtrl Is Nothing Then
        oFrameCtrl.Width = vNewValue
        Call SetWindowPos(hLbx, 0, 0, 0, PTtoPX(Me.Width, False), _
            PTtoPX(Me.Height, True), SWP_SHOWWINDOW + SWP_NOMOVE + SWP_FRAMECHANGED)
    End If
End Property

Public Property Get Height() As Single
    Height = snHeight
End Property

Public Property Let Height(ByVal vNewValue As Single)
    Const SWP_NOMOVE = &H2
    Const SWP_SHOWWINDOW = &H40
    Const SWP_FRAMECHANGED = &H20
  
    snHeight = vNewValue
    If Not oFrameCtrl Is Nothing Then
       oFrameCtrl.Height = vNewValue
       Call SetWindowPos(hLbx, 0, 0, 0, PTtoPX(Me.Width, False), _
           PTtoPX(Me.Height, True), SWP_SHOWWINDOW + SWP_NOMOVE + SWP_FRAMECHANGED)
    End If
End Property

Public Property Get MultiColor() As Boolean
    MultiColor = bMultiColor
End Property

Public Property Let MultiColor(ByVal vNewValue As Boolean)
    bMultiColor = vNewValue
End Property

Public Property Get EnableEvents() As Boolean
    EnableEvents = bEnableEvents
End Property

Public Property Let EnableEvents(ByVal vNewValue As Boolean)
    If vNewValue = False Then
        bEventsDisabled = True
    Else
        bEventsDisabled = False
    End If
    bEnableEvents = vNewValue
End Property

Public Property Get GetItemsList() As Variant
    Dim tmpArr() As Variant
    Dim sTmp As String, i As Long
  
    If Not Not sAddedItemsList Then
        For i = LBound(sAddedItemsList) To UBound(sAddedItemsList)
            ReDim Preserve tmpArr(i)
            sTmp = sAddedItemsList(i)
            If InStr(sTmp, "||*||") Then
                sTmp = Left(sTmp, InStr(sTmp, "||*||") - 1)
                tmpArr(i) = Right(sTmp, Len(sTmp) - 2)
            End If
        Next
        GetItemsList = tmpArr
    End If
    Erase tmpArr
End Property

Public Property Get ItemBackColor(ByVal ItemIndex As Long) As OLE_COLOR
    Const LB_GETITEMDATA = &H199
  
    If bMultiColor Then
        ItemBackColor = SendMessage(hLbx, LB_GETITEMDATA, ItemIndex, ByVal 0)
        ItemBackColor = lItemBackColor
    Else
        ItemBackColor = lBackColor
    End If
End Property

Public Property Let ItemBackColor(ByVal ItemIndex As Long, ByVal vNewValue As OLE_COLOR)
    Const LB_SETITEMDATA = &H19A
    Const RDW_INVALIDATE = &H1
    Const RDW_ERASE = &H4
  
    Call SendMessage(hLbx, LB_SETITEMDATA, ItemIndex, ByVal vNewValue)
    sAddedItemsList(ItemIndex) = Split(CStr(sAddedItemsList(ItemIndex)), "||*||")(0) & "||*||" & vNewValue
    lItemBackColor = vNewValue
    Call RedrawWindow(hLbx, 0, 0, RDW_INVALIDATE + RDW_ERASE)
End Property

Public Property Get ToolTipText() As String
    ToolTipText = sToolTipText
End Property

Public Property Let ToolTipText(ByVal vNewValue As String)
    sToolTipText = vNewValue
End Property

Public Property Get HasToolTip() As Boolean
    HasToolTip = bHasTTip
End Property

Public Property Let HasToolTip(ByVal vNewValue As Boolean)
    Const WS_POPUP = &H80000000
    Const WS_BORDER = &H800000
    Const WS_EX_NOACTIVATE = &H8000000
    Const WS_EX_TOOLWINDOW = &H80&
    Const CW_USEDEFAULT = &H80000000
  
    If vNewValue Then
        hToolTip = CreateWindowEx(WS_EX_NOACTIVATE + WS_EX_TOOLWINDOW, "Static", 0, WS_BORDER + WS_POPUP, _
            CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
        If hToolTip Then
            Call SetProp(Application.hwnd, "ToolTip", hToolTip)
            bHasTTip = vNewValue
        End If
    Else
        Call RemoveToolTip
    End If
End Property

Public Property Get TopIndex() As Long
    Const LB_GETTOPINDEX = &H18E
    TopIndex = SendMessage(hLbx, LB_GETTOPINDEX, 0, ByVal 0)
End Property

Public Property Let TopIndex(ByVal vNewValue As Long)
    Const LB_SETTOPINDEX = &H197
    Call SendMessage(hLbx, LB_SETTOPINDEX, vNewValue, ByVal 0)
End Property

Public Property Get IsActive() As Boolean
    On Error Resume Next
    IsActive = CBool(oForm.ActiveControl Is Me.FrameParent)
End Property

Public Property Get Name() As String
    Name = sName
End Property

Public Property Let Name(ByVal vNewValue As String)
    sName = vNewValue
End Property



'___________________________________________ISecret Interface Implementation_________________________________________

#If Win64 Then
    Private Function ISecret_FrameWndProc( _
        ByVal hwnd As LongLong, _
        ByVal wMsg As Long, _
        ByVal wParam As LongLong, _
        ByVal lParam As LongLong, _
        ByVal uIdSubclass As Object, _
        ByVal This As LongLong _
    ) As LongLong
      
        Dim Ptr As LongLong
    
#Else
    Private Function ISecret_FrameWndProc( _
        ByVal hwnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long, _
        ByVal uIdSubclass As Object, _
        ByVal This As Long _
    ) As Long
    
#End If

    Const WM_COMMAND = &H111
    Const WM_SETCURSOR = &H20
    Const WM_SETFOCUS = &H7
    Const WM_DRAWITEM = &H2B
    Const WM_VKEYTOITEM = &H2E
    Const WM_DESTROY = &H2
    Const WM_USER = &H400
    Const DL_BEGINDRAG = (WM_USER + 133)
    Const DL_DRAGGING = (WM_USER + 134)
    Const DL_DROPPED = (WM_USER + 135)
    Const DL_CANCELDRAG = (WM_USER + 136)
    Const LB_ERR = (-1)
    Const LB_GETTEXT = &H189
    Const LB_GETTEXTLEN = &H18A
    Const LB_GETTOPINDEX = &H18E
    Const LB_DELETESTRING = &H182
    Const LB_GETCURSEL = &H188
    Const LB_INSERTSTRING = &H181
    Const LB_ITEMFROMPOINT = &H1A9
    Const IDC_NO = 32648&
  
    Static StartDragIdx As Long
    Static EndDragIdx As Long
    Static sLBItemText As String

    Dim tDLI As DRAGLISTINFO
    Dim sBuffer As String, lCurSel As Long, lRet As Long, lTopIndex As Long, lp As Long

    On Error Resume Next
  
    If ProcessScrollEvent Then
        Exit Function
    End If

    Select Case wMsg
        Case WM_SETFOCUS
            Call ProcessSetFocusMsg
        Case WM_DRAWITEM
            Call ProcessDrawItemMsg(lParam)
        Case WM_VKEYTOITEM
            Call ProcessKeyStrokes(wParam)
            ISecret_FrameWndProc = -1
            Exit Function
        Case WM_SETCURSOR
            Call ProcessSetCursorMsg(wParam, lParam)
        Case WM_COMMAND
            Call ProcessCommandMsg(wParam)
        Case DL_Message
            If bDragList Then
                Call CopyMemory(tDLI, ByVal lParam, LenB(tDLI))
                #If Win64 Then
                    Call CopyMemory(Ptr, tDLI.ptCursor, LenB(tDLI.ptCursor))
                #End If
                Select Case tDLI.uNotification
                    Case DL_BEGINDRAG
                        lCurSel = SendMessage(tDLI.hwnd, LB_GETCURSEL, 0, ByVal 0)
                        #If Win64 Then
                            StartDragIdx = LBItemFromPt(tDLI.hwnd, Ptr, False)
                        #Else
                            StartDragIdx = LBItemFromPt(tDLI.hwnd, tDLI.ptCursor.X, tDLI.ptCursor.Y, False)
                        #End If
                        lRet = SendMessage(tDLI.hwnd, LB_GETTEXTLEN, StartDragIdx, ByVal 0)
                        If lRet <> LB_ERR Then
                            sBuffer = Space(lRet) & vbNullChar
                            lRet = SendMessage(tDLI.hwnd, LB_GETTEXT, StartDragIdx, ByVal sBuffer)
                            sLBItemText = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
                            ISecret_FrameWndProc = True
                            Exit Function
                        End If
                    Case DL_DRAGGING
                        lTopIndex = SendMessage(tDLI.hwnd, LB_GETTOPINDEX, 0, ByVal 0)
                        #If Win64 Then
                            EndDragIdx = LBItemFromPt(tDLI.hwnd, Ptr, True)
                        #Else
                            EndDragIdx = LBItemFromPt(tDLI.hwnd, tDLI.ptCursor.X, tDLI.ptCursor.Y, True)
                        #End If
                        Call DrawInsert(hForm, tDLI.hwnd, EndDragIdx)
                        Call ScreenToClient(hwnd, tDLI.ptCursor)
                        lp = MAKELPARAM(tDLI.ptCursor.X, tDLI.ptCursor.Y)
                        lRet = SendMessage(hLbx, LB_ITEMFROMPOINT, 0, ByVal lp)
                        If EndDragIdx = -1 Then
                            Call SetCursor(LoadCursor(0, IDC_NO))
                        Else
                            Call SetCursor(GetProp(Application.hwnd, "CUR"))
                        End If
                        If bEventsDisabled = False Then
                            RaiseEvent MouseMove(lRet, PXtoPT(tDLI.ptCursor.X, False), PXtoPT(tDLI.ptCursor.Y, True), 0&)
                            RaiseEvent OnDrag(StartDragIdx, EndDragIdx)
                        End If
                    Case DL_CANCELDRAG
                        If bEventsDisabled = False Then
                            RaiseEvent OnCancelDrag(StartDragIdx)
                        End If
                        Call InvalidateRect(hFormClient, 0, 0)
                    Case DL_DROPPED
                        If EndDragIdx <> -1 Then
                            #If Win64 Then
                                 EndDragIdx = LBItemFromPt(tDLI.hwnd, Ptr, True)
                            #Else
                                EndDragIdx = LBItemFromPt(tDLI.hwnd, tDLI.ptCursor.X, tDLI.ptCursor.Y, True)
                            #End If
                            If EndDragIdx <> StartDragIdx Then
                                If (sLBItemText) <> "" Then
                                    Call SendMessage(tDLI.hwnd, LB_INSERTSTRING, EndDragIdx + lTopIndex, ByVal sLBItemText)
                                    Call SendMessage(tDLI.hwnd, LB_DELETESTRING, _
                                    SendMessage(tDLI.hwnd, LB_GETCURSEL, 0, ByVal 0), ByVal 0)
                                End If
                            End If
                            If bEventsDisabled = False Then
                                RaiseEvent OnDrop(StartDragIdx, EndDragIdx)
                            End If
                            Me.SelectItem EndDragIdx
                            If Me.MultiColor Then
                                Call RefreshData
                            End If
                            oFrameCtrl.SetFocus
                            Call SetFocus(hLbx)
                            Call SetCursor(0)
                            Call InvalidateRect(hFormClient, 0, 0)
                            Exit Function
                        End If
                    End Select
                End If
        Case WM_DESTROY
            Call CleanUp
    End Select

    ISecret_FrameWndProc = DefSubclassProc(hwnd, wMsg, wParam, lParam)

End Function

#If Win64 Then
    Private Sub ISecret_SafeExitHook( _
            ByVal HookId As LongLong, _
            ByVal LEvent As Long, _
            ByVal hwnd As LongLong, _
            ByVal idObject As Long, _
            ByVal idChild As Long, _
            ByVal idEventThread As Long, _
            ByVal dwmsEventTime As Long _
        )
#Else
    Private Sub ISecret_SafeExitHook( _
        ByVal HookId As Long, _
        ByVal LEvent As Long, _
        ByVal hwnd As Long, _
        ByVal idObject As Long, _
        ByVal idChild As Long, _
        ByVal idEventThread As Long, _
        ByVal dwmsEventTime As Long _
            )
#End If


    Const EVENT_OBJECT_CREATE = &H8000&
    Dim vChild As Variant, oAccDlg As IAccessible

    On Error Resume Next
  
    If IsWindow(hForm) = 0 Then
        Call CleanUp
    End If
  
    If AccessibleObjectFromEvent(hwnd, idObject, idChild, oAccDlg, vChild) = 0& Then
        If LEvent = EVENT_OBJECT_CREATE Then
            If InStr(oAccDlg.accName(0&), "Microsoft Visual Basic") Then
                Call CleanUp
            End If
        End If
    End If
  
End Sub



'______________________________________________Private Routines_______________________________________________________

Private Sub SubclassFrame(Optional ByVal bHook As Boolean = True)
    Dim i As Long

    If bHook Then
        Call SetWindowSubclass(hFrame, WinProcAddr, ObjPtr(Me), ByVal hToolTip)
        If oAllClassesObjPtrs Is Nothing Then
            Set oAllClassesObjPtrs = New Collection
            Set oAllFramesHwnds = New Collection
        End If
        oAllClassesObjPtrs.Add ObjPtr(Me)
        oAllFramesHwnds.Add hFrame
    Else
        If Not oAllClassesObjPtrs Is Nothing Then
            With oAllClassesObjPtrs
                For i = .Count To 1 Step -1
                    Call RemoveWindowSubclass(oAllFramesHwnds.Item(i), WinProcAddr, ByVal .Item(i))
                Next i
            End With
            Set oAllClassesObjPtrs = Nothing
            Set oAllFramesHwnds = Nothing
        End If
    End If
End Sub

#If Win64 Then
    Private Function ContainerFrameHwnd( _
        ByVal X As Single, _
        ByVal Y As Single, _
        ByVal W As Single, _
        ByVal h As Single, _
        ByVal ParentForm As Object _
    ) As LongLong
#Else
    Private Function ContainerFrameHwnd( _
        ByVal X As Single, _
        ByVal Y As Single, _
        ByVal W As Single, _
        ByVal h As Single, _
        ByVal ParentForm As Object _
    ) As Long

#End If

    Const GW_CHILD = 5
    Dim lCtlsWithHwndCounter As Long, i As Long
    hFrame = GetWindow(hFormClient, GW_CHILD)
  
    Do While Not IsNull(hFrame) And (hFrame <> 0)
        hFrame = FindWindowEx(hFormClient, hFrame, vbNullString, vbNullString)
        lCtlsWithHwndCounter = lCtlsWithHwndCounter + 1
    Loop
  
  
    Set oFrameCtrl = ParentForm.Controls.Add("Forms.Frame.1")
    If Not oFrameCtrl Is Nothing Then
        If SinkFrameEnterEvent = False Then
            Err.Raise Number:=vbObjectError + 513, _
                Description:="Unable to sink the run-time frame ctrl 'Enter Event' !!!" 'get out
        End If
        With oFrameCtrl
            .Left = X
            .Top = Y
            .Width = W
            .Height = h
        End With
        hFrame = GetWindow(hFormClient, GW_CHILD)
        For i = 1 To lCtlsWithHwndCounter
            hFrame = FindWindowEx(hFormClient, hFrame, vbNullString, vbNullString)
        Next
        ContainerFrameHwnd = hFrame
    End If
 
End Function

Private Function SinkFrameEnterEvent(Optional ByVal bHook As Boolean = True) As Boolean
    Const S_OK = 0&
    Dim tGUID As GUID
     With tGUID
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    If ConnectToConnectionPoint(Me, tGUID, bHook, oFrameCtrl, lCookie) = S_OK Then
        SinkFrameEnterEvent = True
    End If
End Function


Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1), hDc

    If lDPI(0) = 0 Then
        hDc = GetDC(0)
        lDPI(0) = GetDeviceCaps(hDc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hDc, LOGPIXELSY)
        hDc = ReleaseDC(0, hDc)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
    Const POINTS_PER_INCH = 72
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function

Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72
    PXtoPT = (Pixels / (ScreenDPI(bVert) / POINTSPERINCH))
End Function

Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Function MAKELONG(wLow As Long, wHigh As Long) As Long
  MAKELONG = loword(wLow) Or (&H10000 * loword(wHigh))
End Function

Private Function MAKELPARAM(wLow As Long, wHigh As Long) As Long
  MAKELPARAM = MAKELONG(wLow, wHigh)
End Function

#If Win64 Then
    Private Function loword(ByVal Word As LongLong) As Integer
#Else
    Private Function loword(ByVal Word As Long) As Integer
#End If
    Dim X As LongToInteger
    Call CopyMemory(X, Word, LenB(X))
    loword = X.Low
End Function

#If Win64 Then
    Private Function hiword(ByVal Word As LongLong) As Integer
#Else
    Private Function hiword(ByVal Word As Long) As Integer
#End If
    Dim X As LongToInteger
    Call CopyMemory(X, Word, LenB(X))
    hiword = X.High
End Function

#If Win64 Then
    Private Function BuildDragCursor() As LongLong
#Else
    Private Function BuildDragCursor() As Long
#End If

    ReDim longs(0 To 186) As Long
  
    longs(0) = 0: longs(1) = 40: longs(2) = 32: longs(3) = 64: longs(4) = 262145: longs(5) = 0: longs(6) = 640: longs(7) = 0: longs(8) = 0: longs(9) = 16: longs(10) = 0: longs(11) = 0: longs(12) = 8388608: longs(13) = 32768: longs(14) = 8421376: longs(15) = 128: longs(16) = 8388736: longs(17) = 32896: longs(18) = 12632256: longs(19) = 8421504: longs(20) = 16711680: longs(21) = 65280: longs(22) = 16776960: longs(23) = 255: longs(24) = 16711935: longs(25) = 65535: longs(26) = 16777215: longs(27) = 0: longs(28) = 0: longs(29) = 0
    longs(30) = 0: longs(31) = 0: longs(32) = 0: longs(33) = 0: longs(34) = 0: longs(35) = 0: longs(36) = 151587072: longs(37) = 151587081: longs(38) = 9: longs(39) = 0: longs(40) = -1869611008: longs(41) = -1869574000: longs(42) = 144: longs(43) = 0: longs(44) = 2304: longs(45) = 0: longs(46) = 9: longs(47) = 0: longs(48) = 9437184: longs(49) = 0: longs(50) = 144: longs(51) = 0: longs(52) = 2304: longs(53) = 0: longs(54) = 9: longs(55) = 0: longs(56) = 9437184: longs(57) = 0: longs(58) = 144: longs(59) = 0
    longs(60) = 2304: longs(61) = 0: longs(62) = 9: longs(63) = 0: longs(64) = 9437184: longs(65) = 0: longs(66) = 144: longs(67) = 0: longs(68) = 2304: longs(69) = 0: longs(70) = 9: longs(71) = 0: longs(72) = -1869611008: longs(73) = -1869574000: longs(74) = 144: longs(75) = 0: longs(76) = 151587072: longs(77) = 151587081: longs(78) = 9: longs(79) = 150994944: longs(80) = 144: longs(81) = 0: longs(82) = 0: longs(83) = -1728053248: longs(84) = 153: longs(85) = 0: longs(86) = 0: longs(87) = -1728053248: longs(88) = 153: longs(89) = 0
    longs(90) = 0: longs(91) = -1727463424: longs(92) = 144: longs(93) = 0: longs(94) = 0: longs(95) = -1727463280: longs(96) = 144: longs(97) = 0: longs(98) = 0: longs(99) = -1718026087: longs(100) = 0: longs(101) = 0: longs(102) = 0: longs(103) = -1717989223: longs(104) = 0: longs(105) = 0: longs(106) = 0: longs(107) = -1868981863: longs(108) = 0: longs(109) = 0: longs(110) = 0: longs(111) = -1717986919: longs(112) = 37017: longs(113) = 0: longs(114) = 0: longs(115) = -1717986919: longs(116) = 153: longs(117) = 0: longs(118) = 0: longs(119) = -1717986919
    longs(120) = 144: longs(121) = 0: longs(122) = 0: longs(123) = -1717986919: longs(124) = 0: longs(125) = 0: longs(126) = 0: longs(127) = -1868981863: longs(128) = 0: longs(129) = 0: longs(130) = 0: longs(131) = 10066329: longs(132) = 0: longs(133) = 0: longs(134) = 0: longs(135) = 9476505: longs(136) = 0: longs(137) = 0: longs(138) = 0: longs(139) = 39321: longs(140) = 0: longs(141) = 0: longs(142) = 0: longs(143) = 37017: longs(144) = 0: longs(145) = 0: longs(146) = 0: longs(147) = 153: longs(148) = 0: longs(149) = 0
    longs(150) = 0: longs(151) = 144: longs(152) = 0: longs(153) = 0: longs(154) = 0: longs(155) = -1: longs(156) = -1: longs(157) = -1079317761: longs(158) = 2136339967: longs(159) = -1073745921: longs(160) = 2147481599: longs(161) = -1073745921: longs(162) = 2147481599: longs(163) = -1073745921: longs(164) = 2147481599: longs(165) = -1073745921: longs(166) = 2136339967: longs(167) = -1079317761: longs(168) = -32770: longs(169) = -49156: longs(170) = -49156: longs(171) = -32776: longs(172) = -32904: longs(173) = -208: longs(174) = -240: longs(175) = -255: longs(176) = -57600: longs(177) = -49408: longs(178) = -33024: longs(179) = -256
    longs(180) = -255: longs(181) = -253: longs(182) = -249: longs(183) = -241: longs(184) = -225: longs(185) = -193: longs(186) = -129:
  
    BuildDragCursor = CreateIconFromResourceEx(longs(0), UBound(longs) * 4 + 4, 0&, &H30000, 0, 0, 0&)

End Function

Private Sub RemoveToolTip()
    Call DestroyWindow(hToolTip)
End Sub

Private Sub RefreshData()
    Const LB_SETITEMDATA = &H19A
    Const RDW_INVALIDATE = &H1
    Const RDW_ERASE = &H4
    Dim i As Long, lItemCol As Long
  
    For i = LBound(sAddedItemsList) To UBound(sAddedItemsList)
        If InStr(sAddedItemsList(i), "||*||") Then
            lItemCol = Split(CStr(sAddedItemsList(i)), "||*||")(1)
            Call SendMessage(hLbx, LB_SETITEMDATA, i, ByVal lItemCol)
        End If
    Next i
    Call RedrawWindow(hLbx, 0, 0, RDW_INVALIDATE + RDW_ERASE)
End Sub

Private Function ProcessScrollEvent() As Boolean
    Static lPrvTopIndx As Long
    Dim lSrollVal As Long
  
    lSrollVal = Me.TopIndex - lPrvTopIndx
    If lSrollVal Then
        RaiseEvent VScroll(lSrollVal / Abs(lSrollVal))
        lPrvTopIndx = Me.TopIndex
        ProcessScrollEvent = True
    End If
End Function

Private Sub ProcessSetFocusMsg()
    Const WM_LBUTTONDOWN = &H201
    Const WM_LBUTTONUP = &H202
    Const MK_LBUTTON = &H1
  
    Call PostMessage(hLbx, WM_LBUTTONDOWN, MK_LBUTTON, -1)
    Call PostMessage(hLbx, WM_LBUTTONUP, MK_LBUTTON, -1)
    DL_Message = 0
End Sub

#If Win64 Then
    Private Sub ProcessDrawItemMsg(ByVal lParam As LongLong)
        Dim hBrush1 As LongLong, hBrush2 As LongLong
#Else
    Private Sub ProcessDrawItemMsg(ByVal lParam As Long)
        Dim hBrush1 As Long, hBrush2 As Long
#End If

    Const ODT_LISTBOX = 2
    Const ODS_SELECTED = &H1
    Const COLOR_HIGHLIGHT = 13
    Const COLOR_HIGHLIGHTTEXT = 14
    Const LB_GETTEXT = &H189
    Const TRANSPARENT = 1
  
    Static tItem As DRAWITEMSTRUCT
    Dim sItem As String * 256, IFont As stdole.IFont

    Call CopyMemory(tItem, ByVal lParam, LenB(tItem))
    Set IFont = oFrameCtrl.Font
  
    If tItem.CtlType = ODT_LISTBOX Then
        Call SendMessage(tItem.hwndItem, LB_GETTEXT, tItem.itemID, ByVal sItem)
        sItem = Left(sItem, InStr(sItem, vbNullChar) - 1)
        If (tItem.itemState And ODS_SELECTED) Then
            hBrush1 = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
            Call SelectObject(tItem.hDc, hBrush1)
            Call FillRect(tItem.hDc, tItem.rcItem, hBrush1)
            Call SelectObject(tItem.hDc, IFont.hFont)
            Call SetTextColor(tItem.hDc, GetSysColor(COLOR_HIGHLIGHTTEXT))
            Call SetBkMode(tItem.hDc, TRANSPARENT)
            Call TextOut(tItem.hDc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem))
            Call DeleteObject(hBrush1)
        Else
            If bMultiColor Then
                hBrush2 = CreateSolidBrush(CLng(tItem.itemData))
            Else
                If lBackColor = 0 Then
                    If bBoolBackColor = False Then
                        lBackColor = vbWhite
                    End If
                End If
                hBrush2 = CreateSolidBrush(lBackColor)
            End If
            Call SelectObject(tItem.hDc, hBrush2)
            Call FillRect(tItem.hDc, tItem.rcItem, hBrush2)
            Call SelectObject(tItem.hDc, IFont.hFont)
            Call SetTextColor(tItem.hDc, lTextColor)
            Call SetBkMode(tItem.hDc, TRANSPARENT)
            Call TextOut(tItem.hDc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem))
            Call DeleteObject(hBrush2)
        End If
    End If

End Sub

#If Win64 Then
    Private Sub ProcessKeyStrokes(ByVal wParam As LongLong)
#Else
    Private Sub ProcessKeyStrokes(ByVal wParam As Long)
#End If

    Const MAPVK_VK_TO_VSC = 0
    Const MAPVK_VSC_TO_VK = 1
    Const MAPVK_VK_TO_CHAR = 2

    Static iVirKey As Integer
    Static iScanCode As Integer

    iVirKey = MapVirtualKey(loword(wParam), MAPVK_VK_TO_CHAR)
    iScanCode = MapVirtualKey(loword(wParam), MAPVK_VK_TO_VSC)
  
    If iVirKey Then
        If CBool(((GetKeyState(vbKeyCapital) And 1) = 1)) Then
            If bEventsDisabled = False Then
                RaiseEvent KeyPress(Asc(UCase(Chr(iVirKey))))
                RaiseEvent KeyDown(iScanCode)
            End If
        Else
             If bEventsDisabled = False Then
                RaiseEvent KeyPress(Asc(LCase(Chr(iVirKey))))
                RaiseEvent KeyDown(iScanCode)
            End If
        End If
    Else
        iScanCode = MapVirtualKey(iScanCode, MAPVK_VSC_TO_VK)
         If bEventsDisabled = False Then
            RaiseEvent KeyDown(iScanCode)
        End If
    End If

End Sub

#If Win64 Then
    Private Sub ProcessSetCursorMsg(ByVal wParam As LongLong, ByVal lParam As LongLong)
#Else
    Private Sub ProcessSetCursorMsg(ByVal wParam As Long, ByVal lParam As Long)
#End If
 
    Const WM_MOUSEMOVE = &H200
    Const WM_LBUTTONDOWN = &H201
    Const WM_RBUTTONUP = &H205
    Const LB_ITEMFROMPOINT = &H1A9
  
    Dim tCurPos As POINTAPI
    Dim lCtrl As Long, lRet As Long, lp As Long
    Dim bSelect As Boolean

    lCtrl = GetAsyncKeyState(VBA.vbKeyControl)
  
    If lCtrl = 0 Then
        Call ShowWindow(hToolTip, 0)
    End If
  
    DL_Message = RegisterWindowMessage("commctrl_DragListMsg")
          
    Call GetCursorPos(tCurPos)
    Call ScreenToClient(hLbx, tCurPos)
    lp = MAKELPARAM(tCurPos.X, tCurPos.Y)
  
    If wParam = hLbx Then
        If hiword(lParam) = WM_MOUSEMOVE Then
            lRet = SendMessage(hLbx, LB_ITEMFROMPOINT, 0, ByVal lp)
            If bEventsDisabled = False Then
                RaiseEvent MouseMove(lRet, (PXtoPT(tCurPos.X, False) + 1.5) * 100 / oForm.Zoom, _
                    (PXtoPT(tCurPos.Y, True) + 1.5) * 100 / oForm.Zoom, lCtrl)
            End If
            If hToolTip And bHasTTip And lCtrl Then
                If Me.IsActive Then
                    Call UpdateTTipText
                End If
            Else
              Call ShowWindow(hToolTip, 0)
            End If
        End If
        If hiword(lParam) = WM_LBUTTONDOWN Then
            lRet = SendMessage(hLbx, LB_ITEMFROMPOINT, 0, ByVal lp)
            Me.SelectItem lRet
            If bEventsDisabled = False Then
                RaiseEvent Click(lRet)
            End If
        End If
        If hiword(lParam) = WM_RBUTTONUP Then
            lRet = SendMessage(hLbx, LB_ITEMFROMPOINT, 0, ByVal lp)
            If bEventsDisabled = False Then
                RaiseEvent RightClick(lRet, bSelect)
            End If
            If bSelect Then
                Me.SelectItem lRet
            End If
        End If
    End If

End Sub

Private Sub UpdateTTipText()

    Const SWP_SHOWWINDOW = &H40
    Const DT_LEFT = &H0
    Const DT_VCENTER = &H4
    Const DT_CALCRECT = &H400
    Const SRCCOPY = &HCC0020
    Const COLOR_HIGHLIGHTTEXT = 14
    Const TRANSPARENT = 1
  
    #If Win64 Then
        Dim hDc As LongLong, hMemDc As LongLong, hBmp As LongLong, hBrush As LongLong, hPrvBrush As LongLong
    #Else
        Dim hDc As Long, hMemDc As Long, hBmp As Long, hBrush As Long, hPrvBrush As Long
    #End If

    Dim tTextRect As RECT, tCurPos As POINTAPI
    Dim IFont As stdole.IFont

    hDc = GetDC(hToolTip)
    Set IFont = oFrameCtrl.Font
    Call SelectObject(hDc, IFont.hFont)

    Call DrawText(hDc, sToolTipText, Len(sToolTipText), tTextRect, DT_CALCRECT)
    Call GetCursorPos(tCurPos)
    With tTextRect
        Call SetRect(tTextRect, .Left - 2, .Top - 2, .Right + 2, .Bottom + 2)
    End With
  
    hMemDc = CreateCompatibleDC(hDc)
    hBmp = CreateCompatibleBitmap(hDc, tTextRect.Right - tTextRect.Left, tTextRect.Bottom - tTextRect.Top)
    Call SelectObject(hMemDc, hBmp)
    Call SelectObject(hMemDc, IFont.hFont)
    hBrush = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHTTEXT))
    hPrvBrush = SelectObject(hMemDc, hBrush)
    Call FillRect(hMemDc, tTextRect, hBrush)
    Call SetBkMode(hMemDc, TRANSPARENT)
  
    With tTextRect
        Call SetRect(tTextRect, .Left + 2, .Top + 2, .Right - 1, .Bottom - 1)
    End With
    Call DrawText(hMemDc, sToolTipText, Len(sToolTipText), tTextRect, DT_VCENTER + DT_LEFT)
    Call BitBlt(hDc, tTextRect.Left, tTextRect.Top, tTextRect.Right - tTextRect.Left, _
        tTextRect.Bottom - tTextRect.Top, hMemDc, 0, 0, SRCCOPY)
  
    With tTextRect
        Call SetWindowPos(hToolTip, 0, tCurPos.X + 15, tCurPos.Y + 15, .Right - .Left, .Bottom - .Top, SWP_SHOWWINDOW)
    End With
  
    Call ReleaseDC(hToolTip, hDc)
    Call SelectObject(hMemDc, hPrvBrush)
    Call DeleteObject(hBrush)
    Call DeleteDC(hMemDc)
    Call DeleteObject(hBmp)
    
End Sub

#If Win64 Then
    Private Sub ProcessCommandMsg(ByVal wParam As LongLong)
#Else
    Private Sub ProcessCommandMsg(ByVal wParam As Long)
#End If

    Const LB_GETCURSEL = &H188
    Const LB_GETTEXTLEN = &H18A
    Const LB_GETTEXT = &H189
    Const LB_ERR = (-1)
    Const LBN_SELCHANGE = 1
    Const LBN_DBLCLK = 2

    Static sLBItemText As String
    Static lFirstIndexSelected As Long
  
    Dim sBuffer As String, lRet As Long, lCurSel As Long

    If hiword(wParam) = LBN_DBLCLK Then
        If Me.Value <> "" Then
            If bEventsDisabled = False Then
                RaiseEvent DblClick(Me.Index)
            End If
        End If
    End If
    If hiword(wParam) = LBN_SELCHANGE Then
      lCurSel = SendMessage(hLbx, LB_GETCURSEL, 0, ByVal 0)
      lRet = SendMessage(hLbx, LB_GETTEXTLEN, lCurSel, ByVal 0)
      If lRet <> LB_ERR Then
          sBuffer = Space(lRet) & vbNullChar
          lRet = SendMessage(hLbx, LB_GETTEXT, lCurSel, ByVal sBuffer)
          sLBItemText = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
          If lFirstIndexSelected <> lCurSel Then
              If bEventsDisabled = False And bLoadingList = False Then
                  sLBItemText = Right(sLBItemText, Len(sLBItemText) - 2)
                  RaiseEvent Change(lCurSel)
              End If
          End If
          bLoadingList = False
     End If
     lFirstIndexSelected = lCurSel
    End If

End Sub

Private Sub MonitorErrorsHook(Optional bMonitor As Boolean = True)

    #If Win64 Then
        Dim hHook As LongLong
    #Else
        Dim hHook As Long
    #End If

    Const EVENT_OBJECT_CREATE = &H8000&
    Const WINEVENT_OUTOFCONTEXT = 0&

    If bMonitor Then
        If GetProp(Application.hwnd, "Hook") = 0 Then
            hHook = SetWinEventHook(EVENT_OBJECT_CREATE, EVENT_OBJECT_CREATE, 0&, _
            AddressOf SafeExitHookDelg, 0&, 0&, WINEVENT_OUTOFCONTEXT)
            Call SetProp(Application.hwnd, "Hook", hHook)
        End If
    Else
        Call UnhookWinEvent(GetProp(Application.hwnd, "Hook"))
        Call RemoveProp(Application.hwnd, "Hook")
    End If

End Sub

Private Sub OnError_RemoveAllWindows_Subclass(Optional ByVal Dummy As Boolean)
    Dim i As Long
 
    On Error Resume Next
    If Not oAllClassesObjPtrs Is Nothing Then
        With oAllClassesObjPtrs
            For i = .Count To 1 Step -1
                Call RemoveWindowSubclass(oAllFramesHwnds.Item(i), WinProcAddr, ByVal .Item(i))
            Next i
        End With
    End If
End Sub

Private Sub CleanUp()
    Call OnError_RemoveAllWindows_Subclass
    Call MonitorErrorsHook(False)
    Call SubclassFrame(False)
    Call SinkFrameEnterEvent(False)
    Call DestroyIcon(GetProp(Application.hwnd, "CUR"))
    Call DestroyWindow(hLbx)
    Call RemoveToolTip
    Call RemoveProp(Application.hwnd, "Hook")
    Call RemoveProp(Application.hwnd, "CUR")
    Set oAllClassesObjPtrs = Nothing
    Set oAllFramesHwnds = Nothing
    Set oInterface = Nothing
    Set oFrameCtrl = Nothing
    Set oForm = Nothing
    Debug.Print "unsubclassed + hooks removed + memories & objects released!!!"
End Sub



'_______________________________________________UserForm Mouse Event______________________________________


Private Sub oForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If hToolTip Then
        Call ShowWindow(hToolTip, 0)
    End If
End Sub

2- Interface Class ISecret

Option Explicit

#If Win64 Then
    Public Function FrameWndProc( _
        ByVal hwnd As LongLong, _
        ByVal wMsg As Long, _
        ByVal wParam As LongLong, _
        ByVal lParam As LongLong, _
        ByVal uIdSubclass As Object, _
        ByVal This As LongLong _
    ) As LongLong
#Else
    Public Function FrameWndProc( _
        ByVal hwnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long, _
        ByVal uIdSubclass As Object, _
        ByVal This As Long _
    ) As Long
#End If
'
End Function

#If Win64 Then
    Public Sub SafeExitHook( _
            ByVal HookId As LongLong, _
            ByVal LEvent As Long, _
            ByVal hwnd As LongLong, _
            ByVal idObject As Long, _
            ByVal idChild As Long, _
            ByVal idEventThread As Long, _
            ByVal dwmsEventTime As Long _
        )
#Else
    Public Sub SafeExitHook( _
        ByVal HookId As Long, _
        ByVal LEvent As Long, _
        ByVal hwnd As Long, _
        ByVal idObject As Long, _
        ByVal idChild As Long, _
        ByVal idEventThread As Long, _
        ByVal dwmsEventTime As Long _
            )
#End If

'
End Sub

3- Standard module bas_Delegate

Option Explicit
 
Public oInterface As ISecret
Public oAllClassesObjPtrs As Collection
Public oAllFramesHwnds As Collection


#If Win64 Then
    Public Function WinProcDelg( _
            ByVal hwnd As LongLong, _
            ByVal wMsg As Long, _
            ByVal wParam As LongLong, _
            ByVal lParam As LongLong, _
            ByVal uIdSubclass As Object, _
            ByVal This As LongLong) As LongLong
#Else
    Public Function WinProcDelg( _
            ByVal hwnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByVal uIdSubclass As Object, _
            ByVal This As Long) As Long
#End If

    Set oInterface = uIdSubclass
    WinProcDelg = CallByName(oInterface, "FrameWndProc", VbMethod, hwnd, wMsg, wParam, lParam, uIdSubclass, This)

End Function

#If Win64 Then
    Public Sub SafeExitHookDelg( _
            ByVal HookId As LongLong, _
            ByVal LEvent As Long, _
            ByVal hwnd As LongLong, _
            ByVal idObject As Long, _
            ByVal idChild As Long, _
            ByVal idEventThread As Long, _
            ByVal dwmsEventTime As Long _
        )
#Else
    Public Sub SafeExitHookDelg( _
        ByVal HookId As Long, _
        ByVal LEvent As Long, _
        ByVal hwnd As Long, _
        ByVal idObject As Long, _
        ByVal idChild As Long, _
        ByVal idEventThread As Long, _
        ByVal dwmsEventTime As Long _
            )
#End If

    If Not oInterface Is Nothing Then
        Call CallByName(oInterface, "SafeExitHook", VbMethod, HookId, LEvent, hwnd, idObject, idChild, idEventThread, dwmsEventTime)
    End If


End Sub

#If Win64 Then
    Public Function WinProcAddr() As LongLong
        WinProcAddr = VBA.CLngLng(AddressOf WinProcDelg)
    #Else
    Public Function WinProcAddr() As Long
        WinProcAddr = VBA.CLng(AddressOf WinProcDelg)
    #End If
End Function

4- Test in UserForm Module as per Workbook Example :

Option Explicit

Private WithEvents ListBox1 As CListBox
Private WithEvents ListBox2 As CListBox


Private Sub UserForm_Initialize()
    Call CreateListBox1
    Call CreateListBox2
End Sub


'___________________________________ListBox1 related code_____________________________________
'_____________________________________________________________________________________________

'IMPORTANT NOTICE !!!
'====================
    '/ No errors are allowed inside any of the ListBoxes Event Handlers.
    '/ Any Compile or unhandled runtime errors will crash excel.
    '/ Errors outside the event handlers are taken care of, so that should be ok.
    '/ So be careful with your event coding. You have been warned.


Private Sub CreateListBox1()
    Dim i As Long, k As Long

    Set ListBox1 = New CListBox
    With ListBox1
        .Name = "ListBox1"
        .MultiColor = True
        .TextColor = vbBlue
        .EnableDragNDrop = True
        .HasToolTip = True
        .TabStop = True
        .TabIndex = 0
        For i = 0 To 100 Step 3
            For k = 0 To 2
                If k + i <= 100 Then
                    If k = 0 Then
                        .AddItem "Item:" & CStr(k + i), &HFF80FF
                    ElseIf k = 1 Then
                        .AddItem "Item:" & CStr(k + i), &H80FFFF
                    Else
                        .AddItem "Item:" & CStr(k + i), &HFFFFC0
                    End If
                End If
            Next k
        Next i
        .Left = 45
        .Top = 24
        .Width = 200
        .Height = 150
        .Create Me
        .InsertItem "This is an intrusive [Newly inserted item].", 4
        .InsertItem "This is another intrusive [Newly inserted item].", 9
    End With
    chkDrag1.Value = ListBox1.EnableDragNDrop
    chkEvents1.Value = ListBox1.EnableEvents
  
    Call UpdateLabels(ListBox1)
End Sub


'ListBox1 Events ...
Private Sub ListBox1_OnDrag(ByVal StartDragIdx As Long, ByVal EndDragIdx As Long)
    lblDragging = "Dragging..."
End Sub

Private Sub ListBox1_OnDrop(ByVal StartDragIdx As Long, ByVal EndDragIdx As Long)
    lblDragging = ""
End Sub

Private Sub ListBox1_OnCancelDrag(ByVal StartDragIdx As Long)
    lblDragging = ""
End Sub

Private Sub ListBox1_Change(ByVal ItemIndex As Long)
 Call UpdateLabels(ListBox1)
End Sub

Private Sub ListBox1_VScroll(ByVal Direction As Long)
    Call UpdateLabels(ListBox1)
End Sub

Private Sub ListBox1_MouseMove(ByVal ItemIndex As Long, ByVal X As Single, ByVal Y As Single, ByVal Ctrl As Long)
    With ListBox1
        If .IsActive Then
            lblX = X
            lblY = Y
            If .HasToolTip Then
                .ToolTipText = "This is Item  : " & ItemIndex _
                    & vbNewLine & .GetItemValue(ItemIndex) & vbNewLine & _
                    "@ : " & "XPOS: " & X & " | " & "YPOS: " & Y
            End If
            Call UpdateLabels(ListBox1)
        End If
    End With
End Sub

Private Sub chkDrag1_Change()
    ListBox1.EnableDragNDrop = chkDrag1.Value
End Sub

Private Sub chkEvents1_Change()
    ListBox1.EnableEvents = chkEvents1.Value
End Sub



'___________________________________ListBox2 related code_____________________________________
'_____________________________________________________________________________________________

Private Sub CreateListBox2()
    Dim i As Long
  
    Set ListBox2 = New CListBox
    With ListBox2
        .Name = "ListBox2"
        .EnableDragNDrop = True
        .HasToolTip = True
        .BackColor = &HFFFFC0
        .TextColor = vbBlue
        .TabStop = True
        .TabIndex = 1
        .Left = 45
        .Top = 212
        .Width = 120
        .Height = 100
        For i = 0 To 200
            .AddItem i & Space(1) & Chr(Asc("A") + 26 * Rnd)
        Next i
        .Create Me
        .InsertItem "This is an inserted item.", 4
    End With
    chkDrag2.Value = ListBox2.EnableDragNDrop
    ChkEvents2.Value = ListBox2.EnableEvents
    Call UpdateLabels(ListBox2)
End Sub


'ListBox2 Events ...
Private Sub ListBox2_OnDrag(ByVal StartDragIdx As Long, ByVal EndDragIdx As Long)
    lblDragging = "Dragging..."
End Sub

Private Sub ListBox2_OnDrop(ByVal StartDragIdx As Long, ByVal EndDragIdx As Long)
    lblDragging = ""
End Sub

Private Sub ListBox2_OnCancelDrag(ByVal StartDragIdx As Long)
    lblDragging = ""
End Sub

Private Sub ListBox2_Change(ByVal ItemIndex As Long)
 Call UpdateLabels(ListBox2)
End Sub

Private Sub ListBox2_VScroll(ByVal Direction As Long)
    Call UpdateLabels(ListBox2)
End Sub

Private Sub ListBox2_MouseMove(ByVal ItemIndex As Long, ByVal X As Single, ByVal Y As Single, ByVal Ctrl As Long)
    With ListBox2
        If .IsActive Then
            lblX = X
            lblY = Y
            If .HasToolTip Then
                .ToolTipText = "This is Item  : " & ItemIndex _
                    & vbNewLine & .GetItemValue(ItemIndex) & vbNewLine & _
                    "@ : " & "XPOS: " & X & " | " & "YPOS: " & Y
            End If
            Call UpdateLabels(ListBox2)
        End If
    End With
End Sub

Private Sub chkDrag2_Change()
    ListBox2.EnableDragNDrop = chkDrag2.Value
End Sub

Private Sub chkEvents2_Change()
    ListBox2.EnableEvents = ChkEvents2.Value
End Sub



'___________________________________Common code_____________________________________
'_____________________________________________________________________________________________

Private Sub UpdateLabels(ByVal Lb As CListBox)
    If Lb.IsActive Then
        Me.lblName.Caption = Lb.Name
        With Lb
            lblIndx = .Index
            lblSel = .Value
            lblTpIndx = .TopIndex
            lblDrgLst = .EnableDragNDrop
            lblTTip = .HasToolTip
            lblMClr = .MultiColor
            lblSort = .SortedContent
        End With
    End If
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Regards.

 

[Jaafar Tribak]

Forgot to say that in order to bring up the Tooltip, you need to press the CTRL key while pointing at the ListBox with the mouse.

 

[Tom.Jones]

Jaafar you are amazing.
Fantastic.

 

[Dan_W]

The final result looks good BUT there are two major limitations which I should mention upfront beofre getting too excited.

Too late! I'm already too excited.

I didn't fully appreciate what this is when I first saw that you had posted it the other day. This is what I've been looking for - a working example of how to create a kind of custom control with APIs in VBA. Forever envious of VB6 and the CTL file/usercontrols, I've been trying to write a PictureBox class for use in VBA and looking at how to use CreateWindowEx to bring other controls to VBA users that we assumed we couldn't get access to.

I note your points re: subclassing/limitations, but all the same, this is great - thank you.

 

[Hasson]

@Jaafar Tribak always your work is fantastic !
honestly I face problem when load the userform . it's heavy , I can't test it to tell you how works

 

[Jaafar Tribak]

@Jaafar Tribak always your work is fantastic !
honestly I face problem when load the userform . it's heavy , I can't test it to tell you how works

What vesrion of Windows and excel are you using ?
Thanks.

 

[Hasson]

Win10 64bit 2019 excel

 

[Jaafar Tribak]

honestly I face problem when load the userform . it's heavy , I can't test it to tell you how works

Do you mean that the entire userform doesn't appear on the screen or just that the ListBoxes don't load their respective lists ?

Did you download the workbbok demo from the link I provided or did you copy and paste the code in a fresh workbook ?

 

[Hasson]

Do you mean that the entire userform doesn't appear on the screen or just that the ListBoxes don't load their respective lists ?

no no! it loads userform and show all of the contents of the form but it's too slow . I have to wait much time.

Did you download the workbbok demo from the link I provided

yes

did you copy and paste the code in a fresh workbook ?

infact no . a problem seems from your file I copy and paste the code in a fresh workbook ,now works perfectly.
thanks