PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Pb Slider Control

https://www.purebasic.fr/english/viewtopic.php?t=22459

Page 1 of 1

Pb Slider Control

Posted: Mon Jun 26, 2006 7:31 pm
by localmotion34
here is an early version of a slider control i am writing.

overall, this is a beginning stage of direct, fast GDI work that is forming the basis for a new DUIhwnd control, like the one I released before.

the dui control wont take the place of srod's, as i am going for a much more customizable interface. it will have a "pretty" look for all you GUI freaks out there. the new DUI and other controls will all have their own classes, and be optimized as much as possible.

comments and suggestions are always welcome, and if you want to, please suggest how i can optimize this code, as the code here is going to be implemented in other relased controls.

Code: Select all

Prototype.l PB_Object_GetOrAllocateID(Objects.l,ID.l)
Prototype.l PB_Gadget_RegisterGadget(ID.l,*Gadget.l,hwnd.l,*GadgetVT.l)

;- includes


;- Constants 
Enumeration
  #PB_GadgetType_Unknown
  #PB_GadgetType_Button
  #PB_GadgetType_String
  #PB_GadgetType_Text
  #PB_GadgetType_CheckBox
  #PB_GadgetType_Option
  #PB_GadgetType_ListView
  #PB_GadgetType_Frame3D
  #PB_GadgetType_ComboBox
  #PB_GadgetType_Image
  #PB_GadgetType_HyperLink
  #PB_GadgetType_Container
  #PB_GadgetType_ListIcon
  #PB_GadgetType_IPAddress
  #PB_GadgetType_ProgressBar
  #PB_GadgetType_ScrollBar
  #PB_GadgetType_ScrollArea
  #PB_GadgetType_TrackBar
  #PB_GadgetType_Web
  #PB_GadgetType_ButtonImage
  #PB_GadgetType_Calendar
  #PB_GadgetType_Date
  #PB_GadgetType_Editor
  #PB_GadgetType_ExplorerList
  #PB_GadgetType_ExplorerTree
  #PB_GadgetType_ExplorerCombo
  #PB_GadgetType_Spin
  #PB_GadgetType_Tree
  #PB_GadgetType_Panel
  #PB_GadgetType_Splitter
  #PB_GadgetType_MDI
  #PB_GadgetType_Scintilla
  #PB_GadgetType_LastEnum
EndEnumeration


#WM_MOUSEHOVER = $2A1
#WM_MOUSELEAVE = $2A3
#BS_FLAT=$8000
#TME_HOVER = 1
#TME_LEAVE = 2
#clnavy=$00800000
#WM_MOUSEWHEEL = $20A

