home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
xbase
/
library
/
dbase
/
duflp
/
fields.prg
< prev
next >
Wrap
Text File
|
1992-07-13
|
14KB
|
393 lines
*-------------------------------------------------------------------------------
*-- Program...: FIELDS.PRG
*-- Programmer: Ken Mayer (KENMAYER)
*-- Date......: 06/25/1992
*-- Notes.....: These field processing routines were deemed as not as commonly
*-- used (at least in my own Applications), and relegated to a
*-- library file. See: README.TXT about how to use this library
*-- file.
*-------------------------------------------------------------------------------
FUNCTION MemoPagr
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN - ATBBS/Borland BBS)
*-- Date........: 10/28/91
*-- Notes.......: Used to display a memo on screen, allowing user to scroll
*-- memo at will.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ?MemoPagr(<cMemo>,<ULRow>,<ULCol>,<BRRow>,<BRCol>)
*-- Example.....: ?MemoPagr(MoreData,10,20,20,65)
*-- Returns.....: .F.
*-- Parameters..: cMemo = name of memo field
*-- nULRow = upper left row position
*-- nULCol = upper left column position
*-- nBRRow = bottom right row position
*-- nBRCol = bottom right column position
*-------------------------------------------------------------------------------
PARAMETER cMemo, nULRow, nULCol, nBRRow, nBRCol
private cCursor, nEsc, nPgDn, nPgUp, nUp, nDn, nNumLines,nLines,nKey
private nAtLine,nAtRow
*-- set environment
set memowidth to nBRCol - nULCol - 1
cCursor = set( "CURSOR" )
set cursor off
*-- define a few keys
nEsc = 27
nPgDn = 3
nPgUp = 18
nUp = 5
nDn = 24
*-- determine size of window
nNumLines = memlines(&cMemo)
nLines = nBRRow - nULRow - 1
*-- save the screen, so we can restore it
save screen to sTmp
@ nULRow+1, nULCol+1 clear to nBRRow+1, nBRCol+1
@ nULRow+1, nULCol+1 fill to nBRRow+1, nBRCol+1 color B/N
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 color RG+/B
@ nULRow, nULCol to nBRRow, nBRCol double color RG+/B
*-- deal with a blank memo ...
if nNumLines = 0
@ nULRow + 1, nULCol + 1 SAY ;
"Blank Memo. Press any key to continue..." color RG+/B
nKey = inkey(0)
*-- reset the whole thing
restore screen from sTmp
release screen sTmp
set cursor &cCursor
RETURN .F.
endif
nAtLine = 1
nAtRow = 1
do while nAtLine <= nNumLines
*-- Show one window full
do while nAtRow <= nLines .and. nAtLine <= nNumLines
@ nULRow+nAtRow, nULCol + 1 say ;
mline( &cMemo, nAtLine ) color RG+/B
nAtLine = nAtLine + 1
nAtRow = nAtRow + 1
enddo
*-- If at last line of memo...
if nAtLine > nNumLines
*-- If memo is shorter than one page, put box character in
*-- bottom left corner of box, otherwise, put an up arrow
*-- symbol there.
@ nBRRow - 1, nBRCol SAY ;
iif( nNumLines <= nLines, chr(186), chr(24)) color W+/B
do while .T.
nKey = inkey(0)
*-- If memo is shorter than one page, only allow Esc key
if nNumLines <= nLines
if nKey = nEsc
exit
endif
*-- Otherwise, allow Esc or PgUp keys
else
if nKey = nEsc .or. nKey = nPgUp .or. nKey = nUp
exit
endif
endif
?? chr(7)
enddo
if nKey = nEsc
restore screen from sTmp
release screen sTmp
set cursor &cCursor
RETURN .F.
endif
@ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
color RG+/B
nAtLine = nAtLine - nAtRow - nLines + 1
nAtLine = iif( nAtLine < 1, 1, nAtLine )
nAtRow = 1
loop
endif
*-- Not at end of memo yet...
*-- If on first page, show down arrow only, otherwise show
*-- up/down arrow on border of box.
@ nBRRow - 1, nBRCol say ;
iif( nAtLine - nLines = 1, chr(25), chr(18)) color W+/B
do while .T.
nKey = inkey(0)
*-- If this is the first page of the memo on screen...
if nAtLine - nLines = 1
*-- Only honor PgDn, up cursor, and Esc keys
if nKey = nPgDn .or. nKey = nDn .or. nKey = nEsc
exit
endif
*-- otherwise honor PgUp and up cursor as well key as well
else
if nKey = nPgUp .or. nKey = nUp .or. nKey = nPgDn .or. ;
nKey = nDn .or. nKey = nEsc
exit
endif
endif
?? chr(7)
enddo
do case
case nKey = nEsc
restore screen from sTmp
release screen sTmp
set cursor &cCursor
RETURN .F.
case nKey = nPgUp .or. nKey = nUp
@ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
color RG+/B
nAtLine = (nAtLine - (2 * nLines))
nAtLine = IIF( nAtLine < 1, 1, nAtLine )
nAtRow = 1
loop
case nKey = nPgDn .or. nKey = nDn
@ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
@ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
color RG+/B
nAtRow = 1
loop
endcase
enddo
RETURN .F.
*-- EoF: MemoPagr()
PROCEDURE ScanMemo
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN)
*-- Date........: 02/27/1992
*-- Notes.......: This simple procedure is used to strip hard carriage returns
*-- out of all Memos in a database.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/15/1991 - original procedure.
*-- 02/07/1992 -- Douglas P. Saine (XRED) modified to handle
*-- passing of database name as a parameter
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Do ScanMemo with "<cDbf>"
*-- Example.....: Do ScanMemo with "TEST"
*-- Returns.....: None.
*-- Parameters..: cDbf = Name of the database to scan memos ...
*-------------------------------------------------------------------------------
parameter cDbf
private nFields, cFieldName, nLines, nLineNum
use (cDbf)
scan && search database 1 record at a time ...
nFields = 1
*-- This loop goes through all fields in the database
do while asc(field(nFields)) # 0
cFieldName = field(nFields) && save current field name
if type(cFieldName) = "M" && check to see if it's a memo
nLines = memlines(&cFieldName) && number of lines in memo
if nLines > 1 && if there's something there
delete file temp.txt && kill old file if it exists
set printer to file temp.txt && copy memo a line at a time to
nLineNum = 1 && temp file, using ??? command.
do while nLineNum <= nLines
??? mline(&cFieldName,nLineNum)
??? " "
nLineNum = nLineNum + 1
enddo
close printer
set printer to
append memo &cFieldName from temp.txt overwrite
endif && nLines > 1
endif && type(cFieldName) = "M"
nFields = nFields + 1 && go to next field ...
enddo && asc(field....
endscan && scan of database record by record ...
use && close database
RETURN
*-- EoP: ScanMemo
PROCEDURE Cut
*-------------------------------------------------------------------------------
*-- Programmer..: Michael B. Carlisle (Borland)
*-- Date........: 01/xx/1992
*-- Notes.......: This retrieves information from the field the user has
*-- currently selected and stores the information into a
*-- memory variable titled CLIPBOARD. The field itself is
*-- then cleared. CLIPBOARD should be declared public.
*-- This routine is taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do CUT with "<cFld>","<cScrType>"
*-- Example.....: on key label F6 do CUT with varread(),"READ"
*-- Returns.....: None
*-- Parameters..: cFld = Field to 'CUT' the data from.
*-- cScrType = What screen type? Valid options are BROWSE,
*-- EDIT and READ.
*-------------------------------------------------------------------------------
parameters cFld,cScrType
*-- test field type, ignore if field is memo
clipboard = iif(type(cFld) = "D",;
right(dtos(&cFld),4)+substr(dtos(&cFld),3,2),;
iif(type(cFld) = "L",iif(&cFld,"T","F"),;
iif(type(cFld)="M","",&cFld)))
*-- if field type is Numeric or Float, convert to string.
if type(cFld) $ "NF"
clipboard = ltrim(str(int(fixed(&cFld)),20)+;
right(str(fixed(&cFld) - int(fixed(&cFld)),20,18,19))
do while val(right(clipboard,1)) = 0 .and. .not. right(clipboard,1)="."
clipboard = left(clipboard,len(clipboard)-1)
enddo
endif
*-- Ring bell if field is MEMO, otherwise, clear the field
if type(cFld) = "M"
?? chr(7)
else
*-- do to difference in function of the HOME keys in BROWSE mode,
*-- Ctrl-Home has to be used in BROWSE
if upper(cScrType) = "BROWS"
keyboard chr(29)+chr(25) && go to beginning of field and clear
else
keyboard chr(26)+chr(25) && ditto
endif
endif
RETURN
*-- EoP: Cut
PROCEDURE Copy
*-------------------------------------------------------------------------------
*-- Programmer..: Michael B. Carlisle (Borland)
*-- Date........: 01/xx/1992
*-- Notes.......: This retrieves information from the field the user has
*-- currently selected and stores the information into a
*-- memory variable titled CLIPBOARD. The field itself is
*-- left 'as is' (unlike CUT). CLIPBOARD should be declared
*-- public. This routine is taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do COPY with "<cFld>"
*-- Example.....: on key label F8 do COPY with varread()
*-- Returns.....: None
*-- Parameters..: cFld = Field to 'COPY' the data from.
*-------------------------------------------------------------------------------
parameters cFld
*-- test field type, ignore if field is memo
clipboard = iif(type(cFld) = "D",;
right(dtos(&cFld),4)+substr(dtos(&cFld),3,2),;
iif(type(cFld) = "L",iif(&cFld,"T","F"),;
iif(type(cFld)="M","",&cFld)))
*-- if field type is Numeric or Float, convert to string.
if type(cFld) $ "NF"
clipboard = ltrim(str(int(fixed(&cFld)),20)+;
right(str(fixed(&cFld) - int(fixed(&cFld)),20,18,19))
do while val(right(clipboard,1)) = 0 .and. .not. right(clipboard,1)="."
clipboard = left(clipboard,len(clipboard)-1)
enddo
endif
*-- Ring bell if field is MEMO, otherwise, clear the field
if type(cFld) = "M"
?? chr(7)
endif
RETURN
*-- EoP: Copy
PROCEDURE Paste
*-------------------------------------------------------------------------------
*-- Programmer..: Michael B. Carlisle (Borland)
*-- Date........: 01/xx/1992
*-- Notes.......: Paste writes out the contents of the CLIPBOARD (public)
*-- memvar to the currently selected field. Because all values
*-- are converted to strings when stored into the CLIPBOARD,
*-- Paste is able to write values from one field type to another
*-- (such as numeric to character, date to numeric, etc.).
*-- This routine is taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do PASTE with "<cFld>","<cScrType>"
*-- Example.....: on key label F7 do PASTE with varread(), "READ"
*-- Returns.....: None
*-- Parameters..: cFld = Field to 'PASTE' the data in CLIPBOARD to.
*-- cScrType = What screen type? Valid options are BROWSE,
*-- EDIT and READ.
*-------------------------------------------------------------------------------
parameters cFld, cScrType
*-- ring bell if field is MEMO, otherwise, fill the field.
if type(cFld) = "M"
?? chr(7)
else
*-- due to difference in function of HOME in the BROWSE mode,
*-- Ctrl-Home has to be used in BROWSE.
if upper(cScrType) = "BROWSE"
keyboard chr(29)+chr(25)+ClipBoard && go to beginning of field,
&& and clear, putting contents
&& of clipboard in.
else
keyboard chr(26)+chr(25)+ClipBoard
endif
endif && type ...
RETURN
*-- EoP: Paste
FUNCTION Blanker
*-------------------------------------------------------------------------------
*-- Programmer..: Curt Schroeders (Borland Tech Support)
*-- Date........: 07/01/1992
*-- Notes.......: Used to BLANK a numeric field once the user presses a key
*-- that may be used IN a numeric field.
*-- SIDE EFFECT -- if you use this function, the original value
*-- in the field will be erased ... this does not allow editing
*-- of the numeric field.
*-- Written for.: dBASE IV, 1.5 (should work in 1.1)
*-- Rev. History: 07/13/1992 -- Ken Mayer -- added '-' and '.' as valid
*-- characters in list ...
*-- Usage.......: Blanker()
*-- Example.....: @5,10 get Salary when blanker()
*-- Returns.....: Logical
*-- Parameters..: None
*-------------------------------------------------------------------------------
private nX
*-- get keystroke from user
nX = inkey(0)
*-- if nX is in list
if chr(nX) $ "0123456789-."
keyboard "{CTRL-Y}" && blank out field
endif
keyboard chr(nX) && return this character ...
RETURN
*-- EoF: Blanker()
*-------------------------------------------------------------------------------
*-- EoP: FIELDS.PRG
*-------------------------------------------------------------------------------