wwbutton.ctl

一个自写的VB按钮控件

             mSetPixel I + 2, 1, RGB(rval, gval, bval)
        Next
        For I = 0 To Wi - Wi \ 3 - 2
             rval1 = 255 - I * (255 - RedColor1) \ (Wi - 2 * Wi \ 3 - 2)
             gval1 = 255 - I * (255 - GreenColor1) \ (Wi - 2 * Wi \ 3 - 2)        '画一条亮色线
             bval1 = 255 - I * (255 - BlueColor1) \ (Wi - 2 * Wi \ 3 - 2)
             If rval1 < 0 Then rval1 = 0
             If gval1 < 0 Then gval1 = 0
             If bval1 < 0 Then bval1 = 0
             mSetPixel I + 2, 2, RGB(rval1, gval1, bval1)
        Next
             Bcl = (BlueColor1 - BlueColor) / (He - He * mPercent / 100 - 4)      '
             Gcl = (GreenColor1 - GreenColor) / (He - He * mPercent / 100 - 4)    ''此段让颜色均匀变化
             Rcl = (RedColor1 - RedColor) / (He - He * mPercent / 100 - 4)
        DrawLine 1, He * mPercent / 100 + 1, Wi - 1, He * mPercent / 100 + 1, SaturatedColor
        DrawLine 1, He * mPercent / 100 + 2, Wi - 1, He * mPercent / 100 + 2, SaturatedColor
        rval = RedColor
        gval = GreenColor
        bval = BlueColor
        For I = He * mPercent / 100 + 3 To He - 4
               DrawLine 1, I, Wi - 1, I, RGB(rval, gval, bval)
               rval = rval + Rcl
               gval = gval + Gcl
               bval = bval + Bcl
               If rval > 255 Then rval = 255
               If rval < 0 Then rval = 0
               If gval > 255 Then gval = 255
               If gval < 0 Then gval = 0
               If bval > 255 Then bval = 255
               If bval < 0 Then bval = 0
        Next
        If He < 10 Then Exit Sub
        Bcl = GetPixel(UserControl.hdc, 2, He - 10)                 '借用Bcl为变量画线
        If Bcl < 0 Then Bcl = 0
        DrawLine 1, He - 9, Wi - 1, He - 9, Bcl
        DrawLine 1, He - 8, Wi - 1, He - 8, Bcl
        DrawLine 1, He * mPercent / 100 + 5, Wi - 1, He * mPercent / 100 + 5, SaturatedColor
        DrawLine 1, He - 3, Wi - 2, He - 3, Bcl
        DrawLine 1, He - 2, Wi - 2, He - 2, Bcl
   Else
       DrawRectangle 1, 1, Wi - 2, He - 2, SaturatedColor
   End If
   DrawXPFrame FrameColor, FrameColor
End Sub


Private Sub mSetPixel(ByVal x As Long, ByVal y As Long, ByVal Color As Long)
    Call SetPixelV(UserControl.hdc, x, y, Color)
End Sub
'**************************************************************************
Private Sub DrawFocusR()                                           '画焦点框
    SetTextColor UserControl.hdc, cText
    DrawFocusRect UserControl.hdc, rc3
End Sub
Private Sub SetColors()

If MyColorType = 2 Then              'Custom
    cFace = BackC
    cText = ForeC
    cShadow = ShiftColor(cFace, -&H40)
    cLight = ShiftColor(cFace, &H1F)
    cHighLight = ShiftColor(cFace, &H2F) 'it should be 3F but it looks too lighter
    cDarkShadow = ShiftColor(cFace, -&HC0)
    'Select Case MyButtonType
    '       Case 3, 4
    '            m_MidColor = RGB(197, 197, 197)
    '            m_EndColor = RGB(238, 238, 238)
    '            m_MouseMoveMidColor = RGB(123, 167, 211)
    '            m_MouseMoveEndColor = RGB(210, 245, 251)
    '            m_MouseDownMidColor = RGB(227, 167, 105)
    '            m_MouseDownEndColor = RGB(252, 220, 199)
    '
    'End Select
ElseIf MyColorType = 3 Then              'ForceStandard
    cFace = &HC0C0C0
    cShadow = &H808080
    cLight = &HDFDFDF
    cDarkShadow = &H0
    cHighLight = &HFFFFFF
    cText = &H0
    m_OfficeXpFillColor = RGB(236, 233, 216)
    m_OfficeXpFrameColor = RGB(172, 169, 154)
    m_OfficeXpMousemoveFillColor = RGB(193, 210, 238)
    m_OfficeXpMousemoveFrameColor = RGB(49, 105, 198)
