Canvas double sliders
Posted: Fri Nov 04, 2011 2:05 am
Code: Select all
;Canvas Double Sliders
;by einander
;PB 4.60 RC 2
;
EnableExplicit
;
#DGRAY=$464646
#No=#PB_Ignore
#ZBLUE=$FF9933
;
Structure Pos : X.L : Y.L : Wi.L : He.L : EndStructure
;
Structure Dslid
CG.I
HiCanv.I
LoCanv.I
HiVal.I
LoVal.I
Link.I
Po.Pos
Min.I
Max.I
SlidRGB.I
BkRGB.I
Radius.I
HiInfo.I
LoInfo.I
EndStructure
;
Global Dim _DS.DSlid(2) ; 3 Double Sliders; define more at will
Global _Drawing
Define Ev,OldMy,iWi=20,Radius=iWi/2
;
Macro GadgetBottom(Gad) : GadgetY(Gad)+GadgetHeight(Gad) : EndMacro
;
Macro GadRGB(Gad,RGB1=#White,RGB2=0)
SetGadgetColor(Gad,1,RGB1)
SetGadgetColor(Gad,2,RGB2)
EndMacro
;
Macro MMx : WindowMouseX(EventWindow()) : EndMacro
;
Macro MMy : WindowMouseY(EventWindow()) : EndMacro
;
Macro MMk
Abs(GetAsyncKeyState_(#VK_LBUTTON) +GetAsyncKeyState_(#VK_RBUTTON)*2+GetAsyncKeyState_(#VK_MBUTTON)*3)/$8000
EndMacro
;
Procedure R3(A,B,C,D,Va) ; In: Va btw a And b - Out: proportion btw c And d
If B=A:ProcedureReturn 0:EndIf
Define E.D=(D-C)/(B-A)
ProcedureReturn C+E*(Va-A)
EndProcedure
;
Procedure Lim(A,B,C)
If A<B :ProcedureReturn B
ElseIf A>C :ProcedureReturn C
EndIf
ProcedureReturn A
EndProcedure
;
Procedure InitDSlid(Index,X,Y,Wi,He,Min,Max,BkRGB,SlidRGB,Lo=-1,Hi=-1)
Protected W3.F=Wi/3,W4=Wi/4
With _Ds(Index)
If Lo=-1:Lo=Min:EndIf
If Hi=-1:Hi=Max:EndIf
\Po\X=X : \Po\Y=Y
\Po\Wi=Wi : \Po\He=He
\Min=Min : \Max=Max
\LoVal=Lo : \HiVal=Hi
\BkRGB=BkRGB
\SlidRGB=SlidRGB
\Radius=Wi/2-1
\CG=ContainerGadget(#PB_Any,X-1,Y-1,Wi+2,He+2,#PB_Container_Flat)
SetGadgetColor(\CG,#PB_Gadget_BackColor,BkRGB)
;
\HiCanv=CanvasGadget(#PB_Any,1, R3(\Min,\Max,0,\Po\He-\PO\Wi*2,\Max-Hi),Wi,Wi)
SetGadgetData(\HiCanv,Index+1)
If _drawing:StopDrawing():EndIf
StartDrawing(CanvasOutput(\HiCanv))
Box(0,0,\Po\Wi,\Po\Wi,BkRGB)
Circle(\Radius,\Radius,\Radius+1,#Dgray)
Circle(\Radius,\Radius,\Radius,SlidRGB)
;
\LoCanv=CanvasGadget(#PB_Any,1,R3(\Min,\Max,\Po\Wi,\Po\He-\Po\Wi,\Max-Lo),Wi,Wi)
SetGadgetData(\LoCanv,-(Index+1))
StopDrawing()
StartDrawing(CanvasOutput(\LoCanv))
Box(0,0,\Po\Wi,\Po\Wi,BkRGB)
Circle(\Radius,\Radius,\Radius+1,#DGray)
Circle(\Radius,\Radius,\Radius,SlidRGB)
;
\Link=CanvasGadget(#PB_Any,W3,GadgetY(\HiCanv)+\Radius,Wi-W3*2,GadgetY(\LoCanv)-GadgetY(\HiCanv))
StopDrawing()
StartDrawing(CanvasOutput(\Link))
Box(0,0,GadgetWidth(\Link),GadgetHeight(\Link),SlidRGB)
StopDrawing():_drawing=0
CloseGadgetList()
\HiInfo=TextGadget(#PB_Any,GadgetX(\CG),Gadgetbottom(\CG),Wi,Wi,Str(Hi))
\LoInfo=TextGadget(#PB_Any,GadgetX(\CG),Gadgetbottom(\Hiinfo),Wi,Wi,Str(Lo))
GadRGB(\HiInfo,#White,0)
GadRGB(\LoInfo,#White,0)
EndWith
EndProcedure
;
Procedure MoveSlider(EvGad)
Protected A=GetGadgetData(EvGad)
Protected Y,Index=Abs(A)-1
With _Ds(Index)
Y=MMy-GadgetY(\CG)-\Radius
If A>-1
\Hival=Lim(\Max-R3(0,\Po\He-\PO\Wi*2,\Min,\Max,MMy-GadgetY(\CG)-\Radius),\Loval,\Max)
SetGadgetText(\HiInfo,Str(\Hival))
ResizeGadget(EvGad,#No,R3(\Min,\Max,0,\Po\He-\PO\Wi*2,\Max-\HiVal),#No,#No)
Else
\Loval=Lim(\Max-R3(\Po\Wi,\Po\He-\Po\Wi,\Min,\Max,MMy-GadgetY(\CG)-\Radius),0,\Hival)
SetGadgetText(\LoInfo,Str(\Loval))
ResizeGadget(EvGad,#No,R3(\Min,\Max,\Po\Wi,\Po\He-\Po\Wi,\Max-\LoVal),#No,#No)
EndIf
ResizeGadget(\Link,#No,GadgetY(\HiCanv)+\Radius,#No,GadgetY(\LoCanv)-GadgetY(\HiCanv))
If _Drawing:StopDrawing():EndIf
StartDrawing(CanvasOutput(\Link))
Box(0,0,GadgetWidth(\Link),GadgetHeight(\Link),\SlidRGB)
EndWith
StopDrawing():_drawing=0
EndProcedure
;
;Test it <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
OpenWindow(0, 100, 100,700,500 ,"Canvas Double Sliders", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)
SetWindowColor(0,0)
InitDSlid(0,100,100,iWi,300,0,255,0,#Red,128,128)
InitDSlid(1,130,100,iWi,300,0,255,0,#Green,100,200)
InitDSlid(2,160,100,iWi,300,0,255,0,#ZBlue)
Repeat
If GetAsyncKeyState_(27)&$8000 : End : EndIf
EV=WaitWindowEvent()
Select Ev
Case #PB_Event_Gadget
Select EventGadget()
Case _Ds(0)\HiCanv ,_Ds(0)\LoCanv,_Ds(1)\HiCanv ,_Ds(1)\LoCanv,_Ds(2)\HiCanv ,_Ds(2)\LoCanv
If MMk And MMy<>Oldmy
MoveSlider(EventGadget()) ; values for each slider are stored in _Ds(Index)\LoVal and _Ds(Index)\HiVal
Oldmy=MMy
EndIf
EndSelect
EndSelect
Until EV=#PB_Event_CloseWindow
End 
einander 
