2013-06-19 07:54

'  QArrow Ver. 0.01 by Peter Scheutz 1999.09.28
'
'  Feel free to use, extend and modify.
'  Use "as is". No refund if it makes our cat loose it's tale
'
'  Qarrow extends Qcanvs to provide a Arrow shaped button.
'
'  Qarrow has a "Hot" feature, so that color can change when mouse is over the button
'  Hot color is turned ON by the mouse move event, and turned OFF by a timer.
'  The Timer checks if the mouse has gone outside the arrow canvas area.
'  It also has an disabled color, that is used if the canvas is disabled.
'  when toggling the "Enabled" property, be sure to call the arrows "refresh"
'  method to show the color changes.
'
'  Useful Qarrow Properties:
'
'  Orientation 		'see "Qarrow.inc" for orientation constants
'  State As Long		'poll this to get the current state (see "qarrow.inc")
'  ArrowWidth		'Should be aspect 1:2 or 2:1 depending on orientation
'  ArrowHeight
'
'  ArrowColorNormal	'colors for the states' change these in calling code or
'  ArrowColorHot		'directly in "Qarrow.bas" Constructor to make new defaults
'  ArrowColorDown
'  ArrowColorDisabled
'
'  Bevel			'turnes bevel on and off
'
'  Notes: Flickering will occur with large arrows, haven't found a way around this.
'
'  The "MidColor" function can be used in other projects:
'  the syntax is: Color1, Color2, tone (a factor between 0 and 1) 0 means only
'  Color1 and 1 means only Color2


