Scrolling vfp containers with FlatScrollbar activeX
i was surprised by an old microsoft scrollbar shipped with vfp as activex (olecontrol).i project to make it in use.
in preview posts i have presented 2 scrollbars classes for vfp containers (from SPS and kirov sites) (see links below the page).
The FlatScrollBar control is a mouse-sensitive version of the standard Windows scroll bar that offers two-dimensional formatting options.
The FlatScrollBar provides increased interactivity when using vfp containers.
the FlatScrollBar has three Appearance styles: a standard style, a three-dimensional (beveled) style, and
a two-dimensional style that becomes beveled when the mouse pointer hovers over it
the demo code below builds:
-a container with vertical and horizontal scrollbars and with many objects in the scrollable area of the container.
-a scrolling region with an inside container (cntInside ) with a big image downloaded from the web(internet must be connected and some fast).
i added a grid, a listbox and an editbox to diversify objects.
-what is good is the simplicity of this control (like a slider)
there is 2 methods (change and scroll) to make it working. of course properties must set before using(orientation,width,left,top,with,height,
smallChange,largeChange,value...and min and max).see in code.
the olescrollbar scale can be (min=0 and max=100% or absolute pixel value<=32000).
-fill the "cntInside" container with custom objects and set the scrollbars properties in setViewport method.
-better method to work with scrollbars is to use api to implement scrollH or scrollV.the sendmessage api and constants are used here.
the olescrollbar control have a builder (can set properties in a dialog...rightclick on and select assistant...).
*the big image is downloaded from the web.can use local image.
Notes: MSCOMCTL32 library must be redistributed to work with the flatscrollbar ole object.
this code is rendered/tested on 32 pouces screen.
https://msdn.microsoft.com/en-us/library/aa276347(v=vs.60).aspx
Distribution Note The FlatScrollBar control is part of a group of ActiveX controls that are found in the MSCOMCT2.OCX file.
To use the FlatScrollBar control in your application, you must add the MSCOMCT2.OCX file to the project. When distributing
your application, install the MSCOMCT2.OCX file in the user's Microsoft Windows System or System32 directory.
[Post 244]
Click on code to select [then copy] -click outside to deselect
*1* created on thursday 23 of november 2017
*working with scrolling container of objects with the ole flatScrollbar "MSComCtl2.FlatScrollBar.2" of mscomctl32 library.
*
*test if mscomctl32 library exists on system otherwise cancel this code.
Local m.o,m.test
m.test=.F.
Try
o=Newobject("MSComCtl2.FlatScrollBar.2")
m.test=.T.
Catch
m.test=.F.
Endtry
If m.test=.F.
Messagebox("Mscomctl32 library have no longer on system....cancelling application!",16+4096)
m.o=Null
Return .F.
Endi
m.o=Null
*
Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
*download a big image from my blog used in code.nternet must be connected.
Local m.ydownl
m.ydownl=.T. && make it false since image downloaded for use
If m.ydownl=.T.
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20171123/ob_29d95d_taghit.jpg"
lcDownloadLoc ="taghit.jpg"
lnResult = DeleteUrlCacheEntry(lcDownloadURL)
lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0)
If lnResult = 0
Wait Window "Download "+lcDownloadLoc +" Complete" Nowait
*Else
*!* Messagebox("Download fails")
Endi
Endi
*
_Screen.WindowState=1
set curs off
_vfp.autoyield=.f.
Publi oform
oform=Newobject("yscroll")
oform.Show
Read Events
Retu
Define Class yscroll As Form
Height = 625
Width = 1040
BorderStyle=0
Closable=.F.
MaxButton=.F.
ShowWindow = 2
AutoCenter = .T.
ShowTips=.T.
Caption = "scrolling any vfp container."
Name = "form1"
BackColor=Rgb(45,45,45)
Add Object ycnt As cntscrollregion With ;
Top = 15, ;
Left = 15, ;
Width = 900, ;
Height = 500, ;
borderwidth=3,;
Name = "ycnt"
Add Object check1 As Checkbox With ;
anchor=768,;
autosize=.T.,;
Top = 560, ;
Left = 432, ;
Caption= " Mousewheel V ",;
style=1,;
value=1,;
backcolor=Rgb(255,140,120),;
specialEffect=2,;
mousepointer=15,;
fontbold=.T.,;
Name = "Check1"
Add Object ycom As ycom With;
anchor=768,;
left=1020-110 ,;
top= 10 ,;
name="ycom"
Procedure KeyPress
Lparameters nKeyCode, nShiftAltCtrl
If nKeyCode=27
Thisform.Release
Endi
Endproc
Procedure check1.InteractiveChange()
With Thisform.ycnt
Do Case
Case This.Value=1
.mwV=1
.mwH=0
Case This.Value=0
.mwV=0
.mwH=1
Endcase
This.BackColor=Iif(This.Value=1,Rgb(255,140,120),Rgb(0,255,0))
This.Caption=Iif(This.Value=1," Mousewheel V "," Mousewheel H ")
Endwith
Endproc
Procedure Load
Declare Integer SendMessage In user32;
INTEGER HWnd,;
INTEGER Msg,;
INTEGER wParam,;
INTEGER Lparam
Declare Integer Sleep In kernel32 Integer
Close Data All
Endproc
Procedure Init
DoDefault()
This.check1.Left=(This.ycnt.Width-This.check1.Width)/2
Endproc
Enddefine
*
*scrolling region container embedding the cntinside container and olescrollbars (V,H)
Define Class cntscrollregion As Container
Width = 820
Height = 600
BorderWidth = 0
BackColor=Rgb(153,217,234)
BackStyle=1
Name = "cntscrollregion"
gnScrollValue=0
mwV=1
mwH=0
Add Object cntInside As cntInside With ;
Left = 0, ;
BackStyle = 0, ;
BorderWidth = 0, ;
TabIndex = 3, ;
Name = "cntInside"
Add Object olescrollBarH As OleControl With ;
oleclass="MSComCtl2.FlatScrollBar.2", ;
Top = 0, ;
Left = 432, ;
Height = 198, ;
Width = 17, ;
Visible = .T., ;
TabIndex = 1, ;
Name = "oleScrollBarH"
Add Object olescrollBarV As OleControl With ;
oleclass="MSComCtl2.FlatScrollBar.2", ;
Top = 0, ;
Left = 432, ;
Height = 198, ;
Width = 17, ;
Visible = .T., ;
TabIndex = 2, ;
Name = "oleScrollBarV"
Procedure Init
With This
.AddProperty("gnScrollValue",0)
.gnScrollValue = 0
.SetViewPort()
Endwith
Endproc
*-- Specifies the ViewPortLeft and ViewPortTop properties for a form.
Procedure SetViewPort
*-- Set up the olescrollbarH
With This.olescrollBarH
.appearance=0
.Orientation=1
.arrows=0
.Height =17
.Left = This.Left -15
.Top = This.Height-.Height +18
.Width=This.Width
.Min = 0
.Max =Max(0,(This.cntInside.Width -This.Width) + 20)
.SmallChange = 20
.LargeChange = This.Width- 20
.Value =This.gnScrollValue
.Refresh
.Visible = .T.
Endwith
*-- Set up the olescrollbarV
With This.olescrollBarV
.appearance=0
.Orientation=0
.arrows=0
.Width=17
.Left = This.Width - 18
.Top = 0
.Height =This.Height
.Min = 0
.Max =Max(0,(This.cntInside.Height - This.Height) + 20)
.SmallChange = 20
.LargeChange = This.Height - 20
.Value =This.gnScrollValue
.Refresh
.Visible = .T.
Endwith
Endproc
*-- Releases all controls within the pane container
Procedure Clear
This.cntInside.Clear()
Endproc
Procedure MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
Do Case
Case This.mwV=1
This.mwH=0
#Define WM_VSCROLL 0x0115
#Define WM_HSCROLL 0x0114
#Define SB_LINEUP 0
#Define SB_LINEDOWN 1
If nDirection>0
=SendMessage(This.olescrollBarV.HWnd, WM_VSCROLL, SB_LINEUP, 0)
=SendMessage(This.olescrollBarV.HWnd, WM_VSCROLL, SB_LINEUP, 0)
Else
=SendMessage(This.olescrollBarV.HWnd, WM_VSCROLL, SB_LINEDOWN, 0) &&vertical
=SendMessage(This.olescrollBarV.HWnd, WM_VSCROLL, SB_LINEDOWN, 0)
Endi
This.olescrollBarV.Change()
Case This.mwH=1
This.mwV=0
If nDirection>0
=SendMessage(This.olescrollBarH.HWnd, WM_HSCROLL, SB_LINEDOWN, 0) &&horizontal
=SendMessage(This.olescrollBarH.HWnd, WM_HSCROLL, SB_LINEDOWN, 0)
Else
=SendMessage(This.olescrollBarH.HWnd, WM_HSCROLL, SB_LINEUP, 0)
=SendMessage(This.olescrollBarH.HWnd, WM_HSCROLL, SB_LINEUP, 0)
Endi
This.olescrollBarH.Change()
Endcase
Endproc
Procedure cntInside.MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.MouseWheel(nDirection)
DoEvents
Endproc
Procedure olescrollBarV.Refresh
*** ActiveX Control Method ***
This.Change()
Endproc
Procedure olescrollBarH.Refresh
*** ActiveX Control Method ***
This.Change()
Endproc
Procedure olescrollBarV.Change
*** ActiveX Control Event ***
This.Parent.gnScrollValue = This.Value
This.Parent.cntInside.Top = -This.Parent.gnScrollValue
Endproc
Procedure olescrollBarH.Change
*** ActiveX Control Event ***
This.Parent.gnScrollValue = This.Value
This.Parent.cntInside.Left = -This.Parent.gnScrollValue
Endproc
Enddefine
*
*-- EndDefine: cntscrollregion
*
*here the cntInside container where the user fill with objetcs to scroll (H or V)
Define Class cntInside As Container
Top=0
Left=0
Width = 2500
Height = 2200
BorderWidth = 0
Name = "cntInside"
*
*fill container with objects...hereone image.
Add Object image1 As Image With ;
top=1,;
left=1,;
width=1000,;
height=1700,;
stretch=0,;
picture="taghit.jpg" &&getpict() for local image
Name="image1"
Add Object edit1 As EditBox With ;
left=450,;
top=50,;
width=400,;
height=400,;
scrollbars=0,;
forecolor=Rgb(128,0,64),;
fontbold=.T.,;
scrollbars=0,;
borderstyle=0,;
backstyle=0,;
fontname="script",;
fontsize=14,;
name="edit1"
Add Object list1 As ListBox With ;
Height = 285, ;
Left = 516, ;
Top = 429, ;
Width = 145, ;
Name = "List1"
Add Object grid1 As Grid With ;
Height = 133, ;
Left = 100, ;
Top = 369, ;
Width = 349, ;
Name = "Grid1"
Procedure edit1.Init
With This
.Top=.Parent.image1.Top+.Parent.image1.Height+40
TEXT to .value pretext 7 noshow
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat
fermentum nec a turpis. Phasellus purus sem, mollis ac posuere eget, ornare vel orci. Sed ac rutrum
nulla. Aenean ultrices eget lectus eu efficitur. In hac habitasse platea dictumst. Nulla in iaculis nisi.
Nullam et pulvinar tellus. Donec arcu dui, efficitur a odio non, porta congue dolor. Aenean viverra
auctor sagittis. Integer lobortis dignissim auctor. Proin et volutpat massa.
Cras vitae felis venenatis, egestas sem quis, sodales neque. Donec venenatis hendrerit odio, non
pellentesque metus scelerisque ac. Suspendisse aliquet rhoncus odio id viverra. Vestibulum feugiat
lectus a nisl pulvinar, in tempor metus eleifend. Nunc id odio quam. Praesent egestas lorem ut
sollicitudin consectetur. Vestibulum id bibendum est. Ut vel lacus sapien. Quisque eget molestie
sem. Integer eget purus eu orci molestie aliquam quis in ante. Integer a magna eget lectus finibus
porttitor. Donec fringilla sapien a quam aliquet, pellentesque blandit nisl placerat. Nam hendrerit
velit vel ex aliquam, eget convallis ante mollis.
ENDTEXT
Endwith
Endproc
Procedure grid1.Init
Sele address From Home(1)+"samples\data\customer" Into Cursor ycurs1
With This
.RecordSource=""
.RecordSource="ycurs1"
.RecordSourceType=1
.GridLines=0
.DeleteMark=.F.
.Height=400
.Left=90
.Top=.Parent.image1.Top+.Parent.image1.Height+40
.FontBold=.T.
.SetAll("DynamicBackColor", "IIF(MOD(RECNO( ), 2)=0, RGB(255,255,255) , RGB(190,235,200))", "Column")
Locate
.Refresh
Endwith
Endproc
Procedure list1.Init
Sele company From Home(1)+'samples\data\customer' Into Cursor lcurs
With This
.RowSource="lcurs"
.RowSourceType=2
.SelectedItemBackColor=Rgb(70,60,50)
.SelectedItemForeColor=Rgb(10,191,160)
.SpecialEffect=1
.FontSize=8
.ItemBackColor=Rgb(40,40,40)
.ItemForeColor=Rgb(255,204,153)
.BorderColor=Rgb(235,132,0)
.ItemTips=.T.
.MousePointer=15
.ListIndex=1
.Top=.Parent.edit1.Top+.Parent.edit1.Height+10
Endwith
Endproc
Procedure Init
DoDefault()
With This
.BackColor=Rgb(153,217,234)
.BackStyle=1
Endwith
Endproc
Procedure image1.MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.Parent.MouseWheel(nDirection)
DoEvents
Endproc
*-- Releases all controls
Procedure Clear
lnControlCount = This.ControlCount
For i = 1 To lnControlCount
This.RemoveObject(This.Controls(1).Name)
Endfor
Endproc
Procedure Destroy
oform=Null
Release oform
Clea Events
Endproc
Enddefine
*
*command commandGroup container class
Define Class ycom As CommandGroup
AutoSize = .T.
ButtonCount = 11
BackStyle = 0
BorderStyle = 1
Value = 1
Height = 240
Left = 798
SpecialEffect = 0
Top = 1
Width = 94
Name = "Commandgroup1"
Command1.Top = 5
Command1.Left = 5
Command1.Height = 27
Command1.Width = 84
Command1.Caption = "Summary help"
Command1.Name = "Command1"
Command2.Top = 34
Command2.Left = 5
Command2.Height = 27
Command2.Width = 84
Command2.Caption = "MSDN help"
Command2.Name = "Command2"
Command3.Top = 63
Command3.Left = 5
Command3.Height = 27
Command3.Width = 84
Command3.Caption = "scrollH visibility"
Command3.Name = "Command3"
Command4.Top = 92
Command4.Left = 5
Command4.Height = 27
Command4.Width = 84
Command4.Caption = "ScrollV visibility"
Command4.Name = "Command4"
Command5.Top = 121
Command5.Left = 5
Command5.Height = 27
Command5.Width = 84
Command5.Caption = "ScrollV down"
Command5.Name = "Command5"
Command6.Top = 150
Command6.Left = 5
Command6.Height = 27
Command6.Width = 84
Command6.Caption = "ScrollV up"
Command6.Name = "Command6"
Command7.Top = 179
Command7.Left = 5
Command7.Height = 27
Command7.Width = 84
Command7.Caption = "Arrows"
Command7.Name = "Command7"
Command8.Top = 208
Command8.Left = 5
Command8.Height = 27
Command8.Width = 84
Command8.Caption = "Appearance"
Command8.Name = "Command8"
Command9.Top = 236
Command9.Left = 5
Command9.Height = 27
Command9.Width = 84
Command9.Caption = "ScrollH left"
Command9.Name = "Command9"
Command10.Top = 264
Command10.Left = 5
Command10.Height = 27
Command10.Width = 84
Command10.Caption = "ScrollH right"
Command10.Name = "Command10"
Command11.Top = 264+27+1
Command11.Left = 5
Command11.Height = 27
Command11.Width = 84
Command11.fontbold=.t.
Command11.forecolor=255
Command11.Caption = "Exit"
Command11.Name = "Command11"
Procedure Init
With This
.AutoSize=.T.
.Left=.Parent.Width-.Width-25
.SetAll("Backcolor",Rgb(0,255,0))
.SetAll("mousepointer",15)
.SetAll("width",100)
.SetAll("specialeffect",2)
Endwith
Endproc
Procedure Command1.Click
Local m.myvar
TEXT to m.myvar pretext 7 noshow
i was surprised by an old microsoft scrollbar shipped with vfp as activex (olecontrol). i project to make it in use.
in preview posts i have presented 2 scrollbars classes for vfp containers (from SPS and kirov sites).
The FlatScrollBar control is a mouse-sensitive version of the standard Windows scroll bar that offers two-dimensional formatting options.
The FlatScrollBar provides increased interactivity when using vfp containers.
the FlatScrollBar has three Appearance styles: a standard style, a three-dimensional (beveled) style, and a two-dimensional style that becomes beveled when the mouse pointer hovers over it.
the demo code below builds:
-a container with vertical and horizontal scrollbars and with many objects in the scrollable area of the container.
-a scrolling region with an inside container (cntInside ) with a big image downloaded from the web(internet must be connected and some fast).
i added in this cntInside container a grid, a listbox and an editbox to diversify objects.
-what is good is the simplicity of this control (like a slider)
there is 2 methods (change and scroll) to make it working.
Of course properties must set before using(orientation,width,left,top,with,height,smallChange, largeChange,value...and min and max).see in code.
the olescrollbar scale can be (min=0 and max=100% or absolute pixel value<=32767).Be care to set scrollbars and to make them appear around the container to scroll.
-fill the "cntInside" container with custom objects and set the scrollbars properties in setViewport method.
-better method to work with scrollbars is to use api to implement scrollH or scrollV.the sendmessage api and constants are used here.
the olescrollbar control have a builder (can set properties in a dialog...rightclick on and select assistant...see photo below).
*the big image is downloaded from the web (internet connected and fast).can use local image.
Notes: MSCOMCTL32 library must be redistributed to work with the flatscrollbar ole object.
this code is rendered/tested on 32 pouces screen.
ENDTEXT
Local oshell
oshell = Createobject('WScript.Shell')
oshell.Popup(m.myvar,0, 'Summary help launched from web to vfp', 0+32+4096) &&4,16,48,64...
oshell=Null
Endproc
Procedure Command2.Click
Local o
o=Newobject("hyperlink")
o.NavigateTo("https://msdn.microsoft.com/en-us/library/aa231260(v=vs.60).aspx")
o=Null
Endproc
Procedure Command3.Click
With Thisform.ycnt.olescrollBarH
.Visible=!.Visible
DoEvents
Endwith
Endproc
Procedure Command4.Click
With Thisform.ycnt.olescrollBarV
.Visible=!.Visible
DoEvents
Endwith
Endproc
Procedure Command5.Click
#Define WM_VSCROLL 0x0115
#Define WM_HSCROLL 0x0114
#Define SB_LINEDOWN 1
#Define SB_LINEUP 0
With Thisform.ycnt.olescrollBarV
.Change() &&give focus
For i=.Value To .Max
=SendMessage(.HWnd, WM_VSCROLL, SB_LINEDOWN, 0)
=SendMessage(.HWnd, WM_VSCROLL, SB_LINEDOWN, 0)
.Change()
Endfor
Endwith
Endproc
Procedure Command6.Click
#Define WM_VSCROLL 0x0115
#Define WM_HSCROLL 0x0114
#Define SB_LINEDOWN 1
#Define SB_LINEUP 0
With Thisform.ycnt.olescrollBarV
.Change() &&give focus
For i=.Value To .Min Step-1
=SendMessage(.HWnd, WM_VSCROLL, SB_LINEUP, 0)
=SendMessage(.HWnd, WM_VSCROLL, SB_LINEUP, 0)
.Change()
Endfor
Endwith
Endproc
Procedure Command7.Click
With Thisform.ycnt.olescrollBarH
Try
.arrows=.arrows+1
Catch
.arrows=0
Endtry
Endwith
With Thisform.ycnt.olescrollBarV
Try
.arrows=.arrows+1
Catch
.arrows=0
Endtry
Endwith
DoEvents
Endproc
Procedure Command8.Click
With Thisform.ycnt.olescrollBarH
Try
.appearance=.appearance+1
Catch
.appearance=0
Endtry
Endwith
With Thisform.ycnt.olescrollBarV
Try
.appearance=.appearance+1
Catch
.appearance=0
Endtry
Endwith
DoEvents
Endproc
Procedure Command9.Click
#Define WM_VSCROLL 0x0115
#Define WM_HSCROLL 0x0114
#Define SB_LINEDOWN 1
#Define SB_LINEUP 0
With Thisform.ycnt.olescrollBarH
.Change() &&give focus
For i=.Value To .Min Step-1
=SendMessage(.HWnd, WM_HSCROLL, SB_LINEUP, 0)
=SendMessage(.HWnd, WM_HSCROLL, SB_LINEUP, 0)
.Change()
Endfor
Endwith
Endproc
Procedure Command10.Click
#Define WM_VSCROLL 0x0115
#Define WM_HSCROLL 0x0114
#Define SB_LINEDOWN 1
#Define SB_LINEUP 0
With Thisform.ycnt.olescrollBarH
.Change() &&give focus
For i=.Value To .Max
=SendMessage(.HWnd, WM_HSCROLL, SB_LINEDOWN, 0)
=SendMessage(.HWnd, WM_HSCROLL, SB_LINEDOWN, 0)
.Change()
Endfor
Endwith
Endproc
Procedure Command11.Click
oform=Null
Thisform.Release
Endproc
Enddefine
*
*-- EndDefine: ycom
*
A complet demo how to use flatScrollbar V & H on any vfp container
embed the comctl32 library on vfp object explorer and see the flatscrollbar PEM.
Important:All Codes above are tested on VFP9SP2 , windows 10 pro version 1703 .Comctl32 library must exits on system.