CompilerIf Defined(PB_GadgetVT, #PB_Structure) = #False
Structure PB_GadgetVT
  GadgetType.l   
  SizeOf.l       
  GadgetCallback.l
  FreeGadget.l
  GetGadgetState.l
  SetGadgetState.l
  GetGadgetText.l
  SetGadgetText.l
  AddGadgetItem2.l
  AddGadgetItem3.l
  RemoveGadgetItem.l
  ClearGadgetItemList.l
  ResizeGadget.l
  CountGadgetItems.l
  GetGadgetItemState.l
  SetGadgetItemState.l
  GetGadgetItemText.l
  SetGadgetItemText.l
  OpenGadgetList2.l
  GadgetX.l
  GadgetY.l
  GadgetWidth.l
  GadgetHeight.l
  HideGadget.l
  AddGadgetColumn.l
  RemoveGadgetColumn.l
  GetGadgetAttribute.l
  SetGadgetAttribute.l
  GetGadgetItemAttribute2.l
  SetGadgetItemAttribute2.l
  SetGadgetColor.l
  GetGadgetColor.l
  SetGadgetItemColor2.l
  GetGadgetItemColor2.l
  SetGadgetItemData.l
  GetGadgetItemData.l
EndStructure
CompilerEndIf

CompilerIf Defined(PB_Gadget, #PB_Structure) = #False

Structure PB_Gadget
  Gadget.l
  *VT.PB_GadgetVT
  UserData.l
  OldCallback.l
  Daten.l[4]
EndStructure
CompilerEndIf

Structure Slinfo
  width.l
  height.l
  value.l
  PBID.l
  button.RECT
  button1.RECT
  color.l
  maxvalue.l
EndStructure 

;- Callbacks
Procedure buttonproc(hwnd,msg,wParam,lParam)
  Select msg
    Case #WM_LBUTTONDOWN
    Case #WM_MOUSEMOVE
      HandCur  = LoadCursor_(0, #IDC_HAND)
      SetCursor_(HandCur)
      Structure myTRACKMOUSEEVENT
        cbSize.l
        dwFlags.l
        hwndTrack.l
        dwHoverTime.l
      EndStructure
      mte.myTRACKMOUSEEVENT
      mte\cbSize = SizeOf(myTRACKMOUSEEVENT)
      mte\dwFlags = #TME_LEAVE
      mte\hwndTrack = hwnd
      TrackMouseEvent_(mte)
      SendMessage_(hwnd,#stm_setimage,#IMAGE_BITMAP,ImageID(collapsespecial))
    Case #WM_MOUSELEAVE
      HandCur  = LoadCursor_(0, #IDC_ARROW)
      SetCursor_(HandCur)
      SendMessage_(hwnd,#stm_setimage,#IMAGE_BITMAP,ImageID(collapse))
  EndSelect
  ProcedureReturn CallWindowProc_(GetProp_(hwnd,"OldProc1"),hwnd,msg,wParam,lParam)
EndProcedure

Procedure Slidercallback(hwnd,msg,wParam,lParam)
  Select msg
    Case #WM_LBUTTONDOWN 
      dc=GetDC_(hwnd)
      *inf.Slinfo=HeapAlloc_(GetProcessHeap_(), 0, SizeOf(Slinfo))
      *inf.Slinfo=GetProp_(hwnd,"slinfo")   
      y=(lParam >> 16 & $FFFF)
      x=lParam & $FFFF
      If ptinrect_(*inf\button1.RECT,x,y)
        If *inf\value=*inf\maxvalue
        Else
          *inf\value+1
          Global uppushed=1
          half=(*inf\height)/2
          rect.RECT
          rect\left=*inf\width-16:rect\right=*inf\width:rect\top=half-8:rect\bottom=half+8
          DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL, #DFCS_SCROLLup|#DFCS_PUSHED	)
          brush=CreateSolidBrush_(*inf\color)
          pen=createpen_(#PS_SOLID,0,#Black)
          SelectObject_(dc,brush)
          SelectObject_(dc,pen)
          b=1
          c=0
          For a=20 To *inf\width-20 Step 7
            c=c+1
            If c>*inf\value
              brush=CreateSolidBrush_(#White)
              pen=createpen_(#PS_SOLID,0,#Black)
              SelectObject_(dc,brush)
              SelectObject_(dc,pen)
            EndIf 
            b=b+2
            rectangle_(dc,a,*inf\height-b,a+5,*inf\height)
            SetProp_(hwnd,"slinfo",*inf.Slinfo)
          Next 
        EndIf 
      ElseIf ptinrect_(*inf\button.RECT,x,y)
        If *inf\value=0
        Else 
          *inf\value-1
          Global downpushed=1
          rect.RECT
          half=(*inf\height)/2
          rect\left=0:rect\right=16:rect\top=half-8:rect\bottom=half+8
          DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL	, #DFCS_SCROLLDOWN|#DFCS_PUSHED)
          brush=CreateSolidBrush_(*inf\color)
          pen=createpen_(#PS_SOLID,0,#Black)
          SelectObject_(dc,brush)
          SelectObject_(dc,pen)
          b=1
          c=0
          For a=20 To *inf\width-20 Step 7
            c=c+1
            If c>*inf\value
              brush=CreateSolidBrush_(#White)
              pen=createpen_(#PS_SOLID,0,#Black)
              SelectObject_(dc,brush)
              SelectObject_(dc,pen)
            EndIf 
            b=b+2
            rectangle_(dc,a,*inf\height-b,a+5,*inf\height)
            rct.RECT
            rct\left=a:rct\top=*inf\height-b:rct\right=a+5:rct\bottom=*inf\height
            SetProp_(hwnd,"slinfo",*inf.Slinfo)
          Next 
        EndIf 
      EndIf 
      
    Case #WM_LBUTTONUP
      If uppushed=1
        dc=GetDC_(hwnd)
        *inf.Slinfo=HeapAlloc_(GetProcessHeap_(), 0, SizeOf(Slinfo))
        *inf.Slinfo=GetProp_(hwnd,"slinfo")
        half=(*inf\height)/2
        rect.RECT
        rect\left=*inf\width-16:rect\right=*inf\width:rect\top=half-8:rect\bottom=half+8
        DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL, #DFCS_SCROLLup	)
        uppushed=0
      ElseIf downpushed=1
        dc=GetDC_(hwnd)
        *inf.Slinfo=HeapAlloc_(GetProcessHeap_(), 0, SizeOf(Slinfo))
        *inf.Slinfo=GetProp_(hwnd,"slinfo")
        half=(*inf\height)/2
        rect.RECT
        rect\left=0:rect\right=16:rect\top=half-8:rect\bottom=half+8
        DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL	, #DFCS_SCROLLDOWN)
        downpushed=0
      EndIf 
    Case #WM_MOUSEMOVE
      mte.myTRACKMOUSEEVENT
      mte\cbSize = SizeOf(myTRACKMOUSEEVENT)
      SendMessage_(hwnd,#BM_SETSTYLE,#BS_DEFPUSHBUTTON,#True)
      mte\dwFlags = #TME_LEAVE
      mte\hwndTrack = hwnd
      TrackMouseEvent_(mte)
    Case #WM_MOUSELEAVE
      If uppushed=1
        dc=GetDC_(hwnd)
        *inf.Slinfo=HeapAlloc_(GetProcessHeap_(), 0, SizeOf(Slinfo))
        *inf.Slinfo=GetProp_(hwnd,"slinfo")
        half=(*inf\height)/2
        rect.RECT
        rect\left=*inf\width-16:rect\right=*inf\width:rect\top=half-8:rect\bottom=half+8
        DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL, #DFCS_SCROLLup	)
        uppushed=0
      ElseIf downpushed=1
        dc=GetDC_(hwnd)
        *inf.Slinfo=HeapAlloc_(GetProcessHeap_(), 0, SizeOf(Slinfo))
        *inf.Slinfo=GetProp_(hwnd,"slinfo")
        half=(*inf\height)/2
        rect.RECT
        rect\left=0:rect\right=16:rect\top=half-8:rect\bottom=half+8
        DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL	, #DFCS_SCROLLDOWN)
        downpushed=0
      EndIf 
      
    Case #WM_PAINT
      *inf.Slinfo=HeapAlloc_(GetProcessHeap_(), 0, SizeOf(Slinfo))
      *inf.Slinfo=GetProp_(hwnd,"slinfo") 
      If *inf.Slinfo
        dc=GetDC_(hwnd)
        newdc=createcompatibledc_(dc)
        brush=CreateSolidBrush_(GetSysColor_(#gray))
        SelectObject_(newdc,brush)
        b=1
        rect.RECT
        half=(*inf\height)/2
        rect\left=0:rect\right=16:rect\top=half-8:rect\bottom=half+8
        DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL	, #DFCS_SCROLLDOWN)
        rect\left=*inf\width-16:rect\right=*inf\width:rect\top=half-8:rect\bottom=half+8
        DrawFrameControl_(dc, rect.RECT, #DFC_SCROLL	, #DFCS_SCROLLup)
        c=0
        brush=CreateSolidBrush_(*inf\color)
        pen=createpen_(#PS_SOLID,0,#Black)
        SelectObject_(dc,brush)
        SelectObject_(dc,pen)
        For a=20 To *inf\width-20 Step 7
          c=c+1
          If c>*inf\value
            brush=CreateSolidBrush_(#White)
            pen=createpen_(#PS_SOLID,0,#Black)
            SelectObject_(dc,brush)
            SelectObject_(dc,pen)
          EndIf 
          b=b+2
          rectangle_(dc,a,*inf\height-b,a+5,*inf\height)
        Next 
        BitBlt_(dc,0,0,*inf\width,*inf\height,newdc,0,0,#SRCCOPY)
        ReleaseDC_(hwnd,dc)
        DeleteDC_(newdc)
        ValidateRect_(hwnd, #Null)
        ProcedureReturn 0
      EndIf 
  EndSelect 
  ProcedureReturn DefWindowProc_(hwnd,msg,wParam,lParam)
EndProcedure

Procedure GetGadgetParent()
  !EXTRN _PB_Object_GetThreadMemory@4
  !EXTRN _PB_Gadget_Globals
  !MOV   Eax,[_PB_Gadget_Globals]
  !PUSH  Eax
  !CALL  _PB_Object_GetThreadMemory@4
  !MOV   Eax,[Eax]
  ProcedureReturn
  CreateGadgetList(0)
EndProcedure

Structure Gadget_Info
  OldCallback.l
  DestroyProc.l
  PBID.l
EndStructure

Procedure RegGadget_Callback(hwnd, msg, wParam, lParam)
  Protected *Gadget_Info.Gadget_Info = GetProp_(hwnd, "GadgetInfo")
  Protected OldProc = *Gadget_Info\OldCallback
  
  If msg = #WM_NCDESTROY
    If *Gadget_Info
      If *Gadget_Info\DestroyProc
        CallFunctionFast(*Gadget_Info\DestroyProc, *Gadget_Info\PBID)
      EndIf
    EndIf
    RemoveProp_(hwnd, "GadgetInfo")
    FreeMemory(*Gadget_Info)
  EndIf
  
  ProcedureReturn CallWindowProc_(OldProc, hwnd, msg, wParam, lParam)
EndProcedure
        
Procedure RegisterGadget(hwnd.l, ID.l, DestroyProc.l = 0, *vttemp.PB_GadgetVT = 0)
  Protected PB_Object_GetOrAllocateID.PB_Object_GetOrAllocateID
  Protected PB_Gadget_RegisterGadget.PB_Gadget_RegisterGadget
  Protected PB_Gadget_Objects.l
  Protected *Gadget.PB_Gadget, *Gadget_Info.Gadget_Info
  Protected OldCallback.l
  Protected *VT.PB_GadgetVT
  
  If ((hwnd = 0) Or (ID < #PB_Any))
    ProcedureReturn 0
  EndIf
  
  *VT = AllocateMemory(SizeOf(PB_GadgetVT))
  If *vttemp <> 0
    CopyMemory(*vttemp,*VT,SizeOf(PB_GadgetVT))
  EndIf
  
  CompilerIf #PB_Compiler_Unicode
  !EXTRN  _PB_Gadget_RegisterGadget_UNICODE@16
  !MOV   [p.v_PB_Gadget_RegisterGadget] ,dword _PB_Gadget_RegisterGadget_UNICODE@16
  CompilerElse
  !EXTRN _PB_Gadget_RegisterGadget@16
  !MOV   [p.v_PB_Gadget_RegisterGadget] ,dword _PB_Gadget_RegisterGadget@16
  CompilerEndIf
  
  !EXTRN _PB_Object_GetOrAllocateID@8
  !EXTRN _PB_Gadget_Objects
  !MOV   [p.v_PB_Object_GetOrAllocateID],dword _PB_Object_GetOrAllocateID@8
  !MOV   Eax,[_PB_Gadget_Objects]
  !MOV   [p.v_PB_Gadget_Objects],Eax
  
  *Gadget = PB_Object_GetOrAllocateID(PB_Gadget_Objects, ID)
  hwnd    = PB_Gadget_RegisterGadget(ID, *Gadget,hwnd,*VT)
  
  If DestroyProc
    *Gadget_Info = AllocateMemory(SizeOf(Gadget_Info))
    *Gadget_Info\DestroyProc = DestroyProc
    *Gadget_Info\OldCallback = SetWindowLong_(*Gadget\Gadget, #GWL_WNDPROC, @RegGadget_Callback())
    If ID = #PB_Any
      *Gadget_Info\PBID = hwnd
    Else
      *Gadget_Info\PBID = ID
    EndIf   
    SetProp_(*Gadget\Gadget, "GadgetInfo", *Gadget_Info)
  EndIf
  
  ProcedureReturn hwnd
EndProcedure

Procedure CreateGadget(ID.l, ClassName.s, text.s, style.l, x.l, y.l, DX.l, DY.l, ExStyle.l = 0, DestroyProc.l = 0, *VT.PB_GadgetVT = 0)
  Protected hwnd.l
  Protected parent.l    = GetGadgetParent()
  Protected hInstance.l = GetModuleHandle_(0)
  wc.WNDCLASSEX
  wc\cbSize = SizeOf(WNDCLASSEX)
  wc\style = #CS_DBLCLKS
  wc\lpfnWndProc = @Slidercallback()
  wc\hInstance = hInstance
  wc\lpszClassName = @ClassName
  wc\hcursor=LoadCursor_(0,#IDC_HAND)
  wc\hbrBackground=GetStockObject_(#red)
  RegisterClassEx_(@wc)
  hwnd = CreateWindowEx_(0, ClassName, text, style, x, y, DX, DY, parent, 0, hInstance, 0)
  ShowWindow_(hwnd, #SW_SHOWNORMAL)
  UpdateWindow_(hwnd)
  ProcedureReturn RegisterGadget(hwnd, ID, DestroyProc, *VT)
EndProcedure 

Procedure PBslider(ID.l,x,y,width,height,color.l)
  temphwnd=CreateGadget(ID,"PB_Slider","",#WS_CHILD|#WS_VISIBLE	,x,y,width,height)
  If ID = #PB_Any
    hwnd=GadgetID(temphwnd)
  Else
    hwnd=temphwnd 
  EndIf   
  
  *info.Slinfo=HeapAlloc_(GetProcessHeap_(), 0, SizeOf(Slinfo))
  *info\value=0
  *info\height=height
  *info\width=width
  *info\PBID=ID
  *info\color=color
  half=(*info\height)/2
  steps=(*info\width-40)/7
  steps+1
  *info\maxvalue=steps
  *info\button\left=0:*info\button\right=16:*info\button\top=half-8:*info\button\bottom=half+8
  *info\button1\left=*info\width-16:*info\button1\right=*info\width:*info\button1\top=half-8:*info\button1\bottom=half+8
  SetProp_(hwnd,"slinfo",*info.Slinfo)
  RedrawWindow_(hwnd,0,0,7)
EndProcedure 

OpenWindow(0,0,0,470,460,"PB_Slider",#PB_Window_SystemMenu|#PB_Window_ScreenCentered) 
CreateGadgetList(WindowID(0))
PBslider(10,20,50,150,40,#blue)

Repeat
  Select WaitWindowEvent()
    Case #PB_Event_Gadget
      Select EventGadget()
        Case 10
          Debug 555
      EndSelect
    Case #PB_Event_CloseWindow
      Quit=1
  EndSelect
Until Quit=1

Posted: Mon Jun 26, 2006 9:46 pm
by srod
Some nice code there Localmotion34.

Should the slider move continuously though if I hold the mouse down over one of the buttons? This would be a nice addition.

I notice that in your button callback proc., you use SetCursor_() etc. I don't think this is required because you set the class cursor to the hand anyhow.

Anyhow thanks, this is pretty smart stuff. :)

Posted: Mon Jun 26, 2006 11:13 pm
by mskuma
Very nice localmotion34 - looking forward to seeing more!
srod wrote:Should the slider move continuously though if I hold the mouse down over one of the buttons? This would be a nice addition
I agree.

Posted: Mon Jun 26, 2006 11:56 pm
by localmotion34
srod wrote:
Should the slider move continuously though if I hold the mouse down over one of the buttons? This would be a nice addition.
give me an idea of HOW to do it, and i wil. ive been counting thousands of tissue sections on slides, and my brain is fried this month.

Posted: Tue Jun 27, 2006 12:09 am
by srod
TrackMouseEvent_() sending the #WM_MOUSEHOVER message comes to mind. Not sure if this would work, but it would need combining with some global flag to indicate whether the mouse button is down etc. I must admit that I've never used this function and I don't know if it will work whilst the mouse button is down etc. Still, worth a try I reckon! :)

Posted: Thu Jun 07, 2007 1:38 pm
by Progi1984
How can EventGadget() can receive event from your gadget ?

An idea ?
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited