Option Explicit
Private Const GridScale As Long = 1000 'Grid Height and Width . U may want to have one for each
Private Const ScrollPosn As Long = 700 'Point at where the tape starts scrolling
Private Const ScrollJump As Long = 20 'X and Y jump. Again u may want to separate
Dim lCounter As Integer 'Loop counter
Dim XPosn As Single 'X Posn of line
Dim YPosn As Single 'Y Posn of line
Dim XMarker As Single 'Your minimum line
Dim CurPicture As Integer 'Which picture is being drawn on
Dim lScroll As Boolean 'Are we ready to scroll
Private Sub SetupTreadMill()
XPosn = GridScale / 2 'Default X Posn
YPosn = 0
XMarker = GridScale / 2
CurPicture = 0
Randomize 'Used to make 'runner' .. u would use actuals
With pic_container 'Set up container picture
.BorderStyle = 0
.Height = 4 * GridScale
.Width = 4 * GridScale
.ScaleHeight = GridScale
.ScaleWidth = GridScale
End With
'These 2 pictures are IN pic_container
For lCounter = 0 To 1
With pic_inner(lCounter)
.Cls
.AutoRedraw = True
.BackColor = vbWhite
.BorderStyle = 0
.DrawWidth = 1
.Move 0, lCounter * GridScale, GridScale, GridScale
.ScaleHeight = GridScale 'Set scaling
.ScaleWidth = GridScale
End With
With Line1(lCounter) 'Your minimum line
.X1 = XMarker: .X2 = XMarker: .Y1 = 0: .Y2 = GridScale
End With
Next
With HScroll1 'Scroll bar for your minimum line
.Move pic_container.Left - 300, pic_container.Top + pic_container.Height, pic_container.Width + 600
.Min = 0
.Max = GridScale
.Value = XMarker
.SmallChange = GridScale / 50
.LargeChange = GridScale / 20
End With
End Sub
Private Sub Command1_Click()
SetupTreadMill 'Set up the form
DrawGridLines 0 'Draw grid lines for first pic
DrawGridLines 1
SetStartPosn 0 'Set starting position for first pic
Timer1.Enabled = True 'Start it rolling
End Sub
Private Sub DrawGridLines(ByVal WhichPic As Integer)
'Downward lines
With pic_inner(WhichPic)
.Cls
For lCounter = 1 To 3
pic_inner(WhichPic).Line (lCounter * GridScale / 4, 0)-(lCounter * GridScale / 4, GridScale), vbBlue
Next
End With
End Sub
Private Sub SetStartPosn(ByVal WhichPic As Integer)
'Starting positions
With pic_inner(WhichPic)
.CurrentX = XPosn
.CurrentY = YPosn
.ZOrder
End With
End Sub
Private Sub Timer1_Timer()
GetRandomValues
DrawLine
ScrollDown
End Sub
Private Sub GetRandomValues()
'Add or subtract from the current x position
XPosn = Int(Rnd * ScrollJump * 2) - ScrollJump + XPosn
If XPosn < 0 Then XPosn = 0
If XPosn > GridScale Then XPosn = GridScale
YPosn = YPosn + ScrollJump 'Move down a bit
End Sub
Private Sub DrawLine()
Dim lColour As Long
'Set colour based on above or below minimum
lColour = vbBlack
If XPosn < XMarker Then lColour = vbRed
With pic_inner(CurPicture)
'Draw line
pic_inner(CurPicture).Line -(XPosn, YPosn), lColour
.CurrentX = XPosn 'Update X Y posn
.CurrentY = YPosn
End With
End Sub
Private Sub ScrollDown()
If YPosn > ScrollPosn Then lScroll = True 'Once only to set scrolling
If lScroll Then
With pic_inner(CurPicture)
.Top = ScrollPosn - YPosn 'Move picture up
If .Top <= 0 Then 'Is it negative?
'then other pic should be below it
pic_inner(1 - CurPicture).Top = .Top + .Height
Else 'otherwise it is above it
pic_inner(1 - CurPicture).Top = .Top - .Height
End If
'Is the non current pic fully off the page?
If pic_inner(1 - CurPicture).Top <= -.Height + ScrollJump * 2 Then
pic_inner(1 - CurPicture).Cls 'Clear it
DrawGridLines 1 - CurPicture 'REdraw lines
End If
End With
If YPosn >= GridScale Then 'Have we reached end of current pic
CurPicture = 1 - CurPicture 'Swap to other pic
YPosn = 0 'Reset Y to top
With pic_inner(CurPicture)
.CurrentX = XPosn 'Get X position
.CurrentY = YPosn
End With
End If
End If
End Sub
Private Sub HScroll1_Change()
'Move the minimum line
XMarker = HScroll1.Value
For lCounter = 0 To 1
With Line1(lCounter)
.X1 = XMarker: .X2 = XMarker: .Y1 = 0: .Y2 = GridScale
End With
Next
End Sub
