Option Explicit
Private Const LB_SETTABSTOPS As Long = &H192
Private Const WM_GETFONT = &H31
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type SIZE
cx As Long
cy 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetDialogBaseUnits Lib "user32" () As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpString As String, ByVal cbString As Long, lpSize As SIZE) 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 SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Sub Form_Load()
List1.AddItem vbTab & "123"
End Sub
Private Sub Command1_Click()
Dim hwndLB As Long
Dim rc As RECT
ReDim tabarray(0 To 0) As Long
hwndLB = List1.hWnd
Call GetClientRect(hwndLB, rc)
tabarray(0) = -((rc.Right - rc.Left) / CalcPixelsPerDlgUnit(hwndLB))
Call SendMessage(List1.hWnd, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(List1.hWnd, LB_SETTABSTOPS, 1&, tabarray(0))
List1.Refresh
End Sub
Private Function CalcPixelsPerDlgUnit(hwndLB As Long) As Single
Dim hFont As Long
Dim hFontOld As Long
Dim hDC As Long
Dim sz As SIZE
Dim cxAvLBChar As Long
Dim cxDlgBase As Long
Const sChars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
hDC = GetDC(hwndLB)
If hDC Then
hFont = SendMessage(hwndLB, WM_GETFONT, 0, ByVal 0&)
hFontOld = SelectObject(hDC, hFont)
If GetTextExtentPoint32(hDC, sChars, Len(sChars), sz) Then
cxAvLBChar = sz.cx / Len(sChars)
cxDlgBase = GetDialogBaseUnits And &HFFFF&
CalcPixelsPerDlgUnit = (2 * cxAvLBChar) / cxDlgBase
End If
Call SelectObject(hDC, hFontOld)
Call ReleaseDC(hwndLB, hDC)
End If
End Function
