📄 wwbutton.ctl
字号:
If Button <> 2 Then lastStat = 0 '####Call Redraw(0, False)
Call Redraw(lastStat, True)
RaiseEvent MouseUp(Button, Shift, X, Y)
End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button < 2 And isEnabled = True Then
Timer1.Enabled = True
If X >= 0 And Y >= 0 And _
X <= UserControl.ScaleWidth And Y <= UserControl.ScaleHeight Then
'在按钮内部
RaiseEvent MouseMove(Button, Shift, X, Y)
If Button = vbLeftButton Then
Call Redraw(2, False)
Else
If disyellowrect = True Then
Exit Sub
Else
disyellowrect = True
End If
Call Redraw(0, True)
End If
End If
End If
End Sub
Private Sub UserControl_Resize()
He = UserControl.ScaleHeight
Wi = UserControl.ScaleWidth
rc.Bottom = He: rc.Right = Wi
rc2.Bottom = He: rc2.Right = Wi
rc3.Left = 2: rc3.Top = 2: rc3.Right = Wi - 2: rc3.Bottom = He - 2
DeleteObject rgnNorm
Call MakeRegion
SetWindowRgn UserControl.HWnd, rgnNorm, True
Call Redraw(lastStat, True) '####(0, True)
End Sub
Private Sub UserControl_Terminate()
DeleteObject rgnNorm
End Sub
'按钮重画子程序
Private Sub Redraw(ByVal curStat As Byte, ByVal Force As Boolean)
Dim i As Long, stepXP1 As Single, XPface As Long
Dim preFocusValue As Boolean
Dim lens As Integer
Dim iunicode As Integer
Dim ii As Integer, NumLine As Long 'rcText As RECT,
'Dim pt As POINTAPI
If Force = False Then 'check drawing redundancy
If (curStat = lastStat) And (Te = m_Caption) Then Exit Sub
End If
If He = 0 Then Exit Sub 'we don't want errors
lastStat = curStat
Te = m_Caption
preFocusValue = hasFocus '保存焦点状态
If hasFocus = True Then hasFocus = ShowFocusRect
With UserControl
.Cls
DrawRectangle 0, 0, Wi, He, cFace
allcount = LenB(StrConv(m_Caption, vbFromUnicode)) '此段为中英文显示判断
If isEnabled = True Then
SetTextColor .hdc, cText 'restore font color
If curStat = 0 Then
'#@#@#@#@#@# 按钮在正常状态 #@#@#@#@#@#
Select Case MyButtonType
Case 1 'Windows XP
If MyColorType = 2 Or MyColorType = 3 Then
stepXP1 = 25 / He
XPface = ShiftColor(cFace, &H30, True)
For i = 1 To He - 2
DrawLine 0, i, Wi, i, ShiftColor(XPface, -stepXP1 * i, True)
Next
Else
Select Case MyXpType
Case 1 '银色风格
DrawJianBian 198, 197, 215, He - 2, 1, -1 'XP银色效果
Case 2 '翠色风格
stepXP1 = 25 / He
XPface = RGB(242, 237, 218)
For i = He - 2 To 1 Step -1
XPface = ShiftColor(XPface, 1, False)
DrawLine 1, i, Wi - 2, i, XPface
Next
Case 3 '蓝色风格
DrawJianBian 236, 235, 230, He - 2, 1, -1 '蓝色风格
End Select
End If
'SetTextColor UserControl.hdc, cText
DrawXPFrame &H733C00, &H7B4D10
If (hasFocus = True) Or ((Ambient.DisplayAsDefault = True) And (showFocusR = True)) Then
If disyellowrect = True Then
If MyXpType = 2 Then
XPface = RGB(228, 144, 80)
Else
XPface = m_rectcolor
End If '鼠标移入时显示黄色框
DrawRectangle 2, 1, Wi - 4, He - 2, XPface, True
DrawLine 1, 2, 1, He - 2, XPface
DrawLine 3, 2, Wi - 3, 2, XPface
DrawLine Wi - 2, 2, Wi - 2, He - 2, XPface
DrawLine 3, He - 3, Wi - 3, He - 3, XPface
Else
Select Case MyXpType
Case 1, 3
DrawRectangle 1, 2, Wi - 2, He - 4, &HE7AE8C, True
DrawLine 2, He - 2, Wi - 2, He - 2, &HEF826B
DrawLine 2, 1, Wi - 2, 1, &HFFE7CE
DrawLine 2, 2, Wi - 2, 2, &HF7D7BD
DrawLine 2, 3, 2, He - 3, &HF0D1B5
DrawLine Wi - 3, 3, Wi - 3, He - 3, &HF0D1B5
Case 2
DrawRectangle 1, 2, Wi - 2, He - 4, &H62B87A, True
DrawLine 2, He - 2, Wi - 2, He - 2, &H62B87A
DrawLine 2, 1, Wi - 2, 1, &H62B87A
DrawLine 2, 2, Wi - 2, 2, &H62B87A
DrawLine 2, 3, 2, He - 3, &H62B87A ' FF00&
DrawLine Wi - 3, 3, Wi - 3, He - 3, &H62B87A ' &HABF15E
End Select
DrawFocusR
End If
Else
If disyellowrect = True Then
If MyXpType = 2 Then '
XPface = RGB(228, 144, 80)
Else
XPface = m_rectcolor '
End If '
DrawRectangle 2, 1, Wi - 4, He - 2, XPface, True '鼠标移入时显示黄色框
DrawLine 1, 2, 1, He - 2, XPface '
DrawLine 3, 2, Wi - 3, 2, XPface '
DrawLine Wi - 2, 2, Wi - 2, He - 2, XPface '
DrawLine 3, He - 3, Wi - 3, He - 3, XPface '
End If
End If
Case 2 'Mac
Case 3 '[Mac OS] = 8
If MyColorType = 1 Then
DrawMacOS m_MidColor, RGB(183, 183, 183), m_EndColor, m_Percent
Else
DrawMacOS m_MidColor, RGB(1, 66, 115), m_EndColor, m_Percent
End If
If disyellowrect = True Then
If MyColorType = 1 Then
DrawMacOS m_MouseMoveMidColor, RGB(0, 60, 115), m_MouseMoveEndColor, m_Percent
Else
DrawMacOS m_MouseMoveMidColor, RGB(0, 60, 115), m_MouseMoveEndColor, m_Percent
End If
End If
If (hasFocus = True) Or ((Ambient.DisplayAsDefault = True) And (showFocusR = True)) Then
DrawFocusR
End If
End Select
SetTextColor .hdc, cText 'restore font color
If UserControl.TextWidth(m_Caption) <= Wi Then
DrawText .hdc, m_Caption, -1, rc, DT_CENTERABS
Else
NumLine = (UserControl.TextWidth(m_Caption) \ Wi) + 1
rc.Top = (He - UserControl.TextHeight(m_Caption) * NumLine) \ 2
DrawText .hdc, m_Caption, -1, rc, DT_CENTER Or DT_WORDBREAK '
End If
ElseIf curStat = 2 Then
'#@#@#@#@#@# 按钮按下 #@#@#@#@#@#
Select Case MyButtonType
Case 1 'Windows XP
Select Case MyXpType
Case 1
DrawJianBian 171, 170, 188, 1, He - 2, 1 'XP银色效果
Case 2
stepXP1 = 15 / He
XPface = ShiftColor(cFace, &H30, True)
XPface = ShiftColor(XPface, -32, True)
For i = 1 To He
DrawLine 0, He - i, Wi, He - i, ShiftColor(XPface, -stepXP1 * i, True)
Next
Case 3
DrawJianBian 224, 224, 216, 1, He - 2, 1 'XP蓝色效果
End Select
SetTextColor UserControl.hdc, cText
If UserControl.TextWidth(m_Caption) <= Wi Then
DrawText UserControl.hdc, m_Caption, -1, rc2, DT_CENTERABS
Else
rc2.Top = rc.Top + 2
DrawText .hdc, m_Caption, -1, rc2, DT_CENTER Or DT_WORDBREAK '
End If
DrawXPFrame &H733C00, &H7B4D10
If hasFocus = True Then DrawFocusR
Case 2 'Mac
Case 3
If MyColorType = 1 Then
DrawMacOS m_MouseDownMidColor, RGB(203, 130, 62), m_MouseDownEndColor, m_Percent
Else
DrawMacOS m_MouseDownMidColor, RGB(8, 87, 124), m_MouseDownEndColor, m_Percent, True
End If
SetTextColor .hdc, cText
If .TextWidth(m_Caption) <= Wi Then
DrawText .hdc, m_Caption, -1, rc2, DT_CENTERABS
Else
rc2.Top = rc.Top + 2
DrawText .hdc, m_Caption, -1, rc2, DT_CENTER Or DT_WORDBREAK '
End If
If hasFocus = True Then DrawFocusR
End Select
End If
Else
'#~#~#~#~#~# DISABLED STATUS #~#~#~#~#~#
Select Case MyButtonType
Case 1 'Windows XP
DrawRectangle 0, 0, Wi, He, RGB(244, 244, 234)
SetTextColor UserControl.hdc, RGB(161, 162, 146)
If .TextWidth(m_Caption) <= Wi Then
DrawText .hdc, m_Caption, -1, rc, DT_CENTERABS
Else
NumLine = (.TextWidth(m_Caption) \ Wi) + 1
rc.Top = (He - .TextHeight(m_Caption) * NumLine) \ 2
DrawText .hdc, m_Caption, -1, rc, DT_CENTER Or DT_WORDBREAK '
End If
DrawXPFrame RGB(201, 199, 186), RGB(201, 199, 186)
Case 2 'Mac
Case 3
DrawRectangle 1, 1, Wi - 2, He - 2, RGB(241, 242, 237)
DrawXPFrame RGB(204, 204, 202), RGB(204, 204, 202)
SetTextColor .hdc, RGB(171, 168, 153)
If .TextWidth(m_Caption) <= Wi Then
DrawText .hdc, m_Caption, -1, rc, DT_CENTERABS
Else
NumLine = (.TextWidth(m_Caption) \ Wi) + 1
rc.Top = (He - .TextHeight(m_Caption) * NumLine) \ 2
DrawText .hdc, m_Caption, -1, rc, DT_CENTER Or DT_WORDBREAK '
End If
End Select
End If
End With
'restore focus value
hasFocus = preFocusValue
End Sub
Private Sub DrawRectangle(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As Long, Optional OnlyBorder As Boolean = False)
'this is my custom function to draw rectangles and frames
'it's faster and smoother than using the line method
Dim bRect As RECT
Dim hBrush As Long
Dim ret As Long
bRect.Left = X
bRect.Top = Y
bRect.Right = X + Width
bRect.Bottom = Y + Height
hBrush = CreateSolidBrush(Color)
If OnlyBorder = False Then
ret = FillRect(UserControl.hdc, bRect, hBrush)
Else
ret = FrameRect(UserControl.hdc, bRect, hBrush)
End If
ret = DeleteObject(hBrush)
End Sub
Private Sub DrawLine(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As Long)
'a fast way to draw lines
Dim pt As POINTAPI
UserControl.ForeColor = Color
MoveToEx UserControl.hdc, X1, Y1, pt
LineTo UserControl.hdc, X2, Y2
End Sub
Private Sub DrawJianBian(ByVal R As Long, ByVal G As Long, ByVal B As Long, ByVal Lower As Long, ByVal Uper As Long, ByVal Steper As Long)
Dim i As Integer
Dim rval As Single
Dim gval As Single
Dim bval As Single
rval = R
gval = G
bval = B
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -