candybutton.ctl

糖果水晶按钮,这个代码支持XP按钮,XP工具栏按钮。

End Sub

Private Function DrawPlasticButton(vState As eState)
    Select Case vState
        Case eHover
            DrawPlastic 0, 0, Picture1.ScaleWidth - 1, UserControl.ScaleHeight - 1, m_ColorButtonHover
        Case ePressed, eChecked
            DrawPlastic 0, 0, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1, ColorButtonDown
        Case eNormal, eFocus
            DrawPlastic 0, 0, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1, m_ColorButtonUp
    End Select
End Function

Private Sub DrawPlastic(x As Long, y As Long, Width As Long, Height As Long, Color As Long)
Dim i As Long, j As Long, HighlightColor As Long, ShadowColor As Long
Dim ptColor As Long, LinearGPercent As Long
    ShadowColor = BlendColors(vbBlack, Color, 50)
    
    For j = 0 To Height
        If j < CornerRadius Then
            HighlightColor = BlendColors(vbWhite, Color, j * 30 \ CornerRadius)
        End If
        LinearGPercent = Abs((2 * j - Height) * 100 \ Height)
        For i = 0 To Width \ 2
            If IsInRoundRect(i, j, 1, 1, Width - 2, Height - 2, CornerRadius) Then
                'Drawing the button properly
                If IsInRoundRect(i, j, 4, 2, Width - CornerRadius, 2 * CornerRadius - 1, 2 * CornerRadius \ 3) _
                And Not IsInRoundRect(i, j, 4, CornerRadius \ 2, Width - CornerRadius, 2 * CornerRadius - 1, 2 * CornerRadius \ 3) Then
                    ptColor = HighlightColor 'draw reflected highlight
                Else
                    ptColor = BlendColors(Color, m_ColorBright, LinearGPercent)
                End If
                SetPixelV Picture1.hdc, i + x, j + y, ptColor
                SetPixelV Picture1.hdc, x + Width - i, j + y, ptColor
            ElseIf IsInRoundRect(i, j, 0, 0, Width, Height, CornerRadius) Then
                'this draw a thin border
                SetPixelV Picture1.hdc, i + x, j + y, ShadowColor
                SetPixelV Picture1.hdc, x + Width - i, j + y, ShadowColor
            End If
        Next i
    Next j
End Sub

Private Sub CreateRoundedRegion(Width As Long, Height As Long, Radius As Long)
Dim i As Long, j As Long, i2 As Long, j2 As Long
Dim hRgn As Long
    CornerRadius = Radius
    'Create initial region
    hRgn = CreateRectRgn(0, 0, Width, Height)
    For j = 0 To Height
        For i = 0 To Width \ 2
            If IsInRoundRect(i, j, 0, 0, Width, Height, CornerRadius) = False Then
                'This will substract the pixels outside the rounded rectangle to make the
                'button transparent.
                If j <> j2 Then
                    'If 2 * i2 <> Width Then i2 = i2 + 1
                    ExcludePixelsFromRegion hRgn, Width - i2, j2, Width - i, j
                    If 2 * i2 <> Width Then i2 = i2 + 1
                    ExcludePixelsFromRegion hRgn, i, j, i2, j2
                End If
                i2 = i
                j2 = j
            End If
        Next i
    Next j
    Call SetWindowRgn(UserControl.hwnd, hRgn, True)
    DeleteObject hRgn
End Sub

Private Function IsInRoundRect(i As Long, j As Long, x As Long, y As Long, Width As Long, Height As Long, Radius As Long) As Boolean
Dim offX As Long, offY As Long
    offX = i - x
    offY = j - y
    If offY > Radius And offY + Radius < Height And _
       offX > Radius And offX + Radius < Width Then
       'This is to catch early most cases
        IsInRoundRect = True
    ElseIf offX < Radius And offY <= Radius Then
        If IsInCircle(offX - Radius, offY, Radius) Then IsInRoundRect = True
    ElseIf offX + Radius > Width And offY <= Radius Then
        If IsInCircle(offX - Width + Radius, offY, Radius) Then IsInRoundRect = True
    ElseIf offX < Radius And offY + Radius >= Height Then
        If IsInCircle(offX - Radius, offY - Height + Radius * 2, Radius) Then IsInRoundRect = True
    ElseIf offX + Radius > Width And offY + Radius >= Height Then
        If IsInCircle(offX - Width + Radius, offY - Height + Radius * 2, Radius) Then IsInRoundRect = True
    Else
        If offX > 0 And offX < Width And offY > 0 And offY < Height Then IsInRoundRect = True
    End If
