[RaggiTech]

كاتب الموضوع : أحمد جمال

من المعروف انه افتراضياً ما تحتوي أداة ListBox على اشرطة طولية عند زيادة عدد العناصر ، ولكن في حالة زيادة عرض العنصر فإنه لا يظهر لديك شريط عرضي للتحرك ، هذا الكود للقيام بذلك .

في قسم التصريحات :

كود :

Option Explicit
Private Declare Function SendMessageByNum Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const LB_SETHORIZONTALEXTENT = &H194

وفي الوظيفة التي تقوم بهذه المهمة :

كود :

Public Sub AddHorizontalScrollToLB(LB As Object)
'PURPOSE: ADDS HORIZONTAL SCROLL BAR
'TO LIST BOX
'LOGIC: ATTEMPTS TO DETERMINE
'IF SCROLL BOX IS NECESSARY, BASED
'ON WIDTH OF ITEMS IN LIST AND
'SCALE MODE OF THE CONTAINER
'IF THIS CANNOT BE DETERMINED,
'IT GOES AHEAD AND ADDS THE
'SCROLL BAR ANYWAY
'USAGE: JUST CALL
'AddHorizontalScrollToLB lstMyListBox
'WHERE lstMyListBox is the name of
'the list box to
'add the scroll bar to
Dim sngTextWidth As Single
Dim sngPixelWidth As Single
Dim lCount As Long, lCtr As Long

On Error GoTo ErrorHandler
'Determine if we can calculate
'pixelwidth.
sngPixelWidth = ControlWidthInPixels(LB)

If sngPixelWidth <> 0 Then
lCount = LB.ListCount
For lCtr = 0 To lCount - 1

'if using this function in a form rather
'than a bas or class module,
'change to me.textwidth
'as there's no guarantee lb.parent
'supports textwidth property

sngTextWidth = LB.Parent.TextWidth(LB.List(lCtr) _
& " ")
If sngTextWidth > LB.Width Then
SendMessageByNum LB.hwnd, _
LB_SETHORIZONTALEXTENT, sngPixelWidth + 1, 0
Exit For
End If
Next
Else
SendMessageByNum LB.hwnd, LB_SETHORIZONTALEXTENT, _
100000000, 0
End If

ErrorHandler:
Exit Sub

End Sub
Private Function CharactersPerPixelX() As Single
CharactersPerPixelX = Format _
(Screen.TwipsPerPixelX / 120, "######.####")
End Function
Private Function PointsPerPixelX() As Single
PointsPerPixelX = InchesPerPixelX * 72
End Function
Private Function InchesPerPixelX() As Single
Dim sngAns As Single
sngAns = Screen.TwipsPerPixelX / 1440
InchesPerPixelX = Format(sngAns, "#.#####")
End Function
Private Function CentimetersPerPixelX() As Single
Dim sngAns As Single
sngAns = Screen.TwipsPerPixelX / 567
CentimetersPerPixelX = Format(sngAns, "#.#####")
End Function
Private Function MillimetersPerPixelX() As Single
MillimetersPerPixelX = CentimetersPerPixelX * 10
End Function
Private Function ControlWidthInPixels(ctl As Object) As Single
Dim oTest As Object
Dim iScaleMode As Integer
Dim sngWidth As Single
Dim sngAns As Single
sngAns = 0
On Error Resume Next
Set oTest = ctl.Parent
iScaleMode = oTest.ScaleMode
sngWidth = ctl.Width

If Err.Number <> 0 Then Exit Function
Err.Clear
On Error GoTo 0
Select Case iScaleMode
Case vbTwips
sngAns = sngWidth / Screen.TwipsPerPixelX
Case vbInches
sngAns = sngWidth / InchesPerPixelX
Case vbCentimeters
sngAns = sngWidth / CentimetersPerPixelX
Case vbMillimeters
sngAns = sngWidth / MillimetersPerPixelX
Case vbPoints
sngAns = sngWidth / PointsPerPixelX
Case vbCharacters
sngAns = sngWidth / CharactersPerPixelX
Case vbPixels
sngAns = sngWidth

End Select
'format ans to 4 decimal places
If sngAns <> 0 Then
ControlWidthInPixels = Format _
(sngAns, "#########.####")
End If
End Function