sijobutton.ctl

漂亮的vb 程序

'  a single ampersand is drawn and this is not the access key.
'  So we continue searching for another possible access key.

'   I only do a second pass because no one writes text like "Me & them & everyone"
'   so the caption prop should be "Me && them && &everyone", this is rubbish and a
'   search like this would only waste time
Dim ampersandPos As Long

'we first clear the AccessKeys property, and will be filled if one is found
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 '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))
            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
'this function will add or remove a certain color
'quantity and return the result

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

'this is just a tricky way to do it and will result in weird colors for WinXP and KDE2
If isSoft Then Value = Value \ 2

If Not isXP Then 'for XP button i use a work-aroud that works fine
    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

'a bit of optimization done here, values will overflow a
' byte only in one direction... eg: if we added 32 to our
' color, then only a > 255 overflow can occurr.
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

'more optimization by replacing the RGB function by its correspondent calculation
ShiftColor = Red + 256& * Green + 65536 * Blue
End Function

Private Function ShiftColorOXP(ByVal theColor As Long, Optional ByVal Base As Long = &HB0) As Long
Dim Red As Long, Blue As Long, Green As Long
Dim Delta As Long

Blue = ((theColor \ &H10000) Mod &H100)
Green = ((theColor \ &H100) Mod &H100)
Red = (theColor And &HFF)
Delta = &HFF - Base

Blue = Base + Blue * Delta \ &HFF
Green = Base + Green * Delta \ &HFF
Red = Base + Red * Delta \ &HFF

If Red > 255 Then Red = 255
If Green > 255 Then Green = 255
If Blue > 255 Then Blue = 255

ShiftColorOXP = Red + 256& * Green + 65536 * Blue
End Function

Private Sub CalcTextRects()
'this sub will calculate the rects required to draw the text
Select Case PicPosition
    Case 0
        rc2.Left = 1 + picSZ.X: rc2.Right = Wi - 2: rc2.Top = 1: rc2.Bottom = He - 2
    Case 1
        rc2.Left = 1: rc2.Right = Wi - 2 - picSZ.X: rc2.Top = 1: rc2.Bottom = He - 2
    Case 2
        rc2.Left = 1: rc2.Right = Wi - 2: rc2.Top = 1 + picSZ.Y: rc2.Bottom = He - 2
    Case 3
        rc2.Left = 1: rc2.Right = Wi - 2: rc2.Top = 1: rc2.Bottom = He - 2 - picSZ.Y
    Case 4
        rc2.Left = 1: rc2.Right = Wi - 2: rc2.Top = 1: rc2.Bottom = He - 2
End Select
DrawText UserControl.hdc, elTex, Len(elTex), rc2, DT_CALCRECT Or DT_WORDBREAK
CopyRect rc, rc2: fc.X = rc.Right - rc.Left: fc.Y = rc.Bottom - rc.Top
Select Case PicPosition
    Case 0, 2
        OffsetRect rc, (Wi - rc.Right) \ 2, (He - rc.Bottom) \ 2
    Case 1
        OffsetRect rc, (Wi - rc.Right - picSZ.X - 4) \ 2, (He - rc.Bottom) \ 2
    Case 3
        OffsetRect rc, (Wi - rc.Right) \ 2, (He - rc.Bottom - picSZ.Y - 4) \ 2
    Case 4
        OffsetRect rc, (Wi - rc.Right) \ 2, (He - rc.Bottom) \ 2
End Select
CopyRect rc2, rc: OffsetRect rc2, 1, 1

Call CalcPicPos 'once we have the text position we are able to calculate the pic position
End Sub

Public Sub DisableRefresh()
'this is for fast button editing, once you disable the refresh,
' you can change every prop without triggering the drawing methods.
' once you are done, you call Refresh.
    isShown = False
End Sub

Public Sub Refresh()
    If MyButtonType = 11 Then Call GetParentPic
    Call SetColors
    Call CalcTextRects
    isShown = True
    Call Redraw(lastStat, True)
End Sub

Private Function ConvertFromSystemColor(ByVal theColor As Long) As Long
    Call OleTranslateColor(theColor, 0, ConvertFromSystemColor)
End Function

Private Sub DrawCaption(ByVal State As Byte)
'this code is commonly shared through all the buttons so
' i took it and put it toghether here for easier readability
' of the code, and to cut-down disk size.

captOpt = State

