module:
Option Explicit' These functions required to set the drop-down width:
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const CB_SETDROPPEDWIDTH = &H160' These are only required if you want to automatically
' calculate the drop-down width:
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 Const DT_CALCRECT = &H400Public Property Let DropDownWidth(ByRef cboThis As ComboBox, ByVal lWidth As Long)
SendMessageLong cboThis.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0
End Property
Public Property Get DropDownWidth(ByRef cboThis As ComboBox) As Long
Dim lW As Long
DropDownWidth = SendMessageLong(cboThis.hwnd, CB_GETDROPPEDWIDTH, 0, 0)
End Property
Public Sub DropDownWidthFromContents(ByRef cboThis As ComboBox, Optional ByVal lMaxWidth = -1)
Dim i As Long
Dim tR As RECT
Dim lW As Long
Dim lWidth As Long
Dim lHDC As Long ' Evaluate the width of each item in the
' combo box:
'Print
' First set the combo's parent form font to the
' combo font:
With cboThis.Parent.Font
.Name = cboThis.Font.Name
.Size = cboThis.Font.Size
.Bold = cboThis.Font.Bold
' Surely you don't have a combo box with
' italic font?
.Italic = cboThis.Font.Italic
End With
' Cache the HDC of the parent form for speed:
lHDC = cboThis.Parent.hdc
'Print
' Loop through each combo box list item & get its
' width, storing the largest:
For i = 0 To cboThis.ListCount - 1
DrawText lHDC, cboThis.List(i), -1, tR, DT_CALCRECT
lW = tR.Right - tR.Left + 8
If (lW > lWidth) Then
lWidth = lW
End If
Next i
'Print
' Don't allow width to exceed specified max
' width, or the width of the screen:
If lMaxWidth <= 0 Then
lMaxWidth = Screen.Width \ Screen.TwipsPerPixelX - 16
End If
If (lWidth > lMaxWidth) Then
lWidth = lMaxWidth
End If
'Print
' Combo box looks a bit strange when the
' drop down portion is smaller than the
' combo box itself:
If (lWidth < cboThis.Width \ Screen.TwipsPerPixelX) Then
lWidth = cboThis.Width \ Screen.TwipsPerPixelX
End If
'Print
' Set the drop down width:
DropDownWidth(cboThis) = lWidth
End Subform:
Option ExplicitPrivate Sub Command1_Click()
Dim sI As String
sI = InputBox("Enter string", , "New item")
If (sI <> "") Then
Combo1.AddItem sI
End If
End SubPrivate Sub Command2_Click()
DropDownWidthFromContents Combo1
Label1.Caption = DropDownWidth(Combo1)
End SubPrivate Sub Command3_Click()
Dim sI As String
sI = InputBox("Enter width", , DropDownWidth(Combo1))
If IsNumeric(sI) Then
DropDownWidth(Combo1) = CLng(sI)
Label1.Caption = DropDownWidth(Combo1)
End If
End SubPrivate Sub Form_Load()
Label1.Caption = DropDownWidth(Combo1)
End Sub
Option Explicit' These functions required to set the drop-down width:
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const CB_SETDROPPEDWIDTH = &H160' These are only required if you want to automatically
' calculate the drop-down width:
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 Const DT_CALCRECT = &H400Public Property Let DropDownWidth(ByRef cboThis As ComboBox, ByVal lWidth As Long)
SendMessageLong cboThis.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0
End Property
Public Property Get DropDownWidth(ByRef cboThis As ComboBox) As Long
Dim lW As Long
DropDownWidth = SendMessageLong(cboThis.hwnd, CB_GETDROPPEDWIDTH, 0, 0)
End Property
Public Sub DropDownWidthFromContents(ByRef cboThis As ComboBox, Optional ByVal lMaxWidth = -1)
Dim i As Long
Dim tR As RECT
Dim lW As Long
Dim lWidth As Long
Dim lHDC As Long ' Evaluate the width of each item in the
' combo box:
' First set the combo's parent form font to the
' combo font:
With cboThis.Parent.Font
.Name = cboThis.Font.Name
.Size = cboThis.Font.Size
.Bold = cboThis.Font.Bold
' Surely you don't have a combo box with
' italic font?
.Italic = cboThis.Font.Italic
End With
' Cache the HDC of the parent form for speed:
lHDC = cboThis.Parent.hdc
' Loop through each combo box list item & get its
' width, storing the largest:
For i = 0 To cboThis.ListCount - 1
DrawText lHDC, cboThis.List(i), -1, tR, DT_CALCRECT
lW = tR.Right - tR.Left + 8
If (lW > lWidth) Then
lWidth = lW
End If
Next i
' Don't allow width to exceed specified max
' width, or the width of the screen:
If lMaxWidth <= 0 Then
lMaxWidth = Screen.Width \ Screen.TwipsPerPixelX - 16
End If
If (lWidth > lMaxWidth) Then
lWidth = lMaxWidth
End If
' Combo box looks a bit strange when the
' drop down portion is smaller than the
' combo box itself:
If (lWidth < cboThis.Width \ Screen.TwipsPerPixelX) Then
lWidth = cboThis.Width \ Screen.TwipsPerPixelX
End If
' Set the drop down width:
DropDownWidth(cboThis) = lWidth
End Subform:
Option ExplicitPrivate Sub Command1_Click()
Dim sI As String
sI = InputBox("Enter string", , "New item")
If (sI <> "") Then
Combo1.AddItem sI
End If
End SubPrivate Sub Command2_Click()
DropDownWidthFromContents Combo1
Label1.Caption = DropDownWidth(Combo1)
End SubPrivate Sub Command3_Click()
Dim sI As String
sI = InputBox("Enter width", , DropDownWidth(Combo1))
If IsNumeric(sI) Then
DropDownWidth(Combo1) = CLng(sI)
Label1.Caption = DropDownWidth(Combo1)
End If
End SubPrivate Sub Form_Load()
Label1.Caption = DropDownWidth(Combo1)
End Sub
解决方案 »
- 有一个VB程序中用到MsFiexGrid,数据绑定后,想在其中编辑
- 关于StretchBlt api函数的速度问题
- 多个窗体在使用中,怎么样写代码只可已让用户点击当前窗体上的内容?其他窗体不可选?
- 如何实现在点击窗口的关闭按钮时,使窗口最小化,而不退出程序?
- 救命啊,关于 vb 中的一个 strconv的bug,如何解决?
- 结贴王请问:最近做共享注册部分,怎样把用户填写的信息在VB里直接发送到我的邮箱?
- 湖南电信实在是太可耻了
- 一个看似简单的问题:关于VB组件封装连接字符串的问题<高手请进>
- LK007(LK007): 请进来拿分!
- 用shell调用一外部exe程序,如何获得该程序的返回值(整型)?
- 字符串的处理。在此先答谢各位。
- 简单问题,你肯定会
还有个问题见:你的邮箱,然后在问题()中通知一下好吗?
还有个问题见:你的邮箱,然后在问题(专家们请注意,我要请教问题在你们的邮箱里。有源程序!Help...)中通知一下好吗?