Plateforme Level Extreme
Abonnement
Profil corporatif
Produits & Services
Support
Légal
English
Vcx to available prg
Message
De
04/01/2016 13:12:26
 
 
À
03/01/2016 04:17:25
Information générale
Forum:
Visual FoxPro
Catégorie:
Classes - VCX
Versions des environnements
Visual FoxPro:
VFP 9 SP2
OS:
Windows 10
Database:
Visual FoxPro
Application:
Desktop
Virtual environment:
VirtualPC
Divers
Thread ID:
01629513
Message ID:
01629571
Vues:
292
No Koen, its the class downloaded exactly from http://www.arg.kirov.ru/downloads/Download.aspx?filename=ScrollContainer.zip
i build a working example ine my blog as i pointed in code *2* of:
http://yousfi.over-blog.com/2016/01/the-vfpscrollbar-container-class-as-prg-code.html#ob
if you add the code i gave you its works and makes a some (adjustable) automatic vertical scroll continously.
infortunatly this site dont admit to send zips...even if he said the inverse
Maybe its a bug in new UniversalThread version.......the i send you complet code..its big (37ko)

Regards
*updated on Tuesday 5 january 2016 (added h file+correct scroll for koen)

*2* original scroll Container class from  http://www.arg.kirov.ru/
*dont omit vfpsbcnt.h in same folder (its created here)
declare integer Sleep in kernel32 integer
local m.my
text to m.my noshow
#IFNDEF    __VFP_SBCONTAINER_H_INCLUDED
#DEFINE	__VFP_SBCONTAINER_H_INCLUDED
#DEFINE	SBC_HORS			1
#DEFINE	SBC_VERT			2
#DEFINE	SB_LINEUP			0
#DEFINE	SB_LINELEFT			0
#DEFINE	SB_LINEDOWN			1
#DEFINE	SB_LINERIGHT		1
#DEFINE	SB_PAGEUP			2
#DEFINE	SB_PAGELEFT			2
#DEFINE	SB_PAGEDOWN			3
#DEFINE	SB_PAGERIGHT		3
#DEFINE	SB_THUMBPOSITION	4
#DEFINE	SB_THUMBTRACK		5
#DEFINE	SB_TOP				6
#DEFINE	SB_LEFT				6
#DEFINE	SB_BOTTOM			7
#DEFINE	SB_RIGHT			7
#define COLOR_SCROLLBAR			0
#define COLOR_BACKGROUND		1
#define COLOR_ACTIVECAPTION		2
#define COLOR_INACTIVECAPTION		3
#define COLOR_MENU			4
#define COLOR_WINDOW			5
#define COLOR_WINDOWFRAME		6
#define COLOR_MENUTEXT			7
#define COLOR_WINDOWTEXT		8
#define COLOR_CAPTIONTEXT		9
#define COLOR_ACTIVEBORDER		10
#define COLOR_INACTIVEBORDER		11
#define COLOR_APPWORKSPACE		12
#define COLOR_HIGHLIGHT			13
#define COLOR_HIGHLIGHTTEXT		14
#define COLOR_BTNFACE			15
#define COLOR_BTNSHADOW			16
#define COLOR_GRAYTEXT			17
#define COLOR_BTNTEXT			18
#define COLOR_INACTIVECAPTIONTEXT	19
#define COLOR_BTNHIGHLIGHT		20
*-- #if(WINVER >= 0x0400)
#define COLOR_3DDKSHADOW        21
#define COLOR_3DLIGHT           22
#define COLOR_INFOTEXT          23
#define COLOR_INFOBK            24
*-- #endif /* WINVER >= 0x0400 */
*-- #if(WINVER >= 0x0500)
#define COLOR_HOTLIGHT                  26
#define COLOR_GRADIENTACTIVECAPTION     27
#define COLOR_GRADIENTINACTIVECAPTION   28
*-- #endif /* WINVER >= 0x0500 */
*-- #if(WINVER >= 0x0400)
#define COLOR_DESKTOP           COLOR_BACKGROUND
#define COLOR_3DFACE            COLOR_BTNFACE
#define COLOR_3DSHADOW          COLOR_BTNSHADOW
#define COLOR_3DHIGHLIGHT       COLOR_BTNHIGHLIGHT
#define COLOR_3DHILIGHT         COLOR_BTNHIGHLIGHT
#define COLOR_BTNHILIGHT        COLOR_BTNHIGHLIGHT
*-- #endif /* WINVER >= 0x0400 */
#ENDIF		&&	__VFP_SBCONTAINER_H_INCLUDED
endtext
set safe off
strtofile(m.my,"vfpsbcnt.h")

Publi yform
yform=Newobject("yimg")
yform.Show
Read Events
Retu
*
Define Class yimg As Form
Height = 512
Width = 737
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "Test sbcont scroll container class"
ScaleMode=3
xint=2    &&space between 2 images (pixels)
hscroll=0
Name = "Form1"

Add Object _scrollcontainer1 As _scrollcontainer With ;
Anchor = 15, ;
Top = 60, ;
Left = 5, ;
Width = 728, ;
Height = 456, ;
specialEffect=2, ;
borderWidth=0, ;
Name = "_scrollcontainer1"

Add Object command1 As CommandButton With ;
Top = 1, ;
Left = 275, ;
Height = 37, ;
Width = 109, ;
Anchor = 768, ;
Caption = "Images", ;
Name = "Command1"

Add Object spinner1 As Spinner With ;
Anchor = 768, ;
Height = 24, ;
KeyboardHighValue = 2, ;
KeyboardLowValue = 0, ;
Left = 206, ;
SpinnerHighValue =   2.00, ;
SpinnerLowValue =   0.00, ;
ToolTipText = "Stretch", ;
Top = 8, ;
Width = 49, ;
Name = "Spinner1"

Add Object label1 As Label With ;
Anchor=768, ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 18, ;
BackStyle = 0, ;
Caption = "?", ;
Height = 32, ;
Left = 400, ;
MousePointer = 15, ;
Top = 6, ;
Width = 17, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label1"