'$INCLUDE "RAPIDQ.INC" '(must be included before you include qarrow bas in calling code)

     $INCLUDE "QARROW.INC"  'constants for Orientation and states

     TYPE QArrow EXTENDS QCANVAS
      Bevel AS LONG
      Orientation AS LONG
      State AS LONG
      ArrowColorNormal AS LONG
      ArrowColorHot AS LONG
      ArrowColorDown AS LONG
      ArrowColorDisabled AS LONG
      OffTimer AS QTIMER

      FUNCTION MidColor(Color1 AS LONG,Color2 AS LONG,tone AS SINGLE) AS LONG
       DIM Red1 AS LONG
       DIM Green1 AS LONG
       DIM Blue1 AS LONG

       DIM Red2 AS LONG
       DIM Green2 AS LONG
       DIM Blue2 AS LONG

       DIM RedMid AS LONG
       DIM GreenMid AS LONG
       DIM BlueMid AS LONG

       Blue1 =   SHR(Color1 AND &HFF0000)  16
       Green1 =  SHR(Color1 AND &HFF00) 8
       Red1 =  (Color1 AND &HFF)

       Blue2=   SHR (Color2 AND &HFF0000) 16
       Green2=  SHR (Color2 AND &HFF00) 8
       Red2=  (Color2 AND &HFF)

       RedMid=(Red1*(1-tone)+Red2*tone) AND  &HFF
       GreenMid=(Green1*(1-tone)+Green2*tone) AND  &HFF
       BlueMid=(Blue1*(1-tone)+Blue2*tone) AND  &HFF

       QArrow.MidColor=RedMid OR (SHL GreenMid  8) OR  (SHL BlueMid 16 )

      END FUNCTION


      SUB DrawComponent
       DIM BevelColorHilight  AS LONG
       DIM BevelColorShadow AS LONG
       DIM nowColor AS LONG

       IF QArrow.Enabled = False THEN
        QArrow.State = -1
       END IF


       SELECT CASE QArrow.State
       CASE asNormal
        nowColor = QArrow.ArrowColorNormal
       CASE asHot
        nowColor = QArrow.ArrowColorHot
       CASE asDown
        nowColor = QArrow.ArrowColorDown
       CASE ELSE
        nowColor = QArrow.ArrowColorDisabled
       END SELECT


       IF QArrow.Bevel=True THEN
        BevelColorHilight=QArrow.MidColor(nowColor,&HFFFFFF,0.7)
        BevelColorShadow=QArrow.MidColor(nowColor,0,0.5)

        IF  QArrow.State=asDown THEN
         SWAP BevelColorHilight,BevelColorShadow
        END IF
       END IF

       SELECT CASE QArrow.Orientation
       CASE aoPointE
        QArrow.line (0,0,QArrow.Width,QArrow.Height/2,nowColor)
        QArrow.line (0,QArrow.Height-1,QArrow.Width,QArrow.Height/2-1,nowColor)
              'QArrow.line (0,0,0,QArrow.Height,nowColor)

        QArrow.Paint QArrow.Width / 2, QArrow.Height / 2, nowColor, nowColor
        IF QArrow.Bevel=True THEN

         QArrow.line (0,0,QArrow.Width,QArrow.Height/2,BevelColorShadow)
         QArrow.line (0,QArrow.Height-1,QArrow.Width,QArrow.Height/2-1,BevelColorShadow)
         QArrow.line (0,0,0,QArrow.Height,BevelColorHilight)

        END IF
       CASE aoPointW
        QArrow.line (QArrow.Width-1,0,-1,QArrow.Height/2,nowColor)
        QArrow.line (QArrow.Width-1,QArrow.Height-1,-1,QArrow.Height/2-1,nowColor)
              'QArrow.line (QArrow.Width-1,0,QArrow.Width-1,QArrow.Height,nowColor)

        QArrow.Paint QArrow.Width / 2, QArrow.Height / 2, nowColor, nowColor

        IF QArrow.Bevel=True THEN
         QArrow.line (QArrow.Width-1,0,-1,QArrow.Height/2,BevelColorHilight)
         QArrow.line (QArrow.Width-1,QArrow.Height-1,-1,QArrow.Height/2-1,BevelColorShadow)
         QArrow.line (QArrow.Width-1,0,QArrow.Width-1,QArrow.Height,BevelColorShadow)
        END IF

       CASE aoPointN
        QArrow.line (0,QArrow.Height-1,QArrow.Width/2,-1,nowColor)
        QArrow.line (QArrow.Width-1,QArrow.Height-1,QArrow.Width/2-1,-1,nowColor)
        QArrow.line (0,QArrow.Height-1,QArrow.Width-1,QArrow.Height-1,nowColor)

        QArrow.Paint QArrow.Width / 2, QArrow.Height / 2, nowColor, nowColor

        IF QArrow.Bevel=True THEN
         QArrow.line (0,QArrow.Height-1,QArrow.Width/2,-1,BevelColorHilight)
         QArrow.line (QArrow.Width-1,QArrow.Height-1,QArrow.Width/2-1,-1,BevelColorShadow)
         QArrow.line (0,QArrow.Height-1,QArrow.Width-1,QArrow.Height-1,BevelColorShadow)

        END IF

       CASE aoPointS
        QArrow.line (0,0,QArrow.Width/2,QArrow.Height,nowColor)
        QArrow.line (QArrow.Width-1,0,QArrow.Width/2-1,QArrow.Height,nowColor)
              'QArrow.line (0,0,QArrow.Width-1,0,nowColor)
        QArrow.Paint QArrow.Width / 2, QArrow.Height / 2, nowColor, nowColor

        IF QArrow.Bevel=True THEN
         QArrow.line (0,0,QArrow.Width/2,QArrow.Height,BevelColorShadow)
         QArrow.line (QArrow.Width-1,0,QArrow.Width/2-1,QArrow.Height,BevelColorShadow)
         QArrow.line (1,0,QArrow.Width-1,0,BevelColorHilight)
        END IF

       END SELECT

      END SUB

      SUB Refresh
       IF QArrow.Enabled = True THEN
        QArrow.State = asNormal
       END IF
       QArrow.DrawComponent
      END SUB

      FUNCTION IsInside(x, y, x1, y1, x2, y2) AS LONG
       QArrow.IsInside = False
       IF x >= x1 AND x <= x2 THEN
        IF y1 >= 0 AND y <= y2 THEN
         QArrow.IsInside = True
        END IF
       END IF
      END FUNCTION


      EVENT OffTimer.OnTimer

       IF QArrow.IsInside(MOUSEX, MOUSEY, 0, 0, QArrow.Width, QArrow.Height) = False THEN
        QArrow.State = asNormal
        QArrow.DrawComponent
        QArrow.OffTimer.Enabled = False
       END IF

      END EVENT
      EVENT OnPaint
       QArrow.DrawComponent
      END EVENT
      EVENT OnMouseDown

       IF QArrow.State <> asDown THEN
        QArrow.State = asDown
        QArrow.DrawComponent
       END IF

      END EVENT
      EVENT OnMouseUp
       IF QArrow.State = asDown THEN
        QArrow.State = asHot
        QArrow.DrawComponent
       END IF

      END EVENT
      EVENT OnMouseMove
       IF QArrow.IsInside(MOUSEX, MOUSEY, 0, 0, QArrow.Width, QArrow.Height) = False THEN
         'QArrow.OffTimer.Enabled=FALSE
       ELSE
        IF QArrow.State <> asHot AND QArrow.State <> asDown THEN
         QArrow.State = asHot
         QArrow.DrawComponent
         QArrow.OffTimer.Enabled = True
        END IF
       END IF
      END EVENT

      CONSTRUCTOR
       Bevel=True
       State = asNormal
       Orientation = aoPointE
       ArrowColorNormal = &HB0E0
       ArrowColorHot = &HD0F0
       ArrowColorDown = &HF0
       ArrowColorDisabled = &H999999
       Width = 25
       Height = 50
       OffTimer.Enabled = False
       OffTimer.Interval = 50

      END CONSTRUCTOR


     END TYPE

2013-06-19 07:54