xpbutton.ctl

超市的管理与及时的维护

    If myProps.bShape = lv_FullDiagonal Or myProps.bShape = lv_LeftDiagonal Then
        ptTRI(1).x = lEdge  ' left portion
        myProps.bSegPts.x = lEdge
    End If
    If myProps.bShape = lv_FullDiagonal Or myProps.bShape = lv_RightDiagonal Then
        ptTRI(3).x = rEdge + 1        ' bottom right
        myProps.bSegPts.y = rEdge
    End If
    ' for rounded corner buttons, we'll take of the corner pixels where appropriate when the
    ' diagonal button is not a fully-segmeneted type. Diagonal edges are always sharp,
    ' never rounded.
    rgn2Use = CreatePolygonRgn(ptTRI(0), 4, 2)
    Select Case myProps.bBackStyle
    Case 1
        If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners1
        If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners2
    Case 2, 7
        If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners3
        If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners4
    Case 3
        If UserControl.Enabled Then
            If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners1
            If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners2
        End If
    End Select
End Select
Erase ptTRI
If rgnA Then DeleteObject rgnA
If rgnB Then DeleteObject rgnB
SetWindowRgn UserControl.hwnd, rgn2Use, True
If myProps.bSegPts.y = 0 Then myProps.bSegPts.y = ScaleWidth
Exit Sub

LopOffCorners1: ' left side top/bottom corners (Java/Win3.x)
    If myProps.bBackStyle = 3 Then
        rgnA = CreateRectRgn(0, ScaleHeight, 1, ScaleHeight - 1)
    Else
        rgnA = CreateRectRgn(0, 0, 1, 1)
    End If
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    rgnA = CreateRectRgn(0, ScaleHeight, 1, ScaleHeight - 1)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
    Return
LopOffCorners2: ' right side top/bottom corners (Java/Win3.x)
    If myProps.bBackStyle = 3 Then
        rgnA = CreateRectRgn(ScaleWidth, 0, ScaleWidth - 1, 1)
    Else
        rgnA = CreateRectRgn(ScaleWidth, ScaleHeight, ScaleWidth - 1, ScaleHeight - 1)
    End If
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    rgnA = CreateRectRgn(ScaleWidth, 0, ScaleWidth - 1, 1)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
    Return
LopOffCorners3: ' left side top/bottom corners (XP/Mac)
    ptTRI(0).x = 0: ptTRI(0).y = 0
    ptTRI(1).x = 2: ptTRI(1).y = 0
    ptTRI(2).x = 0: ptTRI(2).y = 2
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    ptTRI(0).x = 0: ptTRI(0).y = ScaleHeight
    ptTRI(1).x = 3: ptTRI(1).y = ScaleHeight
    ptTRI(2).x = 0: ptTRI(2).y = ScaleHeight - 3
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
Return
LopOffCorners4: ' right side top/bottom corners (XP/Mac)
    ptTRI(0).x = ScaleWidth: ptTRI(0).y = 0
    ptTRI(1).x = ScaleWidth - 2: ptTRI(1).y = 0
    ptTRI(2).x = ScaleWidth: ptTRI(2).y = 2
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    ptTRI(0).x = ScaleWidth: ptTRI(0).y = ScaleHeight
    ptTRI(1).x = ScaleWidth - 3: ptTRI(1).y = ScaleHeight
    ptTRI(2).x = ScaleWidth: ptTRI(2).y = ScaleHeight - 3
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
Return
End Sub

Private Sub DrawTransparentBitmap(lHDCdest As Long, destRect As RECT, _
                                                    lBMPsource As Long, bmpRect As RECT, _
                                                    Optional lMaskColor As Long = -1, _
                                                    Optional lNewBmpCx As Long, _
                                                    Optional lNewBmpCy As Long)
