lvbuttons.ctl

漂亮的vb 程序

' sanity checks
If tRect.Top < 4 Then tRect.Top = 4
If tRect.Left < 4 + lEdge Then tRect.Left = 4 + lEdge
If tRect.Right > rEdge - 4 Then tRect.Right = rEdge - 4
If tRect.Bottom > ScaleHeight - 5 Then tRect.Bottom = ScaleHeight - 5
myProps.bRect = tRect
Select Case myImage.Size
Case Is < 33
    If iRect.Top < 4 Then iRect.Top = 4
    If iRect.Left < 4 + lEdge Then iRect.Left = 4 + lEdge
    If iRect.Right > rEdge - 4 Then iRect.Right = rEdge - 4
    If iRect.Bottom > ScaleHeight - 5 Then iRect.Bottom = ScaleHeight - 5
Case 40 ' stretch
    If myProps.bShape = lv_RoundFlat Then
        SetRect iRect, 1, 1, ScaleWidth - 1, ScaleHeight - 1
    Else
        SetRect iRect, 3, 3, ScaleWidth - 3, ScaleHeight - 3
    End If
    bNormalizeImage = True
Case Else   ' scale
    If myProps.bShape > lv_RoundFlat Then
        SetRect iRect, 0, 0, ScaleWidth, ScaleHeight
    Else
        If (myImage.SourceSize.X + myImage.SourceSize.Y) > 0 Then
            ScaleImage adjWidth - 12, ScaleHeight - 12, cRect.Right, cRect.Bottom
            iRect.Left = (adjWidth - cRect.Right) \ 2 + lEdge
            iRect.Top = (ScaleHeight - cRect.Bottom) \ 2
            iRect.Right = iRect.Left + cRect.Right
            iRect.Bottom = iRect.Top + cRect.Bottom
            bNormalizeImage = True
        End If
    End If
End Select
myImage.iRect = iRect
If bNormalizeImage Then NormalizeImage iRect.Right - iRect.Left, iRect.Bottom - iRect.Top, 0
End Sub

Private Sub GetSetOffDC(bSet As Boolean)

' This sets up our off screen DC & pastes results onto our control.

If bSet = True Then
    If ButtonDC.hDC = 0 Then
        ButtonDC.hDC = CreateCompatibleDC(UserControl.hDC)
        SetBkMode ButtonDC.hDC, 3&
        ' by pulling these objects now, we ensure no memory leaks &
        ' changing the objects as needed can be done in 1 line of code
        ' in the SetButtonColors routine
        ButtonDC.OldBrush = SelectObject(ButtonDC.hDC, CreateSolidBrush(0&))
        ButtonDC.OldPen = SelectObject(ButtonDC.hDC, CreatePen(0&, 1&, 0&))
    End If
    GetGDIMetrics "Font"
    If ButtonDC.OldBitmap = 0 Then
        Dim hBmp As Long
        hBmp = CreateCompatibleBitmap(UserControl.hDC, ScaleWidth, ScaleHeight)
        ButtonDC.OldBitmap = SelectObject(ButtonDC.hDC, hBmp)
    End If
Else
    BitBlt UserControl.hDC, 0, 0, ScaleWidth, ScaleHeight, ButtonDC.hDC, 0, 0, vbSrcCopy
End If
End Sub

Private Sub DrawRect(m_hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, _
                                   ByVal X2 As Long, ByVal Y2 As Long, _
                                   tColor As Long, Optional pColor As Long = -1, _
                                   Optional PenWidth As Long = 0, Optional PenStyle As Long = 0)

' Simple routine to draw a rectangle

If pColor <> -1 Then SetButtonColors True, m_hDC, cObj_Pen, pColor, , PenWidth, , PenStyle
SetButtonColors True, m_hDC, cObj_Brush, tColor, (pColor = -1)
Call Rectangle(m_hDC, X1, Y1, X2, Y2)
End Sub


Private Sub SetButtonColors(bSet As Boolean, m_hDC As Long, TypeObject As ColorObjects, lColor As Long, _
    Optional bSamePenColor As Boolean = True, Optional PenWidth As Long = 1, _
    Optional bSwapPens As Boolean = False, Optional PenStyle As Long = 0)

