home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
High Voltage Shareware
/
high1.zip
/
high1
/
DIR2
/
CLATPL.ZIP
/
CLARION8.TPX
< prev
next >
Wrap
Text File
|
1993-07-26
|
29KB
|
591 lines
#!-------------------------------------------------------------------------------#!
#! CLARION8.TPX
#!
#! File Select a file from a directory listing
#! Redirect Select destination for a report
#! View View a selected text file in a listbox
#!
#!------------------------------------------------------------------------------
#!
#! The File Template
#!
#! The File template creates a procedure to allow a user to select a file.
#! The file name with its full path will be saved in the variable entered
#! at the 'Filename Variable' prompt. If this field is left blank the
#! default of GLO:Filespec is used. (GLO:Filespec has been entered in
#! Clarion's Default Application file for your convenience. It will be
#! Smart-linked out of your final .EXE if not used.)
#!
#! If a Next Procedure is requested (ie: a procedure created with the View
#! template) it will be called just prior to returning to the calling
#! procedure.
#!
#!------------------------------------------------------------------------------
#!
#PROCEDURE(File,'Select a file from a directory listing'),SCREEN
#!
#!------------------------------------------------------------------------------
#PROTOTYPE('')
#MAP('GETDIR.INC')
#DISPLAY(' ')
#PROMPT('Filename &Variable',FIELD),%SaveFilenameVar
#PROMPT('Initial Directory',@S30),%StartDir
#PROMPT('Beginning File Mask',@S6),%StartMask
#PROMPT('Next Procedure',PROCEDURE),%NextProcedure
#PROMPT('Reselect Upon Return',CHECK),%AllowReselect
#PROMPT('Blank Name On Cancel',CHECK),%ClearOnCancel
#INSERT(%StandardHeader)
#INSERT(%SetFileSymbols)
#INSERT(%SetFileErrors)
%Procedure PROCEDURE
%LocalData
%ScreenStructure
DirString CSTRING(64) !Used for Directory to search
SaveDir LIKE(DirString) !Used to hold beginning path
DirInfo GROUP !Necessary DOS file group
BYTE,DIM(21) ! Used by findfirst
Attrib BYTE ! Attribute in DOS format
DosTime SHORT ! Time in DOS format
DosDate SHORT ! Date in DOS format
Filesize LONG ! Size in BYTES
FileName CSTRING(13) ! File name
. !End GROUP
#EMBED('Data Section')
CODE
#EMBED('Setup Procedure')
OPEN(Screen) !Open the screen
#EMBED('Setup Screen')
#IF(%StartMask)
FileMask = '%StartMask' #<!Set the begining file mask
#ELSE
FileMask = '*.*' !Set the begining file mask
#ENDIF
SaveDir = PATH() !Save the Starting Directory
IF LEN(CLIP(SaveDir)) <> 3 !If not in the root directory
SaveDir = CLIP(SaveDir) & '\' ! Add the trailing '\'
END !End IF
#IF(%StartDir)
Directory = UPPER(%StartDir) #<!Change to the requested
SETPATH(Directory) ! Starting directory
Directory = PATH() ! Reread the current path
IF LEN(CLIP(Directory)) <> 3 !If not in the root directory
Directory = CLIP(Directory) & '\' ! Add the trailing '\'
END !End IF
#ELSE
Directory = SaveDir !Set to the Current Directory
#ENDIF
DO FillQueues !Fill the screen queues
LOOP !Main ACCEPT loop
#INSERT(%GenerateFormulas)
#EMBED('Top of Accept Loop')
CASE SELECTED() #<! Jump to field setup routine
#INSERT(%ScreenSetupRoutines)
END #<! End CASE
ACCEPT ! ACCEPT keyboard input
#INSERT(%HotKeyRoutines)
CASE FIELD() ! Jump to field edit routine
#FOR(%ScreenField)
#IF(%ScreenField = '?FileMask')
OF ?FileMask ! Completed file mask field
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! File mask edit routine
#ENDIF
IF REFER() ! If something was entered
Do FillQueues ! Fill queues with new mask
END ! End IF
#ELSIF(%ScreenField = '?FileList')
OF ?FileList ! FileList field edit
GET(FileQueue,CHOICE()) ! Get selected file entry
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! File list edit routine
#ENDIF
IF KEYCODE() = MouseLeft2 OR | ! On mouse double click
KEYCODE() = EnterKey ! Or the Enter Key
SELECT(?OK) ! Select the OK button and
PRESS(EnterKey) ! Press Enter to complete
END ! End IF
#ELSIF(%ScreenField = '?DirList')
OF ?DirList ! Directory list field edit
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! Directory edit routine
#ENDIF
IF SELECTED() = ?DirList ! If staying on this field
IF KEYCODE() = MouseLeft2 OR | ! On mouse double click
KEYCODE() = EnterKey ! or the Enter Key
GET(DirQueue,CHOICE()) ! Get the selected entry
Directory = CLIP(Directory) & DirLine ! Create a new directory
SETPATH(Directory) ! Set to the directory
Directory = PATH() ! Reread the directory
IF LEN(CLIP(Directory)) <> 3 ! If not in the Root
Directory = CLIP(Directory) & '\' ! add the trailing \
END ! End IF
Do FillQueues ! Fill the screen queues
SELECT(?FileList,1) ! Reset file list box
SELECT(?DirList,1) ! Reset Dir List box
END ! End IF
END ! End IF
#ELSIF(UPPER(%ScreenField) = '?OK')
OF ?Ok ! Ok button field Edit
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! OK button edit routine
#ENDIF
IF FileLine = ' NO MATCH ' ! If no FileName selected
#IF(%DirQueueExists)
SELECT(?DirList) ! Select directory list
#ELSE
SELECT(?Cancel) ! Select cancel button
#ENDIF
CYCLE ! Cycle to ACCEPT.
END ! End IF
%SaveFilenameVar = CLIP(Directory) & FileLine #<! Save the Filename
#IF(%NextProcedure)
SETPATH(SaveDir) ! Return to starting path
#IF(%DirQueueExists)
FREE(DirQueue) ! Free the DirQueue memory
#ENDIF
FREE(FileQueue) ! Free the FileQueue memory
%NextProcedure #<! Call the Next procedure
#IF(%AllowReselect)
DO FillQueues ! Fill the screen queues
SELECT(?FileList) ! Select the file list
CYCLE ! Return to ACCEPT input
#ENDIF
#ELSE
BREAK ! Break out of screen LOOP
#ENDIF
#ELSIF(%ScreenField = '?Cancel')
OF ?Cancel ! Cancel button field Edit
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! Cancel button edit routine
#ENDIF
SETPATH(SaveDir) ! Return to starting path
#IF(%DirQueueExists)
FREE(DirQueue) ! Free the DirQueue memory
#ENDIF
FREE(FileQueue) ! Free the FileQueue memory
#IF(%ClearOnCancel)
CLEAR(%SaveFilenameVar) #<! Clear the filename variable
#ENDIF
BREAK ! Return to calling procedure
#ELSIF(%ScreenFieldEdit)
OF %ScreenField #<! Completed %ScreenField
%ScreenFieldEdit #<! %ScreenField edit routine
#ENDIF
#ENDFOR
#INSERT(%PulldownEditRoutines)
END ! End CASE FIELD()
END !End LOOP
SETPATH(SaveDir) !Return to starting path
#IF(%DirQueueExists)
FREE(DirQueue) !Free the DirQueue memory
#ENDIF
FREE(FileQueue) !Free the FileQueue memory
#EMBED('End of Procedure')
FillQueues ROUTINE
FREE(FileQueue) !Free the FileQueue
#IF(%DirQueueExists)
FREE(DirQueue) !Free the DirQueue
DirString = CLIP(Directory) & '*.*' !Set the subdirectory mask
IF NOT LEN(CLIP(DirString)) = 6 !If not in the root directory
DirLine = '..\' ! Make prior directory entry
ADD(DirQueue) ! Add to the DirQueue
END !End IF
IF FindFirst(DirString,DirInfo,FA_DIREC) <> 0 !If unexpected error
FREE(DirQueue) ! Clear the DirQueue
FREE(FileQueue) ! Clear the FileQueue
RETURN ! Return
END !End IF
LOOP !While entries found
IF FileName = '.' OR FileName = '..' ! If the dot entries
IF FindNext(DirInfo) <> 0 ! Get the next entry
BREAK ! Break if unexpected error
END ! End IF
CYCLE ! Return to dot entry check
END ! End IF
IF BAND(ATTRIB,10H) ! If a subdirectory is found
DirLine = FileName ! Fill the queue field
ADD(DirQueue) ! Add to the DirQueue
IF ERRORCODE() THEN BREAK. ! Break if unexpected error
END ! End IF
IF FindNext(DirInfo) <> 0 ! Get the next entry
BREAK ! Break if unexpected error
END ! End IF
END !End LOOP
SORT(DirQueue,+DirLine) !Sort the directory listing
#ENDIF
DirString=CLIP(Directory) & FileMask !Set the file mask
IF FindFirst(DirString,DirInfo,FA_NORMAL) <> 0 !If no matching files found
FileLine = ' NO MATCH ' ! Fill queue with message
ADD(FileQueue) ! Add to the FileQueue
Else !Else matching file found
LOOP ! While entries are found
IF BAND(ATTRIB,10H) = 0 ! If entry is a file
FileLine = FileName ! Fill the queue field and
ADD(FileQueue) ! Add to the FileQueue
IF ERRORCODE() THEN BREAK. ! Break if unexpected error
END ! End IF
IF FindNext(DirInfo) <> 0 ! Get the next entry
BREAK ! Break if unexpected error
END ! End IF
END ! End LOOP
END !End IF
SORT(FileQueue,+FileLine) !Sort the file listing
DISPLAY !Display the new lists
#!
#!***************************************************************************
#PROCEDURE(Redirect,'Select destination for a report'),SCREEN
#!------------------------------------------------------------------------------
#!
#! The Redirect Template
#!
#!------------------------------------------------------------------------------
#PROTOTYPE('')
#INSERT(%StandardHeader)
%Procedure PROCEDURE
%LocalData
%ScreenStructure
#EMBED('Data Section')
CODE
#EMBED('Setup Procedure')
OPEN(Screen)
#EMBED('Setup Screen')
LOOP
#INSERT(%GenerateFormulas)
#EMBED('Top of Accept Loop')
#FOR(%ScreenField)
#IF(%ScreenFieldSetup)
CASE SELECTED() #<!Jump to field setup routine
#INSERT(%ScreenSetupRoutines)
END #<!End CASE
#ENDIF
#ENDFOR
ACCEPT !Accept input
#INSERT(%HotKeyRoutines)
CASE FIELD()
#FOR(%ScreenField)
OF %ScreenField
%ScreenFieldEdit
#ENDFOR
END
END
#EMBED('End of Procedure')
#!
#!
#PROCEDURE(View,'View a selected text file in a listbox'),SCREEN,REPORT,PULLDOWN
#!------------------------------------------------------------------------------
#!
#! The View Template
#!
#!------------------------------------------------------------------------------
#PROTOTYPE('')
#PROJECT('%clapfx%ASCII.LIB')
#INSERT(%StandardHeader)
#DISPLAY(' ')
#PROMPT('File to &View',@s30),%ListFile
#PROMPT('Warning Size (in K)',@s6),%FileWarningSize
#PROMPT('Ma&ximum Line Length',@s6),%FileLineLength
#PROMPT('Progress &Indicator',CHECK), %ShowProg
#PROMPT('Progress Character',@S8),%ProgChar
#!
#IF(%ListFile = %Null)
#SET(%ListFile, 'GLO:FileSpec')
#ENDIF
%Procedure PROCEDURE
%LocalData
SaveRows BYTE !Initial screen rows
SaveCols BYTE !Initial screen columns
FirstPage BYTE !First page display flag
RptFile FILE,DRIVER('ASCII'),NAME(%ListFile),PRE(Dos) #<! Declare Input File
RECORD
Fline STRING(255)
. .
SaveScreen SCREEN(25,80).
%ReportStructure
%ScreenStructure
%PulldownStructure
#IF(%ShowProg)
VEW::Length BYTE !Progress variable
VEW::ProgString STRING('{50}') !Progress display variable
#ENDIF
#EMBED('Data Section')
CODE
#EMBED('Setup Procedure')
#IF(%ProgChar) #!If showing the progress
VEW::ProgString = ALL(%ProgChar) #<!Fill the progress string
#ENDIF
IF NOT %ListFile THEN RETURN. #<!If %ListFile is blank
OPEN(RptFile) !Open the Dos File
IF DiskError('Cannot Locate Selected File') THEN RETURN.
#IF(%FileWarningSize)
IF Bytes(RptFile) > (%FileWarningSize * 1024)#<!If oversized file
GLO:Message1 = 'This is a large file and may take a while'
GLO:Message2 = 'to load. You may press the Esc key'
GLO:Message3 = 'while the file is loading to exit.'
ShowWarning ! Show a warning screen
END !End IF
#ENDIF
IF GRAPHIC(1) = 5Ah !If in text mode
OPEN(SaveScreen) ! Open a save screen
END !End IF
OPEN(Screen) !Open the Screen
IF GRAPHIC(1) <> 5Ah !If not in text mode
DISABLE(?ChangeMode) ! Disable changemode button
END !End IF
DISABLE(?PrintDevice) !Disable the device field
#IF(%Pulldown) #!If a Pulldown exists
OPEN(%Pulldown) #<!Open the Pulldown
#ENDIF
SaveRows = Rows(SCREEN) !Save the Screen Rows
SaveCols = Cols(SCREEN) !Save the Screen Columns
#EMBED('Setup Screen')
FirstPage = 1 !Set flag for Page 1
SET(RptFile) !Set to the file
LOOP !Loop through the dos file
#INSERT(%GenerateFormulas)
#EMBED('Top of Accept Loop')
NEXT(RptFile) ! Get the next record
IF ERRORCODE() THEN BREAK. ! Break if error occurs
#IF(%FileLineLength)
IF Bytes(RptFile) > %FileLineLength ! Line is longer than allowed
GLO:Message1 = 'The line length is greater than %FileLineLength.'
#ELSE
IF Bytes(RptFile) > 255 ! Line is longer than allowed
GLO:Message1 = 'The line length is greater than 255.'
#ENDIF
GLO:Message2 = 'The selected file is not an ASCII file.'
GLO:Message3 = 'No view on this file is available.'
ShowWarning ! Show an error message
FREE(ListQueue) ! Free memory table
CLOSE(RptFile) ! Close the DOS file
#IF(%Pulldown) #!If a Pulldown exists
CLOSE(%Pulldown) #<! Close the Pulldown
#ENDIF
CLOSE(SCREEN) ! Close the Screen
#EMBED('Immediately before RETURN for non-ASCII file error')
RETURN ! Return back to caller
END !End IF
#IF(%ShowProg) #!If showing the progress
#INSERT(%ShowProgress)
#ENDIF
#EMBED('After NEXT in RptFile LOOP')
Que:QueueLine = Dos:Fline ! Fill the queue line.
ADD(ListQueue) ! Add to the queue
IF ERRORCODE() ! If out of memory
GLO:Message1 = 'Error: ' & ERROR() ! Create the error message
GLO:Message2 = 'This file is too large to be read into memory.'
GLO:Message3 = 'The entire file will not be displayed.'
ShowWarning ! Show the error message
BREAK ! Break out of read loop
END ! End IF
IF FirstPage ! If page 1
IF RECORDS(ListQueue) = ROWS(SCREEN) ! If we have a full screen
FirstPage = 0 ! Turn off the page flag
DISPLAY(?List) ! Display page 1
END ! End IF
END ! End IF
LOOP WHILE KEYBOARD() ! While Keyboard Input
SELECT(?List) ! Select the List box
ACCEPT ! Handle internal keystrokes
END ! End LOOP
IF KEYCODE() = EscKey THEN BREAK.
END !End LOOP
StatusLine = 'Viewing: ' & %ListFile #<!Fill the status line
DISPLAY !Redisplay the screen
PrintDevice = '' !Blank the PrintDevice field
LOOP !Process the screen
#FOR(%ScreenField)
#IF(%ScreenFieldSetup)
CASE SELECTED() #<! Jump to field setup routine
#INSERT(%ScreenSetupRoutines)
END #<! End CASE
#ENDIF
#ENDFOR
ACCEPT ! Accept keyboard input
#INSERT(%HotKeyRoutines)
CASE FIELD() ! Which field was completed
#FOR(%ScreenField)
#IF(%ScreenField = '?Exit')
OF ?Exit ! Completed Exit Button
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! Exit edit routine
#ENDIF
BREAK ! Break out of the loop
#ELSIF(%ScreenField = '?ChangeMode')
OF ?ChangeMode ! Completed mode button
IF ROWS(SCREEN) = 25 ! If in 25 line mode
CLOSE(SCREEN) ! Close the current screen
SETTEXT(50,80) ! Set to 50 line mode
ELSE ! Else in 43 or 50 line mode
CLOSE(SCREEN) ! Close the current screen
SETTEXT(25,80) ! Set to 25 line mode
SETAREA(25,80) ! Resize the screen area
LOADSYMBOLS ! Reload graphic mouse
END ! End IF
OPEN(SCREEN) ! Open screen in new mode
DISABLE(?PrintDevice) ! Disable the device field
IF GRAPHIC(1) <> 5Ah ! If not in text mode
DISABLE(?ChangeMode) ! Disable ChangeMode button
END ! End IF
#IF(%MouseSupport)
SETMOUSE(ROW(?ChangeMode),COL(?ChangeMode))! Reset the mouse position
#ENDIF
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! ChangeMode edit routine
#ENDIF
DISPLAY ! Display the fields
PrintDevice = '' ! Blank PrintDevice field
#ELSIF(%ScreenField = '?Print')
OF ?Print ! Completed Print Button
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! Print button edit routine
#ENDIF
IF NOT PrintDevice ! If no print device
DISABLE(?StatusLine) ! Disable the StatusLine
ENABLE(?PrintDevice) ! Enable the PrintDevice
SELECT(?PrintDevice) ! Select the PrintDevice
CYCLE ! Cycle to ACCEPT input
END ! End IF
IF NOT STATUS(PrintDevice) ! If PrintDevice not ready
GLO:Message1 = CLIP(PrintDevice) & ' is not ready.'
GLO:Message2 = 'Be sure the Printer is online and attached to'
GLO:Message3 = 'the specified device and try again.'
ShowWarning ! Show an error message
PrintDevice = '' ! Blank PrintDevice field
CYCLE ! Cycle to ACCEPT input
END ! End IF
StatusLine = 'Printing: ' & %ListFile #<! Fill the status line
DISPLAY(?StatusLine) ! Display the status line
OPEN(REPORT) ! Open the report to print
LOOP I# = 1 to RECORDS(ListQueue) ! Loop while QUEUE records
GET(ListQueue,I#) ! Get the QUEUE entry
IF ERRORCODE() THEN BREAK. ! Break if an error occurs
PRINT(RPT:Detail) ! Print the line
IF KEYBOARD() ! If keyboard input
ACCEPT ! Get the keystroke
IF KEYCODE() = EscKey ! If the ESCAPE key
PrintDevice = '' ! Blank PrintDevice field
BREAK ! Break from printing
END ! End IF
END ! End IF
END ! End LOOP
CLOSE(REPORT) ! Close the report
StatusLine = 'Viewing: ' & %ListFile #<! Fill the status line
DISPLAY(?StatusLine) ! Display the status line
PrintDevice = '' ! Blank PrintDevice field
#ELSIF(%ScreenField = '?PrintDevice')
OF ?PrintDevice ! Selected a port for printer
#IF(%ScreenFieldEdit)
%ScreenFieldEdit #<! PrintDevice edit routine
#ENDIF
DISABLE(?PrintDevice) ! Disable the PrintDevice
ENABLE(?StatusLine) ! Enable the StatusLine
IF KEYCODE() = EscKey ! If escape key pressed
SELECT(?Exit) ! Select the exit button
PrintDevice = '' ! Blank PrintDevice field
CYCLE ! Cycle to ACCEPT input
END ! End IF
SELECT(?Print) ! Select the Print button
PRESS(EnterKey) ! And complete it.
#ELSIF(%ScreenFieldEdit)
OF %ScreenField ! Completed %ScreenField
%ScreenFieldEdit ! %ScreenField edit routine
#ENDIF
#ENDFOR
#INSERT(%PulldownEditRoutines)
END ! End CASE FIELD()
END !End LOOP
#EMBED('Immediately after LOOP, before FREE(Queue)')
FREE(ListQueue) !Free memory table
CLOSE(RptFile) !Close the DOS file
#IF(%Pulldown) #!If a Pulldown exists
CLOSE(%Pulldown) #<!Close the Pulldown
#ENDIF
IF Rows(SCREEN) <> SaveRows | !If the mode is not the same
OR SaveCols <> Cols(SCREEN) ! as when procedure started
CLOSE(SCREEN) !Close the Screen
SETTEXT(SaveRows,SaveCols) ! Reset to the entry mode
SETAREA(SaveRows,SaveCols) ! Resize the screen area
LOADSYMBOLS ! Reload graphic mouse
END !End IF
#EMBED('End of Procedure')
#!
#!***************************************************************************
#GROUP(%ShowProgress)
IF NOT (((POINTER(RptFile)+100)%%100)) !Show the progess indicator
VEW::Length += 1
StatusLine = ' Reading File: ' & SUB(VEW::ProgString,1,VEW::Length)
IF VEW::Length = 50
VEW::Length = 1
StatusLine = ' Reading File: ' & ' {70}'
END
Display(?StatusLine)
END
#!
#!***************************************************************************
#!
#GROUP(%SetFileSymbols)
#IF(%SaveFilenameVar = %Null)
#SET(%SaveFilenameVar, 'GLO:FileSpec')
#ENDIF
#SET(%DirQueueExists,%Null)
#SET(%FileMaskExists,%Null)
#SET(%FileListExists,%Null)
#SET(%DirectoryExists,%Null)
#SET(%FileOkExists,%Null)
#SET(%FileCancelExists,%Null)
#FOR(%ScreenField)
#IF(UPPER(%ScreenField) = '?DIRLIST')
#SET(%DirQueueExists,'YES')
#ELSIF(UPPER(%ScreenField) = '?FILEMASK')
#SET(%FileMaskExists,'YES')
#ELSIF(UPPER(%ScreenField) = '?FILELIST')
#SET(%FileListExists,'YES')
#ELSIF(UPPER(%ScreenField) = '?DIRECTORY')
#SET(%DirectoryExists,'YES')
#ELSIF(UPPER(%ScreenField) = '?OK')
#SET(%FileOkExists,'YES')
#ELSIF(UPPER(%ScreenField) = '?CANCEL')
#SET(%FileCancelExists,'YES')
#ENDIF
#ENDFOR
#!***************************************************************************
#!
#GROUP(%SetFileErrors)
#IF(%FileCancelExists <> 'YES')
#SET(%ErrorMessage,(%Procedure & ' WARNING:'))
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,' ?Cancel button is not found in the screen structure,')
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,' Exit code may not have been generated.')
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,%Null)
#ERROR(%ErrorMessage)
#ENDIF
#!
#CHAIN('CLARION9.TPX')