xpbutton.ctl

超市的管理与及时的维护

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

Private Sub CalculateBoundingRects(adjWidth As Long, bFullRecalc As Boolean, Optional lEdge As Long)

' 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, iEdge 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)
    rEdge = ScaleWidth
    adjWidth = ScaleWidth - lEdge
Case lv_FullDiagonal
    lEdge = myProps.bSegPts.x - (myProps.bSegPts.x \ 3)
    rEdge = myProps.bSegPts.y + ((ScaleWidth - myProps.bSegPts.y) \ 3)
    adjWidth = rEdge - lEdge
Case Else
    adjWidth = myProps.bSegPts.y
    rEdge = ScaleWidth
End Select
' return variables to drawing switchboard
If Not bFullRecalc Then Exit Sub

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 - 12 - (myImage.Size * Abs(CInt(bImgWidthAdj)))
    cRect.Bottom = ScaleHeight - 12 - (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
    'Modify for Chinese
       'th = UserControl.TextHeight("gW")
       'th = UserControl.TextWidth("W")
       'tn = LenB(StrConv(elTex, vbFromUnicode))

    DrawText ButtonDC.hDC, sCaption, LenB(StrConv(sCaption, vbFromUnicode)), 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 + 6 + (Abs(CInt(imgOffset.Left > 0) * 6)), 0
    Case vbRightJustify
        OffsetRect tRect, rEdge - imgOffset.Right - 6 - cRect.Right - (Abs(CInt(imgOffset.Right > 0) * 6)), 0
    Case vbCenter
        If imgOffset.Left > 0 And myImage.Align = lv_LeftOfCaption Then
            OffsetRect tRect, (adjWidth - (imgOffset.Left + cRect.Right + 6)) \ 2 + lEdge + 6 + imgOffset.Left, 0
        Else
            If imgOffset.Right > 0 And myImage.Align = lv_RightOfCaption Then
                OffsetRect tRect, (adjWidth - (imgOffset.Right + cRect.Right + 6)) \ 2 + lEdge, 0
            Else
                OffsetRect tRect, ((adjWidth - (imgOffset.Left + imgOffset.Right)) - cRect.Right) \ 2 + lEdge + imgOffset.Left, 0
            End If
        End If
    End Select
Else
    cRect.Bottom = -3
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 + 6
    Case lv_LeftOfCaption
        If Len(myProps.bCaption) Then
            iRect.Left = tRect.Left - 6 - imgOffset.Left
        Else
            iRect.Left = lEdge + 6
        End If
    Case lv_RightOfCaption
        If Len(myProps.bCaption) Then
            iRect.Left = tRect.Right + 6
        Else
            iRect.Left = rEdge - 6 - imgOffset.Right
        End If
    Case lv_RightEdge
        iRect.Left = rEdge - 6 - 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 + 3
        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
' sanity checks
If tRect.Top < 6 Then tRect.Top = 6
If tRect.Left < 6 Then tRect.Left = 6
If tRect.Right > rEdge Then tRect.Right = rEdge
If tRect.Bottom > ScaleHeight - 6 Then tRect.Bottom = ScaleHeight - 6
myProps.bRect = tRect
If iRect.Top < 6 Then iRect.Top = 6
If iRect.Left < 6 Then iRect.Left = 6
If iRect.Right > rEdge Then iRect.Right = rEdge
If iRect.Bottom > ScaleHeight - 6 Then iRect.Bottom = ScaleHeight - 6
myImage.iRect = iRect
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&))
        GetGDIMetrics "Font"
    End If
    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, rgnB As Long, rgn2Use 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
rgnB = CreateRectRgn(0, 0, 0, 0)

If ButtonDC.ClipRgn Then
    ' this was set for round buttons
    SelectClipRgn ButtonDC.hDC, 0
    DeleteObject ButtonDC.ClipRgn
    ButtonDC.ClipRgn = 0
End If
Select Case myProps.bShape
  Case lv_Round3D, lv_Round3DFixed, lv_RoundFlat
    rgn2Use = CreateEllipticRgn(0, 0, ScaleWidth + 1, ScaleHeight + 1)
    ButtonDC.ClipRgn = CreateEllipticRgn(2 - Abs(myProps.bShape < lv_RoundFlat), 2 - Abs(myProps.bShape < lv_RoundFlat), ScaleWidth - 1 + Abs(myProps.bShape < lv_RoundFlat), ScaleHeight - 1 + Abs(myProps.bShape < lv_RoundFlat))
  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
    ' 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
        UserControl.Width = ScaleX(Wd, vbPixels, Parent.ScaleMode)
        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