*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