tonypecaobuton.ctl

用vb做的防vista的登录界面

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



    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
End Sub

Public Sub DisableRefresh()

 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)


    captOpt = State

    With UserControl
        Select Case State
        Case 0
            txtFX rc
            SetTextColor .hdc, cText
        Case 1
            txtFX rc
            SetTextColor .hdc, cTextO
        Case 2
            txtFX rc2
            If MyButtonType = Mac Then SetTextColor .hdc, cLight Else SetTextColor .hdc, cTextO
            DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
        Case 3
            SetTextColor .hdc, cHighLight
            DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
            SetTextColor .hdc, cShadow
        Case 4
            SetTextColor .hdc, cShadow
        Case 5
            SetTextColor .hdc, ShiftColor(XPFace, -&H68, True)
        Case 6
            SetTextColor .hdc, cHighLight
            DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
            SetTextColor .hdc, cFace
        Case 7
            SetTextColor .hdc, ShiftColor(cShadow, -&H32)
            DrawText .hdc, elTex, Len(elTex), rc2, DT_CENTER
            SetTextColor .hdc, cHighLight
        End Select
       
        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

    With UserControl
        Select Case State
        Case 0
            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
            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
            Select Case MyButtonType
            Case 5, 6, 9
                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
                TransBlt .hdc, picPT.X + 1, picPT.Y + 1, picSZ.X, picSZ.Y, picNormal, cMask, , , True
            Case Else
                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()



    If picNormal Is Nothing And picHover Is Nothing Then Exit Sub

    If (Trim$(elTex) <> "") And (PicPosition <> 4) Then
        Select Case PicPosition
        Case 0
            picPT.X = rc.Left - picSZ.X - 4
            picPT.Y = (He - picSZ.Y) \ 2
        Case 1
            picPT.X = rc.Right + 4
            picPT.Y = (He - picSZ.Y) \ 2
        Case 2
            picPT.X = (Wi - picSZ.X) \ 2
            picPT.Y = rc.Top - picSZ.Y - 2
        Case 3
            picPT.X = (Wi - picSZ.X) \ 2
            picPT.Y = rc.Bottom + 2
        End Select
    Else
        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
        tObj = SelectObject(SrcDC, SrcPic)
    Else
        Dim hBrush As Long
        tObj = SelectObject(SrcDC, CreateCompatibleBitmap(DstDC, DstW, DstH))
        hBrush = CreateSolidBrush(MaskColor)
        DrawIconEx SrcDC, 0, 0, SrcPic.Handle, 0, 0, 0, hBrush, &H1 Or &H2
        DeleteObject hBrush
    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 Sr2DC, Sr2Bmp, 0, DstH, Data2(0), Info, 0

    If BrushColor > 0 Then
        BrushRGB.rgbBlue = (BrushColor \ &H10000) Mod &H100
        BrushRGB.rgbGreen = (BrushColor \ &H100) Mod &H100
        BrushRGB.rgbRed = BrushColor And &HFF
    End If

    If Not useMask Then TransColor = -1

    newW = DstW - 1

    For H = 0 To DstH - 1
        F = H * DstW
        For b = 0 To newW
            i = F + b
            If GetNearestColor(hdc, CLng(Data2(i).rgbRed) + 256& * Data2(i).rgbGreen + 65536 * Data2(i).rgbBlue) <> TransColor Then
                With Data1(i)
                    If BrushColor > -1 Then
                        If MonoMask Then
                            If (CLng(Data2(i).rgbRed) + Data2(i).rgbGreen + Data2(i).rgbBlue) <= 384 Then Data1(i) = BrushRGB
                        Else
                            Data1(i) = BrushRGB
                        End If
                    Else
                        If isGreyscale Then
                            gCol = CLng(Data2(i).rgbRed * 0.3) + Data2(i).rgbGreen * 0.59 + Data2(i).rgbBlue * 0.11
                            .rgbRed = gCol: .rgbGreen = gCol: .rgbBlue = gCol
                        Else
                            If XPBlend Then
                                .rgbRed = (CLng(.rgbRed) + Data2(i).rgbRed * 2) \ 3
                                .rgbGreen = (CLng(.rgbGreen) + Data2(i).rgbGreen * 2) \ 3
                                .rgbBlue = (CLng(.rgbBlue) + Data2(i).rgbBlue * 2) \ 3
                            Else
                                Data1(i) = Data2(i)
                            End If
                        End If
                    End If
                End With
            End If
        Next b
    Next H

    SetDIBitsToDevice DstDC, DstX, DstY, DstW, DstH, 0, 0, 0, DstH, Data1(0), Info, 0

    Erase Data1, Data2
    DeleteObject SelectObject(TmpDC, TmpObj)
    DeleteObject SelectObject(Sr2DC, Sr2Obj)
    If SrcPic.Type = 3 Then DeleteObject SelectObject(SrcDC, tObj)
    DeleteDC TmpDC: DeleteDC Sr2DC
    DeleteObject tObj: DeleteDC SrcDC

End Sub

Private Function isMouseOver() As Boolean

Dim pt As POINTAPI

    GetCursorPos pt
    isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hwnd)

End Function

Private Sub GetParentPic()

    On Local Error Resume Next
    Dim parentDC As Long: parentDC = GetDC(GetParent(hwnd))
    Dim rcP As RECT, rcC As RECT, rcW As RECT, pbW As Long
        inLoop = True
 UserControl.Height = 0
        DoEvents
  GetWindowRect UserControl.hwnd, rcW
        GetWindowRect GetParent(hwnd), rcP
  GetClientRect GetParent(hwnd), rcC
        pbW = ((rcP.Right - rcP.Left) - rcC.Right) \ 2
  BitBlt pDC, 0, 0, Wi, He, parentDC, rcW.Left - rcP.Left - pbW, rcW.Top - rcP.Top - ((rcP.Bottom - rcP.Top) - rcC.Bottom - pbW), vbSrcCopy
        UserControl.Height = ScaleY(He, vbPixels, vbTwips)
   ReleaseDC GetParent(hwnd), parentDC
        inLoop = False
    On Error GoTo 0

End Sub

#If isOCX Then
Public Sub About()

    frmAbout.Show 1

End Sub
#End If