Else
'if MyColorType is 1 or has not been set then use windows colors
    cFace = GetSysColor(COLOR_BTNFACE)
    cShadow = GetSysColor(COLOR_BTNSHADOW)
    cLight = GetSysColor(COLOR_BTNLIGHT)
    cDarkShadow = GetSysColor(COLOR_BTNDKSHADOW)
    cHighLight = GetSysColor(COLOR_BTNHIGHLIGHT)
    cText = ForeC                                              'GetSysColor(COLOR_BTNTEXT)
    Select Case MyButtonType
           Case 4
                m_MidColor = RGB(197, 197, 197)
                m_EndColor = RGB(238, 238, 238)
                m_MouseMoveMidColor = RGB(123, 167, 211)
                m_MouseMoveEndColor = RGB(210, 245, 251)
                m_MouseDownMidColor = RGB(227, 167, 105)
                m_MouseDownEndColor = RGB(252, 220, 199)
           'Case 9
                
    End Select
End If
End Sub

Private Sub MakeRegion()
'this function creates the regions to "cut" the UserControl
'so it will be transparent in certain areas

Dim rgn1 As Long, rgn2 As Long
    
    DeleteObject rgnNorm
    rgnNorm = CreateRectRgn(0, 0, Wi, He)
    rgn2 = CreateRectRgn(0, 0, 0, 0)
    
Select Case MyButtonType

    Case 3, 4, 8, 9 'Windows XP and Mac
        rgn1 = CreateRectRgn(0, 0, 2, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, He, 2, He - 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, 0, Wi - 2, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, He, Wi - 2, He - 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, 1, 1, 2)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, He - 1, 1, He - 2)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, 1, Wi - 1, 2)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, He - 1, Wi - 1, He - 2)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1

End Select

DeleteObject rgn2
End Sub

Private Sub SetAccessKeys()
'设置访问键

Dim ampersandPos As Long

If Len(m_Caption) > 1 Then
    ampersandPos = InStr(1, m_Caption, "&", vbTextCompare)
    If (ampersandPos < Len(m_Caption)) And (ampersandPos > 0) Then
        If Mid(m_Caption, ampersandPos + 1, 1) <> "&" Then 'if text is sonething like && then no access key should be assigned, so continue searching
            UserControl.AccessKeys = LCase(Mid(m_Caption, ampersandPos + 1, 1))
        Else 'do only a second pass to find another ampersand character
            ampersandPos = InStr(ampersandPos + 2, m_Caption, "&", vbTextCompare)
            If Mid(m_Caption, ampersandPos + 1, 1) <> "&" Then
                UserControl.AccessKeys = LCase(Mid(m_Caption, ampersandPos + 1, 1))
            Else
                UserControl.AccessKeys = ""
            End If
        End If
    Else
        UserControl.AccessKeys = ""
    End If
Else
    UserControl.AccessKeys = ""
End If
End Sub

Private Function ShiftColor(ByVal Color As Long, ByVal value As Long, Optional isXP As Boolean = False) As Long
'this function will add or remove a certain color
'quantity and return the result

Dim Red As Long, Blue As Long, Green As Long

If isXP = False Then
    Blue = ((Color \ &H10000) Mod &H100) + value
Else
    Blue = ((Color \ &H10000) Mod &H100)
    Blue = Blue + ((Blue * value) \ &HC0)
End If
Green = ((Color \ &H100) Mod &H100) + value
Red = (Color And &HFF) + value
    
    'check red
    If Red < 0 Then
        Red = 0
    ElseIf Red > 255 Then
        Red = 255
    End If
    'check green
    If Green < 0 Then
        Green = 0
    ElseIf Green > 255 Then
        Green = 255
    End If
    'check blue
    If Blue < 0 Then
        Blue = 0
    ElseIf Blue > 255 Then
        Blue = 255
    End If

