Scrolling texts & images in visual foxpro
Below 6 codes relative to scrolls text,images,scrollable containers..
*Suggestions and Bug Reports are always Welcome.
*1-*A top level form as scrollable container
Visual foxpro dont ship any scrollable container class.The only one big container can be scrollable is the form with its property form.scrollbars=0,1,2,3.
there is some classes coded by vfp developpers as ctl32 class or vfpScrollbars class.
this code use a form as class container and embed in any top level form with the API setParent.
the titlebar is cut and its created as object on a form(createObject from class definition).
I embed too images in this container.Must Bringwindowtotop always to dont disappear.
*Begin code
Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Retu
*
Define Class asup As Form
Top = 20
Left = 89
Height = 650
Width = 820
ShowWindow = 2
BorderStyle=2
MaxButton=.F.
AutoCenter=.T.
Caption = "A scrollable container as form class-"
yhwnd = 0
Name = "Form1"
Add Object grid1 As Grid With ;
FontBold = .T., ;
Anchor = 768, ;
DeleteMark = .F., ;
GridLines = 0, ;
Height = 150, ;
Left = 110, ;
Top = 500, ;
Width = 640, ;
Name = "Grid1"
Procedure Resize
=BringWindowtotop(Thisform.yhwnd)
Endproc
Procedure Load
Declare Integer BringWindowToTop In user32 Integer
Declare Integer SetParent In User32 Integer HWnd, Integer ParenthWnd
Declare Integer Sleep In kernel32 Integer
Sele * From Home(1)+"samples\data\customer" Into Cursor mycurs
Endproc
Procedure Init
Local m.yrep
m.yrep=Getdir()
gnbre=Adir(gabase,m.yrep+"*.jpg")
Set Defa To Addbs(Justpath(Sys(16,1)))
Create Cursor ycurs (yimage c(200))
For i=1 To gnbre
Insert Into ycurs Values (m.yrep+gabase(i,1))
Endfor
Locate
Sele ycurs
Thisform.Caption=Thisform.Caption+Trans(Reccount())+" images)-"
*brow
Publi m.oo
m.oo=Newobject("yscrollable")
With m.oo
DoDefault()
Thisform.yhwnd=.HWnd
SetParent(Thisform.yhwnd, Thisform.HWnd) && change parent the form class as a child of the main form
_Screen.WindowState=1
Sleep(100)
.TitleBar=0
.BorderStyle=0
.Left=10
.Top=10
.Width=640
.Height=480
.BackColor=0
Sele ycurs
Scan
.AddObject("image"+Trans(Recno()),"image")
With Eval(".image"+Trans(Recno()))
.Width=640
.Height=480
.Stretch=2
.Picture=Allt(yimage)
.Top=(Recno()-1)*.Height
.Visible=.T.
Endwith
Endscan
.Visible=.T.
Endwith
Thisform.Refresh
Thisform.Resize()
With Thisform.grid1
.RecordSource="mycurs"
.SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(200,198,155);
, RGB(0,255,0))", "Column")
Sele ycurs
Locate
Endwith
Endproc
Procedure Moved
Thisform.Resize()
Endproc
Procedure Activate
Thisform.Resize()
Endproc
Procedure Destroy
m.oo=Null
Clea Events
endproc
Enddefine
*
Define Class yscrollable As Form
BorderStyle = 0
Top = 23
Left = 51
Height = 358
Width = 422
ShowWindow = 2
ScrollBars = 3
ShowInTaskbar = .F.
DoCreate = .T.
Caption = "Form1"
Name = "yscrollable"
Procedure Init
This.TitleBar=0
Endproc
Procedure Destroy
DoDefault()
Endproc
Enddefine
*End code
*2*- This code uses a container with 3 labels scrolled vertically by a timer
can adjust the scroll speed (in the spinner -its the timer interval).
i made a background image encoded/decode (as ciel_nuit.gif).Can use any picture to fill the form background and make texts scroll on.
can set the fontnames,fontsize,colors for each label.
*fortunatly it can load more 200 images (tried on win8.1)
*Begin Code
publi m.yrep
m.yrep=addbs(justpath(sys(16,1)))
set defa to (yrep)
local m.myvar
text to m.myvar noshow &&this is a background image i used for this demo
R0lGODlhgABgAAAAACH/C05FVFNDQVBFMi4wAwEAAAAh+QQADwAAACwAAAAAgABgAIcAAAAAADMAAGYAAJkAAMwAAP8AKwAAKzMAK2YAK5kAK8wAK/8AVQAAVTMAVWYAVZkAVcwAVf8AgAAAgDMAgGYAgJkAgMwAgP8AqgAAqjMAqmYAqpkAqswAqv8A1QAA1TMA1WYA1ZkA1cwA1f8A/wAA/zMA/2YA/5kA/8wA//8zAAAzADMzAGYzAJkzAMwzAP8zKwAzKzMzK2YzK5kzK8wzK/8zVQAzVTMzVWYzVZkzVcwzVf8zgAAzgDMzgGYzgJkzgMwzgP8zqgAzqjMzqmYzqpkzqswzqv8z1QAz1TMz1WYz1Zkz1cwz1f8z/wAz/zMz/2Yz/5kz/8wz//9mAABmADNmAGZmAJlmAMxmAP9mKwBmKzNmK2ZmK5lmK8xmK/9mVQBmVTNmVWZmVZlmVcxmVf9mgABmgDNmgGZmgJlmgMxmgP9mqgBmqjNmqmZmqplmqsxmqv9m1QBm1TNm1WZm1Zlm1cxm1f9m/wBm/zNm/2Zm/5lm/8xm//+ZAACZADOZAGaZAJmZAMyZAP+ZKwCZKzOZK2aZK5mZK8yZK/+ZVQCZVTOZVWaZVZmZVcyZVf+ZgACZgDOZgGaZgJmZgMyZgP+ZqgCZqjOZqmaZqpmZqsyZqv+Z1QCZ1TOZ1WaZ1ZmZ1cyZ1f+Z/wCZ/zOZ/2aZ/5mZ/8yZ///MAADMADPMAGbMAJnMAMzMAP/MKwDMKzPMK2bMK5nMK8zMK//MVQDMVTPMVWbMVZnMVczMVf/MgADMgDPMgGbMgJnMgMzMgP/MqgDMqjPMqmbMqpnMqszMqv/M1QDM1TPM1WbM1ZnM1czM1f/M/wDM/zPM/2bM/5nM/8zM////AAD/ADP/AGb/AJn/AMz/AP//KwD/KzP/K2b/K5n/K8z/K///VQD/VTP/VWb/VZn/Vcz/Vf//gAD/gDP/gGb/gJn/gMz/gP//qgD/qjP/qmb/qpn/qsz/qv//1QD/1TP/1Wb/1Zn/1cz/1f///wD//zP//2b//5n//8z///8AAAAAAAAAAAAAAAAI/wBXBAgAY+AKAAFiBAAgkKBBhAoZDiwY4GDChQ0pWoyY8eFFiQ4rQsQ40SPHkiI/dkx5MuRGkiFVTDyQ0MABhQZW3Mx5YIXNGAcAKIzB0+fNoEOL/kRaU6dRoEKb9lwalahTqkmvHq2qdGvWqV6l6uwZoGdBgQUVUowBoOcBmWppsnULl6DctjrrwrhL9+LehHjf+uWbdzDgvnEPF048d7Hdsj5DFnSLl+fNqmXZKpzq9O5mn50Bfy7qGTJp0aZDa85cte3Qgas3r0YtO6rOtBdTG4jR+aDOwyrIvnXrEPfqqQ43B/9d0HhU5LiHM08eIKfinm2DT84r2O324TLJ7v8OsNxASeKThXJ2e/AADIHSKTd2aLYswemvc5pXCxnnfZrGpcYUTqFxdxFboF2nU1zwxfcabjkdB9p4OLFnHm6gHVCfhiukN1R2Fv4WQ3B4+ffhXOU5ZVd7mqk3YUJgXeUQT8H951BU2/HkF30HvTbhdDeVxZB5K8QW1X7XiVYiZi3KVWN+Ci1InlxTpgYZeOwRhmRP7YnGmXnELRdUfAdWp5aUjQ0H4wo6tTYilaOVJWZCv2GJmn4LuiYUhMddBB6dZLW4429iriZGdYBG1lx1AkWGZ18ATqljdMGRmGalSFXWWY3ryZmbQkLyJieWT5qnH3ExpIlUXxOSVRBpob3/1xNQFblX1ltDBVoVUzRhsqlwD9aqVIdXqqDcZVZtBqtnNBXpakj8ORUYrXEFC6aYTB0pEII0WUfhlNtGBVFgBclknHVkJqbmWdBV1JiO3IH4GbKsAeVoj3ihVl+LRbaVVlrqpTicejxGSBew7er7I6MLhpdmhvEJtay5If1Jk5hoVidfmW5RCVhZ1r1mVU0lxUARlkap0CaaYnI6Vo36ffywYCJ7KiFlpL3ZYkSNZYgjozapPGCgJD9ca53cFTj0lN1e5ViqRw/Hm8QwkurWpKiNChtDcFL5XWc1bxjvswTatOiikfL0HVw0I2ckz1LXCplDXe4VbtJMhbxnvZn6/3QspgiReJucbO138I5Z9jYe3pgiWS6Vas7F1kdQHRfcrLVenl+RV6opM7ilERW1vdghPavETh9MYnxo0XQ45k9mytt6+F2MHmRCtVXUjG1yxvXgqbqGeGS5Mpo7UAdEyJNtiKIIp5/BLc8bks4jBhxfGCu1mt1ZWlomboARP9Lx1wmeZVTGLnTnTb19qXCGxDPKHpPU8+h2YFEjp2aIvEbfvlTHKsy+7Be719AJRDVyju80xKPYMC1lwsFU6kSEuqC1h3MZ4pTAtnYwtHAwL/a61noSOKW0gGl2iKNOrlbQMg4dRjkX+ZZnAmOswKiIQ+Oxm/zS57VQjcpvUplTC/9h9CRQ0epJXCOf2JiyNtvtJ3djkZZmiGehK00nJ7jJ3VHm9J6ibGtycXpN8uoksMrMhGsnghy3EkLCTjHoQAGjIpMQMpn3/EguFGQP6JR4suYBLEoxe48KExIlAgVrXcUZiK0mkz6FXG5hA6OVUeTGn78QqCyTIVxb6FMqt1GySm8qmZmuhEmSLS+K4kuccJJ2oIgEiT+5epMUT2cyP2XkRKaJTfxCmbQcrqhgH4pgfRI0PWFdLjksOt6jtOMpZAEAf+YJD9BipRuCuLJN0YohoJ60ottF0Iry8xs2MwOyzrCrR/YBSl2IdBc4qtMtUNsVaOrkPMrZcl8E0tCrfjP/rGY9ijtzqU9XBLIluCTRiJj5o2JCiKZNjhN0jyMizdwpUe8hqmXbDCFFkfOc3FCpKKhbD0+2R5n1HOmA8QlPcN72xBUajog0ihTBoriXjW2mmcR6YpBucqbJoMwy8EnRyjxplmZd5nQc0l908EadnPwMiukcpchyUiMPQgmNLssTOjnlkssAaU6SfOcdFdQY5/WyddhMXZlIBzA6CWlgUbSVf84Co5F0sTvv7MlKCRmylKrOLlwD53YAFinMLZWc4ewW4jAFMykFTWR2KmsQDwYs8lzkckk0jdwIK6KPEms4hwvQq+yzKKKYizgAeE8+gbhWHsVQaRkcEGnwwsij/5QSl+iU3EL4J0EArew0tZ1gYQl1GTFoKDBR4d0/TdiZIc2FbjsN7GmkM6RtuVZrsloQmVTnOsfuaDWk4WY+HdksXCKvfQbiVkidMi8oetWZsaFeW7BDK0tGKqJs6aKIdjTEmZHwTUIRoIHCm8jGjmmlqDLeqrgCH/Kq5koBW5NE3iRe7EAuRTZ5mXTkezjRze45VsHVYQIUJOMQim7LChd6nhJOPOmIvJcb4wzp20Fe4Wu/XLKVUfBG0DVZ5zv5mmtTd2k4ROp3w5eFMH86mOFmbdaWLfWncla4YZ2gy8H3pS9yK4mf1uLGOeSllmZXe9zpxXWc3MUT9GBZkRfzk/+gYiwP3NDnsWDVbLY72+RzRztR3wTNMxTsV6TuSGia+AltfnLRwERsK8bCyTYAOtg+dfocCL7ZekPpjNTYmSFE7eWRCU4jJ4tKTMjs05UYG9A9y6eh9Cmmtd3TFebcxsRQBdamLoqSYBQ6WvLCkSaBudB+k6WbPGJqkOKpsoyP10YgVhKOqWthDTWKTS3WiSI6nEy0Fpe0zRwvsA6scfuU6RQe00ZA3HzxqLyjSBnN60CcxmG/pBRFp3aqIGacomeXjbK8wc/JotvYt/YpF/omR4vL0ZaHi80790GpOG0LjSrHHSN0NTI1DlypxOS6IsddCZbVJUzi6sfI0cyrfav/k3jqspNnEIGbSZEzo+sS2R0VoSuPiURckFoYyVr9bM9zW9QN0gCibZp0NDj+X/De9ruW0gmLfvoMvme3qJWm19rd4WynNUM7WnbTniC/3c5g80fztDl+RH1bYpXk7qYFCtjmXaj9JgnEqedyJESCOiChR1TU9Jp54g3nPrWGwrNFdTwGH47em/ezRf+qInYDMeEXShzFR9trCUIVpwjWJEF/77WV35Tl3hWa3nbZWlKhznYEJqPGq5iC6iTnqa2InSaKiXxTDCTJMpmuHZEGkR0zPagCtJ8dE+dRz9XMw3ZnL6kyatKX/s2/fWjTqE3b7w1kWExX1twl43JjCfw3/xor9iK15BuUIrr9lyKDBgSKzIam2vqoh31+XI5neb4L5h1LY2F77SrVSLQ9hvEdFSEgQ8VP4bYcx1FpRpZYlUNDrnIxh/JKiSVtkWIvYKQkRCU0eYQcV+QUPDROKGJEnjY4MAIoD4N0yGFQYgRE4DcmYwVmpqEpW6I4dRJgGTYYhRIS0gM8xfZcrUMeorNOqdQ+qPIoJSRRmdZd/qZkrUUgk0ZELWgX4VFt2NQ99iEwNzUr9yd9toIrXWcpDLEo7qQrfMdy1DE4Mgh9z8MuibQ44qYjjqZ2pVUjC/EVMgKDnsM9twMhYNNma1JXm0F8W8eAliIeAngwWBeATOhzN/91UzlCdQZxIYnCTTpkb3NCJjCAEHLlXHcYPgcGZZEhbsNxTq7TW6IGPl+GHg72bCqyFy3IYcyBOYakLZWWFh5YYmuSKwmHgeSjFDBCI7FoIESTE2rFTMlhY63GQBQTM95mf9WmglISHZiBhG0xJAoDJiKoZwW4eUumQlQDKk2mGhD4dOAyUmuVPXoUZ6iySbena85GOPBEQDWGTKYiGyEYWtjHPneIcJgDjLlSjTSXNHKmLbUGhuNEcPhiLfslPaBHPB7Ee44GazZHOo+XXc4YWKVFWs1DTjyzVjZ0gUzlUx4UXjcDkT1EgRT2djk1TRdSOge2MXqILcMIVPzhLc//5oe6tyqddmRVFAA3cHACGDNHB4EW9oSf4luehIv7VS5K8n6KcmgNMiph8z85Mhbhg45rwYAuIoyTd5VWQ2ei9GK24VRGclS/omhOU0odIiMEVx7QlXCL8VfsiFHsqFZL9Tws9mocFzli1xTlFCYwCJBMyDiGFmLyAxQS8lK7UYOnKG86xRxSUkFnRXMAM0GY6Ek7tiLqsS9q+W3HAm/wIX6+R1wd0UU2Enjf1yOrpCbqFjUSZT9Zcj3EhBe3Rjmc53r/NCzWtEM1hou1MmUzURJ/BIFfE1Pq4WIXpJSAM1FZ8h3qRFK5QYA34yallGB+dRFAFGA8iUWQ83i6pgL1/wMq8HEgZMJ8tfFh/gQamxQ5EmUgX6Z6BiiUoNc4QeiHIeIv8qNF20F67rEfx1aKjhgUbNQuOkNRz7ZBnCVyV3Rv97QcEnZySDJSDbYQODA7r+dx1EE7X2csqlZ53oNUYvR+d7Yt2DGOrekzodQuOzcgPdmRohKT4/aIVoIT4lgkZhdMl5M+qPREQyWGR1dXO8Yd2vGizyifK7JkP/eGInYsCUWc7yk1aRV/7EFCr3IsU2FEsymAPaNY+ZGN7vZr9GEj3+dWS7ZyQzEvFudPc3dI6pZPv4M6oLmh8ElLIQlCtBeVJKpZfkhw+rmRxfR8sBEysKJTEhRArHNUWhqcW//DdCjUQ9GxTKp2Fk7nRr/COVD2WvKTEGuBk77pJ/MXjo8BoagZeX25S8W2JdkBJIojFk5yP56kH2UzGLA3qGXyc7inMM8CMYEnHbelgYMES5f6Y2PCEc5kVOn1GDVzplMxKUHBOSOFGe2oJUUzaP5GGoKEhJYjO4rhmPuVJyWFo+AYJaPFWTFlEDoWJN8VKgiiQ3aWHE8Sn06aGWSEiLBRJk63GwgXF+/IOdapNgKSl+MSGVe0gLL0Vmq4oYqRR6f3TkKpV52IFKDxGcjEFPixSZY0eRwTHjioXdvyLVoKVpiBEHE1kYXTkNDKnqb2Qzaxru11HFsZWd81R6LzNcf/50EkOyoJtBpXgXRDlym0x4DFMRa/IxdvOjc1SUiacp3kmCbP4T2cYzWFMo8xuxExOSV7RVUFp4B+wVRvUW/sZTyakXLaOnfvBZc1E598UiLFwlHsWXB/OEBiBqHmdY0xBEjwWTCJyXfbuJjAxHfB5ZcbG5NnSjpCiBCnBC+UOBk84YwNxBSjNHHjCRFkGSfY1EIJIqsF+JeUmiABYn1IYTAe2ZU7RmYQej+xx2ZYYm1lQ4yf1VvRwXdrImV/UjmC+HFY+4Vz0iaHG0z4aoNZCkd3i6BzFDdAlUmyoquVAo5k4oJu0nSjaIlKZintFSIRYpuHQ2hwaJ0HKUVZqS8JDyWCSbWc4oO3Szlm7AV/UXY7nYxCercSnIbYXdrYTYZoIvGbtuY4KVbmG8XaWB5WjrJhlnBquzbxi1sKYmMoY+Xnd057Ih2FoaH7G0riqmjHNeyRScV0qX8lJZ8Ih+XWQUvqoEHFHvWEspHmNLqna1ToOiS4fL/iMsfmQHOxK4l5Go6WqAEBADs=
endtext
strtofile(strconv(m.myvar,14),m.yrep+"ciel_nuit.gif")
=sys(2002)
Publi yform
yform=Newobject("yscroller")
yform.Show
Read Events
Return
*
Define Class yscroller As Form
Top = 2
Left = 193
Height = 424
Width = 588
ShowWindow = 2
AutoCenter=.T.
Caption = "Scrolling texts"
BackColor = Rgb(0,0,0)
picture="ciel_nuit.gif" &&getpict()
Name = "Form1"
Add Object ycont As Container With ;
Anchor = 15, ;
Top = 5, ;
Left = 5, ;
Width = 580, ;
Height = 368, ;
BackColor = Rgb(0,0,0), ;
Borderwidth=2,;
backstyle=0,;
Name = "ycont"
Add Object spinner1 As Spinner With ;
Anchor = 768, ;
Height = 25, ;
Increment = 5.00, ;
KeyboardHighValue = 1000, ;
KeyboardLowValue = 0, ;
Left = 252, ;
MousePointer = 15, ;
SpinnerHighValue = 1000.00, ;
SpinnerLowValue = 0.00, ;
Top = 398, ;
Width = 85, ;
Value = 40, ;
Name = "Spinner1"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
Fontname="Tahoma",;
FontItalic = .T., ;
FontSize = 11, ;
Anchor = 768, ;
BackStyle = 0, ;
Caption = "Speed", ;
Height = 21, ;
Left = 196, ;
Top = 401, ;
Width = 49, ;
ForeColor = Rgb(255,255,255), ;
Name = "Label1"
Procedure Destroy
Sys(2002,1)
Clea Events
Endproc
Procedure Init
Sys(2002) &&equivalent of "set cursor off"
With Thisform.ycont
.AddObject("timer1","timer")
With .timer1
.Top = 36
.Left = 252
.Height = 23
.Width = 23
.Interval = 30
.Enabled=.F.
.Name = "timer1"
Endwith
.AddObject("label1","label")
With .label1
.FontBold = .T.
.FontSize = 12
.FontName="Comic sans MS"
.BackStyle = 0
.Caption = "Label1"
.Height = 61
.Left = 12
.Top = 84
.Width = 229
.ForeColor = Rgb(255,0,0)
.Name = "label1"
Endwith
.AddObject("label2","label")
With .label2
.FontBold = .T.
.FontName = "BATAVIA"
.FontSize = 12
.BackStyle = 0
.Caption = "Label2"
.Height = 61
.Left = 18
.Top = 199
.Width = 229
.ForeColor = Rgb(128,0,255)
.Name = "Label2"
Endwith
.AddObject("label3","label")
With .label3
.FontBold = .T.
.FontName = "Courier new"
.FontSize = 12
.FontBold=.T.
.fontitalic=.t.
.BackStyle = 0
.Caption = "Label3"
.Height = 61
.Left = 18
.Top = 299
.Width = 229
.ForeColor = Rgb(0,255,195)
.Name = "Label3"
Endwith
With .label1
.Width=.Parent.Width-20
.Height=150
.WordWrap=.T.
.Anchor=15
.Visible=.T.
TEXT to .caption 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.
ENDTEXT
Endwith
With .label2
.Width=.Parent.Width-20
.Height=150
.WordWrap=.T.
.Anchor=15
.Visible=.T.
TEXT to .caption 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.
ENDTEXT
Endwith
With .label3
.Width=.Parent.Width-20
.Height=150
.WordWrap=.T.
.Anchor=15
.Visible=.T.
TEXT to .caption 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.
ENDTEXT
Endwith
Endwith
Bindevent(Thisform.ycont.timer1,;
"timer",Thisform,"my")
Thisform.ycont.timer1.Enabled=.T.
Endproc
Procedure my
* aevent create an array laEvents
Aevents( myArray, 0)
*reference the calling object
loObject = myArray[1]
If loObject.Parent.label1.Top >0
loObject.Parent.label1.Top = loObject.Parent.label1.Top - 1
Else
loObject.Parent.label1.Top = loObject.Parent.Height+1
Endif
If loObject.Parent.label2.Top >0
loObject.Parent.label2.Top = loObject.Parent.label2.Top - 1
Else
loObject.Parent.label2.Top = loObject.Parent.Height+1
Endif
If loObject.Parent.label3.Top >0
loObject.Parent.label3.Top = loObject.Parent.label3.Top - 1
Else
loObject.Parent.label3.Top = loObject.Parent.Height+1
Endif
Endproc
Procedure spinner1.InteractiveChange
Thisform.ycont.timer1.Interval=This.Value
Endproc
Procedure spinner1.Init
Try
This.Value=Thisform.ycont.timer1.Interval
Catch
Endtry
Endproc
Enddefine
*
*Endcode
*3*-This code searchs for all images in any folder(jpg,png,gif,bmp) and make them as a scrollable pellicule (horizontally) on a form.
Click on left image to scroll it towards left
Click on right image to make it scroll towards right.
*Begin code
Publi yform
yform=Newobject("yscrollIm")
yform.Show
Read Events
Retu
*
Define Class yscrollIm As Form
BorderStyle = 3
Top = 16
Left = 86
Height = 365
Width = 803
ShowWindow = 2
ScrollBars = 1
Caption = "Click on left or right of image to scroll"
BackColor = Rgb(0,0,0)
gnbre = 0
Name = "Form1"
Add Object label1 As Label With ;
FontSize = 8, ;
Anchor = 768, ;
Alignment = 2, ;
BackStyle = 0, ;
Caption = "", ;
Height = 25, ;
Left = 164, ;
Top = 345, ;
Width = 477, ;
ForeColor = Rgb(255,255,255), ;
Name = "Label1"
Procedure my
Lparameters nButton, nShift, nXCoord, nYCoord
*--- aevent create an array laEvents
Aevents( myArray, 0)
*--- reference the calling object
loObject = myArray[1]
loObject.MousePointer=15
xrec=Substr(loObject.Name,6)
Thisform.label1.Caption=Trans(xrec)+" - "+Justfname(loObject.Picture)
xw=loObject.Width
With Thisform
Local yim0,yim
yim0= .image1
yim=Eval(".image"+Trans(Thisform.gnbre))
Do Case
Case ! yim.Left<= 0 ;
Between( nXCoord ,0, loObject.Left+loObject.Width/2) &&
For i=1 To .ControlCount
If Lower( .Controls(i).Class)=="image"
.Controls(i).Left=.Controls(i).Left-xw
Endi
Endfor
Case ! yim0.Left>0 ;
And Between( nXCoord ,loObject.Left+loObject.Width/2,loObject.Left+loObject.Width)
For i=1 To .ControlCount
If Lower( .Controls(i).Class)=="image"
.Controls(i).Left=.Controls(i).Left+xw
Endi
Endfor
Endcase
Endwith
Endproc
Procedure Init
Local m.yrep
m.yrep=Getdir()
m.yrep=Addbs(m.yrep)
gnbre=Adir(gabase,m.yrep+"*.*")
Create Cursor ycurs( yimage c(200))
For i=1 To gnbre
If Inlist(Lower(Justext(gabase(i,1))),"png","bmp","jpg","gif")
Insert Into ycurs Values(m.yrep+gabase(i,1))
Endi
Endfor
Thisform.gnbre=Reccount()
*brow
Locate
If Empty(m.yrep) Or Thisform.gnbre=0
Return .F.
Endi
With Thisform
.ScrollBars=0 &&if scollbars=1 can scoll form horizontally
.Caption=.Caption+"("+Trans(Thisform.gnbre)+" images)"
Sele ycurs
Scan
i=Recno()
.AddObject("image"+Trans(i),"image")
With Eval(".image"+Trans(i))
.Stretch=2
.Height=Thisform.Height-40
.Width=.Height*2
.Top=15
.BorderStyle=1
If i=1
.Left=0
Else
.Left=Eval(".parent.image"+Trans(i-1)+".left")+.Width
Endi
.Picture=yimage
.Visible=.T.
Endwith
Endscan
Endwith
Locate
With Thisform
.label1.Caption=Trans(Recno())+"-"+Justfname(yimage)
For i=1 To .ControlCount
If Lower(.Controls(i).Class)=="image"
Bindevent(.Controls(i),"mouseDown",Thisform,"my")
Endi
Endfor
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*End code
*4-*This is a code for a simple marquee with text scolling horizontally
*the speed can be adjusted in spinner (coresponding to timer interval)
*Begin code
loForm = Createobject("asup")
loForm.Show
Read Event
Retu
Define Class asup As Form
Width=800
Height=100
ShowWindow=2
AutoCenter=.T.
ShowTips=.T.
Caption = "Horizontal SCroll"
BackColor = 0
MaxButton=.F.
MinButton=.F.
Name = "form1"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontSize = 28, ;
BackStyle = 0, ;
Caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat...", ;
Height = 45, ;
Left = 60, ;
Top = 5, ;
Width = 800, ;
ForeColor = Rgb(255,255,255), ;
Name = "Label1"
Add Object label2 As Label With ;
AutoSize = .T., ;
FontSize = 28, ;
BackStyle = 0, ;
Caption = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin vel risus eget lorem feugiat...", ;
Height = 45, ;
Left = 63, ;
Top = 8, ;
Width = 800, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label2"
Add Object timer1 As Timer With ;
Interval = 15, ;
enabled=.T.,;
Name = "Timer1"
Add Object pinner1 As yspinner With ;
left=Thisform.Width-70,;
top=Thisform.Height-30
Visible=.T.
Procedure Init
Sys(2002)
This.label1.Left = This.Width
This.label1.ZOrder(0)
This.label2.Left = This.Width+3
This.label2.ZOrder(1)
Endproc
Procedure timer1.Timer
With Thisform.label1
If .Left > -.Width
.Left = .Left - 1
Else
.Left = .Parent.Width
Endif
Endwith
With Thisform.label2
If .Left > -.Width
.Left = .Left - 1
Else
.Left = .Parent.Width
Endif
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
Define Class yspinner As Spinner
Height = 25
KeyboardHighValue = 100
KeyboardLowValue = 5
Left = 324
MousePointer = 15
SpinnerHighValue = 100.00
SpinnerLowValue = 5.00
Top = 216
Width = 50
Value = 10
ToolTipText="Speed"
Name = "ySpinner"
Procedure InteractiveChange
Thisform.timer1.Interval=This.Value
Endproc
Enddefine
*End code
*Begin code
local m.yrep,m.xx,m.gnbre,m.myvar,m.myvar1,m.lcdest
m.yrep=getdir()
if empty(m.yrep)
return .f.
endi
gnbre=adir(gabase,m.yrep+"*.jpg")
if gnbre=0
return .f.
endi
xx=""
for i= 1 to gnbre
m.xx=m.xx+"#"+trans(i)+"{background-color:#ABC;}"+chr(13)
endfor
text to m.myvar noshow
<style>
#container {
width: 820px;
background-color: #CCC;
overflow: auto;
margin-left:2px;
height: 600px;
white-space:nowrap;
}
.contents {
width: 820px;
height: 600px;
display:inline-block;
}
<<m.xx>>
</style>
endtext
m.xx=""
for i=1 to gnbre
m.xx=m.xx+[<div id="div]+trans(i)+[" class="fullScreen" allowfullscreen title="Click for fullscreen on/off !"><div class="contents" id="]+trans(i)+["><img src="file:///]+m.yrep+gabase(i,1)+[" title="]+allt(gabase(i,1))+[" width="800" height="600"></div></div>]+chr(13)
endfor
text to m.myvar1 textmerge noshow
<body bgcolor=black oncontextmenu="return false;">
<<m.myvar>>
<center>
<div id="container">
<<m.xx>>
</div>
</center>
<script type="text/javascript">
var inFullScreen = false; // flag to show when full screen
var fsClass = document.getElementsByClassName("fullScreen");
for (var i = 0; i < fsClass.length; i++) {
fsClass[i].addEventListener("click", function (evt) {
if (inFullScreen == false) {
makeFullScreen(evt.target); // open to full screen
} else {
reset();
}
}, false);
}
function makeFullScreen(divObj) {
if (divObj.requestFullscreen) {
divObj.requestFullscreen();
}
else if (divObj.msRequestFullscreen) {
divObj.msRequestFullscreen();
}
else if (divObj.mozRequestFullScreen) {
divObj.mozRequestFullScreen();
}
else if (divObj.webkitRequestFullscreen) {
divObj.webkitRequestFullscreen();
}
inFullScreen = true;
return;
}
function reset() {
if (document.exitFullscreen) {
document.exitFullscreen();
}
else if (document.msExitFullscreen) {
document.msExitFullscreen();
}
else if (document.mozCancelFullScreen) {
document.mozCancelFullScreen();
}
else if (document.webkitCancelFullScreen) {
document.webkitCancelFullScreen();
}
inFullScreen = false;
return;
}
</script>
</body>
endtext
local m.lcdest
m.lcdest=addbs(sys(2023))+"mydiv_scrollH.html"
strtofile(myvar1,m.lcdest)
&&shellexecute
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
result = ShellExecute(0, "open", m.lcdest,"","",3)
*Endcode
can use the MSDN fullscreen API :https://msdn.microsoft.com/en-us/library/ie/dn265028%28v=vs.85%29.aspx
*6-*the form can embed a big image for ex(and all other standard controls)
*The form.scrollbars property can raises a vertical scrollbar, horizontal scrollbar or no scrollbar at demand.
*Make a big image and then can scroll it on a form as this sample below.
*Begin code
Local m.xpict
m.xpict=Getpict() &&big image (stretched and width/height set too big in code)
Publi yform
yform=Newobject("asup")
yform.Show
Read Events
Return
*
Define Class asup As Form
Top = 0
Left = 147
Height = 233
Width = 519
ShowWindow = 2
ScrollBars = 3
DoCreate = .T.
Caption = "Form as scrolling container (scrollbar=0,1,2,3)"
Name = "Form1"
Add Object image1 As Image With ;
Picture = m.xpict, ;
stretch=2,;
Height = 1200, ;
Left = 0, ;
Top = 0, ;
Width = 1800, ;
Name = "Image1"
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*End code
*7*Controling scrolls by APIs
scrolls vertically or horizontally can be controled by APis.This is usefull with scrollable rtfbox,(editbox) ,scrollable containers...
-send this function a handle and a direction (V,H). It sends back an integer of the current scroll position.
Declare integer GetScrollPos in user32 hWnd As Integer, nBar As Integer
-send SetScrollPos the handle, direction, value and a flag of whether or not it should redraw the control.
Declare Integer SetScrollPos in user32 hWnd As Integer, nBar As Integer,nPos As Integer, bRedraw As Boolean
-sends instructions to the control about what to do next.
Declare Integer PostMessageA in user32 hwnd As Integer, wMsg As Integer,l wParam As Integer, lParam As Integer
Constants used
* Scrollbar direction
#define SBS_HORZ 0
#define SBS_VERT 1
* Windows Messages
#define WM_VSCROLL 0x115
#define WM_HSCROLL 0x114
#define SB_THUMBPOSITION 4
can see
CScrollBar Class : https://msdn.microsoft.com/en-us/library/zz1h061h.aspx
Vfpscrollbar class in sps(Graig Boyd):
http://www.sweetpotatosoftware.com/spsblog/2005/08/27/VisualFoxProScrollbarClasses.aspx