chameleonbutton.ctl

基于vb网络编程。有类似QQ的功能

                mSetPixel 2, He - 2, ShiftColor(cShadow, -&H20)
                mSetPixel 2, He - 3, ShiftColor(cShadow, -&H10)
                mSetPixel 1, He - 3, ShiftColor(cShadow, -&H10)
                mSetPixel Wi - 2, 2, ShiftColor(cShadow, -&H20)
                mSetPixel Wi - 3, 2, ShiftColor(cShadow, -&H10)
                mSetPixel Wi - 3, 1, ShiftColor(cShadow, -&H10)
            Case 5 'Java
                .FontBold = True
                DrawRectangle 1, 1, Wi - 2, He - 2, ShiftColor(cShadow, &H10), False
                DrawRectangle 0, 0, Wi - 1, He - 1, ShiftColor(cShadow, -&H1A), True
                DrawLine Wi - 1, 1, Wi - 1, He, cHighLight
                DrawLine 1, He - 1, Wi - 1, He - 1, cHighLight
                DrawText .hdc, elTex, -1, rc, DT_CENTERABS
                If hasFocus = True Then DrawRectangle (Wi - UserControl.TextWidth(elTex)) \ 2 - 3, (He - UserControl.TextHeight(elTex)) \ 2 - 1, UserControl.TextWidth(elTex) + 6, UserControl.TextHeight(elTex) + 2, &HCC9999, True
                .FontBold = TextFont.Bold
            Case 6 'Netscape
                DrawText .hdc, elTex, -1, rc2, DT_CENTERABS
                DrawRectangle 0, 0, Wi, He, cShadow, True
                DrawRectangle 1, 1, Wi - 2, He - 2, cShadow, True
                DrawLine Wi - 1, 0, Wi - 1, He, ShiftColor(cLight, &H8)
                DrawLine Wi - 2, 1, Wi - 2, He - 1, ShiftColor(cLight, &H8)
                DrawLine 0, He - 1, Wi, He - 1, ShiftColor(cLight, &H8)
                DrawLine 1, He - 2, Wi - 1, He - 2, ShiftColor(cLight, &H8)
                If hasFocus = True Then DrawFocusR
             Case 7 'Flat
                DrawText .hdc, elTex, -1, rc2, DT_CENTERABS
                DrawRectangle 0, 0, Wi, He, cShadow, True
                DrawLine Wi - 1, 0, Wi - 1, He, cHighLight
                DrawLine 0, He - 1, Wi - 1, He - 1, cHighLight
                If hasFocus = True Then DrawFocusR
        End Select
    End If
