Question

我第一次看到Randy Birch关于列出剪贴板格式的帖子here。正如您所看到的，在将LB_SETTABSTOPS消息发送到处理与其“List1”ListBox相对应的窗口的WNDPROC之后，他正在使用Visual Basic 6以及List1上的.Refresh方法

由于.Refresh方法在VBA中不可用（以及.Hwnd，但这对于this post by C. PEARSON和Private Declare Function GetFocus Lib "user32" () As Long来说不是一个问题），我试图“模仿”它。

Apparently，.Refresh方法使ListBox窗口的整个客户区无效，然后向WNDPROC发送WM_PAINT消息，绕过消息队列中的任何其他待处理消息，立即重新绘制更新区域，在这种特殊情况下应该是整个可见的“List1”ListBox。

我的配置：

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

经过多次尝试后，我仍无法使用自定义tabstop位置更新客户区。但是上面的尝试＃1似乎对我来说更合乎逻辑。它工作正常，没有错误，但没有任何变化，ListBox中的任何项目（包含vbTab）都不会受到影响，即使使用较晚的UserForm1.Repaint。

请帮助：）

Answer 1

这不是一个答案，而是更多的解决方法：

我对这个问题的理解（以及Randy Birch）：

唯一的解释是VBA Listbox控件根本无法处理LB_SETTABSTOPS消息。实际上我也尝试过稍后发送LB_SETTABSTOPS消息，但它仍然被忽略了。与invalidate消息和WM_PAINT相同。

这可能是Office开发人员在VBA Excel中实现.ColumnWidth属性的原因，它可以完成与我上面尝试的完全相同的事情。

在VBA Excel中的ListBox控件上设置TabStops

1 个答案: