tonypecaobuton.ctl

用vb做的防vista的登录界面

                    DrawLine 1, He - 1, Wi - 1, He - 1, cHighLight
                    SetTextColor .hdc, cTextO
                    DrawText .hdc, elTex, Len(elTex), rc, DT_CENTER
                    If HasFocus And showFocusR Then DrawRectangle rc.Left - 2, rc.Top - 1, fc.X + 4, fc.Y + 2, &HCC9999, True
                Case 6
                    Call DrawCaption(2)
                    DrawFrame cShadow, ShiftColor(cLight, &H8), cShadow, ShiftColor(cLight, &H8), False
                    Call DrawFocusR
                Case 7, 8, 12
                    Call DrawCaption(2)
                    If MyButtonType = [3D Hover] Then
                        DrawFrame cDarkShadow, cHighLight, cShadow, cLight, False, False
                    Else
                        DrawFrame cShadow, cHighLight, 0, 0, False, True
                    End If
                    Call DrawFocusR
                Case 9
                    If isOver Then DrawRectangle 0, 0, Wi, He, Abs(MyColorType = 2) * ShiftColor(OXPf, -&H20) + Abs(MyColorType <> 2) * ShiftColorOXP(OXPb, &H80)
                    Call DrawCaption(2)
                    DrawRectangle 0, 0, Wi, He, OXPb, True
                    Call DrawFocusR
                Case 11
                    BitBlt hdc, 0, 0, Wi, He, pDC, 0, 0, vbSrcCopy
                    Call DrawCaption(2)
                    Call DrawFocusR
                Case 13
                    DrawEllipse 0, 0, Wi, He, cDarkShadow, ShiftColor(cFace, -&H20)
                    Call DrawCaption(2)
                Case 14
                    DrawRectangle 1, 1, Wi, He, ShiftColor(cFace, -&H9)
                    DrawRectangle 0, 0, Wi, He, ShiftColor(cShadow, -&H30), True
                    DrawLine 2, He - 2, Wi - 2, He - 2, cHighLight
                    DrawLine Wi - 2, 2, Wi - 2, He - 1, cHighLight
                    Call DrawCaption(7)
                    Call DrawFocusR
                End Select
                Call DrawPictures(1)
            End If
        Else
           
            Select Case MyButtonType
            Case 1
                Call DrawCaption(3)
                DrawFrame cHighLight, cShadow, cHighLight, cShadow, True
                DrawRectangle 0, 0, Wi, He, cDarkShadow, True
            Case 2
                Call DrawCaption(3)
                DrawFrame cHighLight, cDarkShadow, cLight, cShadow, False
            Case 3
                DrawRectangle 0, 0, Wi, He, ShiftColor(XPFace, -&H18, True)
                Call DrawCaption(5)
                DrawRectangle 0, 0, Wi, He, ShiftColor(XPFace, -&H54, True), 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
                DrawRectangle 1, 1, Wi - 2, He - 2, cLight
                Call DrawCaption(3)
                DrawRectangle 0, 0, Wi, He, cDarkShadow, True
                mSetPixel 1, 1, cDarkShadow
                mSetPixel 1, He - 2, cDarkShadow
                mSetPixel Wi - 2, 1, cDarkShadow
                mSetPixel Wi - 2, He - 2, cDarkShadow
                DrawLine 1, 2, 2, 0, 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, 2, Wi - 2, He - 2, cShadow
                DrawLine 2, He - 2, Wi - 2, He - 2, cShadow
                mSetPixel Wi - 3, He - 3, cShadow
            Case 5
                Call DrawCaption(4)
                DrawRectangle 0, 0, Wi, He, cShadow, True
            Case 6
                Call DrawCaption(4)
                DrawFrame ShiftColor(cLight, &H8), cShadow, ShiftColor(cLight, &H8), cShadow, False
            Case 7, 8, 12, 13
                Call DrawCaption(3)
                If MyButtonType = [Simple Flat] Then DrawFrame cHighLight, cShadow, 0, 0, False, True
            Case 9
                Call DrawCaption(4)
            Case 11
                BitBlt hdc, 0, 0, Wi, He, pDC, 0, 0, vbSrcCopy
                Call DrawCaption(3)
            Case 14
                stepXP1 = 58 / He
                For i = 1 To He
                    DrawLine 0, i, Wi, i, ShiftColor(cHighLight, -stepXP1 * i)
                Next i
                DrawRectangle 0, 0, Wi, He, ShiftColor(cShadow, -&H32), True
                DrawRectangle 1, 1, Wi - 2, He - 2, ShiftColor(cFace, -&H9), True
                DrawRectangle 2, 2, Wi - 4, 2, cHighLight
                DrawRectangle 2, 4, 2, He - 6, cHighLight
                Call DrawCaption(6)
            End Select
            Call DrawPictures(2)
        End If
    End With

    If isOver And MyColorType = Custom Then BackC = tempCol: SetColors

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)



Dim bRECT As RECT
Dim hBrush As Long

    bRECT.Left = X
    bRECT.Top = Y
    bRECT.Right = X + Width
    bRECT.Bottom = Y + Height

    hBrush = CreateSolidBrush(Color)

    If OnlyBorder Then
        FrameRect UserControl.hdc, bRECT, hBrush
    Else
        FillRect UserControl.hdc, bRECT, hBrush
    End If

    DeleteObject hBrush

End Sub

Private Sub DrawEllipse(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal BorderColor As Long, ByVal FillColor As Long)

Dim pBrush As Long, pPen As Long

    pBrush = SelectObject(hdc, CreateSolidBrush(FillColor))
    pPen = SelectObject(hdc, CreatePen(PS_SOLID, 2, BorderColor))

    Call Ellipse(hdc, X, Y, X + Width, Y + Height)

    Call DeleteObject(SelectObject(hdc, pBrush))
    Call DeleteObject(SelectObject(hdc, pPen))

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)

Dim pt As POINTAPI
Dim oldPen As Long, hPen As Long

    With UserControl
        hPen = CreatePen(PS_SOLID, 1, Color)
        oldPen = SelectObject(.hdc, hPen)

        MoveToEx .hdc, X1, Y1, pt
        LineTo .hdc, X2, Y2

        SelectObject .hdc, oldPen
        DeleteObject hPen
    End With

End Sub

Private Sub DrawFrame(ByVal ColHigh As Long, ByVal ColDark As Long, ByVal ColLight As Long, ByVal ColShadow As Long, ByVal ExtraOffset As Boolean, Optional ByVal Flat As Boolean = False)



Dim pt As POINTAPI
Dim frHe As Long, frWi As Long, frXtra As Long

    frHe = He - 1 + ExtraOffset: frWi = Wi - 1 + ExtraOffset: frXtra = Abs(ExtraOffset)

    With UserControl
        Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColHigh)))
        
        MoveToEx .hdc, frXtra, frHe, pt
        LineTo .hdc, frXtra, frXtra
        LineTo .hdc, frWi, frXtra
       
        Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColDark)))
       
        LineTo .hdc, frWi, frHe
        LineTo .hdc, frXtra - 1, frHe
        MoveToEx .hdc, frXtra + 1, frHe - 1, pt
        If Flat Then Exit Sub
        
        Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColLight)))
        
        LineTo .hdc, frXtra + 1, frXtra + 1
        LineTo .hdc, frWi - 1, frXtra + 1
       
        Call DeleteObject(SelectObject(.hdc, CreatePen(PS_SOLID, 1, ColShadow)))
       
        LineTo .hdc, frWi - 1, frHe - 1
        LineTo .hdc, frXtra, frHe - 1
    End With

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()

    If showFocusR And HasFocus Then
        SetTextColor UserControl.hdc, cText
        DrawFocusRect UserControl.hdc, rc3
    End If

End Sub

