Set TabStops on a ListBox control in VBA Excel - excel

Question

I first came onto that post here by Randy Birch about listing clipboard formats. As you can see, he is using Visual Basic 6 and also a .Refresh method on List1 after sending the LB_SETTABSTOPS messages to the WNDPROC handling the window corresponding to his "List1" ListBox
Since the .Refresh method is not available in VBA (and also the .Hwnd, but that is less a problem withing this post by C. PEARSON and Private Declare Function GetFocus Lib "user32" () As Long), I tried to 'mimic' it.
Apparently, the .Refresh method invalidates the whole client area of the ListBox Window, and then sends a WM_PAINT message to the WNDPROC bypassing any other pending messages in message queue, causing an immediate repaint of the update region, which should be the entire visible "List1" ListBox in this particular case.
My config :
Debug.Print Application.Version
Debug.Print Application.VBE.Version
Debug.Print Application.OperatingSystem
#If VBA6 Then
Debug.Print "VBA6 = True"
#Else
Debug.Print "VBA6 = False"
#End If
#If VBA7 Then
Debug.Print "VBA7 = True"
#Else
Debug.Print "VBA7 = False"
#End If
Results in:
16.0
7.01
Windows (32-bit) NT 10.00
VBA6 = True
VBA7 = True
Now my attempt #1 :
Option Explicit
Private Const LB_SETTABSTOPS As Long = &H192
Private Const EM_SETTABSTOPS As Long = &HCB
Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4
Private Const RDW_ERASENOW = &H200
Private Const RDW_FRAME = &H400
Private Const RDW_INTERNALPAINT = &H2
Private Const RDW_INVALIDATE = &H1
Private Const RDW_NOCHILDREN = &H40
Private Const RDW_NOERASE = &H20
Private Const RDW_NOFRAME = &H800
Private Const RDW_NOINTERNALPAINT = &H10
Private Const RDW_UPDATENOW = &H100
Private Const RDW_VALIDATE = &H8
Private hWndList1 As Long
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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, lParam As Any) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hWnd As LongPtr) As Boolean
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef lpRect As Rect) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, ByRef lprcUpdate As Rect, ByVal hrgnUpdate As Long, Optional ByVal flags As Integer) As Boolean
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect, ByVal bErase As Boolean) As Long
Private Declare Function GetUpdateRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect, ByVal bErase As Boolean) As Boolean
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect) As Boolean
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (ByRef lpRect As Rect) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Sub UserForm_Initialize()
Dim ListWindowUpdated As Boolean
Dim ListWindowRedrawn As Boolean
ReDim TabStop(0 To 1) As Long
TabStop(0) = 90
TabStop(1) = 130
With List1
.Clear
.SetFocus
hWndList1 = GetFocus
Call SendMessage(hWndList1, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(hWndList1, LB_SETTABSTOPS, 2, TabStop(0))
Dim rectList1 As Rect
Call GetWindowRect(hWndList1, rectList1)
Dim lprcList1 As Long
lprcList1 = VarPtrArray(rectList1)
ListWindowRedrawn = RedrawWindow(hWndList1, rectList1, lprcList1, RDW_INVALIDATE)
ListWindowRedrawn = RedrawWindow(hWndList1, rectList1, 0, RDW_INVALIDATE)
MsgBox "ListWindowRedrawn = " & ListWindowRedrawn & " and RDW_INVALIDATE message sent"
'Call RedrawWindowAny(hWndForm2, vbNull, 1&, RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_ALLCHILDREN)
ListWindowUpdated = UpdateWindow(hWndList1)
MsgBox "ListWindowUpdated = " & ListWindowUpdated
End With
End Sub
My attempt #2 :
Dim ScreenRect As Rect
Dim hClientRect As Long
hClientRect = GetClientRect(hWndList1), ScreenRect)
Dim udtScrDim As Rect
Dim lReturn As Long
Dim hRegion As Long
udtScrDim.Left = 0
udtScrDim.Top = 0
udtScrDim.Right = ScreenRect.Right - ScreenRect.Left
MsgBox "Screen width = " & ScreenRect.Right - ScreenRect.Left
udtScrDim.Bottom = ScreenRect.Bottom - ScreenRect.Top
MsgBox "Screen height = " & ScreenRect.Bottom - ScreenRect.Top
hRegion = CreateRectRgnIndirect(udtScrDim)
If hRegion <> 0 Then
lReturn = RedrawWindow(0, udtScrDim, hRegion, RDW_ERASE Or RDW_FRAME Or RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_INTERNALPAINT Or RDW_ALLCHILDREN)
End If
After many attemps, I still can't get the client area to be updated with the custom tabstop positions. But the attempt #1 above still seems to be the more logical to me. It works fine, no errors, but nothing changes, any item (containing vbTab) in the ListBox won't be affected, even with a later UserForm1.Repaint.
Please help :)

Answer 1

This is not quite an answer but more a workaround :
My understanding of the problem (and of Randy Birch) :
The only explaination is that the VBA Listbox control simply can't deal with LB_SETTABSTOPS messages. Indeed I also tried sending the LB_SETTABSTOPS message later, but it's still ignored. Same thing with the invalidate message and WM_PAINT.
That might be why the Office devs implemented the .ColumnWidth property in VBA Excel which can do exactly the same things that what I was trying to do above.