Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,807
- Office Version
- 2016
- Platform
- Windows
Hi all,
I have been looking for ways to overcome the weaknesses of the native Excel Data Validation lists and to make such DV lists more versatile by adding often sought functionalities sunch as the following:
A- Not being affected by the current worksheet zoom (specially when the worksheet zoom is too small, the DV list become zoomed too and its items can become hardly viewable)
B- MouseWheel support
C- Support for different fonts ,Font size , Font color, Background Color and Frame color.
D- Adjustable size and Width of the list.
E- Ability to sort the list items.
Download Workbook demo
Project code.
1- Add a new Class Module to your project, give it the name of CustomDVList_Class and place the following code in it :
2- Add a Standard Module and place the following code in it:
3- Code usage in a Standard Module : (As per the workbook demo in the link)
I have written this project code in Excel2010 64-bit Win10 64-bit but I have also designed it to work in 32-bit systems although I haven't tested it on any 32-bit platform.
This was a good learning exercise. I just hope the code works accross different systems.
Regards.
I have been looking for ways to overcome the weaknesses of the native Excel Data Validation lists and to make such DV lists more versatile by adding often sought functionalities sunch as the following:
A- Not being affected by the current worksheet zoom (specially when the worksheet zoom is too small, the DV list become zoomed too and its items can become hardly viewable)
B- MouseWheel support
C- Support for different fonts ,Font size , Font color, Background Color and Frame color.
D- Adjustable size and Width of the list.
E- Ability to sort the list items.
Download Workbook demo
Project code.
1- Add a new Class Module to your project, give it the name of CustomDVList_Class and place the following code in it :
Code:
Option Explicit
Private WithEvents wb As Workbook
Private WithEvents cmbrs1 As CommandBars
Private WithEvents cmbrs2 As CommandBars
Private oCol As New Collection
Private Sub Class_Initialize()
Set wb = ThisWorkbook
Set cmbrs1 = Application.CommandBars
Set cmbrs2 = Application.CommandBars
Call cmbrs1_OnUpdate
Call cmbrs2_OnUpdate
End Sub
Private Sub Class_Terminate()
Set wb = Nothing
Set cmbrs1 = Nothing
Set cmbrs2 = Nothing
Set oCol = Nothing
End Sub
Public Sub AddList( _
ByVal DVCell As Range, _
Optional ByVal ListWidth As Long, _
Optional ByVal ListHeight As Long, _
Optional ByVal ListFontName As String, _
Optional ByVal ListFontSize As Long, _
Optional ByVal ListFontColor As Long, _
Optional ByVal ListBackColor As Long, _
Optional ByVal ListFrameColor As Long, _
Optional ByVal SortList As Boolean _
)
Dim lValidationType As XlDVType
With DVCell
On Error Resume Next
lValidationType = .Validation.Type
On Error GoTo 0
If lValidationType <> xlValidateList Or .Cells.Count > 1 Then MsgBox "Too many cells or no DV list.": Exit Sub
.Validation.InCellDropdown = False
.ID = .Address & "*" & ListWidth & "*" & ListHeight & "*" _
& ListFontName & "*" & ListFontSize & "*" & ListFontColor & "*" & ListBackColor & "*" _
& ListFrameColor & "*" & SortList & "*" & .Parent.Name & "*" & "CurrentDVButton"
End With
oCol.Add DVCell
Call cmbrs1_OnUpdate
Call cmbrs2_OnUpdate
End Sub
Public Sub RemoveList(ByVal DVCell As Range)
On Error Resume Next
With DVCell
If Len(.ID) > 0 Then
Worksheets(.Parent.Name).Shapes(Split(.ID, "*")(10)).Delete
.ID = ""
.Validation.InCellDropdown = True
End If
End With
End Sub
Public Sub RemoveALLLists()
Dim i As Long
On Error Resume Next
With oCol
For i = 1 To .Count
Worksheets(Range(.Item(1).Address).Parent.Name).Shapes(Split(Range(.Item(1).Address).ID, "*")(10)).Delete
Range(.Item(1).Address).ID = ""
Range(.Item(1).Address).Validation.InCellDropdown = True
.Remove 1
Next
End With
End Sub
Private Sub cmbrs1_OnUpdate()
Static sArray() As String
Set cmbrs1 = Nothing
With ActiveCell
If Len(.ID) > 0 Then
sArray = Split(.ID, "*")
AttachDVList ActiveCell, sArray(1), sArray(2), sArray(3), sArray(4), _
sArray(5), sArray(6), sArray(7), sArray(8)
Else
On Error Resume Next
Worksheets(Range(sArray(0)).Parent.Name).Shapes("CurrentDVButton").Delete
End If
End With
End Sub
Private Sub cmbrs2_OnUpdate()
Call AdjustButtonPos
End Sub
Private Sub wb_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Set cmbrs1 = Application.CommandBars
Set cmbrs2 = Application.CommandBars
End Sub2- Add a Standard Module and place the following code in it:
Code:
Option Explicit
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 KeyboardBytes
kbByte(0 To 255) As Byte
End Type
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Type MSG
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
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 DrawMenuBar Lib "User32.dll" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CreateWindowEx Lib "User32.dll" 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 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 SendMessage Lib "User32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal s As Long, ByVal c As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As LongPtr
Private Declare PtrSafe Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator 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 SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
temps As Long
pt As POINTAPI
End Type
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) 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 DrawMenuBar Lib "User32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "User32.dll" 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 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 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 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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal s As Long, ByVal c As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_HSCROLL = &H100000
Private Const WS_VSCROLL = &H200000
Private Const LBS_HASSTRINGS = &H40&
Private Const LBS_WANTKEYBOARDINPUT = &H400&
Private Const LBS_NOINTEGRALHEIGHT = &H100&
Private Const LBS_SORT = &H2&
Private Const LB_Styles = _
(LBS_HASSTRINGS Or WS_CHILD _
Or WS_VISIBLE Or WS_VSCROLL Or WS_HSCROLL Or LBS_WANTKEYBOARDINPUT Or LBS_NOINTEGRALHEIGHT)
Private Const LB_GETCURSEL = &H188
Private Const LB_ADDSTRING = &H180
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_SETCURSEL = &H186
Private Const LB_ITEMFROMPOINT As Long = &H1A9
Private Const LB_GETITEMHEIGHT = &H1A1
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_SETTOPINDEX = &H197
Private Const LB_GETCOUNT = &H18B
Private Const GWL_STYLE = -16
Private Const GWL_WNDPROC = (-4)
Private Const WM_CTLCOLORLISTBOX = &H134
Private Const WM_SETCURSOR = &H20
Private Const WM_KEYDOWN = &H100
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_SETFONT = &H30
Private Const WM_SYSCOMMAND = &H112
Private Const WM_DESTROY = &H2
Private Const WS_CAPTION = &HC00000
Private Const SWP_NOMOVE = &H2
Private Const SWP_SHOWWINDOW = &H40
Private Const TRANSPARENT = 1
Private Const POINTSPERINCH = 72
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const ROLE_SYSTEM_SCROLLBAR = 3
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private hLBParent As LongPtr, hLb As LongPtr
Private lPrevParentProc As LongPtr, lPrevXLProc As LongPtr
Private hScrDC As LongPtr, hFont As LongPtr
Private hFrameBrush As LongPtr, hBckBrush As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private hLBParent As Long, hLb As Long
Private lPrevParentProc As Long, lPrevXLProc As Long
Private hScrDC As Long, hFont As Long
Private hFrameBrush As Long, hBckBrush As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private tLBParentRect As RECT
Private kbArray As KeyboardBytes
Private oTargetCell As Range
Private oDVListRange As Range
Private oDropButton As Shape
Private lBckColor As Long, lFrameColor As Long, lListWidth As Long, lListHeight As Long
Private lSortList As Long, lTextColor As Long, lFontSize As Long, sFontName As String
Private OprevRowHeight As Single
Private OprevcolumnWidth As Single
Private sLBtextBuffer As String
Private sListSourceSheetName As String
Private bFlag As Boolean
Private bListShowing As Boolean
[COLOR=#008000]'Public Routines ...
'===============[/COLOR]
Public Sub AttachDVList(ByVal DVLCell As Range, _
Optional ByVal ListWidth As Long, _
Optional ByVal ListHeight As Long, _
Optional ByVal FontName As String, _
Optional ByVal FontSize As Long, _
Optional ByVal TextColor As Long, _
Optional ByVal BckColor As Long, _
Optional ByVal FrameColor As Long, _
Optional ByVal SortList As Boolean _
)
On Error Resume Next
lBckColor = BckColor: lFrameColor = FrameColor: lListWidth = ListWidth
lListHeight = ListHeight: lTextColor = TextColor: lSortList = SortList
sFontName = FontName: lFontSize = FontSize
Set oTargetCell = DVLCell
With DVLCell
If Not oDropButton Is Nothing Then oDropButton.Delete
Set oDVListRange = Range(Range(Evaluate(.Validation.Formula1).Address).Address)
sListSourceSheetName = Replace(Left(.Validation.Formula1, InStr(.Validation.Formula1, "!") - 1), "=", "")
If Err.Number = 5 Then sListSourceSheetName = ActiveSheet.Name
On Error GoTo 0
.Validation.InCellDropdown = False
Set oDropButton = .Parent.Shapes.AddFormControl _
(xlButtonControl, .Left + .Width + 2, .Offset(1).Top - 14.25, 15.28, 14.25)
End With
With oDropButton
If DVLCell.RowHeight < 14.25 Then .Height = DVLCell.RowHeight: .Top = DVLCell.Top
.Name = "CurrentDVButton"
.OLEFormat.Object.Font.Name = "Wingdings 3"
.OLEFormat.Object.Caption = Chr(128)
oDropButton.Placement = xlMove
oDropButton.AlternativeText = DVLCell.Address
.OnAction = "OnActionRoutine"
End With
OprevRowHeight = DVLCell.EntireRow.Height
OprevcolumnWidth = DVLCell.EntireColumn.Width
End Sub
Public Sub AdjustButtonPos()
If Not oTargetCell Is Nothing Then
If OprevRowHeight <> oTargetCell.EntireRow.Height Or OprevcolumnWidth <> oTargetCell.EntireColumn.Width Then
bListShowing = False
Call AttachDVList(oTargetCell, _
lListWidth, _
lListHeight, _
sFontName, _
lFontSize, _
lTextColor, _
lBckColor, _
lFrameColor, _
lSortList _
)
End If
End If
End Sub
Public Sub CleanUp(Optional ByVal UpdateDVCell As Boolean, Optional ByVal Closing As Boolean)
Dim ws As Worksheet
On Error Resume Next
Call SetWindowLong(Application.hwnd, GWL_WNDPROC, lPrevXLProc)
bFlag = True
bListShowing = False
If Closing Then
For Each ws In ThisWorkbook.Worksheets
Range(ws.Shapes("CurrentDVButton").AlternativeText).Validation.InCellDropdown = True
ws.Shapes("CurrentDVButton").Delete
Next
End If
DeleteObject hFont
DeleteObject hBckBrush
DeleteObject hFrameBrush
ReleaseDC 0, hScrDC
kbArray.kbByte(vbKeyLButton) = 0
SetKeyboardState kbArray
DestroyWindow hLBParent
Application.Cursor = xlDefault
InvalidateRect hLBParent, tLBParentRect, 0
If UpdateDVCell Then ActiveCell = sLBtextBuffer
End Sub
[COLOR=#008000]'Private Routines ...
'================[/COLOR]
Private Sub OnActionRoutine()
If bListShowing = False Then
Call ShowDVList(oTargetCell, ListWidth:=lListWidth, ListHeight:=lListHeight, FontName:=sFontName, FontSize:=lFontSize, _
TextColor:=lTextColor, BckColor:=lBckColor, FrameColor:=lFrameColor, SortList:=lSortList)
Else
Call CleanUp
End If
End Sub
Private Sub ShowDVList(ByVal DVLCell As Range, _
Optional ByVal ListWidth As Long, _
Optional ByVal ListHeight As Long, _
Optional ByVal FontName As String, _
Optional ByVal FontSize As Long, _
Optional ByVal TextColor As Long, _
Optional ByVal BckColor As Long, _
Optional ByVal FrameColor As Long, _
Optional ByVal SortList As Boolean, _
Optional ByVal Add As Boolean _
)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Dim lStyle As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Dim lStyle As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Dim tAdjusredRect As RECT
Dim tPnt As POINTAPI
Dim tMsg As MSG
Dim oCell As Range
Dim ItemHeight As Long
Dim lAdjustedHeight As Long
Dim lItemsCount As Long
Dim lSearchIndex As Long
Dim i As Long
Dim bUpdateCell As Boolean
If DVLCell.Cells.Count > 1 Then Exit Sub
On Error GoTo Xit
bListShowing = True
bFlag = False
Application.EnableCancelKey = xlErrorHandler
With GetRangeRect(DVLCell)
lListWidth = IIf(ListWidth = 0, .Right - .Left, ListWidth)
lListHeight = IIf(ListHeight = 0, 150, ListHeight)
End With
sFontName = IIf(Len(FontName) = 0, "Calibri", FontName)
lFontSize = IIf(FontSize = 0, 12, FontSize)
lTextColor = IIf(TextColor = 0, vbBlack, TextColor)
lBckColor = IIf(BckColor = 0, vbWhite, BckColor)
lFrameColor = IIf(FrameColor = 0, vbBlack, FrameColor)
lSortList = IIf(SortList, LBS_SORT, 0)
With GetRangeRect(DVLCell.Offset(1))
hLBParent = CreateWindowEx(0, "static", "", WS_VISIBLE, .Right - (.Right - .Left), .Top, _
lListWidth, lListHeight, 0, 0, 0, ByVal 0)
End With
lStyle = GetWindowLong(hLBParent, GWL_STYLE)
lStyle = lStyle And (Not WS_CAPTION)
SetWindowLong hLBParent, GWL_STYLE, lStyle
DrawMenuBar hLBParent
GetWindowRect hLBParent, tLBParentRect
With tLBParentRect
hLb = CreateWindowEx(0, "ListBox", "", LB_Styles Or lSortList, 0, 0, _
.Right + 1 - .Left - 1, .Bottom + 1 - .Top - 1, hLBParent, 0, 0, ByVal 0)
lPrevParentProc = SetWindowLong(hLBParent, GWL_WNDPROC, AddressOf WinProc)
If lPrevXLProc <> 0 Then Call SetWindowLong(Application.hwnd, GWL_WNDPROC, lPrevXLProc)
lPrevXLProc = SetWindowLong(Application.hwnd, GWL_WNDPROC, AddressOf AppWinProc)
hScrDC = GetDC(0)
hFont = CreateFont(-MulDiv(lFontSize, GetDeviceCaps(hScrDC, LOGPIXELSY), POINTSPERINCH), _
0, 0, 0, 40, False, False, False, 1, 0, 0, 2, 0, sFontName)
Call SendMessage(hLb, WM_SETFONT, hFont, 0)
hFrameBrush = CreateSolidBrush(lFrameColor)
hBckBrush = CreateSolidBrush(lBckColor)
For Each oCell In Worksheets(sListSourceSheetName).Range(oDVListRange.Address).Cells
SendMessage hLb, LB_ADDSTRING, 0, ByVal CStr(oCell.Value)
Next oCell
lSearchIndex = SendMessage(hLb, LB_FINDSTRINGEXACT, 0, ByVal (CStr(DVLCell.Value)))
SendMessage hLb, LB_SETCURSEL, lSearchIndex, 0
SendMessage hLb, LB_SETTOPINDEX, ByVal IIf(lSearchIndex = -1, 0, lSearchIndex), 0
lItemsCount = SendMessage(hLb, LB_GETCOUNT, 0, 0)
ItemHeight = SendMessage(hLb, LB_GETITEMHEIGHT, 0, 0)
lAdjustedHeight = IIf(.Bottom - .Top > lItemsCount * (ItemHeight), lItemsCount * (ItemHeight), .Bottom - .Top)
SetWindowPos hLBParent, 0, 0, 0, lListWidth, lAdjustedHeight, SWP_NOMOVE + SWP_SHOWWINDOW
SetWindowPos hLb, 0, 0, 0, lListWidth, lAdjustedHeight, SWP_NOMOVE + SWP_SHOWWINDOW
tAdjusredRect.Left = .Left - 2
tAdjusredRect.Top = .Top - 2
tAdjusredRect.Right = .Left + lListWidth + 2
tAdjusredRect.Bottom = .Top + lAdjustedHeight + 1 + 2
End With
SetFocus hLb
GetKeyboardState kbArray
kbArray.kbByte(vbKeyLButton) = 0
SetKeyboardState kbArray
Do While GetMessage(tMsg, 0, 0, 0)
If GetFocus <> hLb Then Exit Do
If bFlag = True Then bUpdateCell = True: Exit Do
DoEvents
TranslateMessage tMsg
DispatchMessage tMsg
GetCursorPos tPnt
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 And Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, tPnt, LenB(tPnt)
If WindowFromPoint(lngPtr) <> hLb And GetKeyState(vbKeyLButton) = 1 Then Exit Do
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
If WindowFromPoint(tPnt.x, tPnt.y) <> hLb And GetKeyState(vbKeyLButton) = 1 Then Exit Do
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
If tMsg.message = WM_KEYDOWN Then
If GetAsyncKeyState(vbKeyEscape) Then Call CleanUp: Exit Sub
If GetAsyncKeyState(vbKeyReturn) Then Call CleanUp(True): Exit Sub
End If
Call FrameRect(hScrDC, tAdjusredRect, hFrameBrush)
kbArray.kbByte(vbKeyLButton) = 0
SetKeyboardState kbArray
Loop
Xit:
If Err.Number = 91 Then
ActiveSheet.Shapes("CurrentDVButton").Delete
Else
Call CleanUp(bUpdateCell)
End If
End Sub
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Function WinProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim loword As LongPtr, hiword As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Function WinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim loword As Long, hiword As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Dim tPt As POINTAPI
Dim oIA As IAccessible
Dim vKid As Variant
Dim lResult As Long
Dim index As Long
Dim lIndex As Long
Dim lRet As Long
On Error Resume Next
If Application.Cursor <> xlNorthwestArrow Then Application.Cursor = xlNorthwestArrow
lIndex = SendMessage(hLb, LB_GETCURSEL, 0, 0)
lRet = SendMessage(hLb, LB_GETTEXTLEN, lIndex, ByVal 0)
sLBtextBuffer = Space(lRet) & vbNullChar
lRet = SendMessage(hLb, LB_GETTEXT, lIndex, ByVal sLBtextBuffer)
GetCursorPos tPt
Select Case uMsg
Case WM_CTLCOLORLISTBOX
SetBkMode wParam, TRANSPARENT
SetTextColor wParam, lTextColor
WinProc = hBckBrush
Exit Function
Case WM_DESTROY
Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevParentProc)
Case WM_SETCURSOR
SetFocus hLb
GetHiLoword lParam, loword, hiword
If wParam = hLb Then
If hiword = WM_MOUSEMOVE Then
ScreenToClient hLb, tPt
index = SendMessage( _
wParam, LB_ITEMFROMPOINT, 0, ByVal ((tPt.x And &HFF) Or (&H10000 * (tPt.y And &HFF))))
If lIndex <> index Then SendMessage wParam, LB_SETCURSEL, index, 0
End If
End If
If hiword = WM_LBUTTONDOWN Then
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 And Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, tPt, LenB(tPt)
lResult = AccessibleObjectFromPoint(lngPtr, oIA, vKid)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
lResult = AccessibleObjectFromPoint(tPt.x, tPt.y, oIA, vKid)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
If oIA.accRole(0&) <> ROLE_SYSTEM_SCROLLBAR Then bFlag = True
End If
End Select
WinProc = CallWindowProc(lPrevParentProc, hwnd, uMsg, wParam, lParam)
End Function
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Function AppWinProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Function AppWinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
If uMsg = WM_SYSCOMMAND Then
bFlag = True
Exit Function
End If
AppWinProc = CallWindowProc(lPrevXLProc, hwnd, uMsg, wParam, lParam)
End Function
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Sub GetHiLoword(lParam As LongPtr, ByRef loword As LongPtr, ByRef hiword As LongPtr)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Sub GetHiLoword(lParam As Long, ByRef loword As Long, ByRef hiword As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
loword = lParam And &HFFFF&
hiword = lParam \ &H10000 And &HFFFF&
End Sub
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDC
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function GetRangeRect(ByVal TargetRange As Range) As RECT
Dim OWnd As Window
Set OWnd = TargetRange.Parent.Parent.Windows(1)
With TargetRange
GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
+ OWnd.PointsToScreenPixelsX(0)
GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
+ OWnd.PointsToScreenPixelsY(0)
GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
+ GetRangeRect.Left
GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
+ GetRangeRect.Top
End With
End Function3- Code usage in a Standard Module : (As per the workbook demo in the link)
Code:
Option Explicit
Dim DVList As New CustomDVList_Class
Sub CheckBoxesMacro()
With Sheet1.Shapes(Application.Caller)
Select Case True
Case .Name = "CheckBox1"
Sheet1.Range("E10").Select
If .ControlFormat.Value = 1 Then
DVList.AddList Sheet1.Range("E10"), 300, 500, "Blackadder ITC", 28, vbBlack, vbWhite, vbRed, True
Else
DVList.RemoveList Sheet1.Range("E10")
End If
Case .Name = "CheckBox2"
Sheet1.Range("I10").Select
If .ControlFormat.Value = 1 Then
DVList.AddList Sheet1.Range("I10"), 100, 200, "Old English Text MT", 20, vbGreen, vbMagenta, vbBlue, False
Else
DVList.RemoveList Sheet1.Range("I10")
End If
Case .Name = "CheckBox3"
Sheet1.Range("M10").Select
If .ControlFormat.Value = 1 Then
DVList.AddList Sheet1.Range("M10"), 0, 500, "calibri", 12, vbWhite, vbMagenta, vbGreen, False
Else
DVList.RemoveList Sheet1.Range("M10")
End If
End Select
End With
End Sub
Sub ResetAllDataValidations()
Dim i As Long
If Not DVList Is Nothing Then DVList.RemoveALLLists
If ThisWorkbook.Saved = False Then
With Sheet1
For i = 1 To 3
.Shapes("CheckBox" & i).ControlFormat.Value = 0
Next i
End With
Call CleanUp
End If
Sheet1.Range("E10").Select
End SubI have written this project code in Excel2010 64-bit Win10 64-bit but I have also designed it to work in 32-bit systems although I haven't tested it on any 32-bit platform.
This was a good learning exercise. I just hope the code works accross different systems.
Regards.