' This is the basic routine that sets a DC's pen, brush or font color

' here we store the most recent "sets" so we can reset when needed
Dim tBrush As Long, tPen As Long
If bSet Then    ' changing a DC's setting
    Select Case TypeObject
    Case cObj_Brush         ' brush is being changed
        DeleteObject SelectObject(ButtonDC.hDC, CreateSolidBrush(lColor))
        If bSamePenColor Then   ' if the pen color will be the same
            DeleteObject SelectObject(ButtonDC.hDC, CreatePen(PenStyle, PenWidth, lColor))
        End If
    Case cObj_Pen   ' pen is being changed (mostly for drawing lines)
        DeleteObject SelectObject(ButtonDC.hDC, CreatePen(PenStyle, PenWidth, lColor))
    Case cObj_Text  ' text color is changing
        SetTextColor m_hDC, ConvertColor(lColor)
    End Select
Else            ' resetting the DC back to the way it was
    DeleteObject SelectObject(ButtonDC.hDC, ButtonDC.OldBrush)
    DeleteObject SelectObject(ButtonDC.hDC, ButtonDC.OldPen)
End If
End Sub

Private Function ConvertColor(tColor As Long) As Long

' Converts VB color constants to real color values

If tColor < 0 Then
    ConvertColor = GetSysColor(tColor And &HFF&)
Else
    ConvertColor = tColor
End If
End Function

Private Sub CreateButtonRegion()

' this function creates the regions for the specific type of button style

Dim rgnA As Long, rgn2Use As Long, I As Long
Dim lRatio As Single, lEdge As Long, rEdge As Long, Wd As Long
Dim ptTRI(0 To 9) As POINTAPI

myProps.bSegPts.X = 0
myProps.bSegPts.Y = ScaleWidth

SelectClipRgn ButtonDC.hDC, 0
If ButtonDC.ClipRgn Then
    ' this was set for round buttons
    DeleteObject ButtonDC.ClipRgn
    ButtonDC.ClipRgn = 0
End If
If ButtonDC.ClipBorder Then
    DeleteObject ButtonDC.ClipBorder
    ButtonDC.ClipBorder = 0
