sijobutton.ctl

漂亮的vb 程序

                XPFace = ShiftColor(cFace, &H30)
                DrawRectangle 0, 0, Wi, He, cDarkShadow, True
                DrawRectangle 1, 1, Wi - 2, He - 2, ShiftColor(cShadow, -&H40), True
                DrawRectangle 2, 2, Wi - 4, He - 4, ShiftColor(cShadow, -&H20), True
                mSetPixel 2, 2, ShiftColor(cShadow, -&H40)
                mSetPixel 3, 3, ShiftColor(cShadow, -&H20)
                mSetPixel 1, 1, cDarkShadow
                mSetPixel 1, He - 2, cDarkShadow
                mSetPixel Wi - 2, 1, cDarkShadow
                mSetPixel Wi - 2, He - 2, cDarkShadow
                DrawLine Wi - 3, 1, Wi - 3, He - 3, cShadow
                DrawLine 1, He - 3, Wi - 2, He - 3, cShadow
                mSetPixel Wi - 4, He - 4, cShadow
                DrawLine Wi - 2, 3, Wi - 2, He - 2, ShiftColor(cShadow, -&H10)
                DrawLine 3, He - 2, Wi - 2, He - 2, ShiftColor(cShadow, -&H10)
                DrawLine Wi - 2, He - 3, Wi - 4, He - 1, ShiftColor(cShadow, -&H20)
                mSetPixel 2, He - 2, ShiftColor(cShadow, -&H20)
                mSetPixel Wi - 2, 2, ShiftColor(cShadow, -&H20)
            Case 5 'Java
                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
                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 'Netscape
                Call DrawCaption(2)
                DrawFrame cShadow, ShiftColor(cLight, &H8), cShadow, ShiftColor(cLight, &H8), False
                Call DrawFocusR
             Case 7, 8, 12 'Flat buttons
                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 'Office XP
                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 'transparent
                BitBlt hdc, 0, 0, Wi, He, pDC, 0, 0, vbSrcCopy
                Call DrawCaption(2)
                Call DrawFocusR
            Case 13 'Oval
                DrawEllipse 0, 0, Wi, He, cDarkShadow, ShiftColor(cFace, -&H20)
                Call DrawCaption(2)
            Case 14 'KDE 2
                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
'#~#~#~#~#~# DISABLED STATUS #~#~#~#~#~#
    Select Case MyButtonType
        Case 1 'Windows 16-bit
            Call DrawCaption(3)
            DrawFrame cHighLight, cShadow, cHighLight, cShadow, True
            DrawRectangle 0, 0, Wi, He, cDarkShadow, True
        Case 2 'Windows 32-bit
            Call DrawCaption(3)
            DrawFrame cHighLight, cDarkShadow, cLight, cShadow, False
        Case 3 'Windows XP
            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 'Mac
            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 'Java
            Call DrawCaption(4)
            DrawRectangle 0, 0, Wi, He, cShadow, True
        Case 6 'Netscape
            Call DrawCaption(4)
            DrawFrame ShiftColor(cLight, &H8), cShadow, ShiftColor(cLight, &H8), cShadow, False
        Case 7, 8, 12, 13 'Flat buttons
            Call DrawCaption(3)
            If MyButtonType = [Simple Flat] Then DrawFrame cHighLight, cShadow, 0, 0, False, True
        Case 9 'Office XP
            Call DrawCaption(4)
        Case 11 'transparent
            BitBlt hdc, 0, 0, Wi, He, pDC, 0, 0, vbSrcCopy
            Call DrawCaption(3)
        Case 14 'KDE 2
            stepXP1 = 58 / He
            For i = 1 To He
                DrawLine 0, i, Wi, i, ShiftColor(cHighLight, -stepXP1 * i)
            Next
            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)
'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

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)
'a fast way to draw lines
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)
'a very fast way to draw windows-like frames
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()
'this function sets the colors taken as a base to build
'all the other colors and styles.

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) 'it should be 3F but it looks too lighter
    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
'if MyColorType is 1 or has not been set then use windows colors
    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()
'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, 5, 14 'Windows 16-bit, Java & KDE 2
        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  'the above was common code
            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 '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 13
        DeleteObject rgnNorm
        rgnNorm = CreateEllipticRgn(0, 0, Wi, He)
End Select

DeleteObject rgn2
End Sub

Private Sub SetAccessKeys()
'this is a TRUE access keys parser
'the basic rule is that if an ampersand is followed by another,