Private Sub SetColors()


    If MyColorType = Custom Then
        cFace = ConvertFromSystemColor(BackC)
        cFaceO = ConvertFromSystemColor(BackO)
        cText = ConvertFromSystemColor(ForeC)
        cTextO = ConvertFromSystemColor(ForeO)
        cShadow = ShiftColor(cFace, -&H40)
        cLight = ShiftColor(cFace, &H1F)
        cHighLight = ShiftColor(cFace, &H2F)
        cDarkShadow = ShiftColor(cFace, -&HC0)
        OXPb = ShiftColor(cFace, -&H80)
        OXPf = cFace
    ElseIf MyColorType = [Force Standard] Then
        cFace = &HC0C0C0
        cFaceO = cFace
        cShadow = &H808080
        cLight = &HDFDFDF
        cDarkShadow = &H0
        cHighLight = &HFFFFFF
        cText = &H0
        cTextO = cText
        OXPb = &H800000
        OXPf = &HD1ADAD
    ElseIf MyColorType = [Use Container] Then
        cFace = GetBkColor(GetDC(GetParent(hwnd)))
        cFaceO = cFace
        cText = GetTextColor(GetDC(GetParent(hwnd)))
        cTextO = cText
        cShadow = ShiftColor(cFace, -&H40)
        cLight = ShiftColor(cFace, &H1F)
        cHighLight = ShiftColor(cFace, &H2F)
        cDarkShadow = ShiftColor(cFace, -&HC0)
        OXPb = GetSysColor(COLOR_HIGHLIGHT)
        OXPf = ShiftColorOXP(OXPb)
    Else
        
        cFace = GetSysColor(COLOR_BTNFACE)
        cFaceO = cFace
        cShadow = GetSysColor(COLOR_BTNSHADOW)
        cLight = GetSysColor(COLOR_BTNLIGHT)
        cDarkShadow = GetSysColor(COLOR_BTNDKSHADOW)
        cHighLight = GetSysColor(COLOR_BTNHIGHLIGHT)
        cText = GetSysColor(COLOR_BTNTEXT)
        cTextO = cText
        OXPb = GetSysColor(COLOR_HIGHLIGHT)
        OXPf = ShiftColorOXP(OXPb)
    End If
    cMask = ConvertFromSystemColor(MaskC)
    XPFace = ShiftColor(cFace, &H30, MyButtonType = [Windows XP])

End Sub

Private Sub MakeRegion()


Dim rgn1 As Long, rgn2 As Long

    rgnNorm = CreateRectRgn(0, 0, Wi, He)
    rgn2 = CreateRectRgn(0, 0, 0, 0)

    Select Case MyButtonType
    Case 1, 5, 14
        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
        If MyButtonType <> 5 Then
            rgn1 = CreateRectRgn(0, 0, 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
        End If
    Case 3, 4
        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 13
        DeleteObject rgnNorm
        rgnNorm = CreateEllipticRgn(0, 0, Wi, He)
    End Select

    DeleteObject rgn2

End Sub

Private Sub SetAccessKeys()



Dim ampersandPos As Long

   
    UserControl.AccessKeys = ""

    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
                UserControl.AccessKeys = LCase$(Mid$(elTex, ampersandPos + 1, 1))
            Else
                ampersandPos = InStr(ampersandPos + 2, elTex, "&", vbTextCompare)
                If Mid$(elTex, ampersandPos + 1, 1) <> "&" Then
                    UserControl.AccessKeys = LCase$(Mid$(elTex, ampersandPos + 1, 1))
                End If
            End If
        End If
    End If

End Sub

Private Function ShiftColor(ByVal Color As Long, ByVal Value As Long, Optional isXP As Boolean = False) As Long



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

  
    If isSoft Then Value = Value \ 2

    If Not isXP 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

    If Value > 0 Then
        If Red > 255 Then Red = 255
        If Green > 255 Then Green = 255
        If Blue > 255 Then Blue = 255
    ElseIf Value < 0 Then
        If Red < 0 Then Red = 0
        If Green < 0 Then Green = 0
        If Blue < 0 Then Blue = 0
    End If

   
    ShiftColor = Red + 256& * Green + 65536 * Blue

End Function