********************************************added for Koen*****sorollbar vertic&ldont updated!!!*****************
Add Object ylabel1 As Label With ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontName = "Webdings", ;
	FontSize = 18, ;
	Anchor = 768, ;
	BackStyle = 0, ;
	Caption = "5", ;
	Height = 26, ;
	Left = 600, ;
	MousePointer = 15, ;
	Top = 0, ;
	Width = 24, ;
	Name = "yLabel1"


Add Object ylabel2 As Label With ;
	AutoSize = .T., ;
	FontBold = .T., ;
	FontName = "Webdings", ;
	FontSize = 18, ;
	Anchor = 768, ;
	BackStyle = 0, ;
	Caption = "6", ;
	Height = 26, ;
	Left = 600+37, ;
	MousePointer = 15, ;
	Top = 2, ;
	Width = 24, ;
	Name = "yLabel2"


Procedure ylabel1.Click
	*up button
	With thisform._scrollcontainer1
		For i=1 To thisform.hscroll&&adapt to make a partial or complet scroll
		   .scrollby(0,10)
		   **.vscrollbar.update()
		  
			sleep(5)
			 .UpdateScrollBars()      &&dont work
		Endfor
		
	Endwith
Endproc

Procedure ylabel2.Click
	*down button
	With thisform._scrollcontainer1
		For i=1 To  thisform.hscroll  &&adapt to make a partial or complet scroll
			.scrollby(0,-10)
		   **.vscrollbar.update()
		  
			sleep(5)
			  .UpdateScrollBars()   &&dont work
	 Endfor
	Endwith
Endproc

*********************************************added for Koen**************************************

Procedure Init
DoDefault()

With Thisform._scrollcontainer1
.ScrollBars=3
.SpecialEffect=2
.autoScroll=.T.
.wheelScrollLines=8
.Refresh
Endwith
Endproc

Procedure command1.Click
Thisform.xint=2
Local m.yrep
m.yrep=Getdir()
If Empty(m.yrep)
Return .F.
Endi
m.yrep=Addbs(m.yrep)
Local gnbre
gnbre=Adir(gabase,m.yrep+"*.jpg")
If gnbre=0
Return .F.
Endi
Messagebox(Trans(gnbre)+" photos in "+m.yrep,0+32+4096,'',1200)
Set Defa To Addbs(Justpath(Sys(16,1)))

With Thisform._scrollcontainer1.viewframe.clientarea
.BackColor=0
.BackStyle=1
hscroll=0
For i=1 To gnbre
	.AddObject("image"+Trans(i),"image")

	With Eval(".image"+Trans(i))
		.Anchor=0
		.BorderStyle=1
		.Stretch=Thisform.spinner1.Value
		If  !Thisform.spinner1.Value=0
			.Width=.Parent.Width
			.Height=.Width
		Endi
		.Left=1
		thisform.hscroll=thisform.hscroll+.height+thisform.xint
		.Picture=m.yrep+gabase(i,1)
		.ToolTipText=Justfname(.Picture)+Chr(13)+Trans(gabase(i,2))+ "octets"+Chr(13)+"Date:"+Dtoc(gabase(i,3))
		If i=1
			.Top=0
		Else
			.Top=Eval(".parent.image"+Trans(i-1)+".top")+Eval(".parent.image"+Trans(i-1)+".height")+Thisform.xint
		Endi
		Wait Window ("image"+Trans(i)) Nowait
		.Visible=.T.
	Endwith
	Bindevent(Eval(".image"+Trans(i)),"mousewheel",Thisform,"my")
Endfor
.Refresh
Endwith
This.Enabled=.F.
This.Parent.spinner1.Enabled=.F.

With Thisform._scrollcontainer1
.ScrollBars=3
.autoScroll=.T.
.calcAutoRange()
.SpecialEffect=2
.Resize()
Wait Clea
Endwith
messagebox("hscroll="+trans(thisform.hscroll),0+32+4096,'',1000)
Endproc

Procedure my   &&I added this routine to support mouseWheel on images
Lparameters nDirection, nShift, nXCoord, nYCoord
DoDefault()
*--- aevent create an array laEvents
*
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.Parent.MouseWheel(nDirection, nShift, nXCoord, nYCoord)
Endproc

Procedure label1.Click
Local m.myvar
TEXT to m.myvar noshow
The original scrolling container class from  http://www.arg.kirov.ru/downloads/
its now working as converted prg file and can be work as standalone with any code.
I added a routine to mouseWheel on objects contained to scroll with mouse easily.

the scroll container class  can embed a great quantity of controls here tested with an images folder(more 300 big images).
Can set the stretch images as (0 clip,1  Isometric  ,2 extension).
Before embedding objects must set the properties to make the container working as expected (form.init) and
issue the resize method mandatory to make the scrollbars visibles.
there is 2 containers in the scrolling container(Viewframe & clientArea: here add  objects)
this class have the capability to work with mouseWheel (see wheelScrolllines to set the
number of lines with mouseWheel)-(dont work with arrows or PGup,PgDown).

use:
-with a prg main file caller this class
-saved with as a prg class and called
			   -set proc to ....additive
 -createObject...,newObject....	
ENDTEXT
Messagebox(m.myvar,0+32+4096,"Summary help")
Endproc

Procedure Destroy
Clea Events
Endproc

Enddefine
*
*-- EndDefine: yimg
************************************
*here the scrolling class as text
#INCLUDE vfpsbcnt.h
*
Define Class __cntsbbutton As Container
Width = 16
Height = 16
SpecialEffect = 0
BorderColor = Rgb(128,128,128)
Protected m_nbuttonsize
m_nbuttonsize = 16
Delay = 0.02
Name = "__cntsbbutton"
ldown = .F.
Protected ldragging

Add Object lbldirection As Label With ;
AutoSize = .T., ;
FontName = "Marlett", ;
Alignment = 2, ;
BackStyle = 0, ;
Caption = "3", ;
Height = 14, ;
Left = 1, ;
Top = 1, ;
Width = 14, ;
Name = "lblDirection"


Procedure buttondown
If !This.ldown
This.ldown = .T.
This.SpecialEffect = 2		&& 1
This.lbldirection.Move( This.lbldirection.Left + 1, This.lbldirection.Top + 1)
This.Move( This.Left)
Endif
Endproc


