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: Select all
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
Code: Select all
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
Code: Select all
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
Code: Select all
;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
Code: Select all
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
