lvbuttons.ctl

漂亮的vb 程序

End Property

Public Property Get hwnd() As Long

' Makes the control's hWnd available at runtime

hwnd = UserControl.hwnd
End Property

' //////////////////// GENERAL FUNCTIONS, PUBLIC \\\\\\\\\\\\\\\\\\\\\
Public Sub Refresh()

' Refreshes the button & can be called from any form/module
bNoRefresh = False
RedrawButton
End Sub

Public Sub DelayDrawing(bDelay As Boolean)

' Used to prevent redrawing button until all properties are set.
' Should you want to set multiple properties of the control during runtime
' call this function first with a TRUE parameter. Set your button
' attributes and then call it again with a FALSE property to update the
' button.   IMPORTANT: If called with a TRUE parameter you must
' also release it with a call and a FALSE parameter

' NOTE: this function will prevent flicker when several properties
' are being changed at once during run time. It is similar to
' the BeginPaint & EndPaint API functionality
bNoRefresh = bDelay
If bDelay = False Then Refresh
End Sub

Private Sub RedrawButton()
' ==================================================
' Main switchboard routine for redrawing a button
' ==================================================
If bNoRefresh = True Then Exit Sub

Dim polyPts(0 To 15) As POINTAPI, polyColors(1 To 12) As Long
Dim ActiveStatus As Integer, ActiveClipRgn As Integer
Select Case myProps.bBackStyle
    Case 0: DrawButton_Win95 polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
    Case 1: DrawButton_Win31 polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
    Case 2: DrawButton_WinXP polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
    Case 3: DrawButton_Java polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
    Case 4: DrawButton_Flat polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
    Case 5: DrawButton_Hover polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
    Case 6: DrawButton_Netscape polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
    Case 7: DrawButton_Macintosh polyPts(), polyColors(), ActiveStatus, ActiveClipRgn
End Select
Dim FocusColor As Long
FocusColor = polyColors(12)
Erase polyPts()
Erase polyColors()
If ActiveClipRgn Then
    GetSetOffDC False    ' copy the offscreen DC onto the control
    ' to help preventing unnecessary border drawing for round/custom buttons
    ' we returned the current clipping region & will draw the focus
    ' rectangles directly on the HDC for these type buttons only
    If ActiveClipRgn > 1 Then
        Dim tRgn As Long
        Select Case myProps.bShape
        Case lv_Custom3DBorder, lv_CustomFlat
            If bTimerActive And ((myProps.bStatus And 6) <> 6) Then       ' hovering, no click
                If myProps.bBackStyle <> 2 Then FocusColor = adjHoverColor
                If myProps.bBackStyle = 2 Or FocusColor <> ConvertColor(curBackColor) Then
                    tRgn = CreateRectRgn(0, 0, 0, 0)
                    GetWindowRgn UserControl.hwnd, tRgn
                End If
            Else
                If ((myProps.bStatus And 1) = 1) Then       ' got the focus
                    If myProps.bShape = lv_Custom3DBorder Then tRgn = ButtonDC.ClipRgn Else tRgn = ButtonDC.ClipBorder
                    If myProps.bValue And myProps.bBackStyle <> 2 Then FocusColor = ShadeColor(adjBackColorDn, -&H20, False)
                End If
            End If
        Case lv_Round3D, lv_Round3DFixed, lv_RoundFlat
            If myProps.bBackStyle = 2 And ((myProps.bStatus And 6) <> 6) Then ' XP, no click
                tRgn = ButtonDC.ClipBorder
            Else
                If myProps.bShape = lv_RoundFlat Then       ' flat round button
                    tRgn = CreateRectRgn(0, 0, 0, 0)
                    GetWindowRgn UserControl.hwnd, tRgn
                End If
            End If
        End Select
        If tRgn Then
            Dim hBrush As Long
            hBrush = CreateSolidBrush(FocusColor)
            FrameRgn UserControl.hDC, tRgn, hBrush, 1, 1
            If tRgn <> ButtonDC.ClipBorder And tRgn <> ButtonDC.ClipRgn Then DeleteObject tRgn
            DeleteObject hBrush
        End If
    End If
    UserControl.Refresh
End If
End Sub

Private Function ToggleOptionButtons(nMode As Integer) As Boolean

' Function tracks option buttons for each container they are placed on
' It will 1) Toggle others to false when one is set to true
'         2) Add or remove option buttons from a collection
'         3) Query option buttons to see if one is set to true

Dim I As Integer, NrCtrls As Integer
Dim myObjRef As Long, tgtObjRef As Long