Else
'#~#~#~#~#~# DISABLED STATUS #~#~#~#~#~#
    Select Case MyButtonType
        Case 1 'Windows 16-bit
            SetTextColor .hdc, cHighLight
            DrawText .hdc, elTex, -1, rc2, DT_CENTERABS
            SetTextColor .hdc, cShadow
            DrawText .hdc, elTex, -1, rc, DT_CENTERABS
            DrawLine 1, 0, Wi - 1, 0, cDarkShadow
            DrawLine 1, He - 1, Wi - 1, He - 1, cDarkShadow
            DrawLine 0, 1, 0, He - 1, cDarkShadow
            DrawLine Wi - 1, 1, Wi - 1, He - 1, cDarkShadow
            DrawRectangle 1, 1, Wi - 2, He - 2, cHighLight, True
            DrawRectangle 2, 2, Wi - 4, He - 4, cHighLight, True
            DrawLine Wi - 2, 1, Wi - 2, He - 1, cShadow
            DrawLine Wi - 3, 2, Wi - 3, He - 1, cShadow
            DrawLine 1, He - 2, Wi - 1, He - 2, cShadow
            DrawLine 2, He - 3, Wi - 2, He - 3, cShadow
        Case 2 'Windows 32-bit
            SetTextColor .hdc, cHighLight
            DrawText .hdc, elTex, -1, rc2, DT_CENTERABS
            SetTextColor .hdc, cShadow
            DrawText .hdc, elTex, -1, rc, DT_CENTERABS
            DrawRectangle 0, 0, Wi - 1, He - 1, cHighLight, True
            DrawRectangle 1, 1, Wi - 2, He - 2, cLight, True
            DrawLine Wi - 1, 0, Wi - 1, He, cDarkShadow
            DrawLine Wi - 2, 1, Wi - 2, He - 1, cShadow
            DrawLine 0, He - 1, Wi - 1, He - 1, cDarkShadow
            DrawLine 1, He - 2, Wi - 2, He - 2, cShadow
        Case 3 'Windows XP
            XPface = ShiftColor(cFace, &H30, True)
            DrawRectangle 0, 0, Wi, He, ShiftColor(XPface, -&H18, True)
            SetTextColor .hdc, ShiftColor(XPface, -&H68, True)
            DrawText .hdc, elTex, -1, rc, DT_CENTERABS
            DrawLine 2, 0, Wi - 2, 0, ShiftColor(XPface, -&H54, True)
            DrawLine 2, He - 1, Wi - 2, He - 1, ShiftColor(XPface, -&H54, True)
            DrawLine 0, 2, 0, He - 2, ShiftColor(XPface, -&H54, True)
            DrawLine Wi - 1, 2, Wi - 1, He - 2, ShiftColor(XPface, -&H54, True)
            mSetPixel 1, 1, ShiftColor(XPface, -&H48, True)
            mSetPixel 1, He - 2, ShiftColor(XPface, -&H48, True)
            mSetPixel Wi - 2, 1, ShiftColor(XPface, -&H48, True)
            mSetPixel Wi - 2, He - 2, ShiftColor(XPface, -&H48, True)
        Case 4 'Mac
            DrawRectangle 1, 1, Wi - 2, He - 2, cLight
            SetTextColor .hdc, cHighLight
            DrawText .hdc, elTex, -1, rc2, DT_CENTERABS
            SetTextColor .hdc, cShadow
            DrawText .hdc, elTex, -1, rc, DT_CENTERABS
            DrawLine 2, 0, Wi - 2, 0, cDarkShadow
            DrawLine 2, He - 1, Wi - 2, He - 1, cDarkShadow
            DrawLine 0, 2, 0, He - 2, cDarkShadow
            DrawLine Wi - 1, 2, Wi - 1, He - 2, cDarkShadow
            mSetPixel 1, 1, cDarkShadow
            mSetPixel 1, He - 2, cDarkShadow
            mSetPixel Wi - 2, 1, cDarkShadow
            mSetPixel Wi - 2, He - 2, cDarkShadow
            mSetPixel 1, 2, cFace
            mSetPixel 2, 1, cFace
            DrawLine 3, 2, Wi - 3, 2, cHighLight
            DrawLine 2, 2, 2, He - 3, cHighLight
            mSetPixel 3, 3, cHighLight
            DrawLine Wi - 3, 1, Wi - 3, He - 3, cFace
            DrawLine 1, He - 3, Wi - 3, He - 3, cFace
            mSetPixel Wi - 4, He - 4, cFace
            DrawLine Wi - 2, 3, Wi - 2, He - 2, cShadow
            DrawLine 3, He - 2, Wi - 2, He - 2, cShadow
            mSetPixel Wi - 3, He - 3, cShadow
            mSetPixel 2, He - 2, cFace
            mSetPixel 2, He - 3, cLight
            mSetPixel Wi - 2, 2, cFace
            mSetPixel Wi - 3, 2, cLight
        Case 5 'Java
            .FontBold = True
            SetTextColor .hdc, cShadow
            DrawText .hdc, elTex, -1, rc, DT_CENTERABS
            DrawRectangle 0, 0, Wi, He, cShadow, True
            .FontBold = TextFont.Bold
        Case 6 'Netscape
            SetTextColor .hdc, cShadow
            DrawText .hdc, elTex, -1, rc, DT_CENTERABS
            DrawRectangle 0, 0, Wi, He, ShiftColor(cLight, &H8), True
            DrawRectangle 1, 1, Wi - 2, He - 2, ShiftColor(cLight, &H8), True
            DrawLine Wi - 1, 0, Wi - 1, He, cShadow
            DrawLine Wi - 2, 1, Wi - 2, He - 1, cShadow
            DrawLine 0, He - 1, Wi, He - 1, cShadow
            DrawLine 1, He - 2, Wi - 1, He - 2, cShadow
        Case 7 'Flat
            SetTextColor .hdc, cHighLight
            DrawText .hdc, elTex, -1, rc2, DT_CENTERABS
            SetTextColor .hdc, cShadow
            DrawText .hdc, elTex, -1, rc, DT_CENTERABS
            DrawRectangle 0, 0, Wi, He, cHighLight, True
            DrawLine Wi - 1, 0, Wi - 1, He, cShadow
            DrawLine 0, He - 1, Wi - 1, He - 1, cShadow
    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 mSetPixel(ByVal X As Long, ByVal Y As Long, ByVal Color As Long)
    Call SetPixel(UserControl.hdc, X, Y, Color)
End Sub

Private Sub DrawFocusR()
    SetTextColor UserControl.hdc, cText
    DrawFocusRect UserControl.hdc, rc3
End Sub
Private Sub SetColors()
'this function sets the colors taken as a base to build
'all the other colors and styles.

If MyColorType = Custom Then
    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)
ElseIf MyColorType = [Force Standard] Then
    cFace = &HC0C0C0
    cShadow = &H808080
    cLight = &HDFDFDF
    cDarkShadow = &H0
    cHighLight = &HFFFFFF
    cText = &H0
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 = GetSysColor(COLOR_BTNTEXT)
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 1 'Windows 16-bit
        rgn1 = CreateRectRgn(0, 0, 1, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, He, 1, He - 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, 0, Wi - 1, 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, He, Wi - 1, He - 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
    Case 3, 4 '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
    Case 5 'Java
        rgn1 = CreateRectRgn(0, He, 1, He - 1)
        CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wi, 0, Wi - 1, 1)
        CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
End Select

DeleteObject rgn2
End Sub

Private Sub SetAccessKeys()
'this is a TRUE access keys parser
'i hate seeing how other programmers just check for the
'existence of the ampersand regardless of what follows it

Dim ampersandPos As Long

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