It is currently Thu Jul 09, 2020 3:02 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 4 posts ] 
Author Message
 Post subject: Canvas SlideBar (TrackBar) Crossplatform, DPI Aware, OOP
PostPosted: Mon Jul 31, 2017 6:12 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Apr 26, 2003 2:49 pm
Posts: 677
I got frustated with the current trackbar so i did this, is more like a progress bar with a slider like the ones you see in media players:
Image
It does not support negative values i don't need them but it can be implemented.
All drawing is done with vector graphics, it's dpi aware(i hope) tested on windows and linux and looks the same, not tested on mac. I haven't messed with dpi fonts yet.
It has a custom drawing interface, you can alter the thumb and channel dimensions, some styles and keyboard and mouse interface.
The channel is rectangular but with custom drawing could be rounded the tricky part is to fill the channel with the rounded edges, for someone with experience should be easy.
Reports all kind of events.
The code is large but very easy to use.
To do, maybe add rectangular slider and channel text.
There are 3 little helper modules enum.pb, drawing.pb and DPI.pb.
And Slidebar.pb wich inherits from guiGadget.pb.

enum.pb:
Code:
DeclareModule enum
   Macro HasFlag(value, flag)
      Bool((value) & (flag) = flag)
   EndMacro
   
   Declare PutFlag(*value.INTEGER, flag.i)
   Declare RemoveFlag(*value.INTEGER, flag.i)
   Declare FixExclusiveFlags(*value.INTEGER, defFlag.i, flag.i)
EndDeclareModule

Module enum
   Procedure PutFlag(*value.INTEGER, flag.i)
      *value\i | flag
   EndProcedure
   
   Procedure RemoveFlag(*value.INTEGER, flag.i)
      *value\i & ~flag
   EndProcedure
   
   ;Ensures that two mutually exclusive flags are not set leaving only the default one.
   Procedure FixExclusiveFlags(*value.INTEGER, defFlag.i, flag.i)
      If HasFlag(*value\i, defFlag | flag) ;Both flags are set.
         RemoveFlag(*value, flag)
         
      ;One or none
      Else
         If Not(HasFlag(*value\i, defFlag)) And Not(HasFlag(*value\i, flag))
            PutFlag(*value, defFlag)
            
         Else
            ;Leave the current flag.
            
         EndIf
      EndIf
   EndProcedure
EndModule


drawing.pb:
Code:
DeclareModule Drawing
   ;-RectangleD
   Structure RectangleD
      X.d
      Y.d
      Width.d
      Height.d
   EndStructure
   
   Macro PointInCircle(x, y, centerX, centerY, radius)
      Bool(Pow((x) - (centerX), 2) + Pow((y) - (centerY), 2) <= Pow((radius), 2))
   EndMacro
   
   ;Only flat rectangles without orientation.
   Macro PointInRect1(x, y, rLeft, rTop, rRight, rBottom)
      Bool(x >= rLeft And x <= rRight And y >= rTop And y <= rBottom)
   EndMacro
   
   Macro PointInRect2(x, y, rLeft, rTop, rWidth, rHeight)
      Bool(x >= rLeft And x <= (rLeft) + (rWidth) And y >= rTop And y <= (rTop) + (rHeight))
   EndMacro
EndDeclareModule

Module Drawing
EndModule


DPI.pb:
Code:
DeclareModule DPI
   Global.f g_ScaleX, g_ScaleY, g_DPIX, g_DPIY
   
   Macro ScaleX(x)
      ((x) * DPI::g_ScaleX)
   EndMacro
   
   Macro ScaleY(y)
      ((y) * DPI::g_ScaleY)
   EndMacro
   
   Macro PointToPxX(point)
      (((point) * DPI::g_DPIX) / 72)
   EndMacro
   
   Macro PointToPxY(point)
      (((point) * DPI::g_DPIY) / 72)
   EndMacro
   
   Macro PxToPointX(pixel)
      (((pixel) * 72) / DPI::g_DPIX)
   EndMacro
   
   Macro PxToPointY(pixel)
      (((pixel) * 72) / DPI::g_DPIY)
   EndMacro
   
   Macro PxToDipX(x)
      ((x) / DPI::g_ScaleX)
   EndMacro
   
   Macro PxToDipY(y)
      ((y) / DPI::g_ScaleY)
   EndMacro
   
   Macro DipToPxX(x)
      ((x) * DPI::g_ScaleX)
   EndMacro
   
   Macro DipToPxY(y)
      ((y) * DPI::g_ScaleY)
   EndMacro
   
   Declare ScaleRect(*x.INTEGER, *y.INTEGER, *width.INTEGER, *height.INTEGER)
   
   Declare Init()
EndDeclareModule

