Scrolling texts & images in visual foxpro

Published on by Yousfi Benameur

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


Scrolling  texts & images in visual foxpro
Scrolling  texts & images in visual foxpro

*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


Scrolling  texts & images in visual foxpro

*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  ;
and 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

Scrolling  texts &amp; images in visual foxpro

*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

 


Scrolling  texts &amp; images in visual foxpro

*-5-*A web div scrollable with css. can fill with images,text,hyperlinks
it consists in a container with scrollbars.
can embed on a form with vfp olebrowser but the fullscreen is not good
I prefer navigator as Firefox having a really good fullscreen.
Point to an Jpg images folder  and view the scrollable container.click on image to fire fullscreen.


*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

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

To be informed of the latest articles, subscribe:
Comment on this post
S
Respected Sir,<br /> Many times your blog have solved my big problems. Currently I am facing problem in VFP 9 (sp2)<br /> I have olecontrol as editor in a form (form2 as IN TOP LEVEL FORM) called from INIT of form1 ( as TOP LEVEL FORM). When I try to scroll text (rtf) with mouse wheel, it is not scrolling. However when I run same form2 from IDE it works (text scrolls with mouse wheel). <br /> In form1 I have created my own menus and calling form2 from procedure.<br /> I humbly request to guide me.<br /> Thanks, very much. <br /> Sanjay.
Reply
Y
activex controls cause the focus lost.you must give the focus to your olerRTF control to work with its PEM or simply click on to give the focus and then you can scroll....<br /> Also this control have a method setfocus() : thisform.oleRTF.setFocus()