QBasic & Borland Pascal & C/Delphi5.iso/Basic/Samples/VBUTIL/VBUTIL.ZIP/PSCRNLIB.BAS

BASIC Source File | 1992-10-06 | 5.1 KB | 182 lines

Sub InitScreen (MaxRow%, MaxCol%, SD As ScreenType)
  ' initialize screen parameters
  SD.MaxCols = MaxCol%
  SD.MaxRows = MaxRow%
  SD.CursX = 1
  SD.CursY = 1
End Sub

Sub ClearScreen (TBox As Control, SL$(), SD As ScreenType)
  ' clear the screen by assigning empty strings to the
  ' TBox and SL$ array and setting the cursor variables to 1.
  Dim I As Integer
  If TypeOf TBox Is TextBox Then
    TBox.Text = ""
    For I = 1 To SD.MaxRows
      SL$(I) = ""
    Next I
    SD.CursX = 1
    SD.CursY = 1
  End If
End Sub

Sub GotoXY (X%, Y%, SL$(), SD As ScreenType)
  ' move the hidden cursor to (X%, Y%)
  Dim L As Integer
  If (X% < 1) Or (Y% < 1) Then Exit Sub
  If (Y% > SD.MaxRows) Or (X% > SD.MaxCols) Then Exit Sub
  L = Len(SL$(Y%))
  If X% > L Then
    SL$(Y%) = SL$(Y%) + Space$(X% - L)
  End If
  SD.CursX = X%
  SD.CursY = Y%
End Sub

Function WhereX (SD As ScreenType) As Integer
  ' return the value of SD.CursX
  WhereX = SD.CursX
End Function

Function WhereY (SD As ScreenType) As Integer
  ' return the value of the SD.CursY
  WhereY = SD.CursY
End Function

Sub ScrollUp (NumLines%, TBox As Control, SL$(), SD As ScreenType)
  ' scroll up a specified number of lines
  Dim I As Integer
  If TypeOf TBox Is TextBox Then
  Else
    Exit Sub
  End If
  If NumLines < 1 Then Exit Sub
  ' scroll at most SD.MaxRows
  If NumLines > SD.MaxRows Then
    NumLines = SD.MaxRows
  End If
  ' copy leading string to emulate scroll
  For I = 1 To SD.MaxRows - NumLines
    SL$(I) = SL$(I + NumLines)
  Next I
  ' assign empty string to trailing strings
  For I = SD.MaxRows - NumLines + 1 To SD.MaxRows
    SL$(I) = ""
  Next I
  UpdateScreenText TBox, SL$(), SD
End Sub

Sub NewLine (TBox As Control, SL$(), SD As ScreenType)
  ' move the hidden cursor to the first column of
  ' the next line.  Scroll screen up if the cursor
  ' is already at the last allowed screen row
  If TypeOf TBox Is TextBox Then
    If SD.CursY < SD.MaxRows Then
      SD.CursY = SD.CursY + 1
      SD.CursX = 1
    Else
      ScrollUp 1, TBox, SL$(), SD
      SD.CursX = 1
    End If
  End If
End Sub

Sub PPrint (S$, UpdateScreenNow%, TBox As Control, SL$(), SD As ScreenType)
  ' Emulate a simple form of the QuickBasic print:
  '
  '            PRINT Astring$;
  '
  ' The second parameter enable you to update the text
  ' on the screen, or keep the changes hidden (for now).
  Dim LenStr As Integer
  Dim LenLine As Integer
  Dim LenDiff As Integer
  Dim S2 As String
  If TypeOf TBox Is TextBox Then
  Else
    Exit Sub
  End If
  If S$ = "" Then Exit Sub
  LenStr = Len(S$)
  If SD.CursY = SD.MaxRows Then ScrollUp 1
  LenLine = Len(SL$(SD.CursY))
  S2 = ""
  ' string cannot fit on the current line?
  If (SD.CursX + LenStr) > SD.MaxCols Then
    LenDiff = SD.CursX + LenStr - SD.MaxCols - 1
    ' split original string into two strings
    S2 = Right$(S$, LenDiff) ' next-line text
    S$ = Left$(S$, LenStr - LenDiff)
  End If
  ' Pad current line
  If (SD.CursX + LenStr) > LenLine Then
    LenDiff = SD.CursX + LenStr - LenLine
    SL$(SD.CursY) = SL$(SD.CursY) + Space$(LenDiff)
  End If
  ' write S to current line
  Mid$(SL$(SD.CursY), SD.CursX, LenStr) = S$
  SD.CursX = SD.CursX + LenStr
  ' the next-line string is not empty?
  If SD.CursX > SD.MaxCols Then NewLine TBox, SL$(), SD
  If S2 <> "" Then ' print to the next line
    If SD.CursY < SD.MaxCols Then NewLine TBox, SL$(), SD
    LenDiff = Len(S2) - Len(SL$(SD.CursY))
    If LenDiff > 0 Then ' pad the string for the next line
      SL$(SD.CursY) = SL$(SD.CursY) + Space$(LenDiff)
    End If
    ' write the next-line string
    Mid$(SL$(SD.CursY), 1, Len(S2)) = S2
    SD.CursX = Len(S2) + 1
    If SD.CursX > SD.MaxCols Then NewLine TBox, SL$(), SD
  End If
  ' update the screen now?
  If UpdateScreenNow% Then UpdateScreenText TBox, SL$(), SD
End Sub

Sub SaveScreen (Buff$(), BufData As ScreenType, SL$(), SD As ScreenType)
  ' save screen to Buff$() array.
  ' the current position of the hidden cursor is
  ' stored in the fields of the SD parameter
  Dim I As Integer
  For I = 1 To SD.MaxRows
    Buff$(I) = SL$(I)
  Next I
  BufData.MaxRows = SD.MaxRows
  BufData.MaxCols = SD.MaxCols
  BufData.CursX = SD.CursX
  BufData.CursY = SD.CursY
End Sub

Sub LoadScreen (TBox As Control, Buff$(), BufData As ScreenType, SL$(), SD As
ScreenType)
  ' load screen from the Buff$() array
  ' the fields of the SD parameters specify new cursor location
  Dim I As Integer
  If TypeOf TBox Is TextBox Then
    For I = 1 To SD.MaxRows
      SL$(I) = Buff$(I)
    Next I
    SD.MaxRows = BufData.MaxRows
    SD.MaxCols = BufData.MaxCols
    SD.CursX = BufData.CursX
    SD.CursY = BufData.CursY
    UpdateScreenText TBox, SL$(), SD
  End If
End Sub

Sub UpdateScreenText (TBox As Control, SL$(), SD As ScreenType)
  ' update the text in the TBox
  Dim I As Integer
  Dim S As String
  Dim NL As String * 2
  If TypeOf TBox Is TextBox Then
    NL = Chr$(13) + Chr$(10)
    S = ""
    For I = 1 To SD.MaxRows - 1
      S = S + SL$(I) + NL
    Next I
    S = S + SL$(SD.MaxRows)
    TBox.Text = S
  End If
End Sub