End Function

Private Function IsInCircle(ByRef x As Long, ByRef y As Long, ByRef R As Long) As Boolean
Dim lResult As Long
    'this detect a circunference that has y centered on y=0 and x=0
    lResult = (R ^ 2) - (x ^ 2)
    If lResult >= 0 Then
        lResult = Sqr(lResult)
        If Abs(y - R) < lResult Then IsInCircle = True
    End If
End Function

Public Function BlendColors(ByRef Color1 As Long, ByRef Color2 As Long, ByRef Percentage As Long) As Long
Dim R(2) As Long, G(2) As Long, B(2) As Long
    
    Percentage = SetBound(Percentage, 0, 100)
    
    GetRGB R(0), G(0), B(0), Color1
    GetRGB R(1), G(1), B(1), Color2
    
    R(2) = R(0) + (R(1) - R(0)) * Percentage \ 100
    G(2) = G(0) + (G(1) - G(0)) * Percentage \ 100
    B(2) = B(0) + (B(1) - B(0)) * Percentage \ 100
    
    BlendColors = RGB(R(2), G(2), B(2))
End Function

Private Function SetBound(ByRef Num As Long, ByRef MinNum As Long, ByRef MaxNum As Long) As Long
    If Num < MinNum Then
        SetBound = MinNum
    ElseIf Num > MaxNum Then
        SetBound = MaxNum
    Else
        SetBound = Num
    End If
End Function

Public Sub GetRGB(ByRef R As Long, ByRef G As Long, ByRef B As Long, ByRef Color As Long)
Dim TempValue As Long
    TranslateColor Color, 0, TempValue
    R = TempValue And &HFF&
    G = (TempValue And &HFF00&) \ &H100&
    B = (TempValue And &HFF0000) \ &H10000
End Sub

Private Sub ExcludePixelsFromRegion(hRgn As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long)
    Dim hRgnTemp As Long
    hRgnTemp = CreateRectRgn(x1, y1, x2, y2)
    CombineRgn hRgn, hRgn, hRgnTemp, RGN_XOR
    DeleteObject hRgnTemp
End Sub

Private Function HiWord(lDWord As Long) As Integer
  HiWord = (lDWord And &HFFFF0000) \ &H10000
End Function

Private Function LoWord(lDWord As Long) As Integer
  If lDWord And &H8000& Then
    LoWord = lDWord Or &HFFFF0000
  Else
    LoWord = lDWord And &HFFFF&
  End If
End Function
'Read the properties from the property bag - also, a good place to start the subclassing (if we're running)
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  Dim w As Long
  Dim h As Long
  Dim s As String
  
    Set Picture1.Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_Caption = PropBag.ReadProperty("Caption", UserControl.Name)
    m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
    Set m_StdPicture = PropBag.ReadProperty("Picture", Nothing)
    m_PictureAlignment = PropBag.ReadProperty("PictureAlignment", m_def_PictureAlignment)
    m_Style = PropBag.ReadProperty("Style", 0)
    m_Checked = PropBag.ReadProperty("Checked", m_Checked)
    m_ColorButtonHover = PropBag.ReadProperty("ColorButtonHover", &HFFC090)
    m_ColorButtonUp = PropBag.ReadProperty("ColorButtonUp", &HE99950)
    m_ColorButtonDown = PropBag.ReadProperty("ColorButtonDown", &HE99950)
    m_ColorBright = PropBag.ReadProperty("ColorBright", &HFFEDB0)
    m_BorderBrightness = PropBag.ReadProperty("BorderBrightness", 0)
    m_DisplayHand = PropBag.ReadProperty("DisplayHand", False)
    m_ColorScheme = PropBag.ReadProperty("ColorScheme", 0)
    If m_DisplayHand Then UserControl.MousePointer = vbCustom Else UserControl.MousePointer = vbArrow
    UserControl.ForeColor = m_ForeColor
    
  If Ambient.UserMode Then                                                              'If we're not in design mode
    bTrack = True
    bTrackUser32 = IsFunctionExported("TrackMouseEvent", "User32")
  
    If Not bTrackUser32 Then
      If Not IsFunctionExported("_TrackMouseEvent", "Comctl32") Then
        bTrack = False
      End If
    End If
  
    If bTrack Then
      'OS supports mouse leave, so let's subclass for it
      With UserControl
        'Subclass the UserControl
        sc_Subclass .hwnd
        sc_AddMsg .hwnd, WM_MOUSEMOVE
        sc_AddMsg .hwnd, WM_MOUSELEAVE
      End With
    End If
  End If