Module DPI
   EnableExplicit
      
   #DefaultDPIX = 96.0
   #DefaultDPIY = 96.0
   
   g_ScaleX = 1.0
   g_ScaleY = 1.0
   
   Procedure ScaleRect(*x.INTEGER, *y.INTEGER, *width.INTEGER, *height.INTEGER)
      *x\i = ScaleX(*x\i)
      *y\i = ScaleY(*Y\i)
      *width\i = ScaleX(*width\i)
      *height\i = ScaleY(*height\i)
   EndProcedure
   
   Procedure Init()      
      Define.i img
      Define.b result
      
      result = #False
      img = CreateImage(#PB_Any, 1, 1)
      
     If StartVectorDrawing(ImageVectorOutput(img))
        g_DPIX = VectorResolutionX()
        g_DPIY = VectorResolutionY()
        
        g_ScaleX = g_DPIX / #DefaultDPIX
        g_ScaleY = g_DPIY / #DefaultDPIY
        StopVectorDrawing()
        
        result = #True
      EndIf
      
      FreeImage(img)
 
     CompilerIf #PB_Compiler_OS = #PB_OS_Windows
        Define.i user32, SetProcessDPIAware
        
        user32 = OpenLibrary(#PB_Any, "user32.dll")
        If user32
           SetProcessDPIAware = GetFunction(user32, "SetProcessDPIAware")
         If SetProcessDPIAware
            result = CallFunctionFast(SetProcessDPIAware)
         EndIf
         
         CloseLibrary(user32)
      EndIf
    CompilerEndIf
   
    ProcedureReturn result
   EndProcedure
EndModule


guiGadget.pb:
Code:
;Base class for all gadgets.

XIncludeFile "enum.pb"
XIncludeFile "DPI.pb"

DeclareModule guiGadget
   Enumeration
      #UNITS_PIXELS
      #UNITS_DIPS
   EndEnumeration
   
   ;- ENUM FLAGS
   EnumerationBinary
      #FLAG_DISABLED
      #FLAG_HIDDEN
   EndEnumeration
   
   ;- Event
   Structure Event
      Type.w
   EndStructure
   
   ;- PROTOTYPES
   Prototype EventCallbackProto(this.i, *event.Event)
      
   ;- GADGET_VT
   Structure GADGET_VT
      Free.i
      Resize.i
      SetData.i
      GetData.i
      GetX.i
      GetY.i
      GetWidth.i
      GetHeight.i
      Disable.i
      IsDisabled.i
      Hide.i
      IsHidden.i
      IsGadget.i
      GetType.i
      Activate.i
      SetFont.i
      GetFont.i
      BindEvent.i
      GetID.i
      SetToolTip.i
      SetEventCallback.i
      GetEventCallback.i
   EndStructure
   Global.GADGET_VT g_GADGET_VT
   
   ;- GADGET_OBJ
   Structure GADGET_OBJ
      VT.i
      Gadget.i
      UserData.i
      Flags.i
      EventCallback.EventCallbackProto
   EndStructure
   
   ;- IGadget
   Interface IGadget
      Free()
      Resize(x.i, y.i, width.i, height.i)
      SetData(userData.i)
      GetData()
      GetX()
      GetY()
      GetWidth(mode.i = #PB_Gadget_ActualSize)
      GetHeight(mode.i = #PB_Gadget_ActualSize)
      Disable(state.i)
      IsDisabled()
      Hide(state.i)
      IsHidden()
      IsGadget()
      GetType()
      Activate()
      SetFont(fontID.i)
      GetFont()
      BindEvent(callBack.i, eventType.i)
      GetID()
      SetToolTip(text.s)
      SetEventCallback(ec.EventCallbackProto)
      GetEventCallback()
   EndInterface
   
   Macro GetActive()
      GetActiveGadget()
   EndMacro
   
   Macro GetObject(gadget)
      GetGadgetData(gadget)
   EndMacro
   
   Declare Free(*this.GADGET_OBJ)
   Declare CallEvent(*this.GADGET_OBJ, *ev.Event)
EndDeclareModule

Module guiGadget
   EnableExplicit
   
   Procedure CallEvent(*this.GADGET_OBJ, *ev.Event)
      If *this\EventCallback
         *this\EventCallback(*this, *ev)
      EndIf
   EndProcedure
   
   Procedure Free(*this.GADGET_OBJ)
      FreeGadget(*this\Gadget)
      FreeMemory(*this)
   EndProcedure
   
   Procedure Resize(*this.GADGET_OBJ, x.i, y.i, width.i, height.i)
      ResizeGadget(*this\Gadget, x, y, width, height)
   EndProcedure
   
   Procedure SetData(*this.GADGET_OBJ, userData.i)
      *this\UserData = userData
   EndProcedure
   
   Procedure GetData(*this.GADGET_OBJ)
      ProcedureReturn *this\UserData
   EndProcedure
   
   Procedure _GetX(*this.GADGET_OBJ)
      ProcedureReturn GadgetX(*this\Gadget)
   EndProcedure
   
   Procedure _GetY(*this.GADGET_OBJ)
      ProcedureReturn GadgetY(*this\Gadget)
   EndProcedure
   
   Procedure GetWidth(*this.GADGET_OBJ, mode.i = #PB_Gadget_ActualSize)
      ProcedureReturn GadgetWidth(*this\Gadget, mode)
   EndProcedure
   
   Procedure GetHeight(*this.GADGET_OBJ, mode.i = #PB_Gadget_ActualSize)
      ProcedureReturn GadgetHeight(*this\Gadget, mode)
   EndProcedure
   
   Procedure Disable(*this.GADGET_OBJ, state.i)
      DisableGadget(*this\Gadget, state)
      If state = #True
         enum::PutFlag(@*this\Flags, #FLAG_DISABLED)
         
      Else
         enum::RemoveFlag(@*this\Flags, #FLAG_DISABLED)
      EndIf
   EndProcedure
   
   Procedure Hide(*this.GADGET_OBJ, state.i)
      HideGadget(*this\Gadget, state)
      If state = #True
         enum::PutFlag(@*this\Flags, #FLAG_HIDDEN)
         
      Else
         enum::RemoveFlag(@*this\Flags,  #FLAG_HIDDEN)
      EndIf
   EndProcedure
   
   Procedure _IsGadget(*this.GADGET_OBJ)
      ProcedureReturn IsGadget(*this\Gadget)
   EndProcedure
   
   Procedure GetType(*this.GADGET_OBJ)
      ProcedureReturn GadgetType(*this\Gadget)
   EndProcedure
   
   Procedure Activate(*this.GADGET_OBJ)
      SetActiveGadget(*this\Gadget)
   EndProcedure
   
   Procedure SetFont(*this.GADGET_OBJ, fontID.i)
      SetGadgetFont(*this\Gadget, fontID)
   EndProcedure
   
   Procedure GetFont(*this.GADGET_OBJ)
      ProcedureReturn GetGadgetFont(*this\Gadget)
   EndProcedure
   
   Procedure _BindEvent(*this.GADGET_OBJ, callback.i, evType.i)
      BindGadgetEvent(*this\Gadget, callback, evType)
   EndProcedure
   
   Procedure GetID(*this.GADGET_OBJ)
      ProcedureReturn GadgetID(*this\Gadget)
   EndProcedure
   
   Procedure SetToolTip(*this.GADGET_OBJ, text.s)
      GadgetToolTip(*this\Gadget, text.s)
   EndProcedure
   
   Procedure IsDisabled(*this.GADGET_OBJ)
      ProcedureReturn enum::HasFlag(*this\Flags, #FLAG_DISABLED)
   EndProcedure
   
   Procedure SetEventCallback(*this.GADGET_OBJ, ec.EventCallbackProto)
      *this\EventCallback = ec
   EndProcedure
   
   Procedure GetEventCallback(*this.GADGET_OBJ)
      ProcedureReturn *this\EventCallback
   EndProcedure
   
   ;- VTABLE CREATION
   g_GADGET_VT\Free = @Free()
   g_GADGET_VT\Resize = @Resize()
   g_GADGET_VT\SetData = @SetData()
   g_GADGET_VT\GetData = @GetData()
   g_GADGET_VT\GetX = @_GetX()
   g_GADGET_VT\GetY = @_GetY()
   g_GADGET_VT\GetWidth = @GetWidth()
   g_GADGET_VT\GetHeight = @GetHeight()
   g_GADGET_VT\Disable = @Disable()
   g_GADGET_VT\Hide = @Hide()
   g_GADGET_VT\IsGadget = @_IsGadget()
   g_GADGET_VT\GetType = @GetType()
   g_GADGET_VT\Activate = @Activate()
   g_GADGET_VT\GetFont = @GetFont()
   g_GADGET_VT\SetFont = @SetFont()
   g_GADGET_VT\BindEvent = @_BindEvent()
   g_GADGET_VT\GetID = @GetID()
   g_GADGET_VT\SetToolTip = @SetToolTip()
   g_GADGET_VT\IsDisabled = @IsDisabled()
   g_GADGET_VT\SetEventCallback = @SetEventCallback()
   g_GADGET_VT\GetEventCallback = @GetEventCallback()
EndModule


And finally SlideBar.pb:
Code:
IncludeFile "guiGadget.pb"
XIncludeFile "DPI.pb"
XIncludeFile "enum.pb"
XIncludeFile "drawing.pb"

DeclareModule SlideBar
   ;- DEFAULTS
   ;Relation between the channel or thumb and the gadget girth.
   ;Must be between 0.0 and 1.0
   #DefChannelFactor = 0.3
   #DefThumbFactor = 0.35
   
   #DefMinRange = 0
   #DefMaxRange = 100
   
   #DefLineSize = 1
   #DefPageSize = 10
   
   #DefColorBackground = $FF000000 ;Black
   #DefColorChannelBackground = $FFC3C3C3 ;Grey
   #DefColorChannelFill = $FF0000FF ;Red
   #DefColorThumb = $FF0000FF ;Red
   
   ;- ENUM Style
   EnumerationBinary
      #StyleHorizontal
      #StyleVertical
      #StyleFocusRect
      #StyleCustomDraw
      #StyleDownIsLeft
      #StyleThumAlways
   EndEnumeration
   
   ;- ENUM State
   EnumerationBinary
      #StateHighlighted
   EndEnumeration
   
   ;- ENUM Events
   Enumeration guiGadget::GadgetEvent
      #EventTypePosChange
   EndEnumeration
   
   ;- ENUM PosChange Reason
   Enumeration
      ;Keyboard
      #PosChangeLineUp
      #PosChangeLineDown
      #PosChangePageUp
      #PosChangePageDown
      #PosChangeTop
      #PosChangeBottom
      
      ;Mouse
      #PosChangeThumbTrack
      #PosChangeThumbPosition
      #PosChangeTrack
      
      ;Keyboard and mouse
      #PosChangeEndTrack
   EndEnumeration
   
   ;- PositionChangeEvent
   Structure PositionChangeEvent Extends guiGadget::Event
      Position.i
      Reason.i ;ENUM PosChange Reason
   EndStructure
   
   ;- ENUM DrawStage
   Enumeration
      #DrawStageBackground
      #DrawStageChannel
      #DrawStageThumb
   EndEnumeration
   
   ;- CustomDrawData
   Structure CustomDrawData
      Width.d
      Height.d
      DrawStage.w
      State.w
   EndStructure
   
   ;- ThumbInfo
   Structure ThumbInfo
      X.d
      Y.d
      Radius.d
   EndStructure
   
   ;- ENUM Color
   EnumerationBinary
      #ColorBackground
      #ColorChannelBackground
      #ColorChannelFill
      #ColorThumb
   EndEnumeration
   
   ;- Colors
   Structure Colors
      Color.l  ;Color enum, the color to get or set
      Background.l
      ChannelBackground.l
      ChannelFill.l
      Thumb.l
   EndStructure
   
   ;- PROTOTYPES
   Prototype CustomDrawCallbackProto(slidebar.i, *cd.CustomDrawData)
   
   ;- ISlideBar
   Interface ISlideBar Extends guiGadget::IGadget
      GetPos()
      SetPos(pos.i)
      SetRange(minrange.i, maxrange.i)
      GetMinRange()
      GetMaxRange()
      SetMinRange(minRange.i)
      SetMaxRange(maxRange.i)
      SetCustomDrawCallback(cdCallback.i)
      GetChannelRect(*rect.Drawing::RectangleD)
      GetThumbInfo(*ti.ThumbInfo)
      GetChannelFillLen.d()
      GetStyle()
      GetLineSize()
      SetLineSize(linesize.i)
      GetPageSize()
      SetPageSize(pageSize.i)
   EndInterface
   
   ;- PUBLIC DECLARES
   Declare Create(x.i, y.i, width.i, height.i, callBack.guiGadget::EventCallbackProto, minRange.i = #DefMinRange,
                  maxRange.i = #DefMaxRange, style.i = #StyleHorizontal, chanFactor.d = #DefChannelFactor, thumbFactor.d = #DefThumbFactor)
EndDeclareModule

Module SlideBar
   EnableExplicit
   
   #VERSION = 1.0
   
   ;- SLIDEBAR_VT
   Structure SLIDEBAR_VT Extends guiGadget::GADGET_VT
      GetPos.i
      SetPos.i
      SetRange.i
      GetMinRange.i
      GetMaxRange.i
      SetMinRange.i
      SetMaxRange.i
      SetCustomDrawCallback.i
      GetChannelRect.i
      GetThumbInfo.i
      GetChannelFillLen.i
      GetStyle.i
      GetLineSize.i
      SetLineSize.i
      GetPageSize.i
      SetPageSize.i
      SetChannelMetrics.i
   EndStructure
   Global.SLIDEBAR_VT g_SLIDEBAR_VT
   ;Extend VTABLE
   CopyMemory(guiGadget::g_GADGET_VT, g_SLIDEBAR_VT, SizeOf(guiGadget::GADGET_VT))
   
   ;- SLIDEBAR_OBJ
   Structure SLIDEBAR_OBJ Extends guiGadget::GADGET_OBJ
      MaxRange.i
      MinRange.i
      ChannelFactor.d
      ThumbFactor.d
      CurrPos.i
      ThumbX.d
      ThumbY.d
      ThumbRadius.d
      ChannelX.d
      ChannelY.d
      ChannelWidth.d
      ChannelHeight.d
      ChannelLen.d
      Style.l
      State.l
      ColorBackground.l
      ColorChannelBackground.l
      ColorChannelFill.l
      ColorThumb.l
      ClickOnChannel.b
      ClickOnThumb.b
      LineSize.i
      PageSize.i
      CustomDrawCallback.CustomDrawCallbackProto
   EndStructure
   
   ;- MACROS
   Macro RangeUnitToPointUnit(this, rangeUnit)
      (((rangeUnit) * this\ChannelLen) / this\MaxRange)
   EndMacro
   
   Macro PointUnitToRangeUnit(this, pointUnit)
      (((pointUnit) * this\MaxRange) / this\ChannelLen)
   EndMacro
   
   Macro HasStyle(this, st)
      enum::HasFlag(this\Style, st)
   EndMacro
   
   Macro IsHighLighted(this)
      enum::HasFlag(this\State, #StateHighlighted)
   EndMacro
   
   ;- PRIVATE DECLARES
   Declare SetPos(*this.SLIDEBAR_OBJ, pos.i)
   
   Procedure SetHighLightedState(*this.SLIDEBAR_OBJ, ptX.d, ptY.d)
      ;Sets highlight state and cursor.
      If Drawing::PointInRect2(ptX, ptY, *this\ChannelX, *this\ChannelY, *this\ChannelWidth, *this\ChannelHeight) Or
         Drawing::PointInCircle(ptX, ptY, *this\ThumbX, *this\ThumbY, *this\ThumbRadius)
         SetGadgetAttribute(*this\Gadget, #PB_Canvas_Cursor, #PB_Cursor_Hand)
         enum::PutFlag(@*this\State, #StateHighlighted)
         
         ProcedureReturn #True
         
      Else
         SetGadgetAttribute(*this\Gadget, #PB_Canvas_Cursor, #PB_Cursor_Default)
         enum::RemoveFlag(@*this\State, #StateHighlighted)
         
         ProcedureReturn #False
      EndIf
   EndProcedure
   
   Procedure CallCustomDraw(*this.SLIDEBAR_OBJ, *cd.CustomDrawData)
      If *this\CustomDrawCallback
         ProcedureReturn *this\CustomDrawCallback(*this, *cd)
      EndIf
   EndProcedure
   
   Procedure DrawChannel(*this.SLIDEBAR_OBJ, gdWidth.d, gdHeight.d)
      Define.d chanFillWidth, chanFillHeight
      Define.CustomDrawData cd
      Define.d lenPadding
      
      lenPadding = 2
      
      ;GET METRICS
      If *this\Style & #StyleVertical = #StyleVertical
         ;Channel      
         *this\ChannelWidth = gdWidth * *this\ChannelFactor
         *this\ChannelX = (gdWidth - *this\ChannelWidth) / 2

         ;Thumb
         *this\ThumbX = *this\ChannelX + (*this\ChannelWidth  / 2)
         *this\ThumbRadius = gdWidth * *this\ThumbFactor
         
         *this\ChannelY = lenPadding + *this\ThumbRadius
         *this\ChannelHeight = gdHeight - (*this\ThumbRadius * 2) - (lenPadding * 2)
         chanFillWidth = *this\ChannelWidth
         chanFillHeight = RangeUnitToPointUnit(*this, *this\CurrPos)
         *this\ThumbY = *this\ChannelY + chanFillHeight
         
         *this\ChannelLen = *this\ChannelHeight

      Else ;Horizontal
         ;Channel      
         *this\ChannelHeight = gdHeight * *this\ChannelFactor
         *this\ChannelY = (gdHeight - *this\ChannelHeight) / 2

         ;Thumb
         *this\ThumbY = *this\ChannelY + (*this\ChannelHeight  / 2)
         *this\ThumbRadius = gdHeight * *this\ThumbFactor

         *this\ChannelX = lenPadding + *this\ThumbRadius
         *this\ChannelWidth = gdwidth - (*this\ThumbRadius * 2) - (lenPadding * 2)
         chanFillWidth = RangeUnitToPointUnit(*this, *this\CurrPos)
         chanFillHeight = *this\ChannelHeight
         *this\ThumbX = *this\ChannelX + chanFillWidth
         
         *this\ChannelLen = *this\ChannelWidth
      EndIf
      
      ;DRAWING
      If HasStyle(*this, #StyleCustomDraw)
         cd\DrawStage = #DrawStageChannel
         cd\Width = gdWidth
         cd\Height = gdHeight
         cd\State = *this\State
         CallCustomDraw(*this, @cd)
         
      Else
         ;Channel
         AddPathBox(*this\ChannelX, *this\ChannelY, *this\ChannelWidth, *this\ChannelHeight)
         VectorSourceColor(*this\ColorChannelBackground)
         FillPath()
         
         ;Fill
         If *this\CurrPos > 0
            AddPathBox(*this\ChannelX, *this\ChannelY, chanFillWidth, chanFillHeight)
            VectorSourceColor(*this\ColorChannelFill)
            FillPath()
         EndIf
         
         ;Thumb
         If enum::HasFlag(*this\State, #StateHighlighted) Or HasStyle(*this, #StyleThumAlways)
            AddPathCircle(*this\ThumbX, *this\ThumbY, *this\ThumbRadius)
            VectorSourceColor(*this\ColorThumb)
            FillPath()
         EndIf
      EndIf
   EndProcedure
   
   Procedure DrawBackground(*this.SLIDEBAR_OBJ, gdWidth.d, gdHeight.d)   
      Define.CustomDrawData cd
      Define.b doDefaultDrawing
      
      doDefaultDrawing = #True
      
      If HasStyle(*this, #StyleCustomDraw)
         cd\DrawStage = #DrawStageBackground
         cd\Width = gdWidth
         cd\Height = gdHeight
         cd\State = *this\State
         doDefaultDrawing = CallCustomDraw(*this, @cd)
      EndIf
      
      If doDefaultDrawing
         AddPathBox(0, 0, gdWidth, gdHeight)
         VectorSourceColor(*this\ColorBackground)
         FillPath()
      EndIf
   EndProcedure
   
   Procedure Draw(*this.SLIDEBAR_OBJ)
      Define.d gdWidth, gdHeight
      
      If StartVectorDrawing(CanvasVectorOutput(*this\Gadget, #PB_Unit_Point))         
         gdWidth = VectorOutputWidth()
         gdHeight = VectorOutputHeight()
         
          DrawBackground(*this, gdWidth, gdHeight)
          DrawChannel(*this, gdWidth, gdHeight)
         
         StopVectorDrawing()
      EndIf
   EndProcedure
      
   Procedure MouseMoveHandler(*this.SLIDEBAR_OBJ)
      Define.d ptX, ptY
      Define.i newPos, oldPos
      Define.PositionChangeEvent ev
      Define.b oldHLState, newHLState
      
      oldHLState = IsHighLighted(*this)
      oldPos = *this\CurrPos
      
      ptX = DPI::PxToPointX(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseX))
      ptY = DPI::PxToPointY(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseY))
      
      ;If is dragging update position and draw.
      If *this\ClickOnThumb ;Is dragging
         If HasStyle(*this, #StyleVertical)
            newPos = PointUnitToRangeUnit(*this, ptY - *this\ChannelY)

         Else ;Horizontal
            newPos = PointUnitToRangeUnit(*this, ptX - *this\ChannelX)
         EndIf
         
         SetPos(*this, newPos) ;Calls Draw()
         
         ;Call event
         If *this\CurrPos <> oldPos
            ev\Type = #EventTypePosChange
            ev\Reason = #PosChangeThumbTrack
            ev\Position = *this\CurrPos
            guiGadget::CallEvent(*this, @ev)
         EndIf
         
      ;Set Highlighted state and draw if it changes.
      Else
         newHLState = SetHighLightedState(*this, ptX, ptY)
         If oldHLState <> newHLState
            Draw(*this)
         EndIf
      EndIf
   EndProcedure
   
   Procedure LButtonDownHandler(*this.SLIDEBAR_OBJ)
      Define.d ptX, ptY
      Define.i newPos
      
      ptX = DPI::PxToPointX(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseX))
      ptY = DPI::PxToPointY(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseY))
      
      If Drawing::PointInCircle(ptX, ptY, *this\ThumbX, *this\ThumbY, *this\ThumbRadius)
         *this\ClickOnThumb = #True
      EndIf
      
      If Drawing::PointInRect2(ptX, ptY, *this\ChannelX, *this\ChannelY, *this\ChannelWidth, *this\ChannelHeight)
         *this\ClickOnChannel = #True
      EndIf
         
      ;Set new position
      If *this\ClickOnThumb Or *this\ClickOnChannel
         If HasStyle(*this, #StyleVertical)
            newPos = PointUnitToRangeUnit(*this, ptY - *this\ChannelY)
            
         Else ;Horizontal
            newPos = PointUnitToRangeUnit(*this, ptX - *this\ChannelX)
         EndIf
         
         SetPos(*this, newPos)
      EndIf
   EndProcedure
   
   Procedure MouseEnterHandler(*this.SLIDEBAR_OBJ)
      Define.d ptX, ptY
      Define.b isHL
      
      ptX = DPI::PxToPointX(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseX))
      ptY = DPI::PxToPointY(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseY))
      
      isHL = SetHighLightedState(*this, ptX, ptY)
      
      If isHL : Draw(*this) : EndIf
   EndProcedure
   
   Procedure MouseLeaveHandler(*this.SLIDEBAR_OBJ)
      enum::RemoveFlag(@*this\State, #StateHighlighted)
      Draw(*this)
   EndProcedure
   
   Procedure LButtonUpHandler(*this.SLIDEBAR_OBJ)
      Define.PositionChangeEvent ev
      
      If *this\ClickOnThumb = #True
         ev\Type = #EventTypePosChange
         ev\Reason = #PosChangeThumbPosition
         ev\Position = *this\CurrPos
         guiGadget::CallEvent(*this, @ev)
         
         ev\Type = #EventTypePosChange
         ev\Reason = #PosChangeEndTrack
         ev\Position = *this\CurrPos
         guiGadget::CallEvent(*this, @ev)
         
      ElseIf *this\ClickOnChannel
         ev\Type = #EventTypePosChange
         ev\Reason = #PosChangeEndTrack
         ev\Position = *this\CurrPos
         guiGadget::CallEvent(*this, @ev)
      EndIf
      
      *this\ClickOnChannel = #False
      *this\ClickOnThumb = #False
   EndProcedure
   
   Procedure LClickHandler(*this.SLIDEBAR_OBJ)
      Define.d ptX, ptY ;Point units
      Define.PositionChangeEvent ev
      
      If enum::HasFlag(*this\State, #StateHighlighted)
          ptX = DPI::PxToPointX(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseX))
          ptY = DPI::PxToPointY(GetGadgetAttribute(*this\Gadget, #PB_Canvas_MouseY))
          
         If enum::HasFlag(*this\Style, #StyleVertical)
            SetPos(*this, PointUnitToRangeUnit(*this, ptY - *this\ChannelY))
            
         Else ;Horizontal
            SetPos(*this, PointUnitToRangeUnit(*this, ptX - *this\ChannelX))
         EndIf
      EndIf
   EndProcedure
   
   Procedure KeyDownHandler(*this.SLIDEBAR_OBJ)
      Define.PositionChangeEvent ev
      Define.b fireEvent
      Define.i oldPos, newPos
      
      fireEvent = #False
      oldPos = *this\CurrPos
      
      Select GetGadgetAttribute(*this\Gadget, #PB_Canvas_Key)
         Case #PB_Shortcut_Right
            If HasStyle(*this, #StyleDownIsLeft) And HasStyle(*this, #StyleVertical)
               newPos = *this\CurrPos - *this\LineSize
               
            Else
               newPos = *this\CurrPos + *this\LineSize
            EndIf
            ev\Reason = #PosChangeLineDown
            fireEvent = #True
            
         Case #PB_Shortcut_Left
            If HasStyle(*this, #StyleDownIsLeft) And HasStyle(*this, #StyleVertical)
               newPos = *this\CurrPos + *this\LineSize
               
            Else
               newPos = *this\CurrPos - *this\LineSize
            EndIf
            ev\Reason = #PosChangeLineUp
            fireEvent = #True
            
         Case #PB_Shortcut_Up
            If HasStyle(*this, #StyleDownIsLeft) And HasStyle(*this, #StyleHorizontal)
               newPos = *this\CurrPos + *this\LineSize
               
            Else
               newPos = *this\CurrPos - *this\LineSize
            EndIf
            ev\Reason = #PosChangeLineUp
            fireEvent = #True
            
         Case #PB_Shortcut_Down
            If HasStyle(*this, #StyleDownIsLeft) And HasStyle(*this, #StyleHorizontal)
               newPos = *this\CurrPos - *this\LineSize
               
            Else
               newPos = *this\CurrPos + *this\LineSize
            EndIf
            ev\Reason = #PosChangeLineDown
            fireEvent = #True
            
         Case #PB_Shortcut_PageUp
            If HasStyle(*this, #StyleDownIsLeft) And HasStyle(*this, #StyleHorizontal)
               newPos = *this\CurrPos + *this\PageSize
               
            Else
               newPos = *this\CurrPos - *this\PageSize
            EndIf
            ev\Reason = #PosChangePageUp
            fireEvent = #True
            
         Case #PB_Shortcut_PageDown
            If HasStyle(*this, #StyleDownIsLeft) And HasStyle(*this, #StyleHorizontal)
               newPos = *this\CurrPos - *this\PageSize
               
            Else
               newPos = *this\CurrPos + *this\PageSize
            EndIf
            ev\Reason = #PosChangePageDown
            fireEvent = #True
      EndSelect
      
      If fireEvent And newPos <> oldPos
         SetPos(*this, newPos)

         ev\Type = #EventTypePosChange
         ev\Position = *this\CurrPos
         guiGadget::CallEvent(*this, @ev)
      EndIf
   EndProcedure
   
   Procedure KeyUpHandler(*this.SLIDEBAR_OBJ)
      Define.PositionChangeEvent ev
      
      Select GetGadgetAttribute(*this\Gadget, #PB_Canvas_Key)
         Case #PB_Shortcut_Home, #PB_Shortcut_End, #PB_Shortcut_Up, #PB_Shortcut_Down, #PB_Shortcut_Right, #PB_Shortcut_Left, #PB_Shortcut_PageDown, #PB_Shortcut_PageUp
            ev\Type = #EventTypePosChange
            ev\Reason = #PosChangeEndTrack
            ev\Position = *this\CurrPos
            guiGadget::CallEvent(*this, @ev)
      EndSelect
   EndProcedure
   
   Procedure MouseWheelHandler(*this.SLIDEBAR_OBJ)
      Define.i wd, oldPos, newPos
      Define.PositionChangeEvent ev
      
      oldPos = *this\CurrPos
      
      If GetGadgetAttribute(*this\Gadget, #PB_Canvas_WheelDelta) < 0
         If HasStyle(*this, #StyleDownIsLeft | #StyleHorizontal)
            newPos = *this\CurrPos - *this\LineSize

         Else
            newPos = *this\CurrPos + *this\LineSize
         EndIf
         
      Else
         If HasStyle(*this, #StyleDownIsLeft | #StyleHorizontal)
            newPos = *this\CurrPos + *this\LineSize

         Else
            newPos = *this\CurrPos - *this\LineSize
         EndIf
      EndIf
      
      If oldPos <> newPos
         SetPos(*this, newPos)
         ev\Type = #EventTypePosChange
         ev\Reason = #PosChangeThumbPosition
         ev\Position = *this\CurrPos
         guiGadget::CallEvent(*this, @ev)
      EndIf
   EndProcedure
   
   Procedure EventHandler()
      Define.SLIDEBAR_OBJ *this
      
      *this = guiGadget::GetObject(EventGadget())
   
      If *this
         Select EventType()               
            Case #PB_EventType_MouseMove : MouseMoveHandler(*this)
               
            Case #PB_EventType_LeftButtonDown : LButtonDownHandler(*this)
               
            Case #PB_EventType_MouseEnter : MouseEnterHandler(*this)
               
            Case #PB_EventType_MouseLeave : MouseLeaveHandler(*this)
               
            Case #PB_EventType_LeftButtonUp : LButtonUpHandler(*this)
               
            Case #PB_EventType_LeftClick : LClickHandler(*this)
               
            Case #PB_EventType_MouseWheel : MouseWheelHandler(*this)
               
            Case #PB_EventType_KeyDown : KeyDownHandler(*this)
               
            Case #PB_EventType_KeyUp : KeyUpHandler(*this)
         EndSelect
      EndIf
   EndProcedure
   
   Procedure Create(x.i, y.i, width.i, height.i, evCallBack.guiGadget::EventCallbackProto, minRange.i = #DefMinRange, maxRange.i = #DefMaxRange,
                    style.i = #StyleHorizontal, chanFactor.d = #DefChannelFactor, thumbFactor.d = #DefThumbFactor)
      Define.SLIDEBAR_OBJ *this
      Define.i canvasFlags
            
      *this = AllocateMemory(SizeOf(SLIDEBAR_OBJ))
      
      If minRange < 0 : minRange = #DefMinRange : EndIf
      If maxRange < 0 : maxRange = #DefMaxRange : EndIf
      
      canvasFlags = #PB_Canvas_Keyboard
      
      If enum::HasFlag(style, #StyleFocusRect)
         enum::PutFlag(@canvasFlags, #PB_Canvas_DrawFocus)
      EndIf
      
      ;Ensure both flags are not set and leave Horizontal only if so.
      enum::FixExclusiveFlags(@style, #StyleHorizontal, #StyleVertical)
      
      *this\VT = g_SLIDEBAR_VT
      *this\Gadget = CanvasGadget(#PB_Any, x, y, width, height, canvasFlags)
      *this\MinRange = minRange
      *this\MaxRange = maxRange
      *this\LineSize = #DefLineSize
      *this\PageSize = #DefPageSize
      *this\ChannelFactor = chanFactor
      *this\ThumbFactor = thumbFactor
      *this\Style = style
      *this\EventCallback = evCallBack
      *this\ColorBackground = #DefColorBackground
      *this\ColorChannelBackground = #DefColorChannelBackground
      *this\ColorChannelFill = #DefColorChannelFill
      *this\ColorThumb = #DefColorThumb
      
      SetGadgetData(*this\Gadget, *this)
      BindGadgetEvent(*this\Gadget, @EventHandler(), #PB_All)
            
      Draw(*this)
                     
      ProcedureReturn *this
   EndProcedure
   
   Procedure Free(*this.SLIDEBAR_OBJ)
      ;Clean up
      
      ;Call inherited object free method to destroy gadget and memory.
      guiGadget::Free(*this)
   EndProcedure
   
   Procedure SetPos(*this.SLIDEBAR_OBJ, pos.i)
      If pos > *this\MaxRange
         pos = *this\MaxRange
         
      ElseIf pos < *this\MinRange
         pos = *this\MinRange
      EndIf
      
      *this\CurrPos = pos
      Draw(*this)
   EndProcedure
   
   Procedure GetPos(*this.SLIDEBAR_OBJ)
      ProcedureReturn *this\CurrPos
   EndProcedure
   
   Procedure SetCustomDrawCallback(*this.SLIDEBAR_OBJ, cdCallback.i)
      *this\CustomDrawCallback = cdCallback
      Draw(*this)
   EndProcedure
   
   Procedure GetChannelRect(*this.SLIDEBAR_OBJ, *rc.Drawing::RectangleD)
      *rc\X = *this\ChannelX
      *rc\Y = *this\ChannelY
      *rc\Width = *this\ChannelWidth
      *rc\Height = *this\ChannelHeight
   EndProcedure
   
   Procedure GetThumbInfo(*this.SLIDEBAR_OBJ, *ti.ThumbInfo)
      *ti\X = *this\ThumbX
      *ti\Y = *this\ThumbY
      *ti\Radius = *this\ThumbRadius
   EndProcedure
   
   Procedure.d GetChannelFillLen(*this.SLIDEBAR_OBJ)
      ProcedureReturn RangeUnitToPointUnit(*this, *this\CurrPos)
   EndProcedure
   
   Procedure GetStyle(*this.SLIDEBAR_OBJ)
      ProcedureReturn *this\Style
   EndProcedure
   
   ;Override Resize method to force redraw, it works better than binding the resize event.
   Procedure Resize(*this.SLIDEBAR_OBJ, x.i, y.i, width.i, height.i)
      ResizeGadget(*this\Gadget, x, y, width, height)
      Draw(*this)
   EndProcedure
   
   Procedure GetLineSize(*this.SLIDEBAR_OBJ)
      ProcedureReturn *this\LineSize
   EndProcedure
   
   Procedure SetLineSize(*this.SLIDEBAR_OBJ, linesize.i)
      *this\LineSize = linesize
   EndProcedure
   
   Procedure GetPageSize(*this.SLIDEBAR_OBJ)
      ProcedureReturn *this\PageSize
   EndProcedure
   
   Procedure SetPageSize(*this.SLIDEBAR_OBJ, pageSize.i)
      *this\PageSize = pageSize
   EndProcedure
   
   Procedure GetMinRange(*this.SLIDEBAR_OBJ)
      ProcedureReturn *this\MinRange
   EndProcedure
   
   Procedure GetMaxRange(*this.SLIDEBAR_OBJ)
      ProcedureReturn *this\MaxRange
   EndProcedure
   
   Procedure SetMinRange(*this.SLIDEBAR_OBJ, minRange.i)
      *this\MinRange = minRange
      
      If *this\CurrPos < *this\MinRange
         SetPos(*this, *this\MinRange)
      EndIf
   EndProcedure
   
   Procedure SetMaxRange(*this.SLIDEBAR_OBJ, maxRange.i)
      *this\MaxRange = maxRange
      
      If *this\CurrPos > *this\MaxRange
         SetPos(*this, *this\MaxRange)
      EndIf
   EndProcedure
   
   Procedure SetRange(*this.SLIDEBAR_OBJ, minrange.i, maxrange.i)
      SetMinRange(*this, minrange)
      SetMaxRange(*this, maxrange)
   EndProcedure
   
   ;- VTABLE CREATION
   g_SLIDEBAR_VT\GetPos = @GetPos()
   g_SLIDEBAR_VT\SetPos = @SetPos()
   g_SLIDEBAR_VT\SetRange = @SetRange()
   g_SLIDEBAR_VT\Free = @Free()
   g_SLIDEBAR_VT\SetCustomDrawCallback = @SetCustomDrawCallback()
   g_SLIDEBAR_VT\GetChannelRect = @GetChannelRect()
   g_SLIDEBAR_VT\GetThumbInfo = @GetThumbInfo()
   g_SLIDEBAR_VT\GetChannelFillLen = @GetChannelFillLen()
   g_SLIDEBAR_VT\GetStyle = @GetStyle()
   g_SLIDEBAR_VT\Resize = @Resize() ;Override
   g_SLIDEBAR_VT\GetLineSize = @GetLineSize()
   g_SLIDEBAR_VT\SetLineSize = @SetLineSize()
   g_SLIDEBAR_VT\GetPageSize = @GetPageSize()
   g_SLIDEBAR_VT\SetPageSize = @SetPageSize()
   g_SLIDEBAR_VT\GetMinRange = @GetMinRange()
   g_SLIDEBAR_VT\GetMaxRange = @GetMaxRange()
   g_SLIDEBAR_VT\SetMinRange = @SetMinRange()
   g_SLIDEBAR_VT\SetMaxRange = @SetMaxRange()
EndModule

CompilerIf #PB_Compiler_IsMainFile   
;- TEST
EnableExplicit

Global.SlideBar::ISlideBar g_slide1, g_slide2
Global.i g_win

Procedure slideBarEvents(slideBar, *ev.guiGadget::Event)
   Define.SlideBar::PositionChangeEvent *posChange
   
   Select *ev\Type
      Case SlideBar::#EventTypePosChange
         *posChange = *ev
         Select *posChange\Reason
            Case SlideBar::#PosChangeEndTrack
               Debug "Endtrack " + Str(*posChange\Position)
               
            Case SlideBar::#PosChangeTrack
               Debug "Track " + Str(*posChange\Position)
               
            Case SlideBar::#PosChangeThumbTrack
               Debug "ThumbTrack " + Str(*posChange\Position)
               
            Case SlideBar::#PosChangeThumbPosition
               Debug "ThumbPosition " + Str(*posChange\Position)
               
            Case SlideBar::#PosChangeBottom
               Debug "Bottom " + Str(*posChange\Position)
               
            Case SlideBar::#PosChangeTop
               Debug "Top " + Str(*posChange\Position)
               
            Case SlideBar::#PosChangeLineUp
               Debug "Line Up " + Str(*posChange\Position)
               
            Case SlideBar::#PosChangeLineDown
               Debug "Line Down " + Str(*posChange\Position)
               
            Case slideBar::#PosChangePageUp
               Debug "Page Up " + Str(*posChange\Position)
               
            Case slideBar::#PosChangePageDown
               Debug "Page Down " + Str(*posChange\Position)

         EndSelect
   EndSelect
EndProcedure

Procedure CustDraw(sBar.SlideBar::ISlideBar, *cd.SlideBar::CustomDrawData)
   Define.SlideBar::ThumbInfo ti
   Define.Drawing::RectangleD chanRect
   
   Select *cd\DrawStage
      Case SlideBar::#DrawStageBackground
         ProcedureReturn #True ;do default drawing
     
      Case SlideBar::#DrawStageChannel
       sBar\GetChannelRect(@chanRect)

       ;Channel background
         AddPathBox(chanRect\X, chanRect\Y, chanRect\Width, chanRect\Height)
         VectorSourceColor(RGBA(195, 195, 195, 255))
         FillPath()
       
       ;Channel fill
       VectorSourceLinearGradient(chanRect\X, chanRect\Y, chanRect\X, chanRect\Y + sBar\GetChannelFillLen())
         VectorSourceGradientColor(RGBA($00, $00, $FF, 255), 0.0)
         VectorSourceGradientColor(RGBA($CC, $FF, $FF, 255), 1.0)
         AddPathBox(chanRect\X, chanRect\Y, chanRect\Width, sBar\GetChannelFillLen())
      FillPath()

      ;Thumb
       sBar\GetThumbInfo(@ti)
       VectorSourceCircularGradient(ti\X, ti\Y, ti\Radius)
      VectorSourceGradientColor(RGBA($CC, $FF, $FF, 255), 0.0)
      VectorSourceGradientColor(RGBA($00, $00, $FF, 255), 1.0)
         AddPathCircle(ti\X, ti\Y, ti\Radius)
         FillPath()
   EndSelect
EndProcedure

Procedure SizeHandler()
   g_slide1\Resize(#PB_Ignore, #PB_Ignore, WindowWidth(g_win), #PB_Ignore)
EndProcedure


Define.i winX, winY, winWidth, winHeight

DPI::Init()

winX = DPI::ScaleX(10)
winY = DPI::ScaleY(10)
winWidth = DPI::ScaleX(600)
winHeight = DPI::ScaleY(400)


g_win = OpenWindow(#PB_Any, winX, winY, winWidth, winHeight, "SlideBar", #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget | #PB_Window_SizeGadget)
g_slide1 = SlideBar::Create(DPI::ScaleX(0), DPI::ScaleY(10), DPI::ScaleX(600), DPI::ScaleY(20), @slideBarEvents(),
                            0, 100, SlideBar::#StyleFocusRect)
g_slide2 = SlideBar::Create(DPI::ScaleX(10), DPI::ScaleY(50), DPI::ScaleX(50), DPI::ScaleY(250), @slideBarEvents(),
                            0, 100, SlideBar::#StyleVertical | SlideBar::#StyleFocusRect | SlideBar::#StyleThumAlways | SlideBar::#StyleCustomDraw, 0.2)
g_slide2\SetCustomDrawCallback(@CustDraw())
g_slide1\SetPos(50)
g_slide1\Activate()
 
BindEvent(#PB_Event_SizeWindow, @SizeHandler())

Repeat
Until WaitWindowEvent() = #PB_Event_CloseWindow

CompilerEndIf


Top
 Profile  
Reply with quote  
 Post subject: Re: Canvas SlideBar (TrackBar) Crossplatform, DPI Aware, OOP
PostPosted: Mon Jul 31, 2017 7:04 pm 
Offline
Addict
Addict
User avatar

Joined: Sun Nov 05, 2006 11:42 pm
Posts: 4692
Location: Lyon - France
Splendid 3D slideBar :shock:
Works very well here
Thanks for sharing 8)

_________________
ImageThe happiness is a road...
Not a destination


Top
 Profile  
Reply with quote  
 Post subject: Re: Canvas SlideBar (TrackBar) Crossplatform, DPI Aware, OOP
PostPosted: Mon Jul 31, 2017 7:17 pm 
Offline
Enthusiast
Enthusiast

Joined: Sat Apr 26, 2003 2:49 pm
Posts: 677
Thanks, i forgot to put methods to set the colors i will add them later. I don't have much more time anyone fell free to improve it.


Top
 Profile  
Reply with quote  
 Post subject: Re: Canvas SlideBar (TrackBar) Crossplatform, DPI Aware, OOP
PostPosted: Fri Jun 05, 2020 11:23 am 
Offline
Enthusiast
Enthusiast
User avatar

Joined: Fri Apr 25, 2003 5:10 pm
Posts: 538
Location: Doubs - France
Like KCC said

Splendid :!:

I'm as stiff as a snail... :cry:
i discover your code today .......

_________________
A+
Denis


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 4 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 8 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye