home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
High Voltage Shareware
/
high1.zip
/
high1
/
DIR19
/
READTXC.ZIP
/
READTXT.PRG
< prev
Wrap
Text File
|
1993-05-12
|
18KB
|
580 lines
//───────────────────────────────────────────────────
//
// Program READTXT.PRG
// Function(S) READTEXT()
// SHOWLINS()
// ML_BOX()
// RS_BOX()
// ParseSlash()
// Centr()
// O_ERROR()
//
// Uses: TEXT.$db
//
// Other Files: &TEXTFILE
//
// Originally written by Eric Engelmann for the US Army.
//
// Extensively modifed by TED LONG 11/92
// Orlando, Fl (407) 380-8882
//──────────────────────────────────────────────────────
//
// Substitute for Buerg's List program with Clipper. Allows user
// to examine any text type file, such as generated report files
// (or source code files, if you have set up your error handler
// to call this program with the name of the error program),
// without having to use the RUN or ! command with its very high
// RAM overhead requirements.
// The program works by appending a DBF file from a text file (SDF)
// It then uses the SCROLL function to move the current picture of
// text on the screen.
//
//
//───────────────────────────────────────────────────────────────────
// Extensive changes were made to the original. The entire screen was
// changed along with additional key trapping.
// Also, optimized for clipper 5.01.
//───────────────────────────────────────────────────────────────
// 1) Converted to a function from a proc
// 2) Save and restore prior screens
// 3) Create text.$$$ on the fly and delete when finished
// 4) Reformated the source code with Snap
// 5) Fixed the color problems with the opening screen
// 6) Added a real help screen
//───────────────────────────────────────────────────────────────
STATIC offset, boxbott, scr_row, boxtop, getstr
//───────────────────────────
FUNCTION READTEXT(textfile)
//───────────────────────────
LOCAL getlist := {}, darray := {}
LOCAL oldcolor := SETCOLOR()
LOCAL oldscreen := SAVESCREEN(0,0,24,79)
LOCAL oldsele := SELECT()
LOCAL toprec := 1 &&Record number on diplay at top line of box.
LOCAL lastrec, keystroke, newrec, oldtop, mphrase, newcolor, flag, readscr
LOCAL readfile := parseslash( textfile )
boxbott := 23 &&Bottom row of display box.
offset := 1 &&Starting position to display for each line of text.
scr_row := 1 &&Screen row.
boxtop := 1 &&Top row of display box.
SET SCOREBOARD OFF
// save the old color attributes
// SET COLOR TO SOMETHING OTHER THAN WHITE ON BLACK
IF ISCOLOR()
IF oldcolor = "" .OR. oldcolor = 'W/N'
newcolor := 'W/+B'
ELSE
newcolor := oldcolor
ENDI
ELSE
newcolor := 'w/n'
ENDI
SETCOLOR(newcolor)
ML_BOX(10, 'Please wait while the File is prepared for display...')
AADD(darray,{"LINE", "C", 220 , 0 } )
DBCREATE('TEXT.$DB', darray )
USE TEXT.$db NEW EXCLUSIVE
APPEND FROM &textfile. SDF
GO TOP
LASTREC := RECCOUNT()
// Present the database in a window.
CLS
// Paint first screen.
SHOWLINS()
SETCOLOR("I")
@ 00,00 SAY SPACE(80)
@ 00,00 SAY 'File: '+ALLTRIM( readfile )
@ 00,70 SAY DTOC(DATE())
@ 24,00 SAY SPACE(80)
@ 24,00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
'/PgDn/PgUp/Home/End ESC=Exit F1=HELP'
@ 24, 00 SAY 'Command '
SETCOLOR(newcolor)
flag := .F.
DO WHILE .T.
SETCOLOR("I")
@ 0,19 SAY 'Line: '+STR(toprec,6,0)
@ 24, 09 SAY ""
SETCOLOR(newcolor)
keystroke := INKEY(0)
DO CASE
// User pressed ESC, and wants out.
CASE LASTKEY() == 27
USE
FCLOSE("TEXT.$DB")
FERASE("TEXT.$db")
SETCOLOR(oldcolor)
CLS
SELECT(oldsele)
RESTSCREEN(0,0,24,79,oldscreen)
RETURN NIL
// User wants to pan right.
CASE keystroke = 4
IF offset< 240
offset := offset+20
ENDIF
GO toprec
showlins()
// User wants to pan left.
CASE keystroke = 19
IF offset>=21
offset := offset-20
ENDIF (offset>=21)
GO toprec
showlins()
// User wants top of file.
CASE keystroke = 1
GO 1
toprec := 1
showlins()
// User wants end of file.
CASE keystroke = 6
IF LASTREC>=boxbott-boxtop
GO LASTREC-(boxbott-boxtop)
ELSE
GO 1
ENDIF (lastrec>=boxbott-boxtop)
toprec := RECNO()
showlins()
// User wants to page down a screen.
CASE keystroke = 3
IF toprec+boxbott-boxtop <= LASTREC
toprec := toprec+boxbott-boxtop
ELSE
toprec := LASTREC
ENDIF (toprec+boxbott-boxtop <= lastrec)
GO toprec
showlins()
// User wants to page up a screen.
CASE keystroke = 18
newrec := toprec-(boxbott-boxtop)
IF newrec>0
toprec := newrec
ELSE
toprec := 1
ENDIF (newrec>0)
GO toprec
showlins()
// User chose uparrow.
CASE keystroke = 5
IF toprec>1
SCROLL(boxtop,0,boxbott,79,-1)
// Got to the new record.
toprec := toprec-1
GO toprec
@ boxtop,0 SAY SUBSTR(FIELD->line,offset,79)
ELSE
// If we are at the first record already, do nothing.
ENDIF (toprec>1)
// User chose down arrow.
CASE keystroke = 24
IF toprec-boxtop+boxbott<LASTREC
SCROLL(boxtop,0,boxbott,79,1)
toprec := toprec+1
GO toprec+boxbott-boxtop
@ boxbott,0 SAY SUBSTR(FIELD->line,offset,79)
ENDIF (toprec-boxtop+boxbott<lastrec)
// User claims he needs help.
CASE keystroke = 28 .OR. keystroke = 72 .OR. keystroke = 104 .OR. keystroke = 63
readscr := SAVESCREEN(0,0,24,79)
IF !ISCOLOR()
CLS
ENDI
RS_BOX(6,8,18,72)
CENTR(6, "┤ HELP SCREEN ├")
@ 07, 09 SAY ' Cursor Left - Pans the screen left'
@ 08, 09 SAY ' Cursor Right - Pans the screen right'
@ 09, 09 SAY ' Cursor up/down - Move to the next or previous line'
@ 10, 09 SAY ' Page-Up - Move up one screen page'
@ 11, 09 SAY ' Page-Down - Move down one screen page'
@ 12, 09 SAY ' Home - Go to the top of the document'
@ 13, 09 SAY ' End - Go to the bottom of the document'
@ 14, 09 SAY ' F Find Text - Non case sensitive find'
@ 15, 09 SAY ' C Find Text - Case sensitive find'
@ 16, 09 SAY ' N Next - Next find'
@ 17, 09 SAY ' P Print - Print viewed document'
INKEY(0)
RESTSCREEN(0,0,24,79, readscr)
CASE keystroke = 112 .OR. keystroke = 80
IF ISPRINTER()
SET CONSOLE OFF
TYPE &TEXTFILE. TO PRINT
SET CONSOLE ON
ELSE
O_ERROR("PRINTER IS NOT READY......")
ENDI
// User wants to locate a string.
CASE keystroke = 70 .OR. keystroke = 102
oldtop := toprec
GO toprec
SETCOLOR("I")
@ 24,0 SAY SPACE(80)
getstr := REPLICATE(" ",25)
@ 24,00 SAY "Search for ? " GET getstr
READ
IF !EMPTY(getstr)
getstr := LOWER(TRIM(getstr))
mphrase := CHR(34)+TRIM(getstr)+CHR(34)
LOCATE NEXT 1000000 FOR getstr $ LOWER(FIELD->line)
IF EOF()
@ 24,0 SAY SPACE(80)
@ 24,0 SAY mphrase+' not found. Press any key....'
keystroke := INKEY(0)
toprec := oldtop
GO toprec
ELSE
toprec := RECNO()
ENDIF (eof())
flag := .T.
ENDI
SETCOLOR(newcolor)
showlins()
SETCOLOR("I")
@ 24,0 SAY SPACE(80)
@ 24, 00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
'/PgDn/PgUp/Home/End ESC=Exit F1=HELP'
@ 24, 00 SAY 'Command '
SETCOLOR(newcolor)
CASE keystroke = 67 .OR. keystroke = 99
getstr := REPLICATE(" ",25)
oldtop := toprec
GO toprec
SETCOLOR("I")
@ 24,0 SAY SPACE(80)
@ 24,00 SAY "Search for ? " GET getstr
READ
mphrase := CHR(34)+TRIM(getstr)+CHR(34)
IF !EMPTY(getstr)
getstr := TRIM(getstr)
LOCATE NEXT 1000000 FOR getstr $ FIELD->line
IF EOF()
@ 24,0 SAY SPACE(80)
@ 24,0 SAY mphrase + ' not found. Press any key....'
keystroke := INKEY(0)
toprec := oldtop
GO toprec
ELSE
toprec := RECNO()
ENDIF (eof())
flag := .T.
ENDI
SETCOLOR(newcolor)
showlins()
SETCOLOR("I")
@ 24,0 SAY SPACE(80)
@ 24, 00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
'/PgDn/PgUp/Home/End ESC=Exit F1=HELP'
@ 24, 00 SAY 'Command '
SETCOLOR(newcolor)
// User wants to find the next occurrence.
CASE keystroke = 78 .OR. keystroke = 110
IF flag
CONTINUE
IF EOF()
SETCOLOR("I")
@ 24,0 SAY SPACE(80)
@ 24,0 SAY mphrase + '- Next occurrence not found. Press any key....'
keystroke := INKEY(0)
toprec := oldtop
GO toprec
ELSE
toprec := RECNO()
ENDIF (eof())
SETCOLOR(newcolor)
showlins()
SETCOLOR("I")
@ 24,0 SAY SPACE(80)
@ 24, 00 SAY SPACE(30)+'Keys: '+CHR(24)+CHR(25)+CHR(26)+CHR(27)+;
'/PgDn/PgUp/Home/End ESC=Exit F1=HELP'
@ 24, 00 SAY 'Command '
SETCOLOR(newcolor)
ENDI
ENDCASE
ENDDO
RETURN NIL
//──────────────────────────────────────────────────────────────────────
//
// Function: SHOWLINS()
//
// Called by: READTXT.PRG
//
//─────────────────────────────────────────────────────────────────────
STATIC FUNCTION showlins()
//──────────────────
LOCAL lastrow
@ boxtop, 0 CLEAR TO boxbott,79
scr_row := boxtop
DO WHILE .NOT. EOF() .AND. scr_row <= boxbott
@ scr_row,0 SAY SUBSTR(FIELD->line, offset,79)
SKIP
scr_row := scr_row+1
ENDDO
lastrow := scr_row-1
RETURN .T.
//───────────────────────────────────
// Function ParseSlash()
// By Ted Long
//───────────────────────────────────
STATIC FUNCTION ParseSlash(cFname)
//───────────────────────────────────
LOCAL posa, posb
cFname := ALLTRIM( cFname )
// If the filename is included within a path, the parse out the filename
posa := RAT("\",cFname)
IF posa > 0
cFname := SUBSTR(cFname, posa + 1, LEN( cfname) )
endif
RETURN cFname
//───────────────────────────────────────────────────────────────────────
// Function: ML_BOX()
//
// By Ted Long
//
// usage: m_box(5,"character string")
// What it does: centers a message on the screen with a box.
// Starting at the specific line number
//───────────────────────────────────────────────────────────────────────
STATIC FUNCTION ML_box(mrow, M_string)
//─────────────────────────────
LOCAL length, beg_it, end_it
IF LEN(ALLTRIM(M_string)) >= 76
length := 76
M_string := SUBSTR(M_string,1,76)
ELSE
length := ROUND(LEN(ALLTRIM(M_string)),0)
ENDI
beg_it := ROUND((80-length)/2,0)-2
end_it := ROUND(((80-length)/2)+length,0)+1
RS_BOX( mrow-1, beg_it, mrow+1, end_it )
@ mrow-1, 34 SAY "┤ Message ├"
@ mrow,(beg_it +2) SAY ALLTRIM(M_string)
RETURN NIL
//───────────────────────────────────────────────────────────────────────
// Function: RS_BOX()
//
// By Ted Long
//
// A REAL SHADOW BOX (NON-DESTRUCTIVE SHADOW ON BOTTOM AND RIGHT)
//
// USAGE: C_BOX(n1 ,n2 , n3, n4, n5)
// WHERE: n1 := BEGINING ROW
// n2 := BEGINING COL
// n3 := ENDING ROW
// n4 := ENDING COLUMN
// n5 := BOX TYPE (optional)
//
// BOX OPTIONS 1 := ┌─┐│┘─└│ 2 := ╔═╗║╝═╚║
// 3 := ╒═╕│╛═╘│ 4 := ╓─╖║╜─╙║
// 5 := "█▀███▄██ ████"
//
// DEFAULT := ┌─┐│┘─└│
//───────────────────────────────────────────────────────────────────────
// I'm sure that this is the fastet non-destructive shadowbox available
// that is written in 100% Clipper. Speed gets damn close to ASM
//───────────────────────────────────────────────────────────────────────
STATIC FUNCTION RS_BOX(beg_row, beg_col, end_row, end_col, b_type, color)
//───────────────────────────────────────────────────────────────────────
LOCAL mboxer, horiz, vert, h, v, origcolor
//───────────────────────────────────────────────────────────────
// check to see if the parameters passed are greater than possible
// shadow box coordinates on a 80 X 25 Screen
//───────────────────────────────────────────────────────────────
DO CASE
CASE beg_row < 0 .or. beg_row > 23
RETURN NIL
CASE beg_col < 0 .or. beg_col > 77
RETURN NIL
CASE end_row < 2 .or. end_row > 23
RETURN NIL
CASE end_col < 0 .or. end_col > 77
RETURN NIL
ENDCASE
origcolor := SETCOLOR()
//───────────────────────────────────────────────────────────────
// Spec out the box type. Default is type 1 or a single line box
//───────────────────────────────────────────────────────────────
DO CASE
CASE b_type == 1
mboxer := "┌─┐│┘─└│"
CASE b_type == NIL
mboxer := "┌─┐│┘─└│"
CASE b_type == 2
mboxer := "╔═╗║╝═╚║ "
CASE b_type == 3
mboxer := "╒═╕│╛═╘│ "
CASE b_type == 4
mboxer := "╓─╖║╜─╙║ "
CASE b_type == 5
mboxer := "█▀███▄██ ████"
CASE b_type == 6
mboxer := " "
OTHERWISE
mboxer := "┌─┐│┘─└│"
ENDCASE
//───────────────────────────────────────────────────────────────
// Create a transparent shadow by replacing every other char within the
// savescreen memvars with CHR(07) [ white on black ] for both the
// vertical and horizontal axis. REPLACED the loop with REPLICATE()
// and TRANSFORM() 03/91
//───────────────────────────────────────────────────────────────
// Save and transform the Right Vertical axis
//───────────────────────────────────────────────────────────────
vert := SAVESCREEN(beg_row+1, end_col+1, end_row+1, end_col+2)
v := TRANSFORM(vert, REPLICATE("X"+CHR(07), LEN(vert)))
//───────────────────────────────────────────────────────────────
// Save and transform the Bottom horizontal axis
//───────────────────────────────────────────────────────────────
horiz := SAVESCREEN(end_row+1, beg_col+2, end_row+1, end_col+2)
h := TRANSFORM(horiz, REPLICATE("X"+CHR(07), LEN(horiz)))
//───────────────────────────────────────────────────────────────
// restore the screen with the vertical and horizontal axis (memvar)
// changed for white on black
//───────────────────────────────────────────────────────────────
RESTSCREEN(beg_row+1, end_col+1, end_row+1, end_col+2, v)
RESTSCREEN(end_row+1, beg_col+2, end_row+1, end_col+2, h)
//─────────────────────────
// do da box
//─────────────────────────
IF color != NIL
SETCOLOR(color)
ENDI
@ (beg_row), (beg_col), (end_row), (end_col) BOX " "
@ (beg_row), (beg_col), (end_row), (end_col) BOX mboxer
SETCOLOR(origcolor)
RETURN NIL
//──────────────────────────────────────────────────────────────────
// Function O_error()
//
// By Ted Long
//──────────────────────────────────────────────────────────────────
STATIC FUNCTION o_error( Amessage, color, whatline, defaultval, boxtype )
//──────────────────────────────────────────────────────────────────
local width, oldcolor, oldscreen, thecolor, choice, retval, i, a
local maxlength
oldcolor := setcolor()
if( iscolor(), thecolor := "+W/R,+W/N", thecolor := "w/n" )
if( !empty(color), thecolor := color, )
if( whatline == nil, whatline := 10, )
if( defaultval == nil, defaultval := .T., )
if( defaultval == nil, defaultval := .T., )
if( boxtype == nil, boxtype := 1, )
if valtype( Amessage ) == "C"
Amessage := { alltrim( Amessage ) }
endi
// Determine the maximum length element of the array
a := 1
maxlength := 1
for i = 1 to len( Amessage )
a := max( len( Amessage[ i ]), maxlength )
maxlength := a
next
width := int(max(74 - maxlength, 0)) / 2
oldscreen := savescreen(whatline, width, whatline + maxlength + 4 , 82 - width)
setcolor(thecolor)
TONE(200,2)
RS_BOX(whatline, width, whatline + len( Amessage ) + 3, 80 - width, boxtype )
for i = 1 to len( Amessage )
centr(whatline + i, Amessage[i] )
next
centr(whatline + len( aMessage ) + 2,"** Press any key **")
inkey(0)
restscreen(whatline, width, whatline + maxlength + 4 , 82 - width, oldscreen)
setcolor(oldcolor)
return( retval )
//───────────────────────────────────────────────────────────────
// Function: CENTR()
//
// By Ted Long
//
// usage: CENTR(5,"character string")
// What it does: centers a char string on the screen.
// Starting at the specific line number
//───────────────────────────────────────────────────────────────
STATIC FUNCTION CENTR(disp_row, m_string, cColor)
//───────────────────────────────────────────────────────────────
LOCAL length, beg, dacolor
if(cColor == NIL, dacolor := setcolor(), dacolor := cColor)
length := ROUND(LEN(ALLTRIM(m_string)),0)
beg := ROUND((80-length)/2,0)-2
@ disp_row,(beg +2) SAY ALLTRIM(m_string) COLOR dacolor
RETURN NIL