Procedure buttonup
If This.ldown
This.ldown = .F.
This.SpecialEffect = 0		&& 1
This.lbldirection.Move( This.lbldirection.Left - 1, This.lbldirection.Top - 1)
This.Move( This.Left)
Endif
Endproc


Protected Procedure enabled_assign
Lparameters tlEnabled

This.Enabled = m.tlEnabled
This.lbldirection.Enabled = m.tlEnabled
Endproc


Procedure Resize
With This
.lbldirection.Move( (.Width - .lbldirection.Width) / 2 + 1, (.Height - .lbldirection.Height) / 2 + 1)
Endwith
Endproc

Procedure Init
This.m_nbuttonsize = Sysmetric( 5)
Declare Integer GetSysColor In Win32API Integer
This.BorderColor = GetSysColor( COLOR_BTNSHADOW)
This.Resize()
DoDefault()
Endproc


Procedure MouseMove
Lparameters nButton, nShift, nXCoord, nYCoord
If m.nButton = 1
Local lnTop, lnLeft, lnSec, lnDelay, loCurObject
lnTop = Objtoclient( This, 1)
lnLeft = Objtoclient( This, 2)
With This
	If .ldragging And Between( m.nXCoord, m.lnLeft, m.lnLeft + .Width) And ;
			Between( m.nYCoord, m.lnTop, m.lnTop + .Height)

		If !.ldown
			.buttondown
		Endif

		lnDelay = .Delay	&& / 3
		Do While .T.
			.Click
			lnSec = Seconds() + m.lnDelay
			*!*			If !This.Parent.Parent.ContinuousScroll
			*!*				Exit
			*!*			EndIf
			Do While Mdown() And m.lnSec > Seconds()
			Enddo
			loCurObject = Sys( 1270)
			If !Mdown() Or Vartype( m.loCurObject) # "O" Or ( m.loCurObject # .lbldirection And m.loCurObject # This)
				If ( Vartype( m.loCurObject) = "O" And m.loCurObject # .lbldirection And loCurObject # This)
					.buttonup()
				Endif
				Exit
			Endif
		Enddo
	Else
		If .ldown
			.buttonup()
		Endif
	Endif
Endwith
Endif
Endproc

Procedure MouseUp
Lparameters nButton, nShift, nXCoord, nYCoord
If m.nButton = 1
This.ldragging = .F.
This.buttonup()
Nodefault
Endif
Endproc

Procedure MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
If m.nButton = 1
With This
	.ldragging = .T.
	.buttondown()

	.Click

	Local lnSec, lnDelay, loCurObject
	lnDelay = .Delay	&& / 3
	Do While Mdown()
		lnSec = Seconds() + m.lnDelay
		.Click
		*!*			If !This.Parent.Parent.ContinuousScroll
		*!*				Exit
		*!*			EndIf
		Do While Mdown() And m.lnSec > Seconds()
		Enddo
		loCurObject = Sys( 1270)
		If !Mdown() Or Vartype( m.loCurObject) # "O" Or ( m.loCurObject # .lbldirection And m.loCurObject # This)
			If ( Vartype( m.loCurObject) = "O" And m.loCurObject # .lbldirection And loCurObject # This)
				.buttonup()
			Endif
			Exit
		Endif
	Enddo
	*!*			DoDefault( nButton, nShift, nXCoord, nYCoord)
Endwith
Endif
Endproc

Procedure lbldirection.MouseUp
Lparameters tnButton, tnShift, tnXCoord, tnYCoord
This.Parent.MouseUp( m.tnButton, m.tnShift, m.tnXCoord, m.tnYCoord)
Endproc


Procedure lbldirection.MouseMove
Lparameters tnButton, tnShift, tnXCoord, tnYCoord
This.Parent.MouseMove( m.tnButton, m.tnShift, m.tnXCoord, m.tnYCoord)
Endproc

Procedure lbldirection.MouseDown
Lparameters tnButton, tnShift, tnXCoord, tnYCoord
This.Parent.MouseDown( m.tnButton, m.tnShift, m.tnXCoord, m.tnYCoord)
Endproc

Enddefine
*
*-- EndDefine: __cntsbbutton
**************************************************

**************************************************
*-- Class:        __vscrollbar (e:\_______________________yoverlblog_posts\yposted\yvfpscrollbars_yimg\scrollcontainer_arg\sbcont.vcx)
*-- ParentClass:  container
*-- BaseClass:    container
*-- Time Stamp:   01/26/05 04:23:09 PM
*
#INCLUDE vfpsbcnt.h
*
Define Class __vscrollbar As Container
Width = 16
Height = 200
BorderWidth = 0
TabStop = .F.
BackColor = Rgb(226,226,226)
*-- Determines how far the scrolling region of the associated control can move.
Range = 1
*-- Specifies the increment a control scrolls when you click on a scroll arrow. Available at design time and run time.
smallchange = 1
*-- Specifies the position of the thumb tab on the scroll bar.
position = 0
kind = 1
Protected m_noffset
m_noffset = 0
controlarea = .Null.
Protected m_npage
m_npage = 0
Protected m_nmax
m_nmax = 0
Protected m_ncalcrange
m_ncalcrange = 0
Delay = 0.02
Protected m_nthumbarea
m_nthumbarea = 0
Protected m_nbuttonsize
m_nbuttonsize = 16
*-- Specifies the margin width created in the text portion of the control.
Margin = 0
thumbsize = 0
Name = "__vscrollbar"
Hidden m_bcalcautorange
Protected m_bthumbmove
Protected m_bthumbmoving

Add Object shpsplash As Shape With ;
Height = 0, ;
Width = 0, ;
Visible = .F., ;
BackColor = Rgb(0,0,0), ;
Name = "shpSplash"

Add Object scrollthumb As Container With ;
Width = 0, ;
Height = 0, ;
SpecialEffect = 0, ;
Name = "ScrollThumb"

Add Object cntup As __cntsbbutton With ;
Width = 0, ;
Height = 0, ;
Name = "cntUp", ;
lbldirection.Caption = "5", ;
lbldirection.Name = "lblDirection"

Add Object cntdown As __cntsbbutton With ;
Width = 0, ;
Height = 0, ;
Name = "cntDown", ;
lbldirection.Caption = "6", ;
lbldirection.Name = "lblDirection"

Procedure scrollmessage
Lparameters tnMessage, tnPos

Local lnKind, lnOldPos, lnScrollDir
With This
lnScrollDir = -1
lnKind = .kind
lnOldPos = .position
Do Case
	Case m.tnMessage = SB_LINEUP
		lnScrollDir = Iif( m.lnKind = 1, 0, 4)
		.position = ( .position - .smallchange)
	Case m.tnMessage = SB_LINEDOWN
		lnScrollDir = Iif( m.lnKind = 1, 1, 5)
		.position = ( .position + .smallchange)
	Case m.tnMessage = SB_PAGEUP
		lnScrollDir = Iif( m.lnKind = 1, 2, 6)
		.position = ( .position - Int( .ControlSize() / .smallchange) * .smallchange)
	Case m.tnMessage = SB_PAGEDOWN
		lnScrollDir = Iif( m.lnKind = 1, 3, 7)
		.position = ( .position + Int( .ControlSize() / .smallchange) * .smallchange)
	Case m.tnMessage = SB_THUMBPOSITION
		.position = ( m.tnPos)
		lnScrollDir = Iif( m.lnKind = 1, ;
			IIF( m.lnOldPos = 0 Or m.lnOldPos > m.tnPos, 0, 1), ;
			IIF( m.lnOldPos = 0 Or m.lnOldPos > m.tnPos, 4, 5))
	Case m.tnMessage = SB_THUMBTRACK
		If .Parent.ContinuousScroll
			.position = ( m.tnPos)
			lnScrollDir = Iif( m.lnKind = 1, ;
				IIF( m.lnOldPos = 0 Or m.lnOldPos > m.tnPos, 0, 1), ;
				IIF( m.lnOldPos = 0 Or m.lnOldPos > m.tnPos, 4, 5))
		Endif
Endcase
*!*		If m.lnOldPos != .Position
.Parent.Scrolled( m.lnScrollDir)
*!*		EndIf
Endwith
Endproc

Procedure Update
With This
Local lnControlSize
lnControlSize = .ControlSize()
.m_ncalcrange = Max( 0, .Range - m.lnControlSize)
.m_npage = m.lnControlSize + 1
.m_nmax = Iif( .m_ncalcrange > 0, .Range, 0)

.SetScrollInfo()
.position = .position
Endwith
Endproc

Procedure calcAutoRange
With This
If !.m_bcalcautorange And !Isnull( .controlarea)
	.m_bcalcautorange = .T.
	Local lnNewRange, loControl, lnMargin
	lnMargin = Val( "0" + Trans( .Margin))
	lnNewRange = 0
	For Each loControl In .controlarea.Controls
		If m.loControl.Visible
			lnNewRange = Max( m.lnNewRange, ;
				IIF( .kind = 1, ;
				m.loControl.Top + m.loControl.Height, ;
				m.loControl.Left + m.loControl.Width))
		Endif
	Endfor
	.Range = ( m.lnNewRange + m.lnMargin)
	.m_bcalcautorange = .F.
Endif
Endwith
Endproc

Protected Procedure SetScrollInfo
With This
If .m_nmax > 0
	Local lnControlSize, lnThumbArea, lnThumbSize
	lnControlSize = .ControlSize()

	If .kind = 1	&& Vertical
		lnThumbArea = .Height - .m_nbuttonsize * 2
		lnThumbSize = Max( 8, ;
			Min( m.lnThumbArea, ;
			( m.lnThumbArea) * m.lnControlSize / .m_nmax))
		.scrollthumb.Height = m.lnThumbSize
		.m_nthumbarea = .Height - .scrollthumb.Height - .m_nbuttonsize * 2
	Else
		lnThumbArea = .Width - .m_nbuttonsize * 2
		lnThumbSize = Max( 8, Min( m.lnThumbArea, ( m.lnThumbArea) * m.lnControlSize / .m_nmax))
		.scrollthumb.Width = m.lnThumbSize
		.m_nthumbarea = .Width - .scrollthumb.Width - .m_nbuttonsize * 2
	Endif

	If m.lnThumbArea >= 8
		.scrollthumb.Visible = .T.
	Else
		.scrollthumb.Visible = .F.
	Endif

	.cntup.Enabled = .T.
	.cntdown.Enabled = .T.

	.Enabled = .T.
Else
	If .kind = 1	&& Vertical
		.scrollthumb.Height = 0
		.m_nthumbarea = .Height - .scrollthumb.Height - .m_nbuttonsize * 2
	Else
		.scrollthumb.Width = 0
		.m_nthumbarea = .Width - .scrollthumb.Width - .m_nbuttonsize * 2
	Endif

	.scrollthumb.Visible = .F.

	.cntup.Enabled = .F.
	.cntdown.Enabled = .F.

	.Enabled = .F.
Endif
Endwith
Endproc

Protected Procedure ControlSize
*--	Return IIF( This.Kind = 0, This.Parent.Width, This.Parent.Height)
Return Iif( This.kind = 0, This.Width, This.Height)
*!*	Return IIF( Type( "This.ControlArea") = "O" And !IsNull( This.ControlArea), ;
*!*				IIF( This.Kind = 0, This.ControlArea.Width, This.ControlArea.Height), ;
*!*				0)
Endproc

Hidden Procedure position_assign
Lparameters tnNewPosition

With This
tnNewPosition = Max( 0, Min( .m_ncalcrange, Int( m.tnNewPosition)))

Local lnOldPos, lnNewThumbPos
lnOldPos = .position
.position = m.tnNewPosition

lnNewThumbPos = Min( .m_nthumbarea, Max( 0, Iif( .m_ncalcrange = 0, 0, (.position / .m_ncalcrange) * .m_nthumbarea))) + .m_nbuttonsize

If .kind = 1	&& Vertical
	.scrollthumb.Top = m.lnNewThumbPos
	.Parent.ScrollBy( 0, m.lnOldPos - m.tnNewPosition)
Else
	.scrollthumb.Left = m.lnNewThumbPos
	.Parent.ScrollBy( m.lnOldPos - m.tnNewPosition, 0)
Endif
Endwith
Endproc

Hidden Procedure range_assign
Lparameters tnNewRange
With This
.Range = Max( 0, m.tnNewRange)
If !Isnull( .controlarea) And .Range != 0
	If .kind = 1 &&Vertical
		.controlarea.Height = .Range
	Else
		.controlarea.Width = .Range
	Endif
Endif
.Parent.UpdateScrollBars()
Endwith
Endproc

Hidden Procedure thumbsize_access
Return Iif( This.kind = 0, This.scrollthumb.Width, This.scrollthumb.Height)
Endproc

Hidden Procedure thumbsize_assign
Lparameters vNewVal

Error 1740, "ThumbSize"
Endproc

Procedure needsscrollbarvisible
Lparameters tnSize
If Pcount() = 0 Or Type( "m.tnSize") != "N"
Return This.Range > This.ControlSize()
Endif
Return This.Range > m.tnSize
Endproc

Procedure thumb_mousedown
Lparameters nButton, nShift, nXCoord, nYCoord
If m.nButton = 1
With This
	.m_noffset = Iif( .kind = 1, m.nYCoord - .scrollthumb.Top, m.nXCoord - .scrollthumb.Left) + .m_nbuttonsize
	.m_bthumbmove = .T.
Endwith
Endif
Endproc

Procedure thumb_mousemove
Lparameters nButton, nShift, nXCoord, nYCoord

If Bitand( m.nButton, 1) = 1 And This.m_bthumbmove And !This.m_bthumbmoving
With This
	.m_bthumbmoving = .T.
	Local lnNewPos
	If .kind = 1	&& Vertical
		lnNewPos = Max( 0, Min( m.nYCoord - .m_noffset, .m_nthumbarea))
	Else
		lnNewPos = Max( 0, Min( m.nXCoord - .m_noffset, .m_nthumbarea))
	Endif
	.scrollmessage( SB_THUMBTRACK, ( m.lnNewPos / .m_nthumbarea) * .m_ncalcrange)
	.m_bthumbmoving = .F.
Endwith
Endif
Endproc

Procedure thumb_mouseup
Lparameters nButton, nShift, nXCoord, nYCoord

If m.nButton = 1
With This
	.m_bthumbmove = .F.
	Local lnNewPos, lnNewPos
	If .kind = 1	&& Vertical
		lnNewPos = Max( 0, Min( m.nYCoord - .m_noffset, .m_nthumbarea))
	Else
		lnNewPos = Max( 0, Min( m.nXCoord - .m_noffset, .m_nthumbarea))
	Endif
	.scrollmessage( SB_THUMBPOSITION, ( m.lnNewPos / .m_nthumbarea) * .m_ncalcrange)
Endwith
Endif
Endproc

Procedure Destroy
This.controlarea = .Null.
DoDefault()
Endproc

Procedure MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord

Local loCurObject, lnSec, lnDelay
With This
lnDelay = This.Delay
nYCoord = m.nYCoord - Objtoclient( This, 1)
nXCoord = m.nXCoord - Objtoclient( This, 2)
If .Enabled And m.nButton = 1 And .scrollthumb.Visible
	If ( .kind = 1 And m.nYCoord < .scrollthumb.Top) Or ( .kind = 0 And m.nXCoord < .scrollthumb.Left)
		Nodefault
		Do While .T.
			lnSec = Seconds() + lnDelay
			If .kind = 1	&& Vertical
				.shpsplash.Move( 0, 0, .m_nbuttonsize, .scrollthumb.Top)
			Else
				.shpsplash.Move( 0, 0, .scrollthumb.Left, .m_nbuttonsize)
			Endif
			.shpsplash.Visible = .T.
			.scrollmessage( SB_PAGEUP)

			Do While Mdown() And m.lnSec > Seconds()
			Enddo

			loCurObject = Sys( 1270)
			If !Mdown() Or Type( "m.loCurObject") # "O" Or m.loCurObject # .shpsplash
				Exit
			Endif
		Enddo
		.shpsplash.Visible = .F.
	Else
		If ( .kind = 1 And m.nYCoord > .scrollthumb.Top + .scrollthumb.Height) Or ( .kind = 0 And m.nXCoord > .scrollthumb.Left + .scrollthumb.Width)
			Nodefault
			Do While .T.
				lnSec = Seconds() + m.lnDelay
				If .kind = 1	&& Vertical
					.shpsplash.Move( 0, .scrollthumb.Top + .scrollthumb.Height, .m_nbuttonsize, .Height - (.scrollthumb.Top + .scrollthumb.Height) - .m_nbuttonsize)
				Else
					.shpsplash.Move( .scrollthumb.Left + .scrollthumb.Width, 0, .Width - (.scrollthumb.Left + .scrollthumb.Width) - .m_nbuttonsize, .m_nbuttonsize)
				Endif
				.shpsplash.Visible = .T.
				.scrollmessage( SB_PAGEDOWN)

				Do While Mdown() And m.lnSec > Seconds()
				Enddo

				loCurObject = Sys( 1270)
				If !Mdown() Or Type( "m.loCurObject") # "O" Or m.loCurObject # .shpsplash
					Exit
				Endif
			Enddo
			.shpsplash.Visible = .F.
		Endif
	Endif
Endif
Endwith
Endproc

Procedure Resize
Local lnSize
With This

If .kind = 1	&& Vertical
	lnSize = .Height
	If m.lnSize <= .m_nbuttonsize * 2
		lnSize = Int( m.lnSize / 2)
		.cntdown.Move( 0, .Height - m.lnSize, .m_nbuttonsize, m.lnSize)
		.cntup.Height = m.lnSize
	Else
		.cntdown.Move( 0, .Height - .m_nbuttonsize, .m_nbuttonsize, .m_nbuttonsize)
		.cntup.Height = .m_nbuttonsize
	Endif
Else
	lnSize = .Width
	If m.lnSize <= .m_nbuttonsize * 2
		lnSize = Int( m.lnSize / 2)
		.cntdown.Move( .Width - m.lnSize, 0, m.lnSize, .m_nbuttonsize)
		.cntup.Width = m.lnSize
	Else
		.cntdown.Move( .Width - .m_nbuttonsize, 0, .m_nbuttonsize, .m_nbuttonsize)
		.cntup.Width = .m_nbuttonsize
	Endif
Endif
.Update()
*--	.Range = .Range
Endwith
Endproc

Procedure Init
Lparameters toArea
Declare Integer GetSysColor In Win32API Integer
With This
.m_nbuttonsize = Sysmetric( 5)
Local lnColor1, lnColor2, lnRed1, lnGreen1, lnBlue1, lnRed2, lnGreen2, lnBlue2

lnColor1 = GetSysColor( COLOR_BTNHIGHLIGHT)
lnColor2 = GetSysColor( COLOR_BTNFACE)

lnRed1 =	Bitand( m.lnColor1, 0x000000FF)
lnGreen1 =	Bitand( m.lnColor1, 0x0000FF00) / 256
lnBlue1 =	Bitand( m.lnColor1, 0x00FF0000) / 65536

lnRed2 =	Bitand( m.lnColor2, 0x000000FF)
lnGreen2 =	Bitand( m.lnColor2, 0x0000FF00) / 256
lnBlue2 =	Bitand( m.lnColor2, 0x00FF0000) / 65536

lnRed1 = 	Bitand( m.lnRed2 + Int( ( m.lnRed1 - m.lnRed2) / 2), 0xFF)
lnGreen1 = 	Bitand( m.lnGreen2 + Int( ( m.lnGreen1 - m.lnGreen2) / 2), 0xFF)
lnBlue1 = 	Bitand( m.lnBlue2 + Int( ( m.lnBlue1 - m.lnBlue2) / 2), 0xFF)

.BackColor = Rgb( m.lnRed1, m.lnGreen1, m.lnBlue1)

.m_nmax = 1
.m_npage = 1
If Pcount() > 0 And Vartype( m.toArea) = "O"
	.controlarea = m.toArea
Else
	.controlarea = .Null.
Endif
.cntup.Move( 0, 0, .m_nbuttonsize, .m_nbuttonsize)
If .kind = 1	&& Vertical
	.cntdown.Move( 0, .Height - .m_nbuttonsize, .m_nbuttonsize, .m_nbuttonsize)
	.scrollthumb.Move( 0, .m_nbuttonsize, .m_nbuttonsize, .m_nbuttonsize)
	.m_nthumbarea = .Height - .scrollthumb.Height - .m_nbuttonsize * 2
Else
	.cntdown.Move( .Width - .m_nbuttonsize, 0, .m_nbuttonsize, .m_nbuttonsize)
	.scrollthumb.Move( .m_nbuttonsize, 0, .m_nbuttonsize, .m_nbuttonsize)
	.m_nthumbarea = .Width - .scrollthumb.Width - .m_nbuttonsize * 2
Endif
*--	.Range = 0
Endwith
Endproc

Procedure MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.MouseWheel( nDirection, nShift, nXCoord, nYCoord)
Endproc

Procedure scrollthumb.MouseUp
Lparameters nButton, nShift, nXCoord, nYCoord
This.Parent.thumb_mousemove( nButton, nShift, nXCoord, nYCoord)
Endproc

Procedure scrollthumb.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
This.Parent.thumb_mousedown( nButton, nShift, nXCoord, nYCoord)
Endproc

Procedure scrollthumb.MouseMove
Lparameters nButton, nShift, nXCoord, nYCoord
This.Parent.thumb_mousemove( nButton, nShift, nXCoord, nYCoord)
Endproc

Procedure scrollthumb.MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.MouseWheel( nDirection, nShift, nXCoord, nYCoord)
Endproc

Procedure cntup.Click
This.Parent.scrollmessage( SB_LINEUP)
Endproc

Procedure cntup.MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.MouseWheel( nDirection, nShift, nXCoord, nYCoord)
Endproc

Procedure cntdown.Click
This.Parent.scrollmessage( SB_LINEDOWN)
Endproc

Procedure cntdown.MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.MouseWheel( nDirection, nShift, nXCoord, nYCoord)
Endproc

Enddefine
*
*-- EndDefine: __vscrollbar
**************************************************


**************************************************
*-- Class:        __hscrollbar (e:\_______________________yoverlblog_posts\yposted\yvfpscrollbars_yimg\scrollcontainer_arg\sbcont.vcx)
*-- ParentClass:  __vscrollbar (e:\_______________________yoverlblog_posts\yposted\yvfpscrollbars_yimg\scrollcontainer_arg\sbcont.vcx)
*-- BaseClass:    container
*-- Time Stamp:   01/26/05 04:11:05 PM
*
#INCLUDE vfpsbcnt.h
*
Define Class __hscrollbar As __vscrollbar
Width = 252
Height = 16
kind = 0
Name = "__hscrollbar"
shpsplash.Name = "shpSplash"
scrollthumb.Name = "ScrollThumb"
cntup.lbldirection.Caption = "3"
cntup.lbldirection.Name = "lblDirection"
cntup.Name = "cntUp"
cntdown.lbldirection.Caption = "4"
cntdown.lbldirection.Name = "lblDirection"
cntdown.Name = "cntDown"
Enddefine
*
*-- EndDefine: __hscrollbar
**************************************************


**************************************************
*-- Class:        _scrollcontainer (e:\_______________________yoverlblog_posts\yposted\yvfpscrollbars_yimg\scrollcontainer_arg\sbcont.vcx)
*-- ParentClass:  container
*-- BaseClass:    container
*-- Time Stamp:   02/18/05 06:26:08 PM
*-- ScrollContainer class for Microsoft Visual FoxPro
*
#INCLUDE vfpsbcnt.h
*
Define Class _scrollcontainer As Container
Width = 447
Height = 329
SpecialEffect = 1
*-- Specifies if control scrolling is continuous or the control is only redrawn when the scroll box is released.
ContinuousScroll = .T.
*-- Specifies the type of scroll bars control has. 0 - none, 1 - horizontal, 2 - vertical, 3 - both.
ScrollBars = 3
*-- Specifies the horizontal scrolling increment for a control's horizontal scroll bar.
HscrollSmallChange = 8
*-- Specifies the vertical scrolling increment for a controls vertical scroll bar.
VscrollSmallChange = 8
*-- Specifies the margin between the client area and the inside edges of the scrolling container.
Margin = 0
*-- Contains reference to the ClientArea container.
clientarea = .Null.
*-- The number of lines to scroll when the mouse wheel is rotated. If this number is less than 0 control will use system default value (3 lines). If this number is equal to 0 control will not support mouse wheel.
wheelScrollLines = -1
Name = "_scrollcontainer"
Protected m_bscrollby
Protected m_bupdatingscrollbars
Protected m_bcalcautorange

*-- Indicates whether scroll bars appear automatically on the scrolling windowed control if it is not large enough to display all of its controls.
autoScroll = .F.

Add Object viewframe As Container With ;
Width = 1024, ;
Height = 1024, ;
Name = "ViewFrame"


Add Object hscrollbar As __hscrollbar With ;
Top = -20, ;
Name = "HScrollBar", ;
shpsplash.Name = "shpSplash", ;
scrollthumb.Name = "ScrollThumb", ;
cntup.lbldirection.Name = "lblDirection", ;
cntup.Name = "cntUp", ;
cntdown.lbldirection.Name = "lblDirection", ;
cntdown.Name = "cntDown"

Add Object vscrollbar As __vscrollbar With ;
Left = -20, ;
Name = "VScrollBar", ;
shpsplash.Name = "shpSplash", ;
scrollthumb.Name = "ScrollThumb", ;
cntup.lbldirection.Name = "lblDirection", ;
cntup.Name = "cntUp", ;
cntdown.lbldirection.Name = "lblDirection", ;
cntdown.Name = "cntDown"

*-- Scrolls the contents of the scrolling container.
Procedure ScrollBy
Lparameters tnDeltaX, tnDeltaY
With This
If !.m_bscrollby
	.m_bscrollby = .T.
	.viewframe.clientarea.Move( .viewframe.clientarea.Left + m.tnDeltaX, .viewframe.clientarea.Top + m.tnDeltaY)
	.m_bscrollby = .F.
Endif
Endwith
Endproc

*-- Updates scroll bars.
Procedure UpdateScrollBars
With This
If !.m_bupdatingscrollbars
	.m_bupdatingscrollbars = .T.
	If Bitand( .ScrollBars, SBC_VERT) != 0
		.vscrollbar.Visible = .T.
		.vscrollbar.Update()
	Else
		.vscrollbar.Visible = .F.
	Endif
	If Bitand( .ScrollBars, SBC_HORS) != 0
		.hscrollbar.Visible = .T.
		.hscrollbar.Update()
	Else
		.hscrollbar.Visible = .F.
		*!*				If Bitand( .ScrollBars, SBC_VERT) != 0
		*!*					.VScrollBar.Visible = .T.
		*!*				EndIf
	Endif
	.m_bupdatingscrollbars = .F.
Endif
Endwith
Endproc

*-- Scrolls a control into the visible area of the scrolling windowed control.
Procedure ensureisvisible
Lparameters toControl

If Type( [m.toControl]) = "O" And !Isnull( m.toControl)

With This
	Local lnLeft, lnTop, lnRight, lnBottom, lnHSPos, lnVSPos, lnVPWidth, lnVPHeight

	lnHSPos = .hscrollbar.position
	lnVSPos = .vscrollbar.position
	lnVPWidth = .viewframe.Width
	lnVPHeight = .viewframe.Height

	lnLeft = m.toControl.Left - m.lnHSPos
	lnTop = m.toControl.Top - m.lnVSPos
	lnRight = m.lnLeft + m.toControl.Width
	lnBottom = m.lnTop + m.toControl.Height

	If Bitand( .ScrollBars, SBC_HORS) != 0 And .hscrollbar.Enabled
		If m.lnLeft < 0
			.hscrollbar.position = ( m.lnHSPos + m.lnLeft)
		Else
			If m.lnRight > m.lnVPWidth
				If m.lnRight - m.lnLeft > m.lnVPWidth
					m.lnRight = m.lnLeft + m.lnVPWidth
				Endif
				.hscrollbar.position = ( m.lnHSPos + m.lnRight - m.lnVPWidth)
			Endif
		Endif
	Endif
	If Bitand( .ScrollBars, SBC_VERT) != 0 And .vscrollbar.Enabled
		If m.lnTop < 0
			.vscrollbar.position = ( m.lnVSPos + m.lnTop)
		Else
			If m.lnBottom > m.lnVPHeight
				If m.lnBottom - m.lnTop > m.lnVPHeight
					m.lnBottom = m.lnTop + m.lnVPHeight
				Endif
				.vscrollbar.position = ( m.lnVSPos + m.lnBottom - m.lnVPHeight)
			Endif
		Endif
	Endif
Endwith
Endif
Endproc

*-- Calculates the size of the client area depending on the size and position of controls and updates scroll bars.
Procedure calcAutoRange
With This
If !.m_bcalcautorange

	Local lOldAutoYield
	lOldAutoYield = _vfp.AutoYield
	_vfp.AutoYield = .F.

	.m_bcalcautorange = .T.
	.hscrollbar.calcAutoRange()
	.vscrollbar.calcAutoRange()
	.m_bcalcautorange = .F.

	_vfp.AutoYield = m.lOldAutoYield
Endif
Endwith
Endproc

Hidden Procedure autoscroll_assign
Lparameters tbNewVal
With This
If .autoScroll != m.tbNewVal
	.autoScroll = m.tbNewVal
	If m.tbNewVal
		.calcAutoRange
	Else
		.hscrollbar.Range = 0
		.vscrollbar.Range = 0
	Endif
Endif
Endwith
Endproc

*-- Occurs when the horizontal or vertical scroll bars are clicked or dragged
Procedure Scrolled
Lparameters tnDirection
Endproc

Hidden Procedure scrollbars_assign
Lparameters tnNewVal
This.ScrollBars = m.tnNewVal
This.Resize
Endproc

Protected Procedure clientarea_access
Return This.viewframe.clientarea
Endproc

Procedure MouseWheel
Lparameters tnDirection, tnShift, tnXCoord, tnYCoord

#Define WHEEL_DELTA		120

With This
If .wheelScrollLines > 0
	If Bitand( .ScrollBars, SBC_VERT) != 0 And .vscrollbar.Enabled
		.vscrollbar.position = .vscrollbar.position - ;
			(.VscrollSmallChange * .wheelScrollLines * Round( m.tnDirection / WHEEL_DELTA, 0))
	Else
		If Bitand( .ScrollBars, SBC_HORS) != 0 And .hscrollbar.Enabled
			.hscrollbar.position = .hscrollbar.position - ;
				(.HscrollSmallChange * .wheelScrollLines * Round( m.tnDirection / WHEEL_DELTA, 0))
		Endif
	Endif
Endif
Endwith
Endproc

Procedure Destroy
If Val( _vfp.Version) < 6
This.clientarea = .Null.
Endif
DoDefault()
Endproc

Procedure Init
DoDefault()
This.viewframe.AddObject("clientarea","clientarea")
#Define SM_MOUSEWHEELPRESENT		75
#Define SPI_GETWHEELSCROLLLINES		0x0068

Local lOldAutoYield
lOldAutoYield = _vfp.AutoYield
_vfp.AutoYield = .F.

With This
Declare Integer GetSystemMetrics In Win32API Integer
If GetSystemMetrics( SM_MOUSEWHEELPRESENT) != 1
	&& Mouse with a wheel isn't installed
	.wheelScrollLines = 0
Else
	If Type( ".WheelScrollLines") != "N" Or .wheelScrollLines < 0
		&& retrieve number of scroll lines

		Declare Integer SystemParametersInfo In Win32API Integer, Integer, Integer @, Integer

		Local lnScrollLines
		lnScrollLines = 3		&& default value

		If SystemParametersInfo( SPI_GETWHEELSCROLLLINES, 0, @m.lnScrollLines, 0) != 1
			.wheelScrollLines = 3
		Else
			.wheelScrollLines = m.lnScrollLines
		Endif
		*!*				Clear Dlls SystemParametersInfo
	Else
		.wheelScrollLines = Int( .wheelScrollLines)
	Endif
Endif
*!*		Clear Dlls GetSystemMetrics


If Val( _vfp.Version) < 6
	.clientarea = .viewframe.clientarea
Endif

.viewframe.BorderWidth = 0
.viewframe.clientarea.BorderWidth = 0
.hscrollbar.smallchange = Val( "0" + Trans( .HscrollSmallChange))
.vscrollbar.smallchange = Val( "0" + Trans( .VscrollSmallChange))
.hscrollbar.Margin = Val( "0" + Trans( .Margin))
.vscrollbar.Margin = Val( "0" + Trans( .Margin))
.hscrollbar.controlarea = .clientarea
.vscrollbar.controlarea = .clientarea
.calcAutoRange()
*!*		.Resize()
Endwith

_vfp.AutoYield = m.lOldAutoYield
Endproc

Procedure Resize
Local lOldAutoYield
lOldAutoYield = _vfp.AutoYield
_vfp.AutoYield = .F.

Local lnMargin, lnVPWidth, lnVPHeight, lOldLockScreen, lnHSBH, lnVSBW
lOldLockScreen = Thisform.LockScreen
Thisform.LockScreen = .T.
With This

lnMargin = .BorderWidth

If This.SpecialEffect != 2
	lnMargin = m.lnMargin + 1
Endif

lnHSBH = Sysmetric( 8)
lnVSBW = Sysmetric( 5)

lnVPWidth = Max( 0, .Width - ( m.lnVSBW + m.lnMargin * 2))
lnVPHeight = Max( 0, .Height - ( m.lnHSBH + m.lnMargin * 2))

If Bitand( .ScrollBars, SBC_VERT) = 0
	lnVPWidth = m.lnVPWidth + m.lnVSBW
Endif

If Bitand( .ScrollBars, SBC_HORS) = 0
	lnVPHeight = m.lnVPHeight + m.lnHSBH
Endif

*!*		If Bitand( .ScrollBars, SBC_VERT) != 0 And .VScrollBar.Enabled And .VScrollBar.NeedsScrollBarVisible( m.lnVPHeight)
If Bitand( .ScrollBars, SBC_VERT) != 0 And .vscrollbar.needsscrollbarvisible( m.lnVPHeight)
	.vscrollbar.Visible = .T.
	.vscrollbar.Enabled = .T.
Else
	.vscrollbar.Visible = .F.
	.vscrollbar.Enabled = .F.
	If Bitand( .ScrollBars, SBC_VERT) != 0
		lnVPWidth = m.lnVPWidth + m.lnVSBW
	Endif
Endif

*!*		If Bitand( .ScrollBars, SBC_HORS) != 0 And .HScrollBar.Enabled And .HScrollBar.NeedsScrollBarVisible( m.lnVPWidth)
If Bitand( .ScrollBars, SBC_HORS) != 0 And .hscrollbar.needsscrollbarvisible( m.lnVPWidth)
	.hscrollbar.Visible = .T.
	.hscrollbar.Enabled = .T.
Else
	.hscrollbar.Visible = .F.
	.hscrollbar.Enabled = .F.
	If Bitand( .ScrollBars, SBC_HORS) != 0
		lnVPHeight = m.lnVPHeight + m.lnHSBH
	Endif
Endif

.viewframe.Move( m.lnMargin, m.lnMargin, m.lnVPWidth, m.lnVPHeight)

.hscrollbar.Move( m.lnMargin, lnVPHeight + m.lnMargin, m.lnVPWidth, m.lnHSBH)
.vscrollbar.Move( m.lnVPWidth + m.lnMargin, m.lnMargin, m.lnVSBW, m.lnVPHeight)
Endwith
Thisform.LockScreen = m.lOldLockScreen
_vfp.AutoYield = m.lOldAutoYield
Endproc
*-- Sets the scrolling range of specified scroll bar.
Procedure setscrollrange
Endproc

Procedure viewframe.MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.MouseWheel( nDirection, nShift, nXCoord, nYCoord)
Endproc

Enddefine
*
*-- EndDefine: _scrollcontainer
**************************************
Define Class clientarea As Container
Top = 0
Left = 0
Width = 1024
Height = 1024
BackStyle = 0
Visible=.T.
Name = "ClientArea"

Procedure MouseWheel
Lparameters nDirection, nShift, nXCoord, nYCoord
This.Parent.Parent.MouseWheel( nDirection, nShift, nXCoord, nYCoord)
Endproc

Enddefine
*-- EndDefine: clientarea
Précédent
Répondre
Fil
Voir

Click here to load this message in the networking platform