UID 1 精华 积分 76361 威望 点
宅币 个
贡献 次
宅之契约 份
最后登录 1970-1-1
在线时间 小时
VERSION 5.00 Begin VB.UserControl Knob ClientHeight = 2415 ClientLeft = 0 ClientTop = 0 ClientWidth = 2430 ScaleHeight = 161 ScaleMode = 3 'Pixel ScaleWidth = 162 Begin VB.PictureBox picKnob Align = 1 'Align Top AutoRedraw = -1 'True Height = 1335 Left = 0 ScaleHeight = 85 ScaleMode = 3 'Pixel ScaleWidth = 158 TabIndex = 0 Top = 0 Width = 2430 Begin VB.PictureBox picBase AutoRedraw = -1 'True BorderStyle = 0 'None Height = 495 Left = 0 ScaleHeight = 33 ScaleMode = 3 'Pixel ScaleWidth = 33 TabIndex = 1 Top = 0 Visible = 0 'False Width = 495 End End End Attribute VB_Name = "Knob" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '============================================================================== '作者：0xAA55 '论坛：[url]http://www.0xaa55.com/[/url] '版权所有 (C) 2013-2015 技术宅的结界 '请保留原作者信息，否则视为侵权。 '------------------------------------------------------------------------------ Option Explicit Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const Knob_PI As Double = 3.14159265358979 Private m_Rad As Double Private m_Max As Long Private m_Value As Long Private m_Steps As Long Private m_MaxAng As Double Private m_MinAng As Double Private m_MouseDown As Boolean Private m_MouseAngle As Double Private m_BaseRad As Double Private m_HandleRad As Double Private m_DrawGrad As Boolean Private m_DrawPoint As Boolean Private m_DrawRaisedHandle As Boolean Private m_RaisedHandleWidth1 As Double Private m_RaisedHandleWidth2 As Double Event Click() Attribute Click.VB_Description = "Triggerd when clicked." Attribute Click.VB_UserMemId = -600 Event DblClick() Attribute DblClick.VB_Description = "Triggerd when double clicked." Attribute DblClick.VB_UserMemId = -601 Event Change(ByVal OldValue As Long, ByVal NewValue As Long) Attribute Change.VB_Description = "Triggerd when the value was changed." Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Attribute MouseMove.VB_UserMemId = -606 Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Attribute MouseUp.VB_UserMemId = -607 Event KeyDown(KeyCode As Integer, Shift As Integer) Attribute KeyDown.VB_UserMemId = -602 Event KeyPress(KeyAscii As Integer) Attribute KeyPress.VB_UserMemId = -603 Event KeyUp(KeyCode As Integer, Shift As Integer) Attribute KeyUp.VB_UserMemId = -604 '绘制旋钮 Private Sub DrawKnob() DrawBaseCircle '先绘制底座圆圈 DrawHandle '然后绘制“把手” End Sub '绘制圆圈底座 Private Sub DrawBaseCircle() If m_Rad <= 0 Then Exit Sub '用picBase来存住底座圆圈的图像 picBase.Cls If m_DrawGrad Then '画刻度 picBase.DrawWidth = 1 Dim Ang As Long For Ang = 0 To m_Steps - 1 Dim CA As Double, CX As Double, CY As Double CA = m_MinAng + (m_MaxAng - m_MinAng) * Ang / (m_Steps - 1) + Knob_PI * 0.5 '刻度的角度 CX = Cos(CA) CY = Sin(CA) picBase.Line (m_Rad + CX * m_Rad * m_BaseRad, m_Rad + CY * m_Rad * m_BaseRad)-(m_Rad + CX * m_Rad, m_Rad + CY * m_Rad) '画辐射线 Next End If '画底座 picBase.DrawWidth = 3 DrawLightedCircle picBase, m_Rad, m_Rad, m_Rad * m_BaseRad - 1, GetSysColor(vb3DHighlight And &HFF&), GetSysColor(vb3DDKShadow And &HFF&) picBase.DrawWidth = 2 DrawLightedCircle picBase, m_Rad, m_Rad, m_Rad * m_BaseRad - 3, GetSysColor(vb3DLight And &HFF&), GetSysColor(vbButtonShadow And &HFF&) End Sub '绘制带光照处理的圆圈 Private Sub DrawLightedCircle(Targ As PictureBox, ByVal X As Double, ByVal Y As Double, ByVal Radius As Double, ByVal Color1 As Long, ByVal Color2 As Long) Dim Ang As Double Dim R1 As Long, G1 As Long, B1 As Long Dim R2 As Long, G2 As Long, B2 As Long Dim DotVal As Double, XV As Double, YV As Double, RV As Long, GV As Long, BV As Long '画笔的开始位置 Targ.CurrentX = X + Radius Targ.CurrentY = Y '颜色1 R1 = Color1 And &HFF G1 = (Color1 And &HFF00&) \ &H100 B1 = (Color1 And &HFF0000) \ &H10000 '颜色2 R2 = Color2 And &HFF G2 = (Color2 And &HFF00&) \ &H100 B2 = (Color2 And &HFF0000) \ &H10000 '以像素为单位画一圈 For Ang = 0 To Knob_PI * 2 Step 1 / Radius XV = Cos(Ang) YV = Sin(Ang) DotVal = (XV + YV + 1) * 0.5 '与光线方向(1,1)做点乘，然后将[-1,1]变换到[0,1] RV = R1 + (R2 - R1) * DotVal '颜色插值 GV = G1 + (G2 - G1) * DotVal BV = B1 + (B2 - B1) * DotVal Targ.Line -(X + XV * Radius, Y + YV * Radius), RGB(RV, GV, BV) Next End Sub Private Sub DrawLighedLine(Targ As PictureBox, ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, ByVal Color1 As Long, ByVal Color2 As Long) On Error Resume Next Dim DirX As Double, DirY As Double, DirL As Double DirX = X2 - X1 DirY = Y2 - Y1 DirL = Sqr(DirX * DirX + DirY * DirY) DirX = DirX / DirL DirY = DirY / DirL Dim NorX As Double, NorY As Double NorX = -DirY NorY = DirX Dim R1 As Long, G1 As Long, B1 As Long Dim R2 As Long, G2 As Long, B2 As Long Dim DotVal As Double, RV As Long, GV As Long, BV As Long '颜色1 R1 = Color1 And &HFF G1 = (Color1 And &HFF00&) \ &H100 B1 = (Color1 And &HFF0000) \ &H10000 '颜色2 R2 = Color2 And &HFF G2 = (Color2 And &HFF00&) \ &H100 B2 = (Color2 And &HFF0000) \ &H10000 DotVal = (NorX + NorY + 1) * 0.5 '与光线方向(1,1)做点乘，然后将[-1,1]变换到[0,1] RV = R1 + (R2 - R1) * DotVal '颜色插值 GV = G1 + (G2 - G1) * DotVal BV = B1 + (B2 - B1) * DotVal Targ.DrawWidth = 2 Targ.Line (X1, Y1)-(X2, Y2), RGB(RV, GV, BV) End Sub '画“把手” Private Sub DrawHandle() If m_Rad <= 0 Then Exit Sub Dim Ang As Double Ang = ValueToAngle(m_Value, m_Max) '旋钮的角度 '先把画好的底座盖上去 picKnob.PaintPicture picBase.Image, 0, 0 '画凸起的把手 If m_DrawRaisedHandle Then DrawRHandle '画小圆点 If m_DrawPoint Then picKnob.DrawWidth = 1 If m_MouseDown Then '鼠标按下的时候，填充颜色 picKnob.FillStyle = vbSolid picKnob.FillColor = vbHighlight Else picKnob.FillStyle = 1 End If picKnob.Circle (m_Rad + Cos(Ang) * m_Rad * m_BaseRad * 0.5, m_Rad + Sin(Ang) * m_Rad * m_BaseRad * 0.5), 2, vbRed End If End Sub '画凸起的把手 Private Sub DrawRHandle() picKnob.DrawWidth = 2 Dim Ang As Double Ang = ValueToAngle(m_Value, m_Max) '旋钮的角度 Dim BaseRad As Double BaseRad = m_Rad * m_BaseRad * m_HandleRad '正向 Dim DirX As Double, DirY As Double DirX = Cos(Ang) DirY = Sin(Ang) '侧向 Dim SideX As Double, SideY As Double SideX = -DirY SideY = DirX Dim RHW1 As Double, RHW2 As Double RHW1 = m_RaisedHandleWidth1 * BaseRad RHW2 = m_RaisedHandleWidth2 * BaseRad Dim BackL As Double, FrontL As Double FrontL = Sqr(BaseRad * BaseRad - RHW1 * RHW1) BackL = Sqr(BaseRad * BaseRad - RHW2 * RHW2) Dim Color1 As Long, Color2 As Long Color1 = GetSysColor(vb3DHighlight And &HFF&) Color2 = GetSysColor(vb3DDKShadow And &HFF&) Dim PtX(3) As Double Dim PtY(3) As Double PtX(0) = m_Rad + DirX * FrontL + SideX * RHW1 PtY(0) = m_Rad + DirY * FrontL + SideY * RHW1 PtX(1) = m_Rad + DirX * FrontL - SideX * RHW1 PtY(1) = m_Rad + DirY * FrontL - SideY * RHW1 PtX(2) = m_Rad - DirX * BackL + SideX * RHW2 PtY(2) = m_Rad - DirY * BackL + SideY * RHW2 PtX(3) = m_Rad - DirX * BackL - SideX * RHW2 PtY(3) = m_Rad - DirY * BackL - SideY * RHW2 DrawLighedLine picKnob, PtX(0), PtY(0), PtX(1), PtY(1), Color1, Color2 DrawLighedLine picKnob, PtX(1), PtY(1), PtX(3), PtY(3), Color1, Color2 DrawLighedLine picKnob, PtX(3), PtY(3), PtX(2), PtY(2), Color1, Color2 DrawLighedLine picKnob, PtX(2), PtY(2), PtX(0), PtY(0), Color1, Color2 End Sub '将数值转换为用于显示的角度值 Private Function ValueToAngle(ByVal Value_ As Long, ByVal MaxValue_ As Long) As Double If MaxValue_ Then ValueToAngle = m_MinAng + (m_MaxAng - m_MinAng) * Value_ / MaxValue_ + Knob_PI * 0.5 End Function '将角度值转换为数值 Private Function AngleToValue(ByVal Angle As Double) As Long If m_MaxAng = 0 Then Exit Function Angle = Angle - Knob_PI * 0.5 While Angle < 0 Angle = Angle + Knob_PI * 2 Wend While Angle > Knob_PI * 2 Angle = Angle - Knob_PI * 2 Wend AngleToValue = (Angle - m_MinAng) * m_Max / (m_MaxAng - m_MinAng) End Function '控件改变大小，重建底座图 Private Sub picBase_Resize() DrawBaseCircle End Sub '鼠标单击操作 Private Sub picKnob_Click() RaiseEvent Click End Sub '鼠标双击操作 Private Sub picKnob_DblClick() RaiseEvent DblClick End Sub '键盘按下操作 Private Sub picKnob_KeyDown(KeyCode As Integer, Shift As Integer) RaiseEvent KeyDown(KeyCode, Shift) End Sub '键盘打字操作 Private Sub picKnob_KeyPress(KeyAscii As Integer) RaiseEvent KeyPress(KeyAscii) End Sub '键盘弹起操作 Private Sub picKnob_KeyUp(KeyCode As Integer, Shift As Integer) RaiseEvent KeyUp(KeyCode, Shift) End Sub '鼠标按下操作 Private Sub picKnob_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) m_MouseDown = True m_MouseAngle = GetAngle(X - m_Rad, Y - m_Rad) - ValueToAngle(m_Value, m_Max) DrawHandle RaiseEvent MouseDown(Button, Shift, X, Y) End Sub '鼠标移动操作 Private Sub picKnob_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If m_MouseDown Then Dim NewAng As Double, OldVal As Long NewAng = GetAngle(X - m_Rad, Y - m_Rad) - m_MouseAngle OldVal = m_Value m_Value = AngleToValue(NewAng) If m_Value > m_Max Then m_Value = m_Max If m_Value < 0 Then m_Value = 0 picKnob.ToolTipText = m_Value DrawHandle RaiseEvent MouseMove(Button, Shift, X, Y) If OldVal <> m_Value Then RaiseEvent Change(OldVal, m_Value) m_MouseAngle = GetAngle(X - m_Rad, Y - m_Rad) - ValueToAngle(m_Value, m_Max) ElseIf m_Value = 0 Or m_Value = m_Max Then m_MouseAngle = GetAngle(X - m_Rad, Y - m_Rad) - ValueToAngle(m_Value, m_Max) End If End If End Sub '鼠标松开操作 Private Sub picKnob_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) m_MouseDown = False DrawHandle RaiseEvent MouseUp(Button, Shift, X, Y) End Sub Private Sub picKnob_Resize() picBase.Move 0, 0, picKnob.ScaleWidth, picKnob.ScaleHeight DrawHandle End Sub '控件初始化 Private Sub UserControl_Initialize() UserControl_Resize End Sub Private Sub UserControl_InitProperties() m_Max = 100 m_Value = 100 m_Steps = 3 m_BaseRad = 0.75 m_HandleRad = 0.8 m_MinAng = Knob_PI / 3 m_MaxAng = Knob_PI * 5 / 3 m_DrawGrad = True m_DrawPoint = True m_DrawRaisedHandle = True m_RaisedHandleWidth1 = 0.3 m_RaisedHandleWidth2 = 0.3 End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) m_Max = PropBag.ReadProperty("Max", m_Max) m_Value = PropBag.ReadProperty("Value", m_Value) m_Steps = PropBag.ReadProperty("Steps", m_Steps) m_BaseRad = PropBag.ReadProperty("BaseRadius", m_BaseRad) m_HandleRad = PropBag.ReadProperty("HandleRadius", m_HandleRad) m_MinAng = PropBag.ReadProperty("MinAngle", m_MinAng) m_MaxAng = PropBag.ReadProperty("MaxAngle", m_MaxAng) m_DrawGrad = PropBag.ReadProperty("DrawGraduation", m_DrawGrad) m_DrawPoint = PropBag.ReadProperty("DrawPoint", m_DrawPoint) m_DrawRaisedHandle = PropBag.ReadProperty("DrawRaisedHandle", m_DrawRaisedHandle) m_RaisedHandleWidth1 = PropBag.ReadProperty("RaisedHandleWidth1", m_RaisedHandleWidth1) m_RaisedHandleWidth2 = PropBag.ReadProperty("RaisedHandleWidth2", m_RaisedHandleWidth2) picKnob.BorderStyle = PropBag.ReadProperty("BorderStyle", picKnob.BorderStyle) m_Rad = picKnob.ScaleHeight \ 2 DrawKnob End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) PropBag.WriteProperty "Max", m_Max PropBag.WriteProperty "Value", m_Value PropBag.WriteProperty "Steps", m_Steps PropBag.WriteProperty "BaseRadius", m_BaseRad PropBag.WriteProperty "HandleRadius", m_HandleRad PropBag.WriteProperty "MinAngle", m_MinAng PropBag.WriteProperty "MaxAngle", m_MaxAng PropBag.WriteProperty "DrawGraduation", m_DrawGrad PropBag.WriteProperty "DrawPoint", m_DrawPoint PropBag.WriteProperty "DrawRaisedHandle", m_DrawRaisedHandle PropBag.WriteProperty "RaisedHandleWidth1", m_RaisedHandleWidth1 PropBag.WriteProperty "RaisedHandleWidth2", m_RaisedHandleWidth2 PropBag.WriteProperty "BorderStyle", picKnob.BorderStyle End Sub '控件改变大小 Private Sub UserControl_Resize() If Width > Height Then Width = Height Exit Sub ElseIf Width < Height Then Height = Width Exit Sub End If picKnob.Height = ScaleHeight m_Rad = picKnob.ScaleHeight \ 2 DrawKnob End Sub '取得角度 Private Function GetAngle(ByVal X As Double, ByVal Y As Double) As Double 'X为Cos计算出来的，Y为Sin计算出来的 If X > 0 Then GetAngle = Atn(Y / X) ElseIf X < 0 Then GetAngle = Atn(Y / X) + Knob_PI ElseIf Y > 0 Then GetAngle = Knob_PI / 2 ElseIf Y < 0 Then GetAngle = Knob_PI * 3 / 2 End If End Function '边框属性，继承的PictureBox的边框属性 Property Get BorderStyle() As Long Attribute BorderStyle.VB_Description = "The style of the border. Same as PictureBox." Attribute BorderStyle.VB_ProcData.VB_Invoke_Property = ";外观" Attribute BorderStyle.VB_UserMemId = -504 BorderStyle = picKnob.BorderStyle End Property Property Let BorderStyle(ByVal NewBorderStyle As Long) picKnob.BorderStyle = NewBorderStyle m_Rad = picKnob.ScaleHeight \ 2 DrawKnob PropertyChanged "BorderStyle" End Property '旋钮的数值，取值0到Max Property Get Value() As Long Attribute Value.VB_Description = "The value of the knob." Attribute Value.VB_ProcData.VB_Invoke_Property = ";行为" Attribute Value.VB_UserMemId = 0 Value = m_Value End Property Property Let Value(ByVal NewValue As Long) If NewValue < 0 Then m_Value = 0 ElseIf NewValue > m_Max Then m_Value = m_Max Else m_Value = NewValue End If DrawHandle PropertyChanged "Value" End Property '旋钮的数值的最大值 Property Get Max() As Long Attribute Max.VB_Description = "The maximum value" Attribute Max.VB_ProcData.VB_Invoke_Property = ";行为" Max = m_Max End Property Property Let Max(ByVal NewMaxValue As Long) If NewMaxValue < 0 Then m_Max = 0 Else m_Max = NewMaxValue End If If m_Value > m_Max Then m_Value = m_Max DrawKnob PropertyChanged "Max" End Property '旋钮的最小角度 Property Get MinAngle() As Double Attribute MinAngle.VB_Description = "The minimum angle the knob can turn." Attribute MinAngle.VB_ProcData.VB_Invoke_Property = ";外观" MinAngle = m_MinAng * 180 / Knob_PI End Property Property Let MinAngle(ByVal NewMinAngle As Double) m_MinAng = NewMinAngle * Knob_PI / 180 While m_MinAng > Knob_PI * 2 m_MinAng = m_MinAng - Knob_PI * 2 Wend While m_MinAng < 0 m_MinAng = m_MinAng + Knob_PI * 2 Wend If m_MaxAng < m_MinAng Then Dim Temp As Double Temp = m_MaxAng m_MaxAng = m_MinAng m_MinAng = Temp End If DrawKnob PropertyChanged "MinAngle" End Property '旋钮的最大角度 Property Get MaxAngle() As Double Attribute MaxAngle.VB_Description = "The maximum angle the knob can turn." Attribute MaxAngle.VB_ProcData.VB_Invoke_Property = ";外观" MaxAngle = m_MaxAng * 180 / Knob_PI End Property Property Let MaxAngle(ByVal NewMaxAngle As Double) m_MaxAng = NewMaxAngle * Knob_PI / 180 While m_MaxAng > Knob_PI * 2 m_MaxAng = m_MaxAng - Knob_PI * 2 Wend While m_MaxAng < 0 m_MaxAng = m_MaxAng + Knob_PI * 2 Wend If m_MinAng > m_MaxAng Then Dim Temp As Double Temp = m_MaxAng m_MaxAng = m_MinAng m_MinAng = Temp End If DrawKnob PropertyChanged "MaxAngle" End Property '旋钮的刻度的密度 Property Get Steps() As Long Attribute Steps.VB_Description = "The steps of the graduation." Attribute Steps.VB_ProcData.VB_Invoke_Property = ";外观" Steps = m_Steps End Property Property Let Steps(ByVal NewSteps As Long) If NewSteps > m_Max Then m_Steps = m_Max ElseIf NewSteps < 0 Then m_Steps = 0 Else m_Steps = NewSteps End If DrawKnob PropertyChanged "Steps" End Property '旋钮的圆盘的半径比例 Property Get BaseRadius() As Double Attribute BaseRadius.VB_Description = "The radius of the base circle." Attribute BaseRadius.VB_ProcData.VB_Invoke_Property = ";外观" BaseRadius = m_BaseRad End Property Property Let BaseRadius(ByVal NewBaseRadius As Double) If NewBaseRadius < 0 Then m_BaseRad = 0 Else m_BaseRad = NewBaseRadius End If DrawKnob PropertyChanged "BaseRadius" End Property '旋钮的把手的半径比例 Property Get HandleRadius() As Double Attribute HandleRadius.VB_Description = "The radius(or length) of the raised handle." Attribute HandleRadius.VB_ProcData.VB_Invoke_Property = ";外观" HandleRadius = m_HandleRad End Property Property Let HandleRadius(ByVal NewHandleRadius As Double) If NewHandleRadius < 0 Then m_HandleRad = 0 Else m_HandleRad = NewHandleRadius End If DrawHandle PropertyChanged "HandleRadius" End Property '是否绘制刻度 Property Get DrawGraduation() As Boolean Attribute DrawGraduation.VB_Description = "Draw the graduation if it was true." Attribute DrawGraduation.VB_ProcData.VB_Invoke_Property = ";外观" DrawGraduation = m_DrawGrad End Property Property Let DrawGraduation(ByVal NewVal As Boolean) m_DrawGrad = NewVal DrawKnob PropertyChanged "DrawGraduation" End Property '是否绘制刻度 Property Get DrawPoint() As Boolean Attribute DrawPoint.VB_Description = "Draw the red point if it was true." Attribute DrawPoint.VB_ProcData.VB_Invoke_Property = ";外观" DrawPoint = m_DrawPoint End Property Property Let DrawPoint(ByVal NewVal As Boolean) m_DrawPoint = NewVal DrawHandle PropertyChanged "DrawPoint" End Property '是否显示凸起的把手 Property Get DrawRaisedHandle() As Boolean Attribute DrawRaisedHandle.VB_Description = "Draw the raised handle if it was true." Attribute DrawRaisedHandle.VB_ProcData.VB_Invoke_Property = ";外观" DrawRaisedHandle = m_DrawRaisedHandle End Property Property Let DrawRaisedHandle(ByVal NewVal As Boolean) m_DrawRaisedHandle = NewVal DrawHandle PropertyChanged "DrawRaisedHandle" End Property '凸起的把手的宽度1 Property Get RaisedHandleWidth1() As Double Attribute RaisedHandleWidth1.VB_Description = "The width of the raised handle." Attribute RaisedHandleWidth1.VB_ProcData.VB_Invoke_Property = ";外观" RaisedHandleWidth1 = m_RaisedHandleWidth1 End Property Property Let RaisedHandleWidth1(ByVal NewVal As Double) m_RaisedHandleWidth1 = NewVal DrawHandle PropertyChanged "RaisedHandleWidth1" End Property '凸起的把手的宽度2 Property Get RaisedHandleWidth2() As Double Attribute RaisedHandleWidth2.VB_Description = "The width of the raised handle." Attribute RaisedHandleWidth2.VB_ProcData.VB_Invoke_Property = ";外观" RaisedHandleWidth2 = m_RaisedHandleWidth2 End Property Property Let RaisedHandleWidth2(ByVal NewVal As Double) m_RaisedHandleWidth2 = NewVal DrawHandle PropertyChanged "RaisedHandleWidth2" End Property 复制代码
Knob.ctl
(19.11 KB, 下载次数: 44)
Knob.7z
(15.08 KB, 下载次数: 68)
|Archiver|小黑屋|技术宅的结界
( 滇ICP备16008837号 )|网站地图
发表于 2015-5-30 02:12:01
发表于 2015-5-30 20:51:27
发表于 2016-11-21 16:34:50
学习了
