VB自绘滚动条控件(OCX)

如图：

通俗原理：

V友们都知道VB自带有两个滚动条控件：HScrollBar和VScrollBar，但今天我们来自己"画"一个功能类似的滚动条OCX，以以上原理图为目的，用户设置滚动条最大值和最小值以及滚动值，来回拖动滑块按钮改变滚动值，输出滚动值。控件样式为横向模式，废话少说，直接开干……
启动VB6.0主程序，“添加用户控件"添加一个OCX控件，切换到代码编辑区。
'一、添加必要的API函数：
Option Explicit
'创建一个圆角矩形，该矩形由X1，Y1-X2，Y2确定，并由X3，Y3确定的椭圆描述圆角弧度
Private Declare Function CreateRoundRectRgn Lib “gdi32” (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
'改变窗口的区域
Private Declare Function SetWindowRgn Lib “user32” (ByVal Hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
'用当前选定的画笔画一个圆角矩形，并用当前选定的刷子在其中填充。X3和Y3定义了用于生成圆角的椭圆
Private Declare Function RoundRect Lib “gdi32” (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
'显示文本
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
'用这个函数删除GDI对象，比如画笔、刷子、字体、位图、区域以及调色板等等。对象使用的所有系统资源都会被释放
Private Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As Long
'滑块按钮和文本的位置
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const DT_CENTER = &H1 '文本垂直居中
Private Const DT_VCENTER = &H4 '指示文本对齐格式化矩形的中部
Private Const DT_SINGLELINE = &H20 '只画单行
'用于鼠标移入移出控件范围的API
'获取鼠标指针的当前位置
Private Declare Function GetCursorpos Lib “user32” Alias “GetCursorPos” (lpPoint As POINTAPI) As Long
'获得整个窗口的范围矩形，窗口的边框、标题栏、滚动条及菜单等都在这个矩形内
Private Declare Function GetWindowRect Lib “user32” (ByVal Hwnd As Long, lpRect As RECT) As Long
'判断函数调用时指定虚拟键的状态
Private Declare Function GetAsyncKeyState Lib “user32” (ByVal vKey As Long) As Integer
'鼠标位置
Private Type POINTAPI
x As Long
y As Long
End Type
'---------------------------------------------------------------------------------------------------------------------------------------
'二、添加其他变量及控件事件
Dim WithEvents TimCom1 As Timer '定义判断鼠标事件的计时器
Dim SliderObject As RECT '定义滑块及文本的位置变量
Private Const SR_WIDTH As Long = 30 '滑块的宽度
Dim SR_Min As Double, SR_Max As Double, SR_Value As Double '最小值，最大值，滑动的值
Dim comColor(2) As Long '按钮边框线、背景、字体颜色
Dim Aix As Boolean '鼠标在滑块按钮的颜色切换"通行卡”
Dim Bcolor(9) As Long '滑块边框线和背景颜色（0-1弹起边框线和背景颜色,2-3鼠标经过时边框线和背景颜色，4-5鼠标按下时边框线和背景颜色，6-7控件无效的边框线和背景颜色）
Dim Fcolor(3) As Long '字体颜色（0弹起颜色，1鼠标经过颜色，2鼠标按下颜色，3无效颜色）
Public Event Scroll() '控件输出值事件
'----------------------------------------------------------------------------------------------------------------------------------------
'三、初始化控件及变量参数
Private Sub UserControl_Initialize()
UserControl.AutoRedraw = True: UserControl.ScaleMode = vbPixels
Set TimCom1 = UserControl.Controls.Add(“VB.Timer”, “TimCom1”)
TimCom1.Interval = 1: TimCom1.Enabled = False
Max = 32767
Min = 0
Value = 0
Bcolor(0) = RGB(0, 0, 0): Bcolor(1) = RGB(83, 83, 83): Bcolor(2) = RGB(120, 120, 120): Bcolor(3) = RGB(150, 150, 150): Bcolor(4) = RGB(0, 0, 0): Bcolor(5) = RGB(50, 50, 50): Bcolor(6) = RGB(168, 168, 168): Bcolor(7) = RGB(240, 240, 240)
Bcolor(8) = RGB(125, 125, 125): Bcolor(9) = RGB(222, 222, 222): Fcolor(0) = vbWhite: Fcolor(1) = vbYellow: Fcolor(2) = RGB(255, 100, 0): Fcolor(3) = RGB(100, 100, 100)
Call MoveVilss(Value)
End Sub

Private Sub UserControl_Resize()
If UserControl.Width < (SR_WIDTH * 15) * 2 Then UserControl.Width = (SR_WIDTH * 15) * 2
If UserControl.Height < 255 Then UserControl.Height = 255
Call RoundedCorners
comColor(0) = Bcolor(0): comColor(1) = Bcolor(1): comColor(2) = Fcolor(0)
Call MoveVilss(Value)
End Sub

'控件圆角样式
Private Sub RoundedCorners()
Dim hRgn(2) As Long
hRgn(0) = CreateRoundRectRgn(0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, 3, 3)
hRgn(1) = SetWindowRgn(UserControl.Hwnd, hRgn(0), True)
For hRgn(2) = 0 To 1
Call DeleteObject(hRgn(hRgn(2)))
Next
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------
'四、编写三个核心函数
'1、用户设置 value 的值(输入)
Private Function MoveVilss(ByVal Vworth As Double)
Dim sldScale As Single, SliderObject As RECT, SldPos(1) As Single
If Vworth > Max Then Vworth = SR_Max: Value = SR_Max
sldScale = (UserControl.ScaleWidth - SR_WIDTH) / (SR_Max - SR_Min)
Call SliderPosition(CInt((Vworth - SR_Min) * sldScale))
End Function
'2、滑块按钮改变滚动值(输出)
Private Sub SlidingBlock(ByVal x As Single)
Dim SldPos(1) As Single
Dim sldScale As Double
SldPos(0) = x - SR_WIDTH / 2
SldPos(1) = IIf(x < SR_WIDTH / 2, 0, IIf(x > UserControl.ScaleWidth - SR_WIDTH / 2, UserControl.ScaleWidth - SR_WIDTH, SldPos(0)))
sldScale = (UserControl.ScaleWidth - SR_WIDTH) / (SR_Max - SR_Min)
On Error GoTo Nx
SR_Value = CInt(SldPos(1) / sldScale)
Nx:
Call SliderPosition(SldPos(0))
End Sub
'3、显示滑块和百分比
Private Sub SliderPosition(ByVal Vprice As Double)
Dim SldPos(1) As Single, Rectangle(1) As Long
SliderObject.Left = IIf(Vprice < 1, 1, IIf(Vprice + SR_WIDTH >= UserControl.ScaleWidth, UserControl.ScaleWidth - SR_WIDTH - 2, Vprice))
SliderObject.Top = 2
SliderObject.Right = SliderObject.Left + SR_WIDTH
SliderObject.Bottom = UserControl.ScaleHeight - 2
UserControl.Refresh
UserControl.Cls
UserControl.BackColor = Bcolor(9)
UserControl.FillStyle = 0
UserControl.ForeColor = comColor(0)
UserControl.FillColor = comColor(1)
Rectangle(0) = RoundRect(UserControl.hdc, SliderObject.Left, SliderObject.Top, SliderObject.Right, SliderObject.Bottom, 3, 3)
UserControl.ForeColor = comColor(2)
DrawText UserControl.hdc, CInt(SR_Value / SR_Max * 100) & “%”, -1, SliderObject, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
UserControl.FillStyle = 1
UserControl.ForeColor = Bcolor(8)
Rectangle(1) = RoundRect(UserControl.hdc, 0, 0, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1, 3, 3)
DeleteObject Rectangle(0): DeleteObject Rectangle(1)
RaiseEvent Scroll
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------
'五、处理鼠标事件
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button <> 1 Then Exit Sub
comColor(0) = Bcolor(4): comColor(1) = Bcolor(5): comColor(2) = Fcolor(2)
Call SlidingBlock(x)
Aix = True
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If x > SliderObject.Left And x < SliderObject.Right And y > SliderObject.Top And y < SliderObject.Bottom Then
TimCom1.Enabled = True
If Aix <> True Then comColor(0) = Bcolor(2): comColor(1) = Bcolor(3): comColor(2) = Fcolor(1): Call MoveVilss(Value)
Else
If Aix <> True Then comColor(0) = Bcolor(0): comColor(1) = Bcolor(1): comColor(2) = Fcolor(0): Call MoveVilss(Value)
End If
If Button = 1 Then
comColor(0) = Bcolor(4): comColor(1) = Bcolor(5): comColor(2) = Fcolor(2)
Call SlidingBlock(x)
End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
comColor(0) = Bcolor(0): comColor(1) = Bcolor(1): comColor(2) = Fcolor(0)
Call MoveVilss(Value)
Aix = False
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------
'六、处理鼠标移出控件范围的事件
Private Sub TimCom1_Timer()
Dim rt As RECT, Point As POINTAPI
GetCursorpos Point
GetWindowRect UserControl.Hwnd, rt
If Point.x < rt.Left Or Point.x > rt.Right Or Point.y < rt.Top Or Point.y > rt.Bottom Then
If Aix <> True Then
comColor(0) = Bcolor(0): comColor(1) = Bcolor(1): comColor(2) = Fcolor(0)
Call MoveVilss(Value)
TimCom1.Enabled = False
End If
End If
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------
'七、编写控件各个属性
'最大数值
Public Property Get Max() As Double
Max = SR_Max
End Property

Public Property Let Max(ByVal vNewValue As Double)
SR_Max = vNewValue
PropertyChanged “Max”
End Property

'最小数值
Public Property Get Min() As Double
Min = SR_Min
End Property

Public Property Let Min(ByVal vNewValue As Double)
SR_Min = vNewValue
PropertyChanged “Min”
End Property

'进度值
Public Property Get Value() As Double
Value = SR_Value
End Property

Public Property Let Value(ByVal vNewValue As Double)
SR_Value = vNewValue
Call MoveVilss(vNewValue)
PropertyChanged “Value”
End Property

'控件边框线及背景颜色
Public Property Get BackColor1() As OLE_COLOR
BackColor1 = Bcolor(8)
End Property

Public Property Let BackColor1(ByVal vNewValue As OLE_COLOR)
Bcolor(8) = vNewValue
Call MoveVilss(Value)
PropertyChanged “BackColor1”
End Property

Public Property Get BackColor2() As OLE_COLOR
BackColor2 = Bcolor(9)
End Property

Public Property Let BackColor2(ByVal vNewValue As OLE_COLOR)
Bcolor(9) = vNewValue
Call MoveVilss(Value)
PropertyChanged “BackColor2”
End Property

'滑块按钮边框线颜色
Public Property Get ButColorA1() As OLE_COLOR
ButColorA1 = Bcolor(0)
End Property

Public Property Let ButColorA1(ByVal vNewValue As OLE_COLOR)
Bcolor(0) = vNewValue
comColor(0) = vNewValue
Call MoveVilss(Value)
PropertyChanged “ButColorA1”
End Property

Public Property Get ButColorA2() As OLE_COLOR
ButColorA2 = Bcolor(1)
End Property

Public Property Let ButColorA2(ByVal vNewValue As OLE_COLOR)
Bcolor(1) = vNewValue
comColor(1) = vNewValue
Call MoveVilss(Value)
PropertyChanged “ButColorA2”
End Property

Public Property Get ButColorB1() As OLE_COLOR
ButColorB1 = Bcolor(2)
End Property

Public Property Let ButColorB1(ByVal vNewValue As OLE_COLOR)
Bcolor(2) = vNewValue
PropertyChanged “ButColorB1”
End Property

Public Property Get ButColorB2() As OLE_COLOR
ButColorB2 = Bcolor(3)
End Property

Public Property Let ButColorB2(ByVal vNewValue As OLE_COLOR)
Bcolor(3) = vNewValue
PropertyChanged “ButColorB2”
End Property

Public Property Get ButColorC1() As OLE_COLOR
ButColorC1 = Bcolor(4)
End Property

Public Property Let ButColorC1(ByVal vNewValue As OLE_COLOR)
Bcolor(4) = vNewValue
PropertyChanged “ButColorC1”
End Property

Public Property Get ButColorC2() As OLE_COLOR
ButColorC2 = Bcolor(5)
End Property

Public Property Let ButColorC2(ByVal vNewValue As OLE_COLOR)
Bcolor(5) = vNewValue
PropertyChanged “ButColorC2”
End Property

Public Property Get ButColorD1() As OLE_COLOR
ButColorD1 = Bcolor(6)
End Property

Public Property Let ButColorD1(ByVal vNewValue As OLE_COLOR)
Bcolor(6) = vNewValue
PropertyChanged “ButColorD1”
End Property

Public Property Get ButColorD2() As OLE_COLOR
ButColorD2 = Bcolor(7)
End Property

Public Property Let ButColorD2(ByVal vNewValue As OLE_COLOR)
Bcolor(7) = vNewValue
PropertyChanged “ButColorD2”
End Property

'字体颜色
Public Property Get ForeColor() As OLE_COLOR
ForeColor = Fcolor(0)
End Property

Public Property Let ForeColor(ByVal vNewValue As OLE_COLOR)
Fcolor(0) = vNewValue
comColor(2) = vNewValue
Call MoveVilss(Value)
PropertyChanged “ForeColor”
End Property

Public Property Get ForeColor1() As OLE_COLOR
ForeColor1 = Fcolor(1)
End Property

Public Property Let ForeColor1(ByVal vNewValue As OLE_COLOR)
Fcolor(1) = vNewValue
PropertyChanged “ForeColor1”
End Property

Public Property Get ForeColor2() As OLE_COLOR
ForeColor2 = Fcolor(2)
End Property

Public Property Let ForeColor2(ByVal vNewValue As OLE_COLOR)
Fcolor(2) = vNewValue
PropertyChanged “ForeColor2”
End Property

Public Property Get ForeColor3() As OLE_COLOR
ForeColor3 = Fcolor(3)
End Property

Public Property Let ForeColor3(ByVal vNewValue As OLE_COLOR)
Fcolor(3) = vNewValue
PropertyChanged “ForeColor3”
End Property
'----------------------------------------------------------------------------------------------------------------------------------------
'八、读写各个属性值
'储存属性参数值到内存
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'- - - 按钮背景颜色 - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Call PropBag.WriteProperty(“Max”, SR_Max, 32767)
Call PropBag.WriteProperty(“Min”, SR_Min, 0)
Call PropBag.WriteProperty(“Value”, SR_Value, 0)
Call PropBag.WriteProperty(“BackColor2”, UserControl.BackColor, RGB(255, 255, 255))
Call PropBag.WriteProperty(“ButColorA1”, Bcolor(0), RGB(0, 0, 0))
Call PropBag.WriteProperty(“ButColorA2”, Bcolor(1), RGB(83, 83, 83))
Call PropBag.WriteProperty(“ButColorB1”, Bcolor(2), RGB(120, 120, 120))
Call PropBag.WriteProperty(“ButColorB2”, Bcolor(3), RGB(150, 150, 150))
Call PropBag.WriteProperty(“ButColorC1”, Bcolor(4), RGB(0, 0, 0))
Call PropBag.WriteProperty(“ButColorC2”, Bcolor(5), RGB(50, 50, 50))
Call PropBag.WriteProperty(“ButColorD1”, Bcolor(6), RGB(168, 168, 168))
Call PropBag.WriteProperty(“ButColorD2”, Bcolor(7), RGB(240, 240, 240))
Call PropBag.WriteProperty(“BackColor1”, Bcolor(8), RGB(125, 125, 125))
Call PropBag.WriteProperty(“BackColor2”, Bcolor(9), RGB(222, 222, 222))
'- - - 按钮字体颜色 - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Call PropBag.WriteProperty(“ForeColor”, Fcolor(0), vbWhite)
Call PropBag.WriteProperty(“ForeColor1”, Fcolor(1), vbYellow)
Call PropBag.WriteProperty(“ForeColor2”, Fcolor(2), RGB(100, 255, 0))
Call PropBag.WriteProperty(“ForeColor3”, Fcolor(3), RGB(100, 100, 100))
End Sub

'从内存里读取属性设置值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
'- - - 按钮背景颜色 - - - - - - - - - - - - - - - - - - - - - - - - - - - -
SR_Max = PropBag.ReadProperty(“Max”, 32767)
SR_Min = PropBag.ReadProperty(“Min”, 0)
SR_Value = PropBag.ReadProperty(“Value”, 0)
UserControl.BackColor = PropBag.ReadProperty(“BackColor2”, RGB(255, 255, 255))
Bcolor(0) = PropBag.ReadProperty(“ButColorA1”, RGB(0, 0, 0))
Bcolor(1) = PropBag.ReadProperty(“ButColorA2”, RGB(83, 83, 83))
Bcolor(2) = PropBag.ReadProperty(“ButColorB1”, RGB(120, 120, 120))
Bcolor(3) = PropBag.ReadProperty(“ButColorB2”, RGB(150, 150, 150))
Bcolor(4) = PropBag.ReadProperty(“ButColorC1”, RGB(0, 0, 0))
Bcolor(5) = PropBag.ReadProperty(“ButColorC2”, RGB(50, 50, 50))
Bcolor(6) = PropBag.ReadProperty(“ButColorD1”, RGB(168, 168, 168))
Bcolor(7) = PropBag.ReadProperty(“ButColorD2”, RGB(240, 240, 240))
Bcolor(8) = PropBag.ReadProperty(“BackColor1”, RGB(125, 125, 125))
Bcolor(9) = PropBag.ReadProperty(“BackColor2”, RGB(222, 222, 222))
'- - - 按钮字体颜色 - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Fcolor(0) = PropBag.ReadProperty(“ForeColor”, vbWhite)
Fcolor(1) = PropBag.ReadProperty(“ForeColor1”, vbYellow)
Fcolor(2) = PropBag.ReadProperty(“ForeColor2”, RGB(255, 100, 0))
Fcolor(3) = PropBag.ReadProperty(“ForeColor3”, RGB(100, 100, 100))
comColor(0) = Bcolor(0): comColor(1) = Bcolor(1): comColor(2) = Fcolor(0): Call MoveVilss(Value)
End Sub
'----------------------------------------------------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------------------------------------------------
'到此一个简易的滚动条OCX控件就完成了，至于控件界面美化或更多功能自己改动和研究啦，嘿嘿~~
'转载请标明出处：https://blog.youkuaiyun.com/ty5858?spm=1010.2135.3001.5421