High Voltage Shareware

home *** CD-ROM | disk | FTP | other *** search

/ High Voltage Shareware / high1.zip / high1 / DIR2 / CLATPL.ZIP / CLARION4.TPX < prev next >

Wrap

Text File | 1993-07-26 | 52KB | 1,205 lines

#!-------------------------------------------------------------------------------#! #! CLARION4.TPX #! #! Form : Update a browse or lookup with a form #! MultiPage Template : Update a file with a multiple page entry form #! PageOf Template : data entry 'Page' used with the MultiPage Form #! #!------------------------------------------------------------------------------ #! #PROCEDURE(Form,'Update a browse or lookup with a form'),SCREEN,PULLDOWN #!------------------------------------------------------------------------------ #! #! The Form Template #! #!------------------------------------------------------------------------------ #PROTOTYPE('') #PROMPT('Insert message',@S20),%InsertMsg #PROMPT('Chan&ge message',@S20),%ChangeMsg #PROMPT('De&lete message',@S20),%DeleteMsg #PROMPT('Action after ADD',OPTION),%AddAction #PROMPT('Return to caller ',RADIO) #PROMPT('Retain Record ',RADIO) #PROMPT('Clear Record ',RADIO) #PROMPT('Copy field hot&key:',KEYCODE),%CopyKey #PROMPT('Next Procedure ',PROCEDURE),%NextProcedure #INSERT(%StandardHeader) #INSERT(%InitFormSymbols) %Procedure PROCEDURE %LocalData #INSERT(%CloseFilesFlags) #!Primary or Secondary Opened #SET(%SetFile,%Primary) #INSERT(%CloseRelatedFlags) #!Related file Opened NoMoreFields BYTE(0) !No more fields flag #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) SCREEN %ScreenAttributes,ALRT(%CopyKey) %ScreenPaintDeclarations %ScreenStringDeclarations %ScreenFieldDeclarations . #IF(%SharedFiles = %NULL) SAV:SaveRecord LIKE(%FilePre:Record),PRE(SAV) #ENDIF #ELSE %ScreenStructure #IF(%SharedFiles = %NULL) SAV:SaveRecord LIKE(%FilePre:Record),PRE(SAV) #ENDIF #ENDIF #ELSE %ScreenStructure #ENDIF %PullDownStructure #IF(%SharedFiles) RecordQueue QUEUE,PRE(SAV) !Queue for concurrency checking SaveRecord LIKE(%FilePre:Record),PRE(SAV) #<!size of primary file record #FOR(%Field) #IF(%FieldType = 'MEMO') SAV:%FieldID STRING(SIZE(%Field)) #ENDIF #ENDFOR . #<!End Queue structure #ENDIF #IF(%RelatedFiles) #SET(%SetFile,%Primary) #INSERT(%RelationalAccessFlds) #<!Declare link fields #IF(%PrimaryDriver = 'Paradox') #FIX(%File,%Primary) UpdRelation STRING(SIZE(%FilePre:Record)) #<!Position of last related record #ELSE UpdRelation STRING(10) #<!Position of last related record #ENDIF #ENDIF #IF(%PrimaryDriver = 'Paradox') #FIX(%File,%Primary) SavePointer STRING(SIZE(%FilePre:Record)) !Position of current record AutoAddPtr STRING(SIZE(%FilePre:Record)) !Position of Autoinc record #ELSE SavePointer STRING(10) !Position of current record AutoAddPtr STRING(10) !Position of Autoinc record #ENDIF AutoIncAdd BYTE(0) !On for Autoincrement add #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') LastPosition STRING(10) !Position of last ADD #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%FieldDups) #ENDIF #ENDIF #IF(%PrimeKeysExist) #INSERT(%SavePrimedFields) #ENDIF #EMBED('Data Section') CODE #EMBED('Setup Procedure') #INSERT(%OpenPrimary) #<!Ensure Primary file is OPEN #INSERT(%OpenSecondaryFiles) #!Group from Clarion9.tpx #INSERT(%FieldLookupOpen) #!Check for Must be in File CASE KEYCODE() !What Key was pressed? OF InsKey !Insert a new record Action = AddRecord !Set action code 1 (ADD) #INSERT(%InsertMessage) #<!Message for ADD RECORD #INSERT(%ClearValues) #<!Clear RECORD and MEMO(s) #IF(%AutoInc) DO AutoNumber !Set autonumber key field(s) #ENDIF #IF(%InitRoutine) #<!Field(s) initial value DO InitializeFields !Initial values from dictionary #ENDIF OF EnterKey !Process a CHANGE request OROF MouseLeft2 !on EnterKey or double mouse Action = ChangeRecord !Set action code 2 (CHANGE) #INSERT(%ChangeMessage) #<!Message for CHANGE RECORD #IF(%SharedFiles) #INSERT(%SetupConcurrency) #<!Setup multi-user Concurrency #ENDIF #IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate) DO RelationAccessSave !Save LINKS for relational update #SET(%RelUpdateRoutine,'TRUE') #ENDIF OF DelKey !Process a DELETE request Action = DeleteRecord !Set action code 3 (DELETE) #INSERT(%DeleteMessage) #<!Message for DELETE RECORD SavePointer = POSITION(%Primary) #<!Position in PRIMARY file #IF(%CascadeDelete OR %ClearOnDelete OR %RestrictDelete) DO RelationAccessSave !Save LINKS for relational update #SET(%RelDeleteRoutine,'TRUE') #ENDIF END !End CASE Keycode #FOR(%Formula) #IF(UPPER(%FormulaClass) = 'SETUP') #INSERT(%GenerateFormula) #ENDIF #ENDFOR #IF(%SecondaryExist) #<!IF schema has a Secondary DO SecondaryLookups !Read any lookup fields #ENDIF #IF(%PullDownStructure) OPEN(%PullDown) #ENDIF OPEN(Screen) !Open the FORM screen IF Action = DeleteRecord !IF request for DELETE DISABLE(1,FIELDS()) !Disable all screen fields ENABLE(?OK) !Enable the OK and the ENABLE(?Cancel) !Cancel buttons END !End IF request for delete #EMBED('Setup Screen') DISPLAY !Display screen fields LOOP !Begin Main process loop #IF(%SecondaryExist) #<!IF File schema has Secondary #INSERT(%SecondaryChanged) #ENDIF #IF(%LoopFormulasExist = 'TRUE') #<!Are there Formula fields? #SET(%GenerateFormulasOn,'TRUE') DO FormulaFields !Calculate Formula fields #ENDIF CASE SELECTED() !Process selected Field #INSERT(%ScreenSetupRoutines) OF NoMoreFields !User pressed Enter or OK CASE Action !Process requested Action OF AddRecord !Action = 1 (ADD) ADD(%Primary) #<!Add Record to Primary file OF ChangeRecord !Action = 2 (Change) #IF(%RestrictUpdate) #SET(%ChkRestrictUpdate,'TRUE') #!Check for relational RESTRICT #ENDIF #IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate) #SET(%RelatedUpdateRoutine,'TRUE') #ENDIF #IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine)) IF AutoIncAdd #<!Was this an Autonumber? #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') LastPosition = POSITION(%Primary) #<!Save last record position #ENDIF PUT(%Primary) #<!Write the Record ELSE #<!not AutoincAdd #ENDIF #IF(%SharedFiles) #SET(%ConcurrentWriteOn,'TRUE') DO ConcurrentWrite !Concurrent update ROUTINE IF AbortWrite# !AbortWrite is on CYCLE !Let user choose response END !End AbortWrite# #IF(%RelatedUpdateRoutine = %NULL) PUT(%Primary) #<!Write the Record #ENDIF #ENDIF #IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate) DO RelationalUpdate !Relational update ROUTINE IF AbortTransaction# !AbortTransaction# is ON SELECT(?Cancel) !Place cursor on Cancel CYCLE !and restart Accept Loop END !End AbortTransaction# #ENDIF #IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine)) END #<!IF AutoIncAdd #ENDIF #IF(%SharedFiles = %NULL) #IF(%RelatedUpdateRoutine = %NULL) #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') LastPosition = POSITION(%Primary) #<!Save last record position #ENDIF PUT(%Primary) #<!Write the Record #ENDIF #ENDIF OF DeleteRecord !Action = 3 (Delete) #IF(%RestrictDelete) #<!IF RESTRICT Constraint DO CheckRestrictedDelete !Check RESTRICT delete IF RestrictDelete# !If RestrictDelete# is ON SELECT(?Cancel) !Place cursor on cancel CYCLE !Restart Loop END !End IF RestrictDelete# #SET(%ChkRestrictDelete,'TRUE') #<!RESTRICT delete code #ENDIF #IF(%CascadeDelete OR %ClearOnDelete) #SET(%RelatedDeleteRoutine,'TRUE') DO RelationalDelete !Relational delete ROUTINE IF AbortTransaction# !AbortTransaction is on CYCLE !Let user try again END !End AbortTransaction #ELSIF(%SharedFiles) #SET(%ConcurrentDeleteOn,'TRUE') DO ConcurrentDelete !Concurrent update ROUTINE IF AbortDelete# !AbortWrite is on CYCLE !Restart main Loop ELSE !Its OK to Delete DELETE(%Primary) !Delete this record END !End AbortWrite# #ELSE DELETE(%Primary) !Delete this record #ENDIF END !End CASE Action IF ERRORCODE() !Error check on File I/O #IF(%DupKeyCheck) #INSERT(%DupKeyCode) #ENDIF CASE Action !Error message based on Action OF AddRecord GLO:Message1 = 'Error attempting to ADD Record' OF ChangeRecord GLO:Message1 = 'Error attempting to CHANGE Record' OF DeleteRecord GLO:Message1 = 'Error attempting to DELETE Record' END !End CASE Action GLO:Message2 = 'The file: %Primary could not be updated' GLO:Message3 = 'Code:'&Errorcode()&': '&Error() ShowWarning !Notify the user #IF(%SharedFiles) RELEASE(%Primary) #<!Release the held record FREE(RecordQueue) !FREE the memory Queue #ENDIF DISABLE(1,FIELDS()) !Disable all the fields ENABLE(?Cancel) !Enable Cancel button SELECT(?Cancel) !and place cursor on Cancel DISPLAY !Re-display the screen CYCLE !Re-start main LOOP ELSE !Else no errorcode() #IF(%SharedFiles) FREE(RecordQueue) !Free memory from Queue #ENDIF #IF(%NextProcedure) #EMBED('Setup Next Procedure') %NextProcedure #<!Call the Next Procedure #EMBED('Return from Next Procedure') #ENDIF #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') IF Action = AddRecord #<!If Action is AddRecord LastPosition = POSITION(%Primary) #<!Save position of last ADD END #<!End IF Action = AddRecord #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'CLEAR RECORD') IF (Action = AddRecord) OR (Action = ChangeRecord AND AutoIncAdd) ERASE #<!Erase screen fields #INSERT(%InsertMessage) #<!Message for ADD RECORD DISPLAY !Update screen display #FIX(%File,%Primary) CLEAR(%FilePre:Record) #<!Clear the record buffer #IF(%AutoInc) DO AutoNumber !Increment autonumber key #IF(%InitRoutine) DO InitializeFields !Initial value from DataDictionary #ENDIF DISPLAY !Display screen field #ENDIF SELECT(1) !Place cursor on 1st field CYCLE !Re-start main LOOP END !End IF (Action = ....) #ELSIF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') IF (Action = AddRecord) OR (Action = ChangeRecord AND AutoIncAdd) #IF(%CopyKey <> %NULL) DO SaveScrFlds #<!Save the Screen fields ERASE #INSERT(%InsertMessage) #<!Message for ADD RECORD DISPLAY !Update screen display #FIX(%File,%Primary) CLEAR(%FilePre:Record) #<!Clear the record buffer #ELSE #IF(%AutoInc) SAV:SaveRecord = %FilePre:Record #<!Save the record buffer #ENDIF #ENDIF #IF(%AutoInc) DO AutoNumber !Increment autonumber key %FilePre:Record = SAV:SaveRecord #<!Restore saved record #INSERT(%RestoreAuto) #<!Restore AutoNumber(s) DISPLAY !Display screen fields #ENDIF SELECT(1) !Place cursor on 1st field CYCLE !Re-start main LOOP END !End IF (Action = ....) #ENDIF #!End %AddAction code BREAK !Break from main Loop END !End IF Errorcode() END !End CASE Selected() ACCEPT !Enable screen entry #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%DupFldCall) #ENDIF #ENDIF CASE KEYCODE() OF EscKey !User pressed Escape key IF FIELD() <> ?Cancel !If user pressed Escape SELECT(?Cancel) !Select Cancel button PRESS(EnterKey) !Process Cancel button code CYCLE !Cycle to Accept END !Field was not Cancel button #IF(%HotKeysExist) #FOR(%HotKey) OF %HotKey !User defined HotKey %HotKeyProc !HotKey Procedure #ENDFOR #ENDIF END !End CASE Keycode CASE FIELD() !Process fields #INSERT(%FormEditRoutines) OF ?Ok !On the OK button #EMBED('OK Button Press') #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Ok') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field Edit procedure #ENDIF #ENDIF #ENDFOR SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop OF ?Cancel !On Cancel button #IF(%AutoInc = 'TRUE') IF AutoIncAdd !ADDed autoincrement record? RESET(%Primary,AutoAddPtr) #<!Re-position record pointer NEXT(%Primary) #<!Re-read the record we added IF DiskError('Could not READ Record') !Check for file I/O error #IF(%SharedFiles = 'TRUE') FREE(RecordQueue) !Free the memory Queue #ENDIF #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF #INSERT(%CloseOpenedFiles) #SET(%SetFile,%Primary) #INSERT(%CloseRelatedFiles) RETURN !Return to caller END !End IF Diskerror DELETE(%Primary) #<!DELETE the record IF DiskError('Record could not be Deleted') #IF(%SharedFiles = 'TRUE') FREE(RecordQueue) !Free the memory Queue #ENDIF #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF #INSERT(%CloseOpenedFiles) #SET(%SetFile,%Primary) #INSERT(%CloseRelatedFiles) RETURN !Return to caller END !End IF Diskerror END !End IF AutoIncAdd #ENDIF #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Cancel') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field edit procedure #ENDIF #ENDIF #ENDFOR #IF(%SharedFiles = 'TRUE') FREE(RecordQueue) !Free the memory Queue #ENDIF #IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER') IF LastPosition #<!IF a record was added RESET(%Primary,LastPosition) #<!Position to the record NEXT(%Primary) #<!and read it ELSE #<!Else no LastPosition GET(%Primary,0) #<!signal Browse to re-read END #<!END If LastPosition #ELSE GET(%Primary,0) #<!signal Browse to re-read #ENDIF BREAK !Break from main LOOP END !End CASE FIELD END !END MAIN PROCESS LOOP #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF #FOR(%Formula) #IF(UPPER(%FormulaClass) = 'RETURN') #INSERT(%GenerateFormula) #<!Return Class formula #ENDIF #ENDFOR #IF(%CloseFiles) #INSERT(%CloseOpenedFiles) #<!Close files Opened here #SET(%SetFile,%Primary) #INSERT(%CloseRelatedFiles) #<!Close related Opened here #ENDIF #EMBED('End of Procedure ') #INSERT(%AutoIncCode) #INSERT(%ConcurrentWrite) #IF(%RelUpdateRoutine OR %RelDeleteRoutine) #INSERT(%RelUpdSave) #ENDIF #INSERT(%RelUpdate) #IF(%ChkRestrictUpdate) #INSERT(%RestrictUpdateCheck) #ENDIF #INSERT(%RelDelete) #INSERT(%ConcurrentDelete) #INSERT(%ClearOnDeleteCode) #IF(%CascadeUpdate = 'TRUE') #INSERT(%CheckTransaction) #ELSIF(%ClearOnUpdate = 'TRUE') #INSERT(%CheckTransaction) #ELSIF(%ClearOnDelete = 'TRUE') #INSERT(%CheckTransaction) #ELSIF(%CascadeDelete = 'TRUE') #INSERT(%CheckTransaction) #ENDIF #IF(%CascadeDeleteOn) #INSERT(%CascadeDeleteCode) #ENDIF #IF(%ChkRestrictDelete) #INSERT(%RestrictDeleteCode) #ENDIF #INSERT(%InitQue) #INSERT(%InitFields) #INSERT(%GenFormulas) #IF(%SecondaryExist) #INSERT(%SecondaryLookups) #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%SaveScrFlds) #INSERT(%DupField) #ENDIF #ENDIF #!*************************************************************************** #!-------------------------------------------------------------------------------#! #! #! Multi-Page Form Update a browse or lookup with multiple pages #! #!------------------------------------------------------------------------------ #! #PROCEDURE(MultiPage,'Multiple Page update form '),SCREEN,PULLDOWN #!------------------------------------------------------------------------------ #! CLARION4.TPX #! #! Multi-Page Template: Update a file with a multiple page entry form #! #!------------------------------------------------------------------------------ #PROTOTYPE('') #PROMPT('Insert message',@S20),%InsertMsg #PROMPT('Chan&ge message',@S20),%ChangeMsg #PROMPT('De&lete message',@S20),%DeleteMsg #PROMPT('2nd Page Procedure ',PROCEDURE),%Page2Proc #PROMPT('3rd Page Procedure ',PROCEDURE),%Page3Proc #PROMPT('4th Page Procedure ',PROCEDURE),%Page4Proc #PROMPT('5th Page Procedure ',PROCEDURE),%Page5Proc #PROMPT('6th Page Procedure ',PROCEDURE),%Page6Proc #PROMPT('7th Page Procedure ',PROCEDURE),%Page7Proc #PROMPT('8th Page Procedure ',PROCEDURE),%Page8Proc #PROMPT('9th Page Procedure ',PROCEDURE),%Page9Proc #PROMPT('Next Procedure ',PROCEDURE),%NextProcedure #INSERT(%StandardHeader) #INSERT(%InitFormSymbols) #INSERT(%ProcCounter) %Procedure PROCEDURE %LocalData #INSERT(%CloseFilesFlags) #!Primary or Secondary Opened #INSERT(%CloseRelatedFlags) #!Related file Opened flag SaveAction BYTE CheckRequired BYTE(4) NoMoreFields BYTE(0) !No more fields flag SCREEN %ScreenAttributes,ALRT(Alt2,Alt%ProcCount) %ScreenPaintDeclarations %ScreenStringDeclarations %ScreenFieldDeclarations . %PullDownStructure #IF(%SharedFiles) RecordQueue QUEUE,PRE(SAV) SaveRecord LIKE(%FilePre:Record),PRE(SAV) #FOR(%Field) #IF(%FieldType = 'MEMO') SAV:%FieldID STRING(SIZE(%Field)) #ENDIF #ENDFOR . #<!End Queue structure #ENDIF #IF(%RelatedFiles) #SET(%SetFile,%Primary) #INSERT(%RelationalAccessFlds) #<!Declare link fields #IF(%PrimaryDriver = 'Paradox') #FIX(%File,%Primary) UpdRelation STRING(SIZE(%FilePre:Record)) #<!Position of last related record #ELSE UpdRelation STRING(10) #<!Position of last related record #ENDIF #ENDIF #IF(%PrimaryDriver = 'Paradox') #FIX(%File,%Primary) SavePointer STRING(SIZE(%FilePre:Record)) !Position of current record AutoAddPtr STRING(SIZE(%FilePre:Record)) !Position of autoinc record #ELSE SavePointer STRING(10) !Position of current record AutoAddPtr STRING(10) !Position of autoinc record #ENDIF AutoIncAdd BYTE(0) !On for Autoincrement add ProcCalls BYTE,DIM(%ProcCount) #EMBED('Data Section') CODE #EMBED('Setup Procedure') #INSERT(%OpenPrimary) #<!Ensure Primary file is OPEN #INSERT(%OpenSecondaryFiles) LOC:Pages = %ProcCount #<!PageOf procedure count LOC:Page = 1 !Initialize page CASE KEYCODE() !What Key was pressed? OF InsKey !Insert a new record Action = AddRecord !Set action code 1 (ADD) #INSERT(%InsertMessage) #<!Message for ADD RECORD #INSERT(%ClearValues) #<!Clear RECORD and MEMO(s) #IF(%AutoInc) DO AutoNumber !Set autonumber key field(s) #ENDIF #IF(%InitRoutine) #<!Field(s) initial value DO InitializeFields !Initial values from dictionary #ENDIF OF EnterKey !Process a CHANGE request OROF MouseLeft2 !on EnterKey or double mouse Action = ChangeRecord !Set action code 2 (CHANGE) #INSERT(%ChangeMessage) #<!Message for CHANGE RECORD #IF(%SharedFiles) #INSERT(%SetupConcurrency) #<!Setup multi-user Concurrency #ENDIF #IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate) DO RelationAccessSave !Save LINKS for relational update #SET(%RelUpdateRoutine,'TRUE') #ENDIF #IF(%SecondaryExist) #<!IF File schema Secondary DO SecondaryLookups !Read any lookup fields #ENDIF OF DelKey !Process a DELETE request Action = DeleteRecord !Set action code 3 (DELETE) #INSERT(%DeleteMessage) #<!Message for DELETE RECORD SavePointer = POSITION(%Primary) #<!Position in PRIMARY file #IF(%CascadeDelete OR %ClearOnDelete OR %RestrictDelete) DO RelationAccessSave !Save LINKS for relational update #SET(%RelDeleteRoutine,'TRUE') #ENDIF #IF(%SecondaryExist) #<!IF File schema Secondary DO SecondaryLookups !Read any lookup fields #ENDIF END !End CASE Keycode #IF(%PullDownStructure) OPEN(%PullDown) #ENDIF OPEN(Screen) !Open the FORM screen IF Action = DeleteRecord !IF request for DELETE DISABLE(1,FIELDS()) !Disable all screen fields ENABLE(?OK) !Enable the OK and the ENABLE(?Cancel) !Cancel buttons ENABLE(?Next_Page) END !End IF request for delete #FOR(%Formula) #IF(UPPER(%FormulaClass) = 'SETUP') #INSERT(%GenerateFormula) #ENDIF #ENDFOR #EMBED('Setup Screen') DISPLAY !Display screen fields LOOP !Begin Main process loop #IF(%LoopFormulasExist = 'TRUE') #<!Are there Formula fields? #SET(%GenerateFormulasOn,'TRUE') DO FormulaFields !Calculate Formula fields #ENDIF #IF(%SecondaryExist) #<!IF File schema Secondary #INSERT(%SecondaryChanged) #ENDIF CASE SELECTED() !Process selected Field #INSERT(%ScreenSetupRoutines) OF NoMoreFields !User pressed Enter or OK CASE Action !Process requested Action OF AddRecord !Action = 1 (ADD) ADD(%Primary) #<!Add Record to Primary file OF ChangeRecord !Action = 2 (Change) #IF(%RestrictUpdate) #SET(%ChkRestrictUpdate,'TRUE') #!Check for relational RESTRICT #ENDIF #IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate) #SET(%RelatedUpdateRoutine,'TRUE') #ENDIF #IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine)) IF AutoIncAdd #<!Was this an Autonumber? PUT(%Primary) #<!Write the Record ELSE #<!not AutoincAdd #ENDIF #IF(%SharedFiles) #SET(%ConcurrentWriteOn,'TRUE') DO ConcurrentWrite !Concurrent update ROUTINE IF AbortWrite# !AbortWrite is on CYCLE !Let user choose response END !End AbortWrite# #IF(%RelatedUpdateRoutine = %NULL) PUT(%Primary) #<!Write the Record #ENDIF #ENDIF #IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate) DO RelationalUpdate !Relational update ROUTINE IF AbortTransaction# !AbortTransaction# is ON SELECT(?Cancel) !Place cursor on Cancel CYCLE !and restart Accept Loop END !End AbortTransaction# #ENDIF #IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine)) END #<!IF AutoIncAdd #ENDIF #IF((%SharedFiles = %NULL) OR (%RelatedUpdateRoutine = %NULL)) PUT(%Primary) #<!Write the Record #ENDIF OF DeleteRecord !Action = 3 (Delete) #IF(%RestrictDelete) #<!IF RESTRICT Constraint DO CheckRestrictedDelete !Check RESTRICT delete IF RestrictDelete# !If RestrictDelete# is ON SELECT(?Cancel) !Place cursor on cancel CYCLE !Restart Loop END !End IF RestrictDelete# #SET(%ChkRestrictDelete,'TRUE') #<!RESTRICT delete code #ENDIF #IF(%CascadeDelete OR %ClearOnDelete) #SET(%RelatedDeleteRoutine,'TRUE') DO RelationalDelete !Relational delete ROUTINE IF AbortTransaction# !AbortTransaction is on CYCLE !Let user try again END !End AbortTransaction #ELSIF(%SharedFiles) #SET(%ConcurrentDeleteOn,'TRUE') DO ConcurrentDelete !Concurrent update ROUTINE IF AbortDelete# !AbortWrite is on CYCLE !Restart main Loop ELSE !Its OK to Delete DELETE(%Primary) !Delete this record END !End AbortWrite# #ELSE DELETE(%Primary) !Delete this record #ENDIF END !End CASE Action IF ERRORCODE() !Error check on File I/O #IF(%DupKeyCheck) #INSERT(%DupKeyCode) #ENDIF CASE Action !Error message based on Action OF AddRecord GLO:Message1 = 'Error attempting to ADD Record' OF ChangeRecord GLO:Message1 = 'Error attempting to CHANGE Record' OF DeleteRecord GLO:Message1 = 'Error attempting to DELETE Record' END !End CASE Action GLO:Message2 = 'The file: %Primary could not be updated' GLO:Message3 = 'Code:'&Errorcode()&': '&Error() ShowWarning !Notify the user #IF(%SharedFiles) RELEASE(%Primary) #<!Release the held record FREE(RecordQueue) !FREE the memory Queue #ENDIF DISABLE(1,FIELDS()) !Disable all the fields ENABLE(?Cancel) !Enable Cancel button SELECT(?Cancel) !and place cursor on Cancel DISPLAY !Re-display the screen CYCLE !Re-start main LOOP ELSE !Else no errorcode() #IF(%SharedFiles) FREE(RecordQueue) !Free memory from Queue #ENDIF #IF(%NextProcedure) #EMBED('Setup Next Procedure') %NextProcedure #<!Call the Next Procedure #EMBED('Return from Next Procedure') #ENDIF BREAK !Break from main Loop END !End IF Errorcode() END !End CASE Selected() ACCEPT !Enable screen entry CASE KEYCODE() OF EscKey !User pressed Escape key IF FIELD() <> ?Cancel !If user pressed Escape SELECT(?Cancel) !Select Cancel button PRESS(EnterKey) !Process Cancel button CYCLE !Cycle to Accept END #FOR(%HotKey) OF %HotKey !User defined HotKey %HotKeyProc #<!HotKey Procedure #ENDFOR #INSERT(%AltKeys) END !End CASE Keycode CASE FIELD() !Process fields #INSERT(%FormEditRoutines) OF ?Ok !On the OK button #EMBED('OK Button Press') #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Ok') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field Edit procedure #ENDIF #ENDIF #ENDFOR #IF(%Page2Proc) IF Action <> DeleteRecord SaveAction = Action Action = CheckRequired LOC:Message = 'Verify Required Field(s)' LOOP LOC:Page = 1 to %ProcCount IF ProcCalls[LOC:Page] !If the Page has been called CYCLE !then check the next page ELSE !Call the Page for CheckRequired #IF(%Page2Proc) EXECUTE (LOC:Page) %Page2Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #IF(%Page3Proc) %Page3Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #ENDIF #IF(%Page4Proc) %Page4Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #ENDIF #IF(%Page5Proc) %Page5Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #ENDIF #IF(%Page6Proc) %Page6Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #ENDIF #IF(%Page7Proc) %Page7Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #ENDIF #IF(%Page8Proc) %Page8Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #ENDIF #IF(%Page9Proc) %Page9Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure #ENDIF END !End Execute LOC:Page END !END IF Page was called #ENDIF #ENDIF #<!Are there any Pages? END !END LOOP for required fields Action = SaveAction !Save the user Action END !End if Action <> delete SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop OF ?Next_Page !On the Next Page button #EMBED('Next Page Button Press') #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Next_Page') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field Edit procedure #ENDIF #ENDIF #ENDFOR #IF(%Page2Proc) LOC:Page += 1 LOOP IF (LOC:Page - 1) = 0 THEN BREAK. EXECUTE (LOC:Page - 1) BEGIN ProcCalls[LOC:Page - 1] = 1 %Page2Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #IF(%Page3Proc) BEGIN ProcCalls[LOC:Page] = 1 %Page3Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #ENDIF #IF(%Page4Proc) BEGIN ProcCalls[LOC:Page] = 1 %Page4Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #ENDIF #IF(%Page5Proc) BEGIN ProcCalls[LOC:Page] = 1 %Page5Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #ENDIF #IF(%Page6Proc) BEGIN ProcCalls[LOC:Page] = 1 %Page6Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #ENDIF #IF(%Page7Proc) BEGIN ProcCalls[LOC:Page] = 1 %Page7Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #ENDIF #IF(%Page8Proc) BEGIN ProcCalls[LOC:Page] = 1 %Page8Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #ENDIF #IF(%Page9Proc) BEGIN ProcCalls[LOC:Page] = 1 %Page9Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure . #ENDIF . !End Execute LOC:Page END !End LOOP #ENDIF OF ?Cancel !On Cancel button #IF(%AutoInc = 'TRUE') IF AutoIncAdd !ADDed autoincrement record? RESET(%Primary,AutoAddPtr) #<!Re-position record pointer NEXT(%Primary) #<!Re-read the record we added IF DiskError('Could not READ Record') !Check for file I/O error #IF(%SharedFiles = 'TRUE') FREE(RecordQueue) !Free the memory Queue #ENDIF #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF #INSERT(%CloseOpenedFiles) #<!Close files Opened here #SET(%SetFile,%Primary) #INSERT(%CloseRelatedFiles) #<!Close files Opened here RETURN !And return to caller END !End IF Diskerror DELETE(%Primary) #<!DELETE the record IF DiskError('Record could not be Deleted') #IF(%SharedFiles = 'TRUE') FREE(RecordQueue) !Free the memory Queue #ENDIF #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF #INSERT(%CloseOpenedFiles) #<!Close files Opened here #SET(%SetFile,%Primary) #INSERT(%CloseRelatedFiles) #<!Close files Opened here RETURN !And return to caller END !End IF Diskerror END !End IF AutoIncAdd #ENDIF #IF(%SharedFiles = 'TRUE') FREE(RecordQueue) !Free the memory Queue #ENDIF #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Cancel') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field edit procedure #ENDIF #ENDIF #ENDFOR #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF BREAK !Break from main LOOP END !End CASE FIELD END !END MAIN PROCESS LOOP #EMBED('End of Procedure') #IF(%CloseFiles) #INSERT(%CloseOpenedFiles) #<!Close files Opened here #SET(%SetFile,%Primary) #INSERT(%CloseRelatedFiles) #<!Close files Opened here #ENDIF #INSERT(%AutoIncCode) #INSERT(%ConcurrentWrite) #IF(%RelUpdateRoutine OR %RelDeleteRoutine) #INSERT(%RelUpdSave) #ENDIF #INSERT(%RelUpdate) #IF(%ChkRestrictUpdate) #INSERT(%RestrictUpdateCheck) #ENDIF #INSERT(%RelDelete) #INSERT(%ConcurrentDelete) #INSERT(%ClearOnDeleteCode) #IF(%CascadeUpdate = 'TRUE') #INSERT(%CheckTransaction) #ELSIF(%ClearOnUpdate = 'TRUE') #INSERT(%CheckTransaction) #ELSIF(%ClearOnDelete = 'TRUE') #INSERT(%CheckTransaction) #ELSIF(%CascadeDelete = 'TRUE') #INSERT(%CheckTransaction) #ENDIF #IF(%CascadeDeleteOn) #INSERT(%CascadeDeleteCode) #ENDIF #IF(%ChkRestrictDelete) #INSERT(%RestrictDeleteCode) #ENDIF #INSERT(%InitQue) #INSERT(%InitFields) #INSERT(%GenFormulas) #IF(%SecondaryExist) #INSERT(%SecondaryLookups) #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%SaveScrFlds) #INSERT(%DupField) #ENDIF #ENDIF #!*************************************************************************** #!-------------------------------------------------------------------------------#! #! #! PageOf the Multi-Page Form - A single page of a multiple page form #! #!------------------------------------------------------------------------------ #! #PROCEDURE(PageOf,'Page of Multi-Page forms '),SCREEN,PULLDOWN #PROTOTYPE('(BYTE,*BYTE,BYTE,STRING)') #!------------------------------------------------------------------------------ #! CLARION4.TPX #! #! PageOf Template: a data entry 'Page' used with the MultiPage Form #! #!------------------------------------------------------------------------------ #INSERT(%StandardHeader) #INSERT(%InitFormSymbols) #INSERT(%ButtonCheck) %Procedure PROCEDURE(Action,Page,Pages,Message) %LocalData #IF(%CloseFiles) #INSERT(%CloseFilesFlags) #ENDIF NoMoreFields BYTE(0) !No more fields flag CheckRequired BYTE(4) NonStop BYTE SCREEN %ScreenAttributes %ScreenPaintDeclarations %ScreenStringDeclarations %ScreenFieldDeclarations . %PullDownStructure #EMBED('Data Section') CODE #EMBED('Setup Procedure') #INSERT(%OpenPrimary) #<!Ensure Primary file is OPEN #INSERT(%OpenSecondaryFiles) #INSERT(%FieldLookupOpen) PAG:Message = Message !Move to local variable PAG:Page = Page !Move to local variable PAG:Pages = Pages !Move to local variable CASE Action !What Action requested? #IF(%SecondaryExist) #<!IF File schema Secondary OF ChangeRecord !Process a CHANGE request DO SecondaryLookups !Read any lookup fields #ENDIF #IF(%SecondaryExist) #<!IF File schema Secondary OF DeleteRecord !Process a DELETE request DO SecondaryLookups !Read any lookup fields #ENDIF OF CheckRequired !Check REQ fields NonStop = 1 END !End CASE Action OPEN(Screen) !Open the FORM screen IF Action = DeleteRecord !IF request for DELETE DISABLE(1,FIELDS()) !Disable all screen fields ENABLE(?Next_Page) !Enable just the ENABLE(?Previous_Page) !useful buttons ENABLE(?Base_Page) !useful buttons ENABLE(?Last_Page) !useful buttons END !End IF request for delete #EMBED('Setup Screen') DISPLAY !Display screen fields LOOP !Begin Main process loop #IF(%LoopFormulasExist = 'TRUE') #<!Are there Formula fields? #SET(%GenerateFormulasOn,'TRUE') DO FormulaFields !Calculate Formula fields #ENDIF #IF(%SecondaryExist) #<!IF File schema Secondary #INSERT(%SecondaryChanged) #ENDIF IF NonStop !Just check for required fields SELECT(1) !Start at first field SELECT !and enter Nonstop mode NonStop = 0 !Switch indicator off END #<!End If CASE SELECTED() !Process selected Field #INSERT(%ScreenSetupRoutines) OF NoMoreFields !All fields have been processed #IF(%DupKeyCheck) #INSERT(%DupKeyCode) #ENDIF #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF RETURN !Return to caller END !End CASE Selected() ACCEPT !Enable screen entry CASE KEYCODE() !Process Alerted keys OF EscKey !User pressed Escape key SELECT(?Previous_Page) !Select PreviousPage button PRESS(EnterKey) !Process PreviousPage button CYCLE !Cycle to Accept #FOR(%HotKey) OF %HotKey #<!User HotKey %HotKeyProc #<!Call HotKey procedure #ENDFOR OF CtrlPgUp Page = 1 !Decrement Page SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop OF CtrlPgDn Page = Pages !Decrement Page SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop OF EscKey Page -= 1 !Decrement Page #IF(%PullDownStructure) CLOSE(%PullDown) #ENDIF RETURN !Return to caller END ! End CASE CASE FIELD() !Process fields #INSERT(%FormEditRoutines) #IF(%BasePageExists) OF ?Base_Page !On the Base Page button #EMBED('Base_Page Button Press') #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Base_Page') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field Edit procedure #ENDIF #ENDIF #ENDFOR Page = 1 !Set to the MultiPage SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop #ENDIF OF ?Previous_Page !On Previous Page button #EMBED('Previous_Page Button Press') #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Previous_Page') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field edit procedure #ENDIF #ENDIF #ENDFOR Page -= 1 !Decrement Page number SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop OF ?Next_Page !On Next Page button #EMBED('Next_Page Button Press') #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Next_Page') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field edit procedure #ENDIF #ENDIF #ENDFOR Page += 1 !Increment Page number IF PAGE > PAGES THEN PAGE = 1. SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop #IF(%LastPageExists) OF ?Last_Page !On Last Page button #EMBED('Last_Page Button Press') #FOR(%ScreenField) #IF(%ScreenFieldUse = '?Last_Page') #IF(%ScreenFieldEdit <> %NULL) %ScreenFieldEdit #<!Field edit procedure #ENDIF #ENDIF #ENDFOR Page = Pages !Pages holds LAST page proc SELECT(1) !Start with the first field SELECT !and cycle non-stop CYCLE !restart main process loop #ENDIF END !End CASE FIELD END !END MAIN PROCESS LOOP #EMBED('End of Procedure') #INSERT(%GenFormulas) #IF(%SecondaryExist) #INSERT(%SecondaryLookups) #ENDIF #IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD') #IF(%CopyKey) #INSERT(%SaveScrFlds) #INSERT(%DupField) #ENDIF #ENDIF #INSERT(%InitFields) #!*************************************************************************** #CHAIN('CLARION5.TPX')