Const DSna = &H220326 '0x00220326
' =====================================================================
' A pretty good transparent bitmap maker I use in several projects
' Modified here to remove stuff I wont use (i.e., Flipping/Rotating images)
' =====================================================================

    Dim lMask2Use As Long 'COLORREF
    Dim lBmMask As Long, lBmAndMem As Long, lBmColor As Long
    Dim lBmObjectOld As Long, lBmMemOld As Long, lBmColorOld As Long
    Dim lHDCMem As Long, lHDCscreen As Long, lHDCsrc As Long, lHDCMask As Long, lHDCcolor As Long
    Dim x As Long, y As Long, srcX As Long, srcY As Long
    Dim lRatio(0 To 1) As Single
    Dim hPalOld As Long, hPalMem As Long
    
    lHDCscreen = GetDC(0&)
    lHDCsrc = CreateCompatibleDC(lHDCscreen)     'Create a temporary HDC compatible to the Destination HDC
    SelectObject lHDCsrc, lBMPsource             'Select the bitmap

        srcX = lNewBmpCx                  'Get width of bitmap
        srcY = lNewBmpCy                 'Get height of bitmap
        
        If bmpRect.Right = 0 Then bmpRect.Right = srcX Else srcX = bmpRect.Right - bmpRect.Left
        If bmpRect.Bottom = 0 Then bmpRect.Bottom = srcY Else srcY = bmpRect.Bottom - bmpRect.Top
        
        If (destRect.Right) = 0 Then x = lNewBmpCx Else x = (destRect.Right - destRect.Left)
        If (destRect.Bottom) = 0 Then y = lNewBmpCy Else y = (destRect.Bottom - destRect.Top)
        If lNewBmpCx > x Or lNewBmpCy > y Then
            lRatio(0) = (x / lNewBmpCx)
            lRatio(1) = (y / lNewBmpCy)
            If lRatio(1) < lRatio(0) Then lRatio(0) = lRatio(1)
            lNewBmpCx = lRatio(0) * lNewBmpCx
            lNewBmpCy = lRatio(0) * lNewBmpCy
            Erase lRatio
        End If
    
    lMask2Use = ConvertColor(GetPixel(lHDCsrc, 0, 0))
    
    'Create some DCs & bitmaps
    lHDCMask = CreateCompatibleDC(lHDCscreen)
    lHDCMem = CreateCompatibleDC(lHDCscreen)
    lHDCcolor = CreateCompatibleDC(lHDCscreen)
    
    lBmColor = CreateCompatibleBitmap(lHDCscreen, srcX, srcY)
    lBmAndMem = CreateCompatibleBitmap(lHDCscreen, x, y)
    lBmMask = CreateBitmap(srcX, srcY, 1&, 1&, ByVal 0&)
    
    lBmColorOld = SelectObject(lHDCcolor, lBmColor)
    lBmMemOld = SelectObject(lHDCMem, lBmAndMem)
    lBmObjectOld = SelectObject(lHDCMask, lBmMask)
    
    ReleaseDC 0&, lHDCscreen
    
' ====================== Start working here ======================
    
    SetMapMode lHDCMem, GetMapMode(lHDCdest)
    hPalMem = SelectPalette(lHDCMem, 0, True)
    RealizePalette lHDCMem
    
    BitBlt lHDCMem, 0&, 0&, x, y, lHDCdest, destRect.Left, destRect.Top, vbSrcCopy
    
    
    hPalOld = SelectPalette(lHDCcolor, 0, True)
    RealizePalette lHDCcolor
    SetBkColor lHDCcolor, GetBkColor(lHDCsrc)
    SetTextColor lHDCcolor, GetTextColor(lHDCsrc)
    
    BitBlt lHDCcolor, 0&, 0&, srcX, srcY, lHDCsrc, bmpRect.Left, bmpRect.Top, vbSrcCopy
    
    SetBkColor lHDCcolor, lMask2Use
    SetTextColor lHDCcolor, vbWhite
    
    BitBlt lHDCMask, 0&, 0&, srcX, srcY, lHDCcolor, 0&, 0&, vbSrcCopy
    
    SetTextColor lHDCcolor, vbBlack
    SetBkColor lHDCcolor, vbWhite
    BitBlt lHDCcolor, 0, 0, srcX, srcY, lHDCMask, 0, 0, DSna

    StretchBlt lHDCMem, 0, 0, lNewBmpCx, lNewBmpCy, lHDCMask, 0&, 0&, srcX, srcY, vbSrcAnd
    
    StretchBlt lHDCMem, 0&, 0&, lNewBmpCx, lNewBmpCy, lHDCcolor, 0, 0, srcX, srcY, vbSrcPaint
    
    BitBlt lHDCdest, destRect.Left, destRect.Top, x, y, lHDCMem, 0&, 0&, vbSrcCopy
    
    'Delete memory bitmaps & DCs
    DeleteObject SelectObject(lHDCcolor, lBmColorOld)
    DeleteObject SelectObject(lHDCMask, lBmObjectOld)
    DeleteObject SelectObject(lHDCMem, lBmMemOld)
    DeleteDC lHDCMem
    DeleteDC lHDCMask
    DeleteDC lHDCcolor
    DeleteDC lHDCsrc
End Sub

Private Sub DrawButtonIcon(iRect As RECT, adjWidth As Long, lEdge As Long)

' Routine will draw the button image

If (myImage.SourceSize.x + myImage.SourceSize.y) = 0 Then Exit Sub

Dim lImgCopy As Long
Dim imgWidth As Long, imgHeight As Long
Dim rcImage As RECT, dRect As RECT
Dim bIsDown As Boolean
Const MAGICROP = &HB8074A

bIsDown = (myImage.iRect.Left <> iRect.Left)
If myImage.Size < 33 Then   ' 16, 24, 32
    imgWidth = myImage.Size
    imgHeight = myImage.Size
