The Developer Connection - Device Driver Kit for OS/2 3

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

/ The Developer Connection…ice Driver Kit for OS/2 3 / DEV3-D1.ISO / devtools / dataflex / dfbrowse.src < prev next >

Wrap

Text File | 1993-05-19 | 53.5 KB | 1,536 lines

// DFBROWSE version 2.21 // Written by Doug Goldner 10/24/1990 // Using DataFlex 3.0 SDK release // // Update to version 2.0 10/30/90 // Update to version 2.1 2/13/91 - Using 3.0 final release // Update to version 2.2 12/6/91 - Added Zerofile function and help // // Invocation: DFRUN DFBROWSE // // Use: // // The program first starts off by allowing the user to select a file // to "browse". Once selected, the .TAG is read and the file definition // determined. The next screen appears which consists of a FIELD TITLE // object, a FIELD DATA object, a button area, and a status object. // // The first page of records appears and the status object reflects the // current file.field information. The navigation keys (UPARROW, DOWNARROW, // LEFTARROW, RIGHTARROW, TAB, SHIFT-TAB, PgUP, PgDN, etc.) will scroll // you around the records in your file. TAB and SHIFT-TAB (or the arrows // in the button area) move right or left 1 field at a time. The scroll // bar will scroll up or down one record at a time. // // The REORDER button or the REORDER key (Alt+R) can be used to reorder // the data based upon the main index of the current field. Indexed // fields are denoted by "<>" around their field names. // // The ESC key exits back to the opening file selection screen. // // The Shift+F2 key will delete the current record // // The browser is virtual meaning only room for 15 records at a time // is needed. // // Version 2.0 enhancements: // // Ability to edit by choosing the EDIT button or Alt+E on the main // browse screen. This will bring up a record zoom screen. Within // this screen, the normal find keys (next, previous, clear, save, etc.) // work as expected. The buttons below the screen can be used in place // of the keys. The ESC key exits back to the browse screen with the // current record displayed at the top of the list. // // Version 2.1 enhancements: // // Modified choose_file to work with new FILELIST.PKG // PgUp used to stop on second record at top of file rather // than first record. Fixed this. // Changed MAX_LINES to 1 instead of 0 to comply with new translation. // // Version 2.2 enhancements: // // Added the Erase a file option to the first screen. // Added help buttons and help keys // // Changed version 2.2 to 2.21 to indicate use of 3.01 packages. // // I welcome suggestions as well as modifications via CompuServe // in the DACCESS forum. Mail ID: 76702,1257 use UI set Application_Name to "SYSTEM" use FILELIST use ENTERR use HELP number initial_argument_size get_argument_size to initial_argument_size set_argument_size 3000 /background ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░_____________________░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░ ░░ ░░░ ░░░_____________________░░________________░░_______________░░_____________░░░░░░ ░░░░░░_________________░░░░ ____________ ░░░░______________░░_______________░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░_________░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ /back2 ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░_____________________░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░ ░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ ░░░░_____________________░░_______________________░░____________░░_________░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ /Choose_File ╔═══════════════════════════════════════════════════════╗ ║ Choose a File to BROWSE: ║ ║ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ________________________________________ ║ ║ ║ ║ ║ ║ ║ ╚═══════════════════════════════════════════════════════╝ /Enter_Rootname ╔═══════════════════════════════════════════════════════╗ ║ Enter the rootname of a file to browse: ║ ║ ║ ║ ________________________________________ ║ ║ ║ ║ ║ ║ ║ ╚═══════════════════════════════════════════════════════╝ /Working ┌──────────────────────────────────────────────────────┐ │ │ │ Reading File Information ... Please Wait ... │ │ │ └──────────────────────────────────────────────────────┘ /Err_Object ┌──────────────────────────────────────────────────────┐ │ │ │ ____________________________________________________ │ │ <__> │ └──────────────────────────────────────────────────────┘ /our_status ┌─┤ Current Field ├──────────────────────────────────────────────────┐ │Field #: __. Name: _________________ Length: ____. Main Index: _. │ └────────────────────────────────────────────────────────────────────┘ /Record_Buttons ░░░_________░_________________░░_________░░____________░________░__________░░░░░ ░░░░░░░░░░░░░░░░░░░░░_______________░░____________░░_________░░░░░░░░░░░░░░░░░░░ ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ /Record_Title ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ Record Edit ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ /Record_Divider ░ ░ ░ ░ ░ ░ ░ ░ ░ ░ ░ ░ ░ ░ ░ /* string Which_File File_Root next_tag integer data_type main_index lvar100 last_field real_field integer File_Number current_position current_field field_length lvar dlast_record integer which_index max_length integer top_recnum bottom_recnum total_records indicator bad indicate in_scroll false #REPLACE EDIT_LENGTH 15 /record_numbers _____. /* procedure exit_application for desktop set_argument_size initial_argument_size abort end_procedure // We use OPEN AS so we need to include the .FD since the fields in the // file are referenced before the OPEN command. #include flexerrs.fd sub_page edit_buttons from background 2 3 4 5 6 7 8 9 10 sub_page file_buttons from back2 2 3 4 5 register_object Field_Data register_object Record_Edit // See the bottom of the program for a description of these arrays object Record_Numbers is a LIST end_object object Field_locator is an EDIT set size to 1 3000 set INSERT_MODE to TRUE end_object object Field_Numbers is an ARRAY end_object object Field_Names is an ARRAY end_object object Field_Start is an ARRAY end_object object Field_End is an ARRAY end_object object Field_Main_Index is an ARRAY end_object object Real_Size is an ARRAY end_object // Background image. We need to activate it but then don't want it to be // clicked on so we change its focus mode after it has been activated and // back again once deactivated. object back2 is a message set LOCATION to 0 0 ABSOLUTE set object_color to 31 27 procedure activating set focus_mode to nonfocusable end_procedure procedure deactivating set focus_mode to focusable end_procedure end_object // Background image. We need to activate it but then don't want it to be // clicked on so we change its focus mode after it has been activated and // back again once deactivated. object background is a message set LOCATION to 0 0 ABSOLUTE procedure activating set focus_mode to pointer_only end_procedure procedure deactivating set focus_mode to focusable end_procedure end_object // Our status object which displays current file.field info. It also must // be "fooled" into being activated and then set nonfocusable. object our_status is a message set LOCATION to 21 5 ABSOLUTE set object_color to 62 48 procedure activating set focus_mode to nonfocusable end_procedure procedure deactivating set focus_mode to focusable end_procedure end_object // A global procedure which updates our entire status object procedure status_line local integer current_fld current_y current_x current_record move (hi(position(Field_Data(Desktop)))) to current_y if current_y lt 1 move 0 to current_record else move (value(Record_Numbers.obj,current_y )) to current_record move (ascii(mid(value(Field_Locator.obj,current),1,low(position(Field_Data(Desktop))) + 1))) to current_fld if ( current_fld eq last_field and Current_Record eq dlast_record) procedure_return move current_fld to last_field move current_Record to dlast_record set value of our_status item 0 to (Integer_Value(Field_Numbers.obj,current_fld)) set value of our_status item 1 to (string_value(field_names.obj,current_fld)) set value of our_status item 2 to (integer_value(Field_End.obj,current_fld) - integer(value(Field_Start.obj,current_fld) + 1)) set value of our_status item 3 to (integer_value(Field_Main_Index.obj,current_fld)) send paint to our_status end_procedure procedure status_line2 local integer current_fld current_y move (hi(position(Record_Edit(desktop))) + 1) to current_fld set value of our_status item 0 to (Integer_Value(Field_Numbers.obj,current_fld)) set value of our_status item 1 to (string_value(field_names.obj,current_fld)) set value of our_status item 2 to (integer_value(Field_End.obj,current_fld) - integer(value(Field_Start.obj,current_fld) + 1)) set value of our_status item 3 to (integer_value(Field_Main_Index.obj,current_fld)) send paint to our_status end_procedure // Some general status messages. object Working is a MESSAGE set object_color to 30 30 set LOCATION to 7 12 ABSOLUTE end_object sub_page err_button from err_object 2 object err_object is a CLIENT set RING_STATE to TRUE set CENTER_STATE of current_object item 0 to TRUE set object_color to 79 79 set LOCATION to 7 12 ABSOLUTE procedure show_error string val set value of current_object item 0 to val ui_accept current_object to windowindex end_procedure object err_button is a button err_button item_list on_item "OK" send stop_ui end_item_list end_object // Err_Button end_object // Err_object /Verify_Image ╔══════════════════════════════╗ ║ ____________________________ ║ ║ ┌──────────────────────────┐ ║ ║ │ <__> <______> │ ║ ║ └──────────────────────────┘ ║ ╚══════════════════════════════╝ /* Sub_Page Ok_Cancel_Prompt FROM Verify_Image 2 3 object Verify_It is a CLIENT Verify_Image set LOCATION to 7 25 ABSOLUTE set object_color to 79 79 set CENTER_STATE of current_object item 0 to TRUE // Define this object (and its children) as a separate, popped up // object with an entirely different scope. This will automatically // turn off the mouse when in this object (you cannot click on other // objects) and it will not send the Exit and Entry messages when this // object is activated. set SCOPE_STATE to TRUE set POPUP_STATE to TRUE object Ask_Ok is a button Ok_Cancel_Prompt item_list On_Item "OK" SEND Ok On_Item "CANCEL" SEND Cancel end_item_list End_Object // Ask_Ok function Validate_Ok string Description returns integer local integer Return_Val set VALUE of Verify_It item 0 to Description ui_accept Verify_It object to Return_Val function_return Return_Val end_function End_Object // Verify_It // This object is used to allow the user to choose a file to browse. object Enter_Rootname is a form set object_color to 121 30 set LOCATION to 6 12 ABSOLUTE on_key KCANCEL send stop_ui procedure activating move "" to which_file move "" to file_root end_procedure procedure chose_it get value of current_object item 0 to which_file move which_file to file_root send stop_ui end_procedure item_list on_item "" send chose_it end_item_list end_object object Choose_File is a FILE_LIST Choose_File FOR Which_File on_key KCANCEL send exit_application on_key KEXIT_FUNCTION send exit_application set LOCATION to 2 12 ABSOLUTE set object_color to 121 48 set SELECT_MODE to SINGLE_SELECT on_key KPROMPT send open_by_rootname on_key KEY_ALT+KEY_E send erase_data_file procedure open_by_rootname ui_accept enter_rootname to windowindex if which_file ne "" send stop_ui end_procedure procedure erase_Data_file if (validate_ok(verify_it.obj,"Erase ALL data in this file?")) ne msg_ok procedure_return get aux_value to File_Number Filelist File_Number to File_Root filelist PATHNAME to Which_File File_Root move Which_File to File_Root send Activate to Working // Try to open our file. We trap the "CAN'T OPEN DATA FILE ERROR" in our // on error routine in BAD_OPEN and have that routine set the BAD // indicator to TRUE. In this way, no error appears at the bottom but // our program knows about the error and can recover. indicate bad false on error gosub bad_open open file_root as Flexerrs on error off // If it was a bad open, put up the "Bad open" message and restart [bad] begin send deactivate to working send show_error to err_object "The chosen file cannot be opened." procedure_return end zerofile flexerrs close flexerrs send deactivate to working send show_error to err_object "All data has been erased." end_procedure procedure OK // We set the global variable File_Root to the name of the // file and the global Which_File to the file's filenumber upon // exiting. get aux_value to File_Number Filelist File_Number to File_Root filelist PATHNAME to Which_File File_Root move Which_File to File_Root send stop_ui end_procedure // The FILE_LIST class is set-up to move the currently selected // piece of data back to the previously focused object (for a // pop-up action). We don't want this so we dummy out the procedure // in FILE_LIST which does this. procedure move_value_out end_procedure end_object // The button object for our File_List object. object file_buttons is a button set focus_mode to POINTER_ONLY set object_color to 31 27 item_list on_item "<F4=Open by Rootname>" send open_by_rootname to choose_file on_item "<Alt+E=Erase data file>" send erase_data_file to choose_file on_item "<ESC=Cancel>" send exit_application on_item "<F1=Help>" send help end_item_list end_object // The edit object that holds the names of our fields (the .TAG data). object Tags is an Edit set location to 1 1 set SIZE to 1 74 set RIGHT_MARGIN to 3000 set object_color to 62 62 set READ_ONLY_STATE to TRUE procedure activating set FOCUS_MODE to NONFOCUSABLE end_procedure procedure deactivating set FOCUS_MODE to FOCUSABLE end_procedure end_object // The object which holds our Field Data object Field_Data is an Edit set COLUMN_MODE to 2 set object_color to 121 48 set location to 2 1 set SIZE to 15 74 set RIGHT_MARGIN to 3000 on_key KCANCEL send stop_ui // Redefine the keys to send our own messages so we can synchronize the // movement of the field data and the field names objects as well as // keep the data scrolling correctly. on_key KRIGHTARROW send do_rightarrow on_key KLEFTARROW send do_leftarrow on_key KDOWNARROW send do_down on_key KUPARROW send do_up on_key KNEXT_ITEM send do_right_Field on_key KPREVIOUS_ITEM send do_left_field on_key KSCROLL_FORWARD send do_down on_key KSCROLL_BACK send do_up on_key KWORD_LEFT send do_left_field on_key KWORD_RIGHT send do_right_field on_key KBEGIN_OF_DATA send beginning_of_data on_key KEND_OF_DATA send end_of_data on_key KSCROLL_RIGHT send end_of_line on_key KSCROLL_LEFT send beginning_of_line on_key KBEGIN_OF_LINE send beginning_of_line on_key KEND_OF_LINE send end_of_line on_key KEY_ALT+KEY_R send do_reorder on_key KEY_ALT+KEY_E send do_edit on_key KSCROLL_BACK send do_page_up on_key KSCROLL_FORWARD send do_page_down on_key KDELETE_RECORD send do_delete // Our scroll bar is going to keep both arrows on at all times. // Since our edit object never gets fuller than a page, the normal // scroll bar would never have scroll-up and scroll-down arrows lit. object New_Scroll_Bar is a ScrollB Procedure set arrows integer ua integer da local integer int forward set arrows 1 1 int procedure_return int End_procedure end_object set ScrollBar to (New_Scroll_Bar(Current_Object)) // Override the standard scroll message to scroll a line at a time // rather than a whole page. procedure scroll integer dir integer dist if dir eq 0 send do_up else send do_down end_procedure procedure do_delete local integer current_y current_record if (validate_ok(verify_it.obj,"Delete this record?")) ne msg_ok procedure_return move (hi(position(Field_Data(Desktop)))) to current_y if current_y lt 0 move 0 to current_record else move (value(Record_Numbers.obj,current_y )) to current_record clear flexerrs move current_record to flexerrs.recnum find eq flexerrs.recnum delete flexerrs clear flexerrs move top_recnum to flexerrs.recnum find ge flexerrs.recnum send fill_with_records to current_object 0 end_procedure procedure do_edit local integer dum1 current_record current_y send delete_Data to Record_Edit move (hi(position(Field_Data(Desktop)))) to current_y if current_y lt 0 move 0 to current_record else move (value(Record_Numbers.obj,current_y )) to current_record clear flexerrs move current_record to flexerrs.recnum find eq flexerrs.recnum for dum1 from 1 to current_field move (Integer_Value(Field_Numbers.obj,dum1)) to fieldindex set value of Record_Edit item (dum1 - 1) to flexerrs.recnum& loop send Beginning_of_Data to Record_Tags send Beginning_of_Data to Record_Edit send activate to Record_Title send activate to Record_Divider send activate to Record_Buttons send activate to Record_Tags send activate to Record_Edit send synchronize to Field_Edit end_procedure // Move the user to the field to his right. We can check the // value of current_field to see which field we are in and then // use the Field_End and Field_Start arrays to perform the moving. // We use the MOVE_ABSOLUTE message to shift our field data and // field tag edit objects. procedure do_right_field if last_field ge current_field procedure_return send move_absolute to current_object (hi(position(current_object))) (Integer_Value(Field_End.obj,last_field + 1) ) send move_absolute to tags 0 (Integer_Value(Field_End.obj,last_field + 1) ) send move_absolute to current_object (hi(position(current_object))) (Integer_Value(Field_Start.obj,last_field + 1) ) send move_absolute to tags 0 (Integer_Value(Field_Start.obj,last_field + 1) ) send status_line end_procedure // Move the user to the field to his left. We can check the // value of current_field to see which field we are in and then // use the Field_End and Field_Start arrays to perform the moving. // We use the MOVE_ABSOLUTE message to shift our field data and // field tag edit objects. procedure do_left_field if last_field lt 2 procedure_return send move_absolute to current_object (hi(position(current_object))) (Integer_Value(Field_Start.obj,last_field - 1) ) send move_absolute to tags 0 (Integer_Value(Field_Start.obj,last_field - 1) ) send status_line end_procedure // We mark the current line to show a line highlight so we need to // insure that the user cannot unmark the line so we override the // mouse_down message by sending a mouse_drag instead (which drags // the mark instead of removing it). procedure mouse_down integer win integer position send mouse_drag win position send status_line end_procedure procedure mouse_up integer win integer position forward send mouse_up win position send status_line end_procedure // The next couple of procedures are used to synchronize the two // objects: TAGS and FIELD_DATA since they both need to always be // positioned at the same place. procedure beginning_of_line forward send beginning_of_line send beginning_of_line to tags send status_line end_procedure procedure end_of_line forward send end_of_line send end_of_line to tags send status_line end_procedure procedure beginning_of_Data forward send beginning_of_data send beginning_of_data to tags send status_line end_procedure procedure end_of_data forward send end_of_Data send end_of_data to tags send status_line end_procedure procedure beginning_of_panel forward send beginning_of_panel send beginning_of_panel to tags send status_line end_procedure procedure end_of_panel forward send end_of_panel send end_of_panel to tags send status_line end_procedure // This procedure is called to fill the Field_Data object with the // first set of records. procedure fill_with_records integer clear_or_not local integer loop_var local integer loop_var2 local string total_line // Do our updating with Dynamic_Update_State FALSE so we don't // see stuff flying around until we set it back to TRUE. set dynamic_update_state to FALSE send delete_Data // We are using OPEN AS on Flexerrs to address our file. if clear_or_not eq 1 clear flexerrs send delete_Data to record_numbers for loop_var from 1 to EDIT_LENGTH if loop_var ne 1 vfind 50 which_index 4 else vfind 50 which_index 3 [not found] begin decrement loop_var goto skip$55 end if loop_var eq 1 move flexerrs.recnum to top_recnum send add_item to record_numbers MSG_NONE flexerrs.recnum set READ_ONLY_STATE to FALSE // Fill in the data from the file onto the edit object, placing // a vertical bar between each field. move "" to total_line for loop_var2 from 1 to current_field move (Integer_Value(Field_Numbers.obj,loop_var2)) to fieldindex append total_line (pad(flexerrs.recnum&,integer_value(field_end.obj,loop_var2) - integer_value(Field_Start.obj,loop_Var2) - 1)) "│" loop set value of current_object item (loop_var - 1) to total_line loop // I know it's a label, so shoot me! skip$55: move flexerrs.recnum to bottom_recnum // This will mark the current line (display it in the nice color // you see). send mark_off send mark_on send beginning_of_data set dynamic_update_state to TRUE send paint // Redisplay our status line send status_line // Keep a count of how many records are on the screen move loop_var to total_records set READ_ONLY_STATE to TRUE end_procedure procedure do_page_up local integer our_loop current_y current_record move (hi(position(Field_Data(Desktop)))) to current_y if current_y lt 0 move 0 to current_record else move (value(Record_Numbers.obj,current_y )) to current_record clear flexerrs move current_record to flexerrs.recnum find eq flexerrs.recnum for our_loop from 1 to EDIT_LENGTH vfind 50 which_index 0 [not found] begin send fill_with_records to current_object 0 procedure_return end loop send fill_with_records to current_object 0 end_procedure procedure do_page_down local integer our_loop current_y current_record move (hi(position(Field_Data(Desktop)))) to current_y if current_y lt 0 move 0 to current_record else move (value(Record_Numbers.obj,current_y )) to current_record clear flexerrs move current_record to flexerrs.recnum find eq flexerrs.recnum for our_loop from 1 to EDIT_LENGTH vfind 50 which_index 4 [not found] begin vfind 50 which_index 0 send fill_with_records to current_object 0 procedure_return end loop send fill_with_records to current_object 0 end_procedure // We reorder by checking the main index of the current field and // changing the WHICH_INDEX global variable which is used as the // index in our VFIND commands. procedure do_Reorder local integer which_position origin_of_us origin_of_him local integer lvar99 get origin to origin_of_us get origin of TAGS to origin_of_him move (low(position(current_object))) to which_position move (ascii(mid(value(Field_Locator.obj,current),1,which_position + 1))) to lvar99 // If we are on a non-indexed field, inform the user. if (((Integer_Value(Field_Main_Index.obj,lvar99)) lt 1) and (lvar99 ne 1)) begin send show_error to err_object "You cannot reorder on a non-indexed field." procedure_return end move (Integer_Value(Field_Main_Index.obj,lvar99)) to which_index set dynamic_update_state to FALSE set dynamic_update_State of TAGS to FALSE send fill_with_records to current_object 1 set origin to (hi(origin_of_us)) (low(origin_of_us)) set origin of TAGS to (hi(origin_of_him)) (low(origin_of_him)) send move_absolute 0 which_position send move_absolute to TAGS 0 which_position set dynamic_update_state to TRUE set dynamic_update_State of TAGS to TRUE send status_line end_procedure // Move right or left while synchronizing the TAGS object procedure do_rightarrow if (low(position(current_object))) ge max_length procedure_return forward send key KRIGHTARROW send key to Tags KRIGHTARROW send status_line end_procedure procedure do_leftarrow if (low(position(current_object))) lt 1 procedure_return forward send key KLEFTARROW send key to Tags KLEFTARROW send status_line end_procedure // Up and down work their magic by inserting or deleting lines // in the edit object from the file. procedure do_down local integer pos_y pos_x lvar2 loop_var2 local string temp_string local string total_line local integer origin_of_us origin_of_him move (hi(position(current_object))) to pos_y move (low(position(current_object))) to pos_x if ((pos_y ne (EDIT_LENGTH - 1)) and (pos_y lt total_Records - 1)) begin send mark_off forward send down send mark_on procedure_return end clear flexerrs move bottom_recnum to flexerrs.recnum find eq flexerrs.recnum // Variable find using our file number, the index in // which_index and mode 4 (GT) vfind 50 which_index 4 [not found] procedure_return get origin to origin_of_us get origin of TAGS to origin_of_him set READ_ONLY_STATE to FALSE send mark_off move flexerrs.recnum to bottom_Recnum clear flexerrs move top_recnum to flexerrs.recnum find eq flexerrs.recnum vfind 50 which_index 4 move flexerrs.recnum to top_recnum clear flexerrs move bottom_recnum to flexerrs.recnum find eq flexerrs.recnum send delete_item to record_numbers 0 send add_item to record_numbers MSG_NONE flexerrs.recnum set dynamic_update_state of current_object FALSE set dynamic_update_state of TAGS FALSE forward send Beginning_of_Data // Take out our old first record send delete_line forward send end_of_data // send key KENTER // Fill in our latest record in the edit object move "" to total_line for loop_var2 from 1 to current_field move (Integer_Value(Field_Numbers.obj,loop_var2)) to fieldindex append total_line (pad(flexerrs.recnum&,integer_value(field_end.obj,loop_var2) - integer_value(Field_Start.obj,loop_Var2) - 1)) "│" // send insert (pad(flexerrs.recnum&,integer_value(field_end.obj,loop_var2) - integer_value(Field_Start.obj,loop_Var2) - 1)) // send insert "│" loop set value of current_object item (line_count(current_object)) to total_line // Shift the display so we are exactly where we were before // we moved. set origin to (hi(origin_of_us)) (low(origin_of_us)) set origin of TAGS to (hi(origin_of_him)) (low(origin_of_him)) send MOVE_ABSOLUTE to current_object (EDIT_LENGTH - 1) pos_x send MOVE_ABSOLUTE to TAGS 0 pos_x send mark_on set dynamic_update_state of current_object TRUE set dynamic_update_state of TAGS TRUE send PAINT set READ_ONLY_STATE to TRUE end_procedure // See the DOWN procedure above. This is almost line for line // identical. procedure do_up local integer pos_y pos_x lvar2 loop_var2 local string temp_string local string total_line local integer origin_of_us origin_of_him move (hi(position(current_object))) to pos_y move (low(position(current_object))) to pos_x if pos_y ne 0 begin send mark_off forward send up send mark_on procedure_return end clear flexerrs move top_recnum to flexerrs.recnum find eq flexerrs.recnum vfind 50 which_index 0 [not found] procedure_return get origin to origin_of_us get origin of TAGS to origin_of_him set READ_ONLY_STATE to FALSE send mark_off set INSERT_MODE TRUE move flexerrs.recnum to top_Recnum clear flexerrs move bottom_recnum to flexerrs.recnum find eq flexerrs.recnum if (line_count(current_object)) ge EDIT_LENGTH begin vfind 50 which_index 0 move flexerrs.recnum to bottom_recnum end clear flexerrs move top_recnum to flexerrs.recnum find eq flexerrs.recnum set dynamic_update_state of TAGS FALSE set dynamic_update_state of current_object FALSE if (line_count(current_object)) ge EDIT_LENGTH begin forward send end_of_Data send delete_line send delete_item to record_numbers (EDIT_LENGTH - 1) end else increment total_records forward send beginning_of_data move "" to total_line for loop_var2 from 1 to current_field move (Integer_Value(Field_Numbers.obj,loop_var2)) to fieldindex append total_line (pad(flexerrs.recnum&,integer_value(field_end.obj,loop_var2) - integer_value(Field_Start.obj,loop_Var2) - 1)) "│" loop send key KENTER set value of current_object item 0 to total_line send insert_item to record_numbers MSG_NONE flexerrs.recnum 0 set origin to (hi(origin_of_us)) (low(origin_of_us)) set origin of TAGS to (hi(origin_of_him)) (low(origin_of_him)) send MOVE_ABSOLUTE to current_object 0 pos_x send MOVE_ABSOLUTE to TAGS 0 pos_x send mark_on set dynamic_update_state of current_object TRUE set dynamic_update_state of TAGS TRUE send PAINT set INSERT_MODE FALSE set READ_ONLY_STATE to TRUE end_procedure end_object // Our button object that appears at the bottom of the data edit screen. // Allow the user to move field right and field left with the TAB and // Shift-Tab keys or by using the arrow buttons below. object edit_buttons is a button set focus_mode to pointer_only set object_color to 31 27 item_list on_item "<Shift+TAB=Left Fld>" send do_left_field to Field_Data on_item "<PgDn=Page Down>" send do_page_down to Field_Data on_item "<Alt+R=Reorder>" send do_reorder to Field_Data on_item "<Alt+E=Edit>" send do_edit to Field_Data on_item "<Shift+F2=Delete>" send do_delete to Field_Data on_item "<Esc=Cancel>" send stop_ui on_item "<PgUp=Page Up>" send do_page_up to Field_Data on_item "<TAB=Right Fld>" send do_right_field to Field_Data on_item "<F1=Help>" send Help end_item_list end_object object Record_Title is a MESSAGE set object_color to 31 27 procedure activating set focus_mode to nonfocusable end_procedure procedure deactivating set focus_mode to focusable end_procedure set location to 1 1 end_object object Record_Divider is a MESSAGE set location to 2 20 set object_color to 31 27 procedure activating set focus_mode to nonfocusable end_procedure procedure deactivating set focus_mode to focusable end_procedure end_object // Our Record_Tags object holds the tag names for our record editing // section. Record_Tags and Record_Edit are side by side edit objects. object Record_Tags is an EDIT set object_color to 62 62 set COLUMN_MODE to 2 set location to 2 1 set SIZE to 15 19 set RIGHT_MARGIN to 18 set scroll_bar_visible_state to FALSE procedure activating set focus_mode to nonfocusable end_procedure procedure deactivating set focus_mode to focusable end_procedure end_object // Record_Edit is the edit object used to display the current field // data from the current record. object Record_Edit is an EDIT set location to 2 21 set object_color to 47 100 set SIZE to 15 54 set RIGHT_MARGIN to 3000 procedure scroll integer dir integer dist if dir eq 0 send do_up to Field_Edit else send do_down to Field_Edit end_procedure procedure mouse_down integer y integer x if y lt 0 procedure_return // In scroll bar send unload to Field_Edit send move_absolute (y - 1) 0 send move_absolute to Record_Tags (y - 1) 0 send synchronize to Field_Edit end_procedure end_object object Record_Buttons is a BUTTON set location to 18 0 set object_color to 31 27 on_Key KCANCEL send do_cancel procedure activating set focus_mode to pointer_only end_procedure procedure deactivating set focus_mode to focusable end_procedure item_list on_item "<F2=Save>" send do_save_and_clear on_item "<Shift+F2=Delete>" send do_delete on_item "<F8=Next>" send do_find_next on_item "<F7=Previous>" send do_find_previous on_item "<F9=Find>" send do_find_eq on_item "<F5=Clear>" send do_clear on_item "<Alt+F2=Update>" send do_update on_item "<ESC=Cancel>" send do_cancel on_item "<F1=Help>" send Help end_item_list procedure do_find_next send do_find 1 end_procedure procedure do_find_previous send do_find 2 end_procedure procedure do_find_eq send do_find 3 end_procedure procedure do_update send do_save to current_object 0 end_procedure procedure do_save_and_clear send do_save to current_object 1 end_procedure procedure do_save integer do_clear2 local integer dum1 send unload to Field_Edit reread for dum1 from 1 to current_field move (Integer_Value(Field_Numbers.obj,dum1)) to fieldindex move (Value(Record_Edit.obj,dum1 - 1)) to flexerrs.recnum& loop saverecord flexerrs unlock if do_clear2 eq 1 send do_clear end_procedure procedure do_delete if not status flexerrs begin send show_error to err_object "No record in memory to delete." procedure_return end if (validate_ok(verify_it.obj,"Delete this record?")) ne msg_ok procedure_return delete flexerrs send do_clear end_procedure procedure do_clear local integer dum1 clear flexerrs set dynamic_update_state of Record_Edit to FALSE send delete_data to Record_Edit for dum1 from 1 to current_field move (Integer_Value(Field_Numbers.obj,dum1)) to fieldindex set value of Record_Edit item (dum1 - 1) to flexerrs.recnum& if dum1 ne current_Field send key to Record_Edit KENTER loop send Beginning_of_Data to Record_Tags send Beginning_of_Data to Record_Edit set dynamic_update_State of Record_Edit to TRUE send synchronize to Field_Edit end_procedure procedure do_find integer which_mode local integer dum1 our_field old_origin move (hi(position(Record_Edit.obj)) + 1) to our_field if (((integer_value(Field_Main_Index.obj,our_field)) lt 1) and (our_Field ne 1)) begin send show_error to err_object "You cannot find by a non-indexed field." procedure_return end send unload to Field_Edit get origin of Record_Edit to old_origin move 0 to flexerrs.recnum for dum1 from 1 to current_field move (Integer_Value(Field_Numbers.obj,dum1)) to fieldindex move (Value(Record_Edit.obj,dum1 - 1)) to flexerrs.recnum& loop move (Integer_Value(Field_Numbers.obj,our_field)) to fieldindex if which_mode eq 1 find gt flexerrs.recnum& if which_mode eq 2 find lt flexerrs.recnum& if which_mode eq 3 find ge flexerrs.recnum& set dynamic_update_state of Record_Edit to FALSE send delete_data to Record_Edit for dum1 from 1 to current_field move (Integer_Value(Field_Numbers.obj,dum1)) to fieldindex set value of Record_Edit item (dum1 - 1) to flexerrs.recnum& loop send Beginning_of_Data to Record_Edit set Origin of Record_Edit to (hi(old_origin)) (low(old_origin)) send move_absolute to Record_Edit (our_field - 1) 0 set dynamic_update_State of Record_Edit to TRUE send synchronize to Field_Edit end_procedure procedure do_cancel send deactivate to Record_Divider send deactivate to Record_Title send deactivate send deactivate to Record_Tags send deactivate to Record_Edit send deactivate to Field_Edit if status flexerrs send fill_with_records to Field_Data 0 else send fill_with_records to Field_Data 1 end_procedure end_object object Field_Edit is an EDIT set SCOPE_STATE to TRUE set MAX_LINES to 1 set object_Color to 110 111 on_key KDOWNARROW send do_down on_key KUPARROW send do_up on_key KCANCEL send do_Cancel to Record_Buttons on_key KENTER send do_down on_key KFIND_NEXT send do_find_next to Record_Buttons on_key KFIND_PREVIOUS send do_find_previous to Record_Buttons on_key KFIND send do_find_eq to Record_Buttons on_key KCLEAR send do_clear to Record_Buttons on_key KSAVE_RECORD send do_save_and_Clear to Record_Buttons on_key KDELETE_RECORD send do_Delete to Record_Buttons on_key KEY_ALT+KEY_F2 send do_update to Record_Buttons procedure switch end_procedure procedure switch_back end_procedure procedure do_down if (hi(position(Record_Edit.obj)) +1) ge current_Field procedure_return send unload send DOWN to Record_Edit send DOWN to Record_Tags send synchronize end_procedure procedure do_up if (hi(position(Record_Edit.obj))) lt 1 begin if (hi(origin(Record_Edit.obj))) le 0 procedure_return end send unload send UP to Record_Edit send UP to Record_Tags send synchronize end_procedure procedure synchronize local integer tot_chars send deactivate send delete_data move (Integer_Value(Real_Size.obj,hi(position(Record_Edit.obj)) + 1)) to tot_chars if (tot_chars + 1) gt 54 set size to 1 54 else set size to 1 (tot_chars + 1) set right_margin to (tot_chars + 1) set value of current_object item 0 to (value(Record_Edit.obj,current)) send beginning_of_data set location to ( hi(position(Record_Edit.obj)) - hi(origin(Record_Edit.obj)) + hi(location(Record_Edit.obj))) (low(location(Record_Edit.obj))) send activate send status_line2 end_procedure procedure unload string total_line move (Value(Field_Edit.obj,current)) to total_line set value of Record_Edit item (hi(position(Record_Edit.obj))) to (pad(total_line,integer_value(Real_Size.obj,hi(position(Record_Edit.obj)) + 1))) send beginning_of_line to Record_Edit send paint to Record_Edit end_procedure end_object // Fill in the program title set value of back2 item 0 to "DFBROWSE Version 2.21" // Wow, another label! again: // This section of code initialize all of our objects so that we can // restart and browse another file. send delete_data to record_numbers send delete_Data to field_locator send delete_data to field_names send delete_Data to field_main_index send delete_Data to field_Start send delete_data to field_end send delete_Data to field_numbers send delete_Data to tags // Put up our background and then allow the user to choose a file send activate to back2 send add_focus to file_buttons DESKTOP start_ui Choose_File // Put up the "Working ... Please wait" message while we open the // file and determine its fields and data types. send Activate to Working // Try to open our file. We trap the "CAN'T OPEN DATA FILE ERROR" in our // on error routine in BAD_OPEN and have that routine set the BAD // indicator to TRUE. In this way, no error appears at the bottom but // our program knows about the error and can recover. indicate bad false on error gosub bad_open open file_root as Flexerrs on error off // If it was a bad open, put up the "Bad open" message and restart [bad] begin send deactivate to working send show_error to err_object "The chosen file cannot be opened." goto again end // Now that the file is opened, open the .TAG and start reading in the // field names direct_input (File_Root + ".TAG") // If the .TAG does not exist, put up the "Bad TAG file open" message and // restart. [seqeof] begin close flexerrs send deactivate to Working send show_error to err_object "The .TAG file for your file cannot be found." goto again end // We use a few arrays to keep track of the file information: // Field_Names is the array of field names // Field_Main_Index is the array of field main indexes // Field_Start is the array of field starting positions in the edit object // Field_End is the array of field ending positions in the edit object // Field_Locator is bizarre: Read on ... // Field Locator is an edit object that is used to store the // corresponding field number for a particular location in the edit // object. For example, if we wanted to know what field was at // position 50 in the edit object, we would look at the 50th // character in field_locator. That character contains a single // ASCII Character whose ASCII Value is the field at that location. // For example, if position 50 was for field 10, then the ASCII // value of the 50th character in field_locator would be 10. // We use this when updating the status object and when moving left // and right from field to field (jumping from field to field with // the TAB keys). We did it this way to save space. This will at // most require 16K (the maximum record length). I told you this // was bizarre! // Initialize starting values move 9 to current_position move 2 to current_Field move 1 to real_field send delete_Data to Field_Locator send delete_Data to Record_Tags send delete_Data to Real_Size set Array_Value of Field_Numbers item 1 to 0 set Array_Value of Field_Main_Index item 1 to 0 set Array_Value of Field_Names item 1 to "<RECNUM>" set Array_Value of Field_Start item 1 to 0 set Array_Value of Real_Size item 1 to 8 set Array_Value of Field_End item 1 to 9 // For each element in the TAG fill in the above arrays with information // about that field. send loadit procedure loadit local string total_string move "" to total_string for lvar100 from 0 to 8 append total_string (character(1)) loop repeat readln next_tag [seqeof] goto skip if next_tag ne "" begin field_def 50 real_Field to data_type main_index if main_index gt 0 begin insert "<" in next_Tag at 0 append next_Tag ">" end // Skip overlap fields if data_type eq 3 goto skip set Array_Value of Field_Numbers item current_field to real_field set Array_Value of Field_Main_Index item current_field to main_index set Array_Value of Field_Names item current_field to next_tag set Array_Value of Field_Start item current_field to current_position // Determine the fields display length from its BYTE length. // Remember, a numeric only needs 1/2 a BYTE for each displayed // character and don't forget the decimal! if data_type eq 1 move (strlen * 2 + 2) to field_length if data_type eq 2 move 10 to field_length if data_type eq 0 move strlen to field_length if data_Type eq 4 move strlen to field_length if data_type eq 5 move strlen to field_length if data_type eq 6 move strlen to field_length set Array_Value of Real_Size item current_field to field_length // If the .TAG entry is actually longer than the field length, // use the .TAG entry as the length of the field (STATE is 5 // characters but the field may only be 2). if (length(next_Tag)) gt field_length move (length(next_Tag)) to field_length set Array_Value of Field_End item current_field to (Current_Position + field_length + 1 ) if (current_position + field_length + 1) gt 3000 goto endit // Fill in the Field_Locator data (see above for a description // of this process) for lvar100 from (integer_value(Field_Start.obj,current_field)) to ((integer_value(Field_End.obj,current_field)) - 1) append total_string (character(current_field)) // send insert to Field_Locator (character(current_Field)) loop move (Current_Position + field_length + 1 ) to current_position move (current_Field + 1) to current_field end skip: increment real_field until [seqeof] endit: // We actually incremented current_field before reading in the next field // so we need to subtract 1 so that current_field points to maximum // fields instead of next field. move (Current_Field - 1) to current_field append total_string (Character(Current_Field)) set value of field_locator to total_string end_procedure // Max_Length is a global which stores the maximum width of the file. move current_position to max_length // Fill in the TAGS object with the name of all of the tags along with // a vertical bar separator. for lvar from 1 to current_field send insert to Record_Tags (String_Value(Field_Names.obj,lvar)) if lvar ne current_Field send key to Record_Tags KENTER send insert to tags (pad(string_value(field_names.obj,lvar),integer_value(field_end.obj,lvar) - integer_value(Field_Start.obj,lvar) -1)) send insert to tags "│" loop // Let's start this show ... send Beginning_Of_Data to tags move 0 to which_index move 0 to dlast_record send Fill_With_Records to Field_Data 1 send deactivate to record_numbers set value of background item 0 to "DFBROWSE Version 2.21" // Remember to get rid of the object we used in the first part of the // program. send deactivate to Working send deactivate to Choose_File send deactivate to file_buttons send deactivate to back2 send activate to background send activate to our_status send status_line send add_focus to edit_buttons DESKTOP send activate to tags start_ui field_Data // Get rid of the objects in the second part of the program. send deactivate to field_Data send deactivate to tags send deactivate to edit_buttons send deactivate to our_status send deactivate to background // Close our file since we are allowing the user to open a new one. close flexerrs goto again bad_open: indicate bad true indicate err false return