End Sub

'The control is terminating - a good place to stop the subclasser
Private Sub UserControl_Terminate()
  sc_Terminate                                                              'Terminate all subclassing
End Sub

'Determine if the passed function is supported
Private Function IsFunctionExported(ByVal sFunction As String, ByVal sModule As String) As Boolean
  Dim hMod        As Long
  Dim bLibLoaded  As Boolean

  hMod = GetModuleHandleA(sModule)

  If hMod = 0 Then
    hMod = LoadLibraryA(sModule)
    If hMod Then
      bLibLoaded = True
    End If
  End If

  If hMod Then
    If GetProcAddress(hMod, sFunction) Then
      IsFunctionExported = True
    End If
  End If

  If bLibLoaded Then
    FreeLibrary hMod
  End If
End Function

'Track the mouse leaving the indicated window
Private Sub TrackMouseLeave(ByVal lng_hWnd As Long)
  Dim tme As TRACKMOUSEEVENT_STRUCT
  
  If bTrack Then
    With tme
      .cbSize = Len(tme)
      .dwFlags = TME_LEAVE
      .hwndTrack = lng_hWnd
    End With

    If bTrackUser32 Then
      TrackMouseEvent tme
    Else
      TrackMouseEventComCtl tme
    End If
  End If
End Sub

'-SelfSub code------------------------------------------------------------------------------------
Private Function sc_Subclass(ByVal lng_hWnd As Long, _
                    Optional ByVal lParamUser As Long = 0, _
                    Optional ByVal nOrdinal As Long = 1, _
                    Optional ByVal oCallback As Object = Nothing, _
                    Optional ByVal bIdeSafety As Boolean = True) As Boolean 'Subclass the specified window handle
'*************************************************************************************************
'* lng_hWnd   - Handle of the window to subclass
'* lParamUser - Optional, user-defined callback parameter
'* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
'* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
'* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
'*************************************************************************************************
Const CODE_LEN      As Long = 260                                           'Thunk length in bytes
Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES + 1))            'Bytes to allocate per thunk, data + code + msg tables
Const PAGE_RWX      As Long = &H40&                                         'Allocate executable memory
Const MEM_COMMIT    As Long = &H1000&                                       'Commit allocated memory
Const MEM_RELEASE   As Long = &H8000&                                       'Release allocated memory flag
Const IDX_EBMODE    As Long = 3                                             'Thunk data index of the EbMode function address
Const IDX_CWP       As Long = 4                                             'Thunk data index of the CallWindowProc function address
Const IDX_SWL       As Long = 5                                             'Thunk data index of the SetWindowsLong function address
Const IDX_FREE      As Long = 6                                             'Thunk data index of the VirtualFree function address
Const IDX_BADPTR    As Long = 7                                             'Thunk data index of the IsBadCodePtr function address
Const IDX_OWNER     As Long = 8                                             'Thunk data index of the Owner object's vTable address
Const IDX_CALLBACK  As Long = 10                                            'Thunk data index of the callback method address
Const IDX_EBX       As Long = 16                                            'Thunk code patch index of the thunk data
Const SUB_NAME      As String = "sc_Subclass"                               'This routine's name