End If
Select Case myProps.bShape
  Case lv_Custom3DBorder, lv_CustomFlat
        If myImage.SourceSize.X = 0 Or myImage.SourceSize.Y = 0 Then Exit Sub
        Dim tRect As RECT, sRect As RECT, Ht As Long
        On Error GoTo ExitRegionCreator
        ' resize the button to fit the image
        DelayDrawing True
        ScaleImage ScaleWidth, ScaleHeight, Wd, Ht
        UserControl.Size Wd * Screen.TwipsPerPixelX, Ht * Screen.TwipsPerPixelY
        myProps.bSegPts.Y = ScaleWidth
        bNoRefresh = False
        rgn2Use = CreateRectRgn(0, 0, ScaleWidth, ScaleHeight)
        NormalizeImage ScaleWidth, ScaleHeight, rgn2Use ' see routine for notes
        ' now we need to align the regions to our button
        GetRgnBox rgn2Use, sRect
        GetRgnBox ButtonDC.ClipBorder, tRect
        OffsetRgn ButtonDC.ClipBorder, -tRect.Left + sRect.Left + 1, -tRect.Top + sRect.Top + 1
        GetRgnBox ButtonDC.ClipRgn, tRect
        OffsetRgn ButtonDC.ClipRgn, -tRect.Left + sRect.Left + 2, -tRect.Top + sRect.Top + 2
        ' create the outer edge border which won't need to be redrawn every time
        If myProps.bShape = lv_Custom3DBorder Then
            I = myProps.bGradient
            myProps.bGradient = lv_Top2Bottom
            DrawGradient vbWhite, vbGray
            myProps.bGradient = I
        Else
            I = CreateSolidBrush(ConvertColor(curBackColor))
            FrameRgn ButtonDC.hDC, rgn2Use, I, 1, 1
            DeleteObject I
        End If
        SelectClipRgn ButtonDC.hDC, ButtonDC.ClipBorder
  Case lv_Round3D, lv_Round3DFixed, lv_RoundFlat
        rgn2Use = CreateEllipticRgn(0, 0, ScaleWidth, ScaleHeight)
        If myProps.bBackStyle <> 5 Then
            If myProps.bShape < lv_RoundFlat Then
                I = myProps.bGradient
                myProps.bGradient = lv_Top2Bottom
                DrawGradient vbWhite, vbGray
                myProps.bGradient = I
            Else
                I = CreateSolidBrush(0)
                FrameRgn ButtonDC.hDC, rgn2Use, I, 1, 1
                DeleteObject I
            End If
            SelectClipRgn ButtonDC.hDC, ButtonDC.ClipBorder
        End If
        ButtonDC.ClipBorder = CreateEllipticRgn(1, 1, ScaleWidth - 1, ScaleHeight - 1)
        ButtonDC.ClipRgn = CreateEllipticRgn(2, 2, ScaleWidth - 2, ScaleHeight - 2)
  Case lv_Rectangular
    rgn2Use = CreateRectRgn(0, 0, ScaleWidth + 1, ScaleHeight + 1)
    Select Case myProps.bBackStyle
        Case 1 'Windows 16-bit
            GoSub LopOffCorners1
            GoSub LopOffCorners2
        Case 2, 7
            GoSub LopOffCorners3
            GoSub LopOffCorners4
        Case 3    'Java
            If UserControl.Enabled Then
                GoSub LopOffCorners1
                GoSub LopOffCorners2
            End If
    End Select
  
  Case Else ' diagonals
    ' here is my trick for ensuring a sharp edge on diagonal buttons.
    ' Basically a bastardized carpenters formula for right angles
    ' (i.e., 3+4=5 < the hypoteneus). Here I want a 60 degree angle,
    ' and not a 45 degree angle. The difference is sharp or choppy.
    ' Based off of the button height, I need to figure how much of
    ' the opposite end I need to cutoff for the diagonal edge
    lRatio = (ScaleHeight + 1) / 4
    Wd = ScaleWidth
    lEdge = (4 * lRatio)
    ' here we ensure a width of at least 5 pixels wide
    Do While Wd - lEdge < 5
        Wd = Wd + 5
    Loop
    If Wd <> ScaleWidth Then
        ' resize the control if necessary
        DelayDrawing True
        If (TypeOf Parent Is MDIForm) Then
            UserControl.Width = ScaleX(Wd, vbPixels, vbTwips)
        Else
            UserControl.Width = ScaleX(Wd, vbPixels, Parent.ScaleMode)
        End If
        myProps.bSegPts.Y = ScaleWidth
        bNoRefresh = False
    End If
    rEdge = ScaleWidth - lEdge
    ' initial dimensions of our rectangle
    ptTRI(0).X = 0: ptTRI(0).Y = 0
    ptTRI(1).X = 0
    ptTRI(1).Y = ScaleHeight + 1
    ptTRI(2).X = ScaleWidth + 1
    ptTRI(2).Y = ScaleHeight + 1
    ptTRI(3).X = ScaleWidth + 1
    ptTRI(3).Y = 0
    ' now modify the left/right side as needed
    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 edge corners are always sharp,
    ' never rounded.
    rgn2Use = CreatePolygonRgn(ptTRI(0), 4, 2)
    Select Case myProps.bBackStyle
    Case 1      ' Win3.x
        If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners1
        If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners2
    Case 2, 7   ' WinXP, Mac
        If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners3
        If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners4
    Case 3      ' Java
        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
SetWindowRgn UserControl.hwnd, rgn2Use, True
If myProps.bSegPts.Y = 0 Then myProps.bSegPts.Y = ScaleWidth
ExitRegionCreator:
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 rgn2Use, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    rgnA = CreateRectRgn(0, ScaleHeight, 1, ScaleHeight - 1)
    CombineRgn rgn2Use, rgn2Use, 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 rgn2Use, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    rgnA = CreateRectRgn(ScaleWidth, 0, ScaleWidth - 1, 1)
    CombineRgn rgn2Use, rgn2Use, 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 rgn2Use, 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, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
Return
LopOffCorners4: ' right side top/bottom corners (XP/Mac)
    ptTRI(0).X = ScaleWidth: ptTRI