[VBnet List API] GetTextExtentPoint32: Right-Align List Box Data


	Visual Basic List API GetTextExtentPoint32: Right-Align List Box Data

Posted:	Monday October 01, 2001
Updated:	Monday December 26, 2011

Applies to:	VB4-32, VB5, VB6
Developed with:	VB6, Windows XP
OS restrictions:	None
Author:	VBnet - Randy Birch

Related:	VBnet CoolTabs GetTextExtentPoint32: Right-Align List Box Data SetWindowLong: Right-Align List Box Data and/or the Scrollbar SetWindowLong: Right-Align List Contents in a Combo SendMessage: Align Text Box Contents Using Tabstops SendMessage: Align List Box Contents Using Tabstops WM_LBUTTONDOWN: Substitute a Tabbed List for a Combo's Dropdown List WM_LBUTTONDOWN: Substitute a ListView for a Combo's Dropdown List

Prerequisites

None.

A recent newsgroup request was for code that would create a right-aligned column of numbers in a list box. I knew that setting a tabstop value to a negative number caused the listbox to right-align at that point, so the only obstacle was determining exactly where that right margin was, since the internal measurement of a listbox is dialog units, not twips or pixels. The routine added below, provided to VBnet by Brad Martinez as an update to the original CalcPixelsPerDlgUnit method posted October 1, calculates where the list's right margin is based on the current listbox font.

The code shown is for a list of single items-per-line, as opposed to a listing of multiple pieces of data per line. To allow the list items to become right-aligned, data added to the list must be prefaced with a vbTab.

This code lends itself to a more dynamic adjustment by placing the appropriate calls in the form resize event to execute whenever the listbox changes width. Remember too that if you are using a static-width control (as opposed to one you resize with the form), the tabstops only need to be set once upon form load. Subsequent items added to the list, even after a .Clear command, will still utilize the tabstops set until another SendMessage call is made to change the settings.

BAS Module Code

None.

Form Code

To the form, add the following code:

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

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"
   List1.AddItem vbTab & "123456"
   List1.AddItem vbTab & "123456789"
   List1.AddItem vbTab & "123456789012"
   List1.AddItem vbTab & "123456789012345"
   List1.AddItem vbTab & "123456789012345678"
   List1.AddItem vbTab & "123456789012345678901"

End Sub


Private Sub Command1_Click()

   Dim hwndLB As Long
   Dim rc As RECT
   ReDim tabarray(0 To 0) As Long
   
  'Assign list handle to a variable.
  'A good rule of thumb is if you are
  'using a property more than three
  'times in a routine, it becomes more
  'efficient to assign and use a variable
  'rather than re-reference the property.
   hwndLB = List1.hWnd
   Call GetClientRect(hwndLB, rc)
  
  'calculate the tab to align with
  'the right-most edge. 
   tabarray(0) = -((rc.Right - rc.Left) / CalcPixelsPerDlgUnit(hwndLB))
   
  'Clear any existing tabs and set the
  'new tabstop
   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

  'Returns the number of pixels-per-dialog
  'unit for the given font.
  '
  'Provided to VBnet by Brad Martinez

   Dim hFont As Long
   Dim hFontOld As Long
   Dim hDC As Long
   Dim sz As SIZE
   Dim cxAvLBChar As Long   'average LB char width, in pixels
   Dim cxDlgBase As Long    'horizontal dialog box base units
   Const sChars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"

  'get the device contect of the listbox
   hDC = GetDC(hwndLB)
  
   If hDC Then
   
     'select hwndLB's HFONT into its DC (VB
     'does not select a control's Font into its DC)
      hFont = SendMessage(hwndLB, WM_GETFONT, 0, ByVal 0&)
      hFontOld = SelectObject(hDC, hFont)
    
      If GetTextExtentPoint32(hDC, sChars, Len(sChars), sz) Then
    
       'get the list box average char width
       'and the system's horizontal dialog
       'base units
        cxAvLBChar = sz.cx / Len(sChars)
        cxDlgBase = GetDialogBaseUnits And &HFFFF&
    
        'calculate and return the number of
        'pixels per dialog unit for the list
         CalcPixelsPerDlgUnit = (2 * cxAvLBChar) / cxDlgBase
         
      End If
    
      Call SelectObject(hDC, hFontOld)
      Call ReleaseDC(hwndLB, hDC)
    
  End If
  
End Function

Comments

PayPal Link