NrCtrls = GetProp(CLng(Tag), "lv_OptCount")
On Error GoTo OptionToggleError

If myProps.bValue And (NrCtrls > 0 Or nMode = 1) Then
    ' called when an option button is set to True; set others to false
    Dim optControl As lvButtons_H
    myObjRef = ObjPtr(Me)
    For I = 1 To NrCtrls
        tgtObjRef = GetProp(CLng(Tag), "lv_Obj" & I)
        If tgtObjRef <> myObjRef Then
            CopyMemory optControl, tgtObjRef, &H4
            optControl.Value = False
            CopyMemory optControl, 0&, &H4
        End If
    Next
End If
Select Case nMode
Case 1: ' Add instance to window db
    SetProp CLng(Tag), "lv_OptCount", NrCtrls + nMode
    SetProp CLng(Tag), "lv_Obj" & NrCtrls + nMode, ObjPtr(Me)
Case -1: ' Remove instance from window db
    Dim bOffset As Boolean
    myObjRef = ObjPtr(Me)
    For I = 1 To NrCtrls
        tgtObjRef = GetProp(CLng(Tag), "lv_Obj" & I)
        If tgtObjRef = myObjRef Then
            bOffset = -1
        Else
            If bOffset Then SetProp CLng(Tag), "lv_Obj" & I, tgtObjRef
        End If
    Next
    RemoveProp CLng(Tag), "lv_Obj" & I - 1
    If NrCtrls = 1 Then
        RemoveProp CLng(Tag), "lv_OptCount"
    Else
        SetProp CLng(Tag), "lv_OptCount", NrCtrls - 1
    End If
Case 2: ' See if any option buttons have True values
    For I = 1 To NrCtrls
        tgtObjRef = GetProp(CLng(Tag), "lv_Obj" & I)
        CopyMemory optControl, tgtObjRef, &H4
        If optControl.Value = True Then
            I = NrCtrls + 1
            ToggleOptionButtons = True
        End If
        CopyMemory optControl, 0&, &H4
    Next
End Select
Exit Function

OptionToggleError:
Debug.Print "Err in OptionToggle: " & Err.Description
End Function

Friend Sub TimerUpdate(lvTimerID As Long)

' pretty good way to determine when cursor moves outside of any shape region
' especially useful for my diagonal/round buttons since they are not your typical
' rectangular shape.

Dim mousePt As POINTAPI, cRect As RECT
GetCursorPos mousePt
If WindowFromPoint(mousePt.X, mousePt.Y) <> UserControl.hwnd Then
    ' when exits button area, kill the timer
    KillTimer UserControl.hwnd, lvTimerID
    myProps.bStatus = myProps.bStatus And Not 4
    bTimerActive = False
    bNoRefresh = False
    RaiseEvent MouseOnButton(False)
    bKeyDown = False
    RedrawButton
End If
End Sub

Private Sub CalculateBoundingRects(bNormalizeImage As Boolean)

' Routine measures and places the rectangles to draw
' the caption and image on the control. The results
' are cached so this routine doesn't need to run
' every time the button is redrawn/painted

Dim cRect As RECT, tRect As RECT, iRect As RECT
Dim imgOffset As RECT, bImgWidthAdj As Boolean, bImgHeightAdj As Boolean
Dim rEdge As Long, lEdge As Long, adjWidth As Long

' calculations needed for diagonal buttons
Select Case myProps.bShape
Case lv_RightDiagonal
    rEdge = myProps.bSegPts.Y + ((ScaleWidth - myProps.bSegPts.Y) \ 3)
    adjWidth = rEdge
Case lv_LeftDiagonal
    lEdge = myProps.bSegPts.X - (myProps.bSegPts.X \ 3) + 3
    rEdge = ScaleWidth
    adjWidth = ScaleWidth - lEdge
Case lv_FullDiagonal
    lEdge = myProps.bSegPts.X - (myProps.bSegPts.X \ 3) + 3
    rEdge = myProps.bSegPts.Y + ((ScaleWidth - myProps.bSegPts.Y) \ 3)
    adjWidth = rEdge - lEdge
Case lv_Custom3DBorder, lv_CustomFlat
    adjWidth = myProps.bSegPts.Y - 3
    rEdge = adjWidth
    lEdge = 3
Case Else
    adjWidth = myProps.bSegPts.Y
    rEdge = ScaleWidth
End Select

If (myImage.SourceSize.X + myImage.SourceSize.Y) > 0 Then
    ' image in use, calculations for image rectangle
    If myImage.Size < 33 Then
        Select Case myImage.Align
        Case lv_LeftEdge, lv_LeftOfCaption
            imgOffset.Left = myImage.Size
            bImgWidthAdj = True
        Case lv_RightEdge, lv_RightOfCaption
            imgOffset.Right = myImage.Size
            bImgWidthAdj = True
        Case lv_TopCenter
            imgOffset.Top = myImage.Size
            bImgHeightAdj = True
        Case lv_BottomCenter
            imgOffset.Bottom = myImage.Size
            bImgHeightAdj = True
        End Select
    End If
End If


If Len(myProps.bCaption) Then
    Dim sCaption As String  ' note: Replace$ not compatible with VB5
    sCaption = Replace$(myProps.bCaption, "||", vbNewLine)
    ' calculate total available button width available for text
    cRect.Right = adjWidth - 8 - (myImage.Size * Abs(CInt(bImgWidthAdj)))
    cRect.Bottom = ScaleHeight - 8 - (myImage.Size * Abs(CInt(bImgHeightAdj = True And myImage.Align > lv_RightOfCaption)))
    ' calculate size of rectangle to hold that text, using multiline flag
    DrawText ButtonDC.hDC, sCaption, Len(sCaption), cRect, DT_CALCRECT Or DT_WORDBREAK
    If myProps.bCaptionStyle Then
        cRect.Right = cRect.Right + 2
        cRect.Bottom = cRect.Bottom + 2
    End If
End If

' now calculate the position of the text rectangle
If Len(myProps.bCaption) Then
    tRect = cRect
    Select Case myProps.bCaptionAlign
    Case vbLeftJustify
        OffsetRect tRect, imgOffset.Left + lEdge + 4 + (Abs(CInt(imgOffset.Left > 0) * 4)), 0
    Case vbRightJustify
        OffsetRect tRect, rEdge - imgOffset.Right - 4 - cRect.Right - (Abs(CInt(imgOffset.Right > 0) * 4)), 0
    Case vbCenter
        If imgOffset.Left > 0 And myImage.Align = lv_LeftOfCaption Then
            OffsetRect tRect, (adjWidth - (imgOffset.Left + cRect.Right + 4)) \ 2 + lEdge + 4 + imgOffset.Left, 0
        Else
            If imgOffset.Right > 0 And myImage.Align = lv_RightOfCaption Then
                OffsetRect tRect, (adjWidth - (imgOffset.Right + cRect.Right + 4)) \ 2 + lEdge, 0
            Else
                OffsetRect tRect, ((adjWidth - (imgOffset.Left + imgOffset.Right)) - cRect.Right) \ 2 + lEdge + imgOffset.Left, 0
            End If
        End If
    End Select
End If
If (myImage.SourceSize.X + myImage.SourceSize.Y) > 0 Then
    ' finalize image rectangle position
    Select Case myImage.Align
    Case lv_LeftEdge
        iRect.Left = lEdge + 4
    Case lv_LeftOfCaption
        If Len(myProps.bCaption) Then
            iRect.Left = tRect.Left - 4 - imgOffset.Left
        Else
            iRect.Left = lEdge + 4
        End If
    Case lv_RightOfCaption
        If Len(myProps.bCaption) Then
            iRect.Left = tRect.Right + 4
        Else
            iRect.Left = rEdge - 4 - imgOffset.Right
        End If
    Case lv_RightEdge
        iRect.Left = rEdge - 4 - imgOffset.Right
    Case lv_TopCenter
        iRect.Top = (ScaleHeight - (cRect.Bottom + imgOffset.Top)) \ 2
        OffsetRect tRect, 0, iRect.Top + 2 + imgOffset.Top
    Case lv_BottomCenter
        iRect.Top = (ScaleHeight - (cRect.Bottom + imgOffset.Bottom)) \ 2 + cRect.Bottom + 4
        OffsetRect tRect, 0, iRect.Top - 2 - cRect.Bottom
    End Select
    If myImage.Align < lv_TopCenter Then
        OffsetRect tRect, 0, (ScaleHeight - cRect.Bottom) \ 2
        iRect.Top = (ScaleHeight - myImage.Size) \ 2
    Else
        iRect.Left = (adjWidth - myImage.Size) \ 2 + lEdge
    End If
    iRect.Right = iRect.Left + myImage.Size
    iRect.Bottom = iRect.Top + myImage.Size
Else
    OffsetRect tRect, 0, (ScaleHeight - cRect.Bottom) \ 2
End If