Установить TabStops в элементе управления ListBox в VBA Excel

Question

Я впервые пришел на этот пост here от Randy Birch о перечислении форматов буфера обмена. Как вы можете видеть, он использует Visual Basic 6, а также метод .Refresh в List1 после отправки сообщений LB_SETTABSTOPS в WNDPROC, обрабатывающих окно, соответствующее его «List1» ListBox

Поскольку метод .Refresh недоступен в VBA (а также .Hwnd, но это меньше проблемы с this post by C. PEARSON и Private Declare Function GetFocus Lib "user32"() As Long), я попытался «имитировать» его.

Apparently, метод .refresh аннулирует всю клиентскую область окна ListBox, а затем посылает сообщение WM_PAINT в WndProc, обходя любые другие ожидающие сообщения в очереди сообщений, вызывая немедленную перерисовку региона обновления, которое должно быть весь видимый ListBox List1 в данном конкретном случае.

Мой конфиг:

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 

Результаты в:

16.0 
7.01 
Windows (32-bit) NT 10.00 
VBA6 = True 
VBA7 = True 

Теперь моя попытка # 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 

Моя попытка # 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 

После многих попыток, я все еще не могу обновить клиентскую область с помощью настраиваемых позиций таблоста. Но попытка № 1 выше все же кажется более логичной для меня. Он работает нормально, никаких ошибок, но ничего не меняется, ни один элемент (содержащий vbTab) в ListBox не будет затронут, даже с более поздним UserForm1.Repaint.

Пожалуйста, помогите :)

Answer 1

Это не совсем ответ, но более обходной путь:

Мое понимание этой проблемы (и Randy Birch):

Единственное объяснений является то, что VBA Элемент управления Listbox просто не может обрабатывать сообщения LB_SETTABSTOPS. Действительно, я также попытался отправить сообщение LB_SETTABSTOPS позже, но он по-прежнему игнорируется. То же самое с сообщением invalidate и WM_PAINT.

Возможно, именно поэтому разработчики Office внедрили свойство .ColumnWidth в VBA Excel, которое может делать то же самое, что и то, что я пытался сделать выше.