AUTRE PETITE FAQ

Option Explicit

'Augmente la taille de la barre de défilement horizontal d'une listbox
'si la longueur de texte des éléments ajoutés est plus long que certains éléments

'http://vbnet.mvps.org/index.html?code/core/sendmessage.htm

Private Const LB_GETHORIZONTALEXTENT = &H193
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const DT_CALCRECT = &H400
Private Const SM_CXVSCROLL = 2

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function DrawText Lib "user32" _
   Alias "DrawTextA" _
  (ByVal hDC As Long, _
   ByVal lpStr As String, _
   ByVal nCount As Long, _
   lpRect As RECT, ByVal _
   wFormat As Long) As Long
   
Private Declare Function GetSystemMetrics Lib "user32" _
  (ByVal nIndex As Long) As Long

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 Sub Form_Load()

   Call AddItemToList(List1, "Ministry of Agriculture and Food")
   Call AddItemToList(List1, "Ministry of the Attorney General")
   Call AddItemToList(List1, "Ministry of Community, City and Social Services")
   Call AddItemToList(List1, "Ministry of Education")
   Call AddItemToList(List1, "Ministry of the Environment")
   Call AddItemToList(List1, "Ministry of Health and Long-Term Care")
   Call AddItemToList(List1, "Ministry of Housing")
 
End Sub


Private Sub Command1_Click()

   Dim newIndex As Long
   
   newIndex = AddItemToList(List1, Text1.Text)
   
  'an 'EnsureVisible' method for the listbox
   List1.TopIndex = newIndex
   Label1.Caption = "Item " & newIndex & " added"
   
End Sub


Private Sub List1_Click()

   Text1.Text = List1.List(List1.ListIndex)
   
End Sub


Private Function AddItemToList(ctl As Control, _
                               sNewItem As String, _
                               Optional dwNewItemData As Variant) As Long

   Dim c As Long
   Dim rcText As RECT
   Dim newWidth As Long
   Dim currWidth As Long
   Dim sysScrollWidth As Long
   
   Dim tmpFontName As String
   Dim tmpFontSize As Long
   Dim tmpFontBold As Boolean
   
  'get the current width used
   If Len(ctl.Tag) > 0 Then
      currWidth = CLng(ctl.Tag)
   End If
   
  'determine the needed width for the new item
  'save the font properties to tmp variables
   tmpFontName = FAQ2.Font.Name
   tmpFontSize = FAQ2.Font.Size
   tmpFontBold = FAQ2.Font.Bold
   
   FAQ2.Font.Name = List1.Font.Name
   FAQ2.Font.Size = List1.Font.Size
   FAQ2.Font.Bold = List1.Font.Bold
   
  'get the width of the system scrollbar
   sysScrollWidth = GetSystemMetrics(SM_CXVSCROLL)
   
  'use DrawText/DT_CALCRECT to determine item length
   Call DrawText(FAQ2.hDC, sNewItem, -1&, rcText, DT_CALCRECT)
   newWidth = rcText.Right + sysScrollWidth
   
  'if this is wider than the current setting,
  'tweak the list and save the new horizontal
  'extent to the tag property
   If newWidth > currWidth Then
      
      Call SendMessage(List1.hwnd, _
                       LB_SETHORIZONTALEXTENT, _
                       newWidth, _
                       ByVal 0&)
                       
      ctl.Tag = newWidth
      
   End If
   
  'restore the form font properties
   FAQ2.Font.Name = tmpFontName
   FAQ2.Font.Bold = tmpFontBold
   FAQ2.Font.Size = tmpFontSize
   
  'add the items to the control, and
  'add the ItemData if supplied
   ctl.AddItem sNewItem
   
   If Not IsMissing(dwNewItemData) Then
      If IsNumeric(dwNewItemData) Then
         ctl.ItemData(ctl.newIndex) = dwNewItemData
      End If
   End If
   
  'return the new index as the function result
   AddItemToList = ctl.newIndex

End Function

Télécharger le zip

03 juillet 2006 07:22:21 :

Si vous connaissez bien VB, je suis sûr qu'il n'y aura aucun blème quant au contenu du projet.