自己作滚动条了。
不过,最后放弃使用滚动条,而以把鼠标滚轮支持放进去了,等会放出完整源码。
包含那个OLE拖放打开文件功能在内。
一个滚动条,增加了程序体积是 16K 。也有点不稳定。不稳定时,表现在拖动滑块时,定位不准确,因为决定不使用滚条,所以就没再去修改。
滚动条的代码在这:
存在的控件,3个按钮,名字分别为:UP , DOWN ,HK
还有一个 Shape,名字就叫 Shape1 ,美观用的
Option Explicit
Const 高度 = 255
'缺省属性值:
Const m_def_Enabled = 1
Const m_def_LargeChange = 1
Const m_def_SmallChange = 1
Const m_def_Value = 0
Const m_def_Min = 0
Const m_def_Max = 0
'属性变量:
Dim m_Enabled As Boolean
Dim m_LargeChange As Long
Dim m_SmallChange As Long
Dim m_Value As Long
Dim m_Min As Long
Dim m_Max As Long
'事件声明:
Event Change()
'拖动用的
Dim Y2 As Long
Dim tdyn As Boolean
Private Sub Down_Click()
Dim i As Long
i = m_Value + m_SmallChange
Call 改变值(i)
End Sub
Private Sub Up_Click()
'
Dim i As Long
i = m_Value - m_SmallChange
Call 改变值(i)
End Sub
Private Sub 改变值(cs As Long, Optional 是否事件 As Boolean = True)
'If cs < m_Min Then
'
    cs = m_Min
'End If
'
'If cs > m_Max Then
'
    cs = m_Max
'End If
'
    m_Value = cs
    
Call 重绘滑块位置(是否事件)
HK.SetFocus
End Sub
Private Sub UserControl_Initialize()
HK.Top = 高度 + 32
'HK.Height = 高度
HK.Left = 0
End Sub
Private Sub HK_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'
If Button And 1 = 1 Then
    tdyn = True
    Y2 = Y
End If
End Sub
Private Sub HK_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
If Button And 1 = 1 Then
    If tdyn Then
        i = Y - Y2 + HK.Top
        If i > 高度 + 32 And i < UserControl.ScaleHeight - 高度 - 32 - HK.Height Then
            HK.Top = i
        End If
    End If
End If
End Sub
Private Sub HK_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
Dim j As Long
Dim o As Double
Dim m As Long
If Button And 1 = 1 Then
    tdyn = False
    i = UserControl.ScaleHeight - 高度 - 高度 - 64 - HK.Height
          '去掉所有的未使用的区域
    j = m_Max - m_Min
           '计算对应多少格
    If j = 0 Then Exit Sub
    o = i / j
                  '每格对应多少坐标
    m = (HK.Top - 高度) / o - 1
        '折算出对应的值
    
    Call 改变值(m)
End If
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Long
If Not m_Enabled Then Exit Sub
If Y < HK.Top Then
    i = m_Value - m_LargeChange
    If i < m_Min Then
        i = m_Min
    End If
        m_Value = i
        
    Call 重绘滑块位置
ElseIf Y > HK.Top Then
    i = m_Value + m_LargeChange
    If i > m_Max Then
        i = m_Max
    End If
        m_Value = i
    Call 重绘滑块位置
End If
End Sub
Private Sub UserControl_Resize()
Up.Height = 高度
Down.Height = 高度
Up.Move 0, 0, UserControl.ScaleWidth, 高度
Down.Move 0, UserControl.ScaleHeight - 高度 - 32, UserControl.ScaleWidth, 高度
HK.Width = UserControl.ScaleWidth - 0
Shape1.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight
End Sub
'注意!不要删除或修改下列被注释的行!
'MemberInfo=8,0,0,0
Public Property Get Min() As Long
    Min = m_Min
End Property
Public Property Let Min(ByVal New_Min As Long)
    m_Min = New_Min
    PropertyChanged "Min"
    Call 重绘滑块大小
    Call 重绘滑块位置(False)
End Property
'注意!不要删除或修改下列被注释的行!
'MemberInfo=8,0,0,0
Public Property Get Max() As Long
    Max = m_Max