ShiftColor = RGB(Red, Green, Blue)
End Function
Private Function ShiftColorCustom(ByVal Color As Long, ByVal Rcl As Long, ByVal Gcl As Long, ByVal Bcl As Long, ByVal Color1 As Long) As Long
Dim Red As Long, Blue As Long, Green As Long
Dim Red1 As Long, Blue1 As Long, Green1 As Long
'If isOnly = True Then
   Blue = ((Color \ &H10000) Mod &H100) + Bcl
   Green = ((Color \ &H100) Mod &H100) + Gcl
   Red = (Color And &HFF) + Rcl
   Blue1 = ((Color1 \ &H10000) Mod &H100)
   Green1 = ((Color1 \ &H100) Mod &H100)
   Red1 = (Color1 And &HFF)
    'check red
    If Red < 0 Then
        Red = 0
    ElseIf Red > Red1 Then
        Red = Red1
    End If
    'check green
    If Green < 0 Then
        Green = 0
    ElseIf Green > Green1 Then
        Green = Green1
    End If
    'check blue
    If Blue < 0 Then
        Blue = 0
    ElseIf Blue > Blue1 Then
        Blue = Blue1
    End If
'Else
    
'End If
ShiftColorCustom = RGB(Red, Green, Blue)
End Function
Private Sub DrawLonghorn(ByVal SaturatedColor As Long, ByVal FrameColor As Long, ByVal TingeColor As Long, ByVal mPercent As Integer)
  '画Longhorn 形状
  Dim I As Integer
  Dim RedColor As Long, BlueColor As Long, GreenColor As Long
  Dim RedColor1 As Long, BlueColor1 As Long, GreenColor1 As Long
  Dim rval As Long, gval As Long, bval As Long
  Dim Rcl As Long, Bcl As Long, Gcl As Long
  
    BlueColor1 = ((TingeColor \ &H10000) Mod &H100)
    GreenColor1 = ((TingeColor \ &H100) Mod &H100)
    RedColor1 = (TingeColor And &HFF)
    BlueColor = ((SaturatedColor \ &H10000) Mod &H100)
    GreenColor = ((SaturatedColor \ &H100) Mod &H100)
    RedColor = (SaturatedColor And &HFF)
       rval = RedColor + 10
       gval = GreenColor + 10
       bval = BlueColor + 10
             Bcl = (BlueColor1 - BlueColor) / (He * mPercent / 100 - 1)
             Gcl = (GreenColor1 - GreenColor) / (He * mPercent / 100 - 1) '此段让颜色均匀变化值
             Rcl = (RedColor1 - RedColor) / (He * mPercent / 100 - 1)
       For I = He * mPercent / 100 To 3 Step -1
             DrawLine 1, I, Wi - 1, I, RGB(rval, gval, bval)
             rval = rval + Rcl
             gval = gval + Gcl
             bval = bval + Bcl
             If rval > 255 Then rval = 255
             If gval > 255 Then gval = 255
             If bval > 255 Then bval = 255
             If rval < 0 Then rval = 0
             If gval < 0 Then gval = 0
             If bval < 0 Then bval = 0
        Next
        
             Bcl = (BlueColor1 - BlueColor) / (He - He * mPercent / 100 - 4)      '
             Gcl = (GreenColor1 - GreenColor) / (He - He * mPercent / 100 - 4)    ''此段让颜色均匀变化值
             Rcl = (RedColor1 - RedColor) / (He - He * mPercent / 100 - 4)
        For I = He * mPercent / 100 + 1 To He * mPercent / 100 + He * 0.27
              DrawLine 1, I, Wi - 1, I, SaturatedColor                            '连续画深色线
        Next
        rval = RedColor + 5
        gval = GreenColor + 5
        bval = BlueColor + 5
        For I = He * (mPercent + 27) / 100 To He - 4
               DrawLine 1, I, Wi - 1, I, RGB(rval, gval, bval)
               rval = rval + Rcl
               gval = gval + Gcl
               bval = bval + Bcl
               If rval > 255 Then rval = 255
               If gval > 255 Then gval = 255
               If bval > 255 Then bval = 255
               If rval < 0 Then rval = 0
               If gval < 0 Then gval = 0
               If bval < 0 Then bval = 0
        Next
        DrawRectangle 1, 1, Wi - 2, He - 2, RGB(211, 229, 255), True
        DrawRectangle 2, 2, Wi - 4, He - 4, RGB(201, 216, 255), True
        DrawLine 1, He - 3, Wi - 1, He - 3, RGB(207, 234, 255)
        DrawXPFrame FrameColor, FrameColor
End Sub


'**************************************************************************
'     timer事件处理鼠标移出
'＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