Else
    If myImage.Size = 40 Then   ' strectch
        iRect.Left = Abs(CInt(bIsDown))
        iRect.Top = Abs(CInt(bIsDown))
        iRect.Right = ScaleWidth
        iRect.Bottom = ScaleHeight
        imgWidth = ScaleWidth + CInt(bIsDown)
        imgHeight = ScaleHeight + CInt(bIsDown)
    Else ' scale up/down
        Dim ratio(0 To 1) As Single
        ratio(0) = (adjWidth - 12) / myImage.SourceSize.x
        ratio(1) = (ScaleHeight - 12) / myImage.SourceSize.y
        If ratio(1) < ratio(0) Then ratio(0) = ratio(1)
        ratio(1) = myImage.SourceSize.y * ratio(0)
        ratio(0) = myImage.SourceSize.x * ratio(0)
        iRect.Left = (adjWidth - CLng(ratio(0))) \ 2 + lEdge + Abs(CInt(bIsDown))
        iRect.Top = (ScaleHeight - CLng(ratio(1))) \ 2 + Abs(CInt(bIsDown))
        iRect.Right = iRect.Left + CLng(ratio(0))
        iRect.Bottom = iRect.Top + CLng(ratio(1))
        imgWidth = CLng(ratio(0))
        imgHeight = CLng(ratio(1))
        Erase ratio
    End If
End If
lImgCopy = CopyImage(myImage.Image.Handle, myImage.Type, imgWidth, imgHeight, 0)
If lImgCopy = 0 Then Exit Sub
' destination rectangle for drawing on the DC
dRect = iRect

Dim hMemDC As Long
If UserControl.Enabled Then
    hMemDC = ButtonDC.hDC
Else
    Dim hBitmap As Long, hOldBitmap As Long
    Dim hOldBrush As Long
    Dim hOldBackColor As Long, hbrShadow As Long, hbrHilite As Long
    
    ' Create a temporary DC and bitmap to hold the image
    hMemDC = CreateCompatibleDC(ButtonDC.hDC)
    hBitmap = CreateCompatibleBitmap(ButtonDC.hDC, imgWidth + 1, imgHeight + 1)
    hOldBitmap = SelectObject(hMemDC, hBitmap)
    PatBlt hMemDC, 0, 0, imgWidth, imgHeight, WHITENESS
    OffsetRect dRect, -dRect.Left, -dRect.Top
End If
    
    If myImage.Type = CI_ICON Then
        ' draw icon directly onto the temporary DC
        ' for icons, we can draw directly on the destination DC
        DrawIconEx hMemDC, dRect.Left, dRect.Top, lImgCopy, 0, 0, 0, 0, &H3
    Else
        ' draw transparent bitmap onto the temporary DC
        DrawTransparentBitmap hMemDC, dRect, lImgCopy, rcImage, , CLng(imgWidth), CLng(imgHeight)
    End If
  
If UserControl.Enabled = False Then
    hOldBackColor = SetBkColor(ButtonDC.hDC, vbWhite)
    hbrHilite = CreateSolidBrush(ShadeColor(&HC0C0C0, 36, False))
    hbrShadow = CreateSolidBrush(ShadeColor(&HC0C0C0, -36, False))
    hOldBrush = SelectObject(ButtonDC.hDC, hbrHilite)
    BitBlt ButtonDC.hDC, iRect.Left - 1, iRect.Top - 1, imgWidth, imgHeight, hMemDC, 0, 0, MAGICROP
    SelectObject ButtonDC.hDC, hbrShadow
    BitBlt ButtonDC.hDC, iRect.Left, iRect.Top, imgWidth, imgHeight, hMemDC, 0, 0, MAGICROP
  
    SetBkColor ButtonDC.hDC, hOldBackColor
    SelectObject ButtonDC.hDC, hOldBrush
    SelectObject hMemDC, hOldBitmap
    DeleteObject hbrHilite
    If hbrShadow Then DeleteObject hbrShadow
    DeleteObject hBitmap
    DeleteDC hMemDC
End If
If myImage.Type = CI_ICON Then DestroyIcon lImgCopy Else DeleteObject lImgCopy
End Sub

Private Function ShadeColor(lColor As Long, shadeOffset As Integer, lessBlue As Boolean, _
    Optional bFocusRect As Boolean, Optional bInvert As Boolean) As Long

' Basically supply a value between -255 and +255. Positive numbers make
' the passed color lighter and negative numbers make the color darker

Dim valRGB(0 To 2) As Integer, i As Integer

CalcNewColor:
valRGB(0) = (lColor And &HFF) + shadeOffset
valRGB(1) = ((lColor And &HFF00&) / 255&) + shadeOffset
If lessBlue Then
    valRGB(2) = (lColor And &HFF0000) / &HFF00&
    valRGB(2) = valRGB(2) + ((valRGB(2) * CLng(shadeOffset)) \ &HC0)
Else
    valRGB(2) = (lColor And &HFF0000) / &HFF00& + shadeOffset
End If

For i = 0 To 2
    If valRGB(i) > 255 Then valRGB(i) = 255
    If valRGB(i) < 0 Then valRGB(i) = 0
    If bInvert = True Then valRGB(i) = Abs(255 - valRGB(i))
Next
ShadeColor = valRGB(0) + 256& * valRGB(1) + 65536 * valRGB(2)
Erase valRGB

If bFocusRect = True And (ShadeColor = vbBlack Or ShadeColor = vbWhite) Then
    shadeOffset = -shadeOffset
    If shadeOffset = 0 Then shadeOffset = 64
    GoTo CalcNewColor
End If
End Function

Private Sub GetGDIMetrics(sObject As String)

' This routine caches information we don't want to keep gathering every time a button is redrawn.

Select Case sObject
Case "Font"
    '