End Property
Public Property Let Max(ByVal New_Max As Long)
    m_Max = New_Max
    PropertyChanged "Max"
    Call 重绘滑块大小
    Call 重绘滑块位置(False)
End Property
'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_Min = m_def_Min
    m_Max = m_def_Max
    m_Value = m_def_Value
    m_LargeChange = m_def_LargeChange
    m_SmallChange = m_def_SmallChange
    m_Enabled = m_def_Enabled
End Sub
'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_Min = PropBag.ReadProperty("Min", m_def_Min)
    m_Max = PropBag.ReadProperty("Max", m_def_Max)
    m_Value = PropBag.ReadProperty("Value", m_def_Value)
    m_LargeChange = PropBag.ReadProperty("LargeChange", m_def_LargeChange)
    m_SmallChange = PropBag.ReadProperty("SmallChange", m_def_SmallChange)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    
    Call 重绘滑块大小
    Up.Enabled = m_Enabled
    Down.Enabled = m_Enabled
    HK.Enabled = m_Enabled
End Sub
'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
    Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
    Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
    Call PropBag.WriteProperty("LargeChange", m_LargeChange, m_def_LargeChange)
    Call PropBag.WriteProperty("SmallChange", m_SmallChange, m_def_SmallChange)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
End Sub
Private Sub 重绘滑块大小()
        
    Dim i As Long
    Dim j As Long
    Dim m As Long
    
    i = UserControl.ScaleHeight - 高度 - 高度 - 64
           '去掉所有的未使用的区域
    j = m_Max - m_Min + 1
         '计算对应多少格
    If j = 0 Then
        HK.Height = i
        HK.Top = 高度 + 32
    Else
        m = i / j
        If m < 高度 Then
            m = 高度
        End If
        HK.Height = m
    End If
End Sub
'注意!不要删除或修改下列被注释的行!
'MemberInfo=8,0,0,0
Public Property Get Value() As Long
    Value = m_Value
End Property
Public Property Let Value(ByVal New_Value As Long)
    m_Value = New_Value
    PropertyChanged "Value"
    Call 重绘滑块位置
End Property
'注意!不要删除或修改下列被注释的行!
'MemberInfo=8,0,0,1
Public Property Get LargeChange() As Long
    LargeChange = m_LargeChange
End Property
Public Property Let LargeChange(ByVal New_LargeChange As Long)
    m_LargeChange = New_LargeChange
    PropertyChanged "LargeChange"
End Property
'注意!不要删除或修改下列被注释的行!
'MemberInfo=8,0,0,1
Public Property Get SmallChange() As Long
    SmallChange = m_SmallChange
End Property
Public Property Let SmallChange(ByVal New_SmallChange As Long)
    m_SmallChange = New_SmallChange
    PropertyChanged "SmallChange"
End Property
Private Sub 重绘滑块位置(Optional 是否事件 As Boolean = True)
'
Dim i As Long
Dim j As Long
Dim o As Single
Dim m As Long
    
    If m_Value < m_Min Then m_Value = m_Min
    If m_Value > m_Max Then m_Value = m_Max
    i = UserControl.ScaleHeight - 高度 - 高度 - 64 - HK.Height
          '去掉所有的未使用的区域
    j = m_Max - m_Min
           '计算对应多少格
    If j = 0 Then Exit Sub
    o = i / j
                  '每格对应多少坐标
    HK.Top = o * m_Value + 高度 + 32
If 是否事件 Then
    HK.SetFocus
    RaiseEvent Change
End If
End Sub
'注意!不要删除或修改下列被注释的行!
'MemberInfo=0,0,0,0
Public Property Get Enabled() As Boolean
    Enabled = m_Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    PropertyChanged "Enabled"
    
    Up.Enabled = m_Enabled
    Down.Enabled = m_Enabled
    HK.Enabled = m_Enabled
End Property
找到错误的地方了,重新修正了代码。
竖滚动条。范围是 long
[[it] 本帖最后由 风吹过b 于 2008-10-16 21:51 编辑 [/it]]