With UserControl
Select Case State 'in this select case, we only change the text color and draw only text that needs rc2, at the end, text that uses rc will be drawn
    Case 0 'normal caption
        txtFX rc
        SetTextColor .hdc, cText
    Case 1 'hover caption
        txtFX rc
        SetTextColor .hdc, cTextO
    Case 2 'down caption
        txtFX rc2
        If MyButtonType = Mac Then SetTextColor .hdc, cLight Else SetTextColor .hdc, cTextO
        DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
    Case 3 'disabled embossed caption
        SetTextColor .hdc, cHighLight
        DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
        SetTextColor .hdc, cShadow
    Case 4 'disabled grey caption
        SetTextColor .hdc, cShadow
    Case 5 'WinXP disabled caption
        SetTextColor .hdc, ShiftColor(XPFace, -&H68, True)
    Case 6 'KDE 2 disabled
        SetTextColor .hdc, cHighLight
        DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
        SetTextColor .hdc, cFace
    Case 7 'KDE 2 down
        SetTextColor .hdc, ShiftColor(cShadow, -&H32)
        DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
        SetTextColor .hdc, cHighLight
End Select
'we now draw the text that is common in all the captions
If State <> 2 Then DrawText .hdc, elTex, Len(elTex), rc, DT_CENTER
End With
End Sub

Private Sub DrawPictures(ByVal State As Byte)

If picNormal Is Nothing Then Exit Sub 'check if there is a main picture, if not then exit

With UserControl
Select Case State
    Case 0 'normal & hover
        If Not isOver Then
            Call DoFX(0, picNormal)
            TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask, , , useGrey, (MyButtonType = [Office XP])
        Else
            If MyButtonType = [Office XP] Then
                Call DoFX(-1, picNormal)
                TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask, cShadow
                TransBlt .hdc, picPT.X - 1, picPT.Y - 1, picSZ.X, picSZ.Y, picNormal, cMask
            Else
                If Not picHover Is Nothing Then
                    Call DoFX(0, picHover)
                    TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picHover, cMask
                Else
                    Call DoFX(0, picNormal)
                    TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask
                End If
            End If
        End If
    Case 1 'down
        If picHover Is Nothing Or MyButtonType = [Office XP] Then
            Select Case MyButtonType
            Case 5, 9
                Call DoFX(0, picNormal)
                TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask
            Case Else
                Call DoFX(1, picNormal)
                TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask
            End Select
        Else
            TransBlt .hdc, picPT.X + Abs(MyButtonType <> [Java metal]), picPT.Y + Abs(MyButtonType <> [Java metal]), picSZ.X, picSZ.Y, picHover, cMask
        End If
    Case 2 'disabled
        Select Case MyButtonType
        Case 5, 6, 9    'draw flat grey pictures
            TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask, Abs(MyButtonType = [Office XP]) * ShiftColor(cShadow, &HD) + Abs(MyButtonType <> [Office XP]) * cShadow, True
        Case 3          'for WinXP draw a greyscaled image
            TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask, , , True
        Case Else       'draw classic embossed pictures
            TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask, cHighLight, True
            TransBlt .hdc, picPT.X, picPT.Y, picSZ.X, picSZ.Y, picNormal, cMask, cShadow, True
        End Select
End Select
End With
If PicPosition = cbBackground Then Call DrawCaption(captOpt)
End Sub

Private Sub DoFX(ByVal offset As Long, ByVal thePic As StdPicture)
If SFX > cbNone Then
    Dim curFace As Long
    If MyButtonType = [Windows XP] Then curFace = XPFace Else If offset = -1 And MyColorType <> Custom Then curFace = OXPf Else curFace = cFace
    TransBlt UserControl.hdc, picPT.X + 1 + offset, picPT.Y + 1 + offset, picSZ.X, picSZ.Y, thePic, cMask, ShiftColor(curFace, Abs(SFX = cbEngraved) * FXDEPTH + (SFX <> cbEngraved) * FXDEPTH)
    If SFX < cbShadowed Then TransBlt UserControl.hdc, picPT.X - 1 + offset, picPT.Y - 1 + offset, picSZ.X, picSZ.Y, thePic, cMask, ShiftColor(curFace, Abs(SFX <> cbEngraved) * FXDEPTH + (SFX = cbEngraved) * FXDEPTH)
End If
End Sub

Private Sub txtFX(ByRef theRect As RECT)
If SFX > cbNone Then
With UserControl
    Dim curFace As Long
    Dim tempR As RECT: CopyRect tempR, theRect: OffsetRect tempR, 1, 1
    Select Case MyButtonType
        Case 3, 4, 14
            curFace = XPFace
        Case Else
            If lastStat = 0 And isOver And MyColorType <> Custom And MyButtonType = [Office XP] Then curFace = OXPf Else curFace = cFace
    End Select
    SetTextColor .hdc, ShiftColor(curFace, Abs(SFX = cbEngraved) * FXDEPTH + (SFX <> cbEngraved) * FXDEPTH)
    DrawText .hdc, elTex, Len(elTex), tempR, DT_CENTER
    If SFX < cbShadowed Then
        OffsetRect tempR, -2, -2
        SetTextColor .hdc, ShiftColor(curFace, Abs(SFX <> cbEngraved) * FXDEPTH + (SFX = cbEngraved) * FXDEPTH)
        DrawText .hdc, elTex, Len(elTex), tempR, DT_CENTER
    End If
End With
End If
End Sub

Private Sub CalcPicSize()
If Not picNormal Is Nothing Then
    picSZ.X = UserControl.ScaleX(picNormal.Width, 8, UserControl.ScaleMode)
    picSZ.Y = UserControl.ScaleY(picNormal.Height, 8, UserControl.ScaleMode)
Else
    picSZ.X = 0: picSZ.Y = 0
End If
End Sub

Private Sub CalcPicPos()
'exit if there's no picture
If picNormal Is Nothing And picHover Is Nothing Then Exit Sub

If (Trim$(elTex) <> "") And (PicPosition <> 4) Then 'if there is no caption, or we have the picture as background, then we put the picture at the center of the button
    Select Case PicPosition
        Case 0 'left
            picPT.X = rc.Left - picSZ.X - 4
            picPT.Y = (He - picSZ.Y) \ 2
        Case 1 'right
            picPT.X = rc.Right + 4
            picPT.Y = (He - picSZ.Y) \ 2
        Case 2 'top
            picPT.X = (Wi - picSZ.X) \ 2
            picPT.Y = rc.Top - picSZ.Y - 2
        Case 3 'bottom
            picPT.X = (Wi - picSZ.X) \ 2
            picPT.Y = rc.Bottom + 2
    End Select
Else 'center the picture
    picPT.X = (Wi - picSZ.X) \ 2
    picPT.Y = (He - picSZ.Y) \ 2
End If
End Sub

Private Sub TransBlt(ByVal DstDC As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstW As Long, ByVal DstH As Long, ByVal SrcPic As StdPicture, Optional ByVal TransColor As Long = -1, Optional ByVal BrushColor As Long = -1, Optional ByVal MonoMask As Boolean = False, Optional ByVal isGreyscale As Boolean = False, Optional ByVal XPBlend As Boolean = False)
    If DstW = 0 Or DstH = 0 Then Exit Sub
        
    Dim B As Long, H As Long, F As Long, i As Long, newW As Long
    Dim TmpDC As Long, TmpBmp As Long, TmpObj As Long
    Dim Sr2DC As Long, Sr2Bmp As Long, Sr2Obj As Long
    Dim Data1() As RGBTRIPLE, Data2() As RGBTRIPLE
    Dim Info As BITMAPINFO, BrushRGB As RGBTRIPLE, gCol As Long
    
    Dim SrcDC As Long, tObj As Long, ttt As Long

    SrcDC = CreateCompatibleDC(hdc)
    
    If DstW < 0 Then DstW = UserControl.ScaleX(SrcPic.Width, 8, UserControl.ScaleMode)
    If DstH < 0 Then DstH = UserControl.ScaleY(SrcPic.Height, 8, UserControl.ScaleMode)
    
    If SrcPic.Type = 1 Then 'check if it's an icon or a bitmap
        tObj = SelectObject(SrcDC, SrcPic)
    Else
        Dim br As RECT, hBrush As Long: br.Right = DstW: br.Bottom = DstH
        ttt = CreateCompatibleBitmap(DstDC, DstW, DstH): tObj = SelectObject(SrcDC, ttt)
        hBrush = CreateSolidBrush(MaskColor): FillRect SrcDC, br, hBrush
        DeleteObject hBrush
        DrawIconEx SrcDC, 0, 0, SrcPic.Handle, 0, 0, 0, 0, &H1 Or &H2
    End If
 
    TmpDC = CreateCompatibleDC(SrcDC)
    Sr2DC = CreateCompatibleDC(SrcDC)
    TmpBmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
    Sr2Bmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
    TmpObj = SelectObject(TmpDC, TmpBmp)
    Sr2Obj = SelectObject(Sr2DC, Sr2Bmp)
    ReDim Data1(DstW * DstH * 3 - 1)
    ReDim Data2(UBound(Data1))
    With Info.bmiHeader
        .biSize = Len(Info.bmiHeader)
        .biWidth = DstW
        .biHeight = DstH
        .biPlanes = 1
        .biBitCount = 24
    End With
    
    BitBlt TmpDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, vbSrcCopy
    BitBlt Sr2DC, 0, 0, DstW, DstH, SrcDC, 0, 0, vbSrcCopy
    GetDIBits TmpDC, TmpBmp, 0, DstH, Data1(0), Info, 0
    GetDIBits Sr2D