Compiling Program: C:\Apps\VDFQuery\AppSrc\dfm.src Memory Available: 1393045504 #REM DFM.SRC - SOME TOOLS FOR VISUAL DATAFLEX 12 Warning: Header for C:\Apps\VDFQuery\AppSrc\dfm not found, compiling whole program. 1>Use APS // Auto Positioning and Sizing classes for VDF Including file: aps.pkg (C:\Apps\VDFQuery\AppSrc\aps.pkg) 1>>>// ************************************************************************* 1>>>// Use APS.pkg // Auto Positioning and Sizing classes for VDF 1>>>// 1>>>// Version: 2.1+ 1>>>// by Sture Andersen 1>>>// 1>>>// NOTE! The classes defined in this file are ONLY concerned with sizing and 1>>>// locating objects. They do not change the navigational behavior of 1>>>// your objects or in any other way extend or limit the functionality 1>>>// compared to standard VDF classes. 1>>>// 1>>>// Once the objects have been created, sized and located APS makes 1>>>// no difference to the behavior to your objects. 1>>>// 1>>>// Support: Contact via DAW news groups preferred. 1>>>// 1>>>// E-mail: sture.aps@mail.tele.dk 1>>>// 1>>>// *********************************************************************** 1>>>// 1>>>// The following classes are defined in this package: 1>>>// 1>>>// 1>>>// Panel containers: aps.View aps.BasicPanel 1>>>// aps.dbView aps.TopMostModalPanel 1>>>// aps.ModalPanel aps.dbTopMostModalPanel 1>>>// aps.dbModalPanel aps.dbTabView 1>>>// 1>>>// Other containers: aps.Group aps.dbGroup 1>>>// aps.Container3D aps.dbContainer3D 1>>>// aps.TabDialog aps.dbTabDialog 1>>>// aps.TabPage aps.dbTabPage 1>>>// aps.RadioGroup aps.dbRadioGroup 1>>>// aps.RadioContainer //<-- NOTE: These do not have sizes 1>>>// aps.dbRadioContainer //<-- or locations. 1>>>// 1>>>// Controls: aps.Form aps.dbForm 1>>>// aps.ComboForm aps.dbComboForm 1>>>// aps.SpinForm aps.dbSpinForm 1>>>// aps.CheckBox aps.dbCheckBox 1>>>// aps.Edit aps.dbEdit 1>>>// aps.RichEdit aps.dbRichEdit 1>>>// aps.TextEdit aps.dbTextEdit 1>>>// aps.TextBox aps.Button 1>>>// aps.Radio aps.Multi_Button 1>>>// 1>>>// Grid controls: aps.List aps.dbList 1>>>// aps.Grid aps.dbGrid 1>>>// 1>>>// Exotics: aps.BitmapContainer aps.ToolButton 1>>>// aps.LineControl 1>>>// 1>>>// *********************************************************************** 1>>>// 1>>>// The following global alignment procedures are defined in this package: 1>>>// 1>>>// 1>>>// Align object 1 relative to object 2, by re-locating object 1: 1>>>// send APS_ALIGN_BY_MOVING obj1# obj2# align_mode# 1>>>// 1>>>// Align object 1 relative to object 2, by re-sizing object 1: 1>>>// send APS_ALIGN_BY_SIZING obj1# obj2# align_mode# 1>>>// 1>>>// Objects are sized to the bigger of the two: 1>>>// send APS_SIZE_IDENTICAL_MAX obj1# obj2# sizing_mode# 1>>>// 1>>>// Align an object (with ID ctrl#) inside its parent by re-locating it: 1>>>// send APS_ALIGN_INSIDE_CONTAINER_BY_MOVING ctrl# align_mode# 1>>>// 1>>>// Align an object (with ID ctrl#) inside its parent by re-sizing it: 1>>>// send APS_ALIGN_INSIDE_CONTAINER_BY_SIZING ctrl# align_mode# 1>>>// 1>>>// 1>>>// align_mode# : SL_ALIGN_LEFT SL_ALIGN_RIGHT SL_ALIGN_TOP 1>>>// SL_ALIGN_BOTTOM SL_ALIGN_CENTER SL_ALIGN_VCENTER 1>>>// 1>>>// sizing_mode# : SL_HORIZONTAL SL_VERTICAL 1>>>// 1>>>// 1>>>// 1>>>// *********************************************************************** 1>>> 1>>>Use DfAllent // Standard DAW everything Using pre-compiled package DFALLENT Including file: dfallent.pkd (c:\VDF12\Pkg\dfallent.pkd) 34150>>>Use dfline // DAW 34150>>>Use Version.nui // Including file: version.nui (C:\Apps\VDFQuery\AppSrc\version.nui) 34150>>>>>enumeration_list // _OS_ values 34150>>>>> define _OS_WIN_ 34150>>>>> define _OS_DOS_ 34150>>>>> define _OS_UNIX_ 34150>>>>>end_enumeration_list 34150>>>>> 34150>>>>>enumeration_list // _PRODUCT_ values 34150>>>>> define _DF_ 34150>>>>> define _VDF_ 34150>>>>> define _WEBAPP_ 34150>>>>>end_enumeration_list 34150>>>>> 34150>>>>>enumeration_list // _VERSION_ values 34150>>>>> define _20_ 34150>>>>> define _30_ 34150>>>>> define _31_ 34150>>>>> define _32_ 34150>>>>> define _4_ 34150>>>>> define _5_ 34150>>>>> define _6_ 34150>>>>> define _7_ 34150>>>>> define _8_ 34150>>>>> define _91_ 34150>>>>> define _10_ 34150>>>>> define _11_ 34150>>>>> define _12_ 34150>>>>>end_enumeration_list 34150>>>>> 34150>>>>> define _OS_ for _OS_WIN_ 34150>>>>> define _PRODUCT_ for _VDF_ // or WebApp server 34150>>>>> define _VERSION_ for _12_ // VDF12 34150>>>Use FieldInf // Global field info objects Including file: fieldinf.pkg (C:\Apps\VDFQuery\AppSrc\fieldinf.pkg) 34150>>>>>//********************************************************************** 34150>>>>>// Use FieldInf // Global field info objects and abstract field types 34150>>>>>// 34150>>>>>// By Sture Andersen 34150>>>>>// 34150>>>>>// Create: Wed 28-01-1997 34150>>>>>// Update: Tue 11-02-1997 - Abstract field thing added 34150>>>>>// Thu 20-02-1997 - Register_abstract_field_label may now be 34150>>>>>// be used with only one argument (does nothing) 34150>>>>>// Thu 04-03-1997 - ascii_window and date_window are now defined 34150>>>>>// if not already (for use with CM) 34150>>>>>// Tue 22-04-1997 - File_Display_Name_Array added 34150>>>>>// Tue 29-04-1997 - Changed REGISTER_FIELD_LABEL command 34150>>>>>// Wed 04-02-1998 - Functions gl_generic_form_margin and 34150>>>>>// gl_generic_form_datatype added 34150>>>>>// Fri 29-01-1999 - DataDictionary_Class property moved to here 34150>>>>>// from dynamo.utl. 34150>>>>>// Wed 17-02-1999 - Class cVirtualFields added. 34150>>>>>// Mon 15-03-1999 - DataDictionary classes are now used when 34150>>>>>// determining field labels 34150>>>>>// Thu 03-07-2003 - Fixed error in procedure set pCurrentRecord 34150>>>>>// Tue 12-08-2003 - Added piDescriptionImage.i 34150>>>>>// Wed 14-09-2005 - Virtual fields now have a "call back" function 34150>>>>>// - Function FieldInf_Field_Length added. 34150>>>>>// Mon 20-03-2006 - Functions FieldInf_ValidationTableObject and 34150>>>>>// FieldInf_ValidationTableDecodeValue added. 34150>>>>>// 34150>>>>>// Purpose: To provide a global mechanism for registering field labels. 34150>>>>>// If used with APS, db-controls will automatically obtain their 34150>>>>>// labels from here, unless they are set manually or they are 34150>>>>>// specifically told not to. 34150>>>>>// 34150>>>>>// The package also let's you define abstract field types for 34150>>>>>// use with non-db controls or for overriding the definition of 34150>>>>>// DBMS fields. A classical example of the latter is that while 34150>>>>>// your data field is defined to have 4 decimal points you 34150>>>>>// really want the field to display with only 3. 34150>>>>>// 34150>>>>>// You set these global informations using the four commands 34150>>>>>// listed here: 34150>>>>>// 34150>>>>>// 1 REGISTER_FIELD_LABEL dffile.field ; 34150>>>>>// [ []] 34150>>>>>// 34150>>>>>// 2 REGISTER_ABSTRACT_FIELD_TYPE ; 34150>>>>>// 34150>>>>>// 34150>>>>>// 3 MODIFY_FIELD_TYPE dffile.field 34150>>>>>// 34150>>>>>// 4 REGISTER_FILE_ALIAS 34150>>>>>// 34150>>>>>// As you can see it is possible to register status help lines. 34150>>>>>// This was implemented since it felt to natural to do so. APS 34150>>>>>// will make use of such registrations only if used with the 34150>>>>>// aps.DataDictionary and only if status help has not been 34150>>>>>// registered the standard DD way. 34150>>>>>// 34150>>>>>// 34150>>>>>// Note: This package makes permanent use of compile-time variable J$. 34150>>>>>// If this is in conflict with your application source it is 34150>>>>>// easily changed since it is only referenced from within this 34150>>>>>// file. 34150>>>>>// 34150>>>>>//********************************************************************** 34150>>>>> 34150>>>>>Use ui 34150>>>>>Use Seq_Chnl // Defines global sequential device management operations (DAW) 34150>>>>>Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes Including file: base.nui (C:\Apps\VDFQuery\AppSrc\base.nui) 34150>>>>>>>// Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface) 34150>>>>>>> 34150>>>>>>>// This purpose of this package is to relieve me of having to remember which 34150>>>>>>>// package exactly holds a particular command or class. 34150>>>>>>> 34150>>>>>>> 34150>>>>>>> define BaseClass for Desktop 34150>>>>>>> 34150>>>>>>>Use Array.nui // Item_Property command Including file: array.nui (C:\Apps\VDFQuery\AppSrc\array.nui) 34150>>>>>>>>>// Use Array.nui // Item_Property command (No User Interface) 34150>>>>>>>>> 34150>>>>>>>>>//> pkgdoc.begin 34150>>>>>>>>>//> This package defines three commands ITEM_PROPERTY_LIST, ITEM_PROPERTY 34150>>>>>>>>>//> and END_ITEM_PROPERTY_LIST. They should be used like this: 34150>>>>>>>>>//> 34150>>>>>>>>>//> 34150>>>>>>>>>//> object oTest is an Array 34150>>>>>>>>>//> item_property_list 34150>>>>>>>>>//> item_property string pItem_Label 34150>>>>>>>>>//> item_property integer pItem_Type 34150>>>>>>>>>//> item_property string pItem_Default 34150>>>>>>>>>//> end_item_property_list // IF IN CLASS REPEAT CLASS NAME HERE! 34150>>>>>>>>>//> end_object 34150>>>>>>>>>//> 34150>>>>>>>>>//> 34150>>>>>>>>>//> You will now be able to write code like: 34150>>>>>>>>>//> 34150>>>>>>>>>//> 34150>>>>>>>>>//> set pItem_Label item 2 to "Amazing" 34150>>>>>>>>>//> get pItem_Default item 0 to sVar 34150>>>>>>>>>//> 34150>>>>>>>>>//> 34150>>>>>>>>>//> Note that you do not need to sub-class the array in order to do this. 34150>>>>>>>>>//> The ITEM_PROPERTY command structure simply defines a number of messages 34150>>>>>>>>>//> that lets you set the values of the array using your own names. 34150>>>>>>>>>//> 34150>>>>>>>>>//> In a normal array you may get the number of items by using the Item_Count 34150>>>>>>>>>//> function. Of course you may still do that, but you would more likely 34150>>>>>>>>>//> want to retrieve the number of 'rows' currently in the array. For this 34150>>>>>>>>>//> purpose the END_ITEM_PROPERTY_LIST command defines a function called 34150>>>>>>>>>//> Row_Count. 34150>>>>>>>>>//> 34150>>>>>>>>>//> In an empty array the Row_Count function returns 0 (surprise). Having 34150>>>>>>>>>//> set just one of the values of the 1'st row (row number 0) the Row_Count 34150>>>>>>>>>//> function will return 1. 34150>>>>>>>>>//> 34150>>>>>>>>>//> If you want to define item_properties as part of a class definition 34150>>>>>>>>>//> you should NOT define them inside procedure construct_object as you 34150>>>>>>>>>//> would with normal properties. Instead it looks like this: 34150>>>>>>>>>//> 34150>>>>>>>>>//> 34150>>>>>>>>>//> class cTest is an Array 34150>>>>>>>>>//> item_property_list 34150>>>>>>>>>//> item_property string pItem_Label 34150>>>>>>>>>//> item_property integer pItem_Type 34150>>>>>>>>>//> item_property string pItem_Default 34150>>>>>>>>>//> end_item_property_list cTest // NOTE: Class name as parameter! 34150>>>>>>>>>//> end_class 34150>>>>>>>>>//> 34150>>>>>>>>>//> pkgdoc.end 34150>>>>>>>>> 34150>>>>>>>>>use ui 34150>>>>>>>>> 34150>>>>>>>>>Enumeration_List // Symbols used internally by the item_property command 34150>>>>>>>>> define ITMP_INTEGER 34150>>>>>>>>> define ITMP_STRING 34150>>>>>>>>> define ITMP_REAL 34150>>>>>>>>> define ITMP_NUMBER 34150>>>>>>>>> define ITMP_DATE 34150>>>>>>>>>End_Enumeration_List 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>> 34150>>>>>>>>>procedure Clone_Array global integer lhSrc integer lhTarget 34152>>>>>>>>> integer liItem liMax 34152>>>>>>>>> move (item_count(lhSrc)) to liMax 34153>>>>>>>>> send delete_data to lhTarget 34154>>>>>>>>> for liItem from 0 to (liMax-1) 34160>>>>>>>>>> 34160>>>>>>>>> set value of lhTarget item liItem to (value(lhSrc,liItem)) 34161>>>>>>>>> loop 34162>>>>>>>>>> 34162>>>>>>>>>end_procedure 34163>>>>>>>>> 34163>>>>>>>>>// 34163>>>>>>>Use Macros.utl // Various macros (FOR_EX...) Including file: macros.utl (C:\Apps\VDFQuery\AppSrc\macros.utl) 34163>>>>>>>>>// Use Macros.utl // Various macros (FOR_EX...) 34163>>>>>>>>> 34163>>>>>>>>>// FOR_EX (extended FOR command) 34163>>>>>>>>>// ----------------------------- 34163>>>>>>>>>//> The FOR_EX command is exactly like the standard FOR command except 34163>>>>>>>>>//> that it will allow you to use keyword "DOWN_TO" instead of "TO" if 34163>>>>>>>>>//> you need to do a decremental loop. 34163>>>>>>>>> 34163>>>>>>>>> 34163>>>>>>>>>// DESKTOP_SECTION 34163>>>>>>>>>// --------------- 34163>>>>>>>>>//> The DESKTOP_SECTION/END_DESKTOP_SECTION commands will make a sequence of 34163>>>>>>>>>//> code compile (or rather instantiate) as if it was situated on the DESKTOP 34163>>>>>>>>>//> even when it isn't. DESKTOP_SECTION's may not be nested. 34163>>>>>>>>> 34163>>>>>>>>> 34163>>>>>>>>> 34163>>>>>>>Use Set.utl // cArray, cSet and cStack classes Including file: set.utl (C:\Apps\VDFQuery\AppSrc\set.utl) 34163>>>>>>>>>// Use Set.utl // cArray, cSet and cStack classes 34163>>>>>>>>> 34163>>>>>>>>>use ui 34163>>>>>>>>> 34163>>>>>>>>>Use DestObj.pkg // DAW - Defines request_destroy_object Including file: destobj.pkg (c:\VDF12\Pkg\destobj.pkg) 34163>>>>>>>>>>>Use VdfBase.pkg // this now lives here. (you don't need to ever use this). 34163>>>>>>>>> 34163>>>>>>>>>// The only difference between a cArray and an Array object is that 34163>>>>>>>>>// a cArray reacts with normal delegation to messages that it does 34163>>>>>>>>>// not understand. 34163>>>>>>>>> 34163>>>>>>>>>class cArray is an Array 34164>>>>>>>>> procedure construct_object integer liImg 34166>>>>>>>>> forward send construct_object liImg 34168>>>>>>>>> set delegation_mode to DELEGATE_TO_PARENT 34169>>>>>>>>> end_procedure 34170>>>>>>>>>end_class // cArray 34171>>>>>>>>> 34171>>>>>>>>>class cArray2d is a cArray 34172>>>>>>>>> function iObjectID.i integer liX returns integer 34174>>>>>>>>> integer lhObj 34174>>>>>>>>> get value item liX to lhObj 34175>>>>>>>>> ifnot lhObj begin 34177>>>>>>>>> object oArray2d is a cArray no_image 34179>>>>>>>>> move self to lhObj 34180>>>>>>>>> end_object 34181>>>>>>>>> set value item liX to lhObj 34182>>>>>>>>> end 34182>>>>>>>>>> 34182>>>>>>>>> function_return lhObj 34183>>>>>>>>> end_function 34184>>>>>>>>> procedure set Value.ii integer liX integer liY string lsValue 34186>>>>>>>>> integer lhObj 34186>>>>>>>>> get iObjectID.i liX to lhObj 34187>>>>>>>>> set value of lhObj item liY to lsValue 34188>>>>>>>>> end_procedure 34189>>>>>>>>> function Value.ii integer liX integer liY returns string 34191>>>>>>>>> integer lhObj 34191>>>>>>>>> get value item liX to lhObj 34192>>>>>>>>> if lhObj function_return (value(lhObj,liY)) 34195>>>>>>>>> function_return 0 34196>>>>>>>>> end_function 34197>>>>>>>>> procedure reset 34199>>>>>>>>> integer liItm liMax lhObj 34199>>>>>>>>> get item_count to liMax 34200>>>>>>>>> decrement liMax 34201>>>>>>>>> for liItm from 0 to liMax 34207>>>>>>>>>> 34207>>>>>>>>> get value item liItm to lhObj 34208>>>>>>>>> if lhObj send request_destroy_object to lhObj 34211>>>>>>>>> loop 34212>>>>>>>>>> 34212>>>>>>>>> send delete_data 34213>>>>>>>>> end_procedure 34214>>>>>>>>>end_class // cArray2d 34215>>>>>>>>> 34215>>>>>>>>>class cArray3d is a cArray2d 34216>>>>>>>>> function iObjectID.ii integer liX integer liY returns integer 34218>>>>>>>>> integer lhObj 34218>>>>>>>>> get Value.ii liX liY to lhObj 34219>>>>>>>>> ifnot lhObj begin 34221>>>>>>>>> object oArray3d is a cArray no_image 34223>>>>>>>>> move self to lhObj 34224>>>>>>>>> end_object 34225>>>>>>>>> set Value.ii liX liY to lhObj 34226>>>>>>>>> end 34226>>>>>>>>>> 34226>>>>>>>>> function_return lhObj 34227>>>>>>>>> end_function 34228>>>>>>>>> procedure set Value.iii integer liX integer liY integer liZ string lsValue 34230>>>>>>>>> integer lhObj 34230>>>>>>>>> get iObjectID.ii liX liY to lhObj 34231>>>>>>>>> set value of lhObj item liZ to lsValue 34232>>>>>>>>> end_procedure 34233>>>>>>>>> function Value.iii integer liX integer liY integer liZ returns string 34235>>>>>>>>> integer lhObj 34235>>>>>>>>> get value item liX to lhObj 34236>>>>>>>>> if lhObj begin 34238>>>>>>>>> get value of lhObj item liY to lhObj 34239>>>>>>>>> if lhObj function_return (value(lhObj,liZ)) 34242>>>>>>>>> end 34242>>>>>>>>>> 34242>>>>>>>>> function_return 0 34243>>>>>>>>> end_function 34244>>>>>>>>> procedure reset 34246>>>>>>>>> integer liXmax liYmax liX liY lhYobj lhZobj 34246>>>>>>>>> get item_count to liXmax 34247>>>>>>>>> decrement liXmax 34248>>>>>>>>> for liX from 0 to liXmax 34254>>>>>>>>>> 34254>>>>>>>>> get value item liX to lhYobj 34255>>>>>>>>> if lhYobj begin 34257>>>>>>>>> get item_count of lhYobj to liYmax 34258>>>>>>>>> decrement liYmax 34259>>>>>>>>> for liY from 0 to liYmax 34265>>>>>>>>>> 34265>>>>>>>>> get value of lhYobj item liY to lhZobj 34266>>>>>>>>> if lhZobj send request_destroy_object to lhZobj 34269>>>>>>>>> loop 34270>>>>>>>>>> 34270>>>>>>>>> end 34270>>>>>>>>>> 34270>>>>>>>>> loop 34271>>>>>>>>>> 34271>>>>>>>>> forward send reset 34273>>>>>>>>> end_procedure 34274>>>>>>>>>end_class // cArray3d 34275>>>>>>>>> 34275>>>>>>>>>class cArray2dFixedWidth is a cArray 34276>>>>>>>>> procedure construct_object integer liImg 34278>>>>>>>>> forward send construct_object liImg 34280>>>>>>>>> property integer private.piMaxColumn public 0 34281>>>>>>>>> end_procedure 34282>>>>>>>>> function piMaxColumn returns integer 34284>>>>>>>>> function_return (private.piMaxColumn(self)) 34285>>>>>>>>> end_function 34286>>>>>>>>> procedure set piMaxColumn integer liMax 34288>>>>>>>>> if (item_count(self)) error 666 "Can't set column index range while not empty" 34291>>>>>>>>> else set private.piMaxColumn to liMax 34293>>>>>>>>> end_procedure 34294>>>>>>>>> procedure set value.ii integer liRow integer liColumn string lsValue 34296>>>>>>>>> integer liItem liMaxColumn 34296>>>>>>>>> get private.piMaxColumn to liMaxColumn 34297>>>>>>>>> move (liRow*liMaxColumn+liColumn) to liItem 34298>>>>>>>>> if liColumn ge liMaxColumn error 666 "Column index is out of range" 34301>>>>>>>>> else set value item liItem to lsValue 34303>>>>>>>>> end_procedure 34304>>>>>>>>> function value.ii integer liRow integer liColumn returns string 34306>>>>>>>>> integer liItem liMaxColumn 34306>>>>>>>>> get private.piMaxColumn to liMaxColumn 34307>>>>>>>>> move (liRow*liMaxColumn+liColumn) to liItem 34308>>>>>>>>> if liColumn ge liMaxColumn error 666 "Column index is out of range" 34311>>>>>>>>> else function_return (value(self,liItem)) 34313>>>>>>>>> end_function 34314>>>>>>>>> function row_count returns integer 34316>>>>>>>>> integer liMaxColumn 34316>>>>>>>>> get private.piMaxColumn to liMaxColumn 34317>>>>>>>>> function_return (liMaxColumn-1+item_count(self)/liMaxColumn) 34318>>>>>>>>> end_function 34319>>>>>>>>> function column_count returns integer 34321>>>>>>>>> function_return (private.piMaxColumn(self)) 34322>>>>>>>>> end_function 34323>>>>>>>>> procedure reset 34325>>>>>>>>> send delete_data 34326>>>>>>>>> end_procedure 34327>>>>>>>>>end_class // cArray2dFixedWidth 34328>>>>>>>>> 34328>>>>>>>>>class cSet is an cArray 34329>>>>>>>>> function element_find string lsValue returns integer 34331>>>>>>>>> integer liMax liItm 34331>>>>>>>>> get item_count to liMax 34332>>>>>>>>> move 0 to liItm 34333>>>>>>>>> while liItm lt liMax 34337>>>>>>>>> if lsValue eq (value(self,liItm)) function_return liItm // Dirty exit 34340>>>>>>>>> increment liItm 34341>>>>>>>>> end 34342>>>>>>>>>> 34342>>>>>>>>> function_return -1 34343>>>>>>>>> end_function 34344>>>>>>>>> 34344>>>>>>>>> procedure element_add string lsValue 34346>>>>>>>>> if (element_find(self,lsValue)=-1) set value item (item_count(self)) to lsValue 34349>>>>>>>>> end_procedure 34350>>>>>>>>> 34350>>>>>>>>> procedure element_remove string lsValue 34352>>>>>>>>> integer liItm 34352>>>>>>>>> get element_find lsValue to liItm 34353>>>>>>>>> if liItm ge 0 send delete_item liItm 34356>>>>>>>>> end_procedure 34357>>>>>>>>> 34357>>>>>>>>> function iAddOrFind_Element string lsValue returns integer 34359>>>>>>>>> integer liRval 34359>>>>>>>>> get element_find lsValue to liRval 34360>>>>>>>>> if liRval eq -1 begin 34362>>>>>>>>> get item_count to liRval 34363>>>>>>>>> set value item liRval to lsValue 34364>>>>>>>>> end 34364>>>>>>>>>> 34364>>>>>>>>> function_return liRval 34365>>>>>>>>> end_function 34366>>>>>>>>> 34366>>>>>>>>>//// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- 34366>>>>>>>>>//// Original procedures (optimized) are mentioned for compatibility: 34366>>>>>>>>>// 34366>>>>>>>>>//function find_element string lsValue returns integer 34366>>>>>>>>>// integer liMax liItm 34366>>>>>>>>>// get item_count to liMax 34366>>>>>>>>>// move 0 to liItm 34366>>>>>>>>>// while liItm lt liMax 34366>>>>>>>>>// if lsValue eq (value(self,liItm)) function_return liItm // Dirty exit 34366>>>>>>>>>// increment liItm 34366>>>>>>>>>// end 34366>>>>>>>>>// function_return -1 34366>>>>>>>>>//end_function 34366>>>>>>>>>// 34366>>>>>>>>>//procedure Add_Element string lsValue returns integer 34366>>>>>>>>>// integer liRval 34366>>>>>>>>>// get find_element lsValue to liRval 34366>>>>>>>>>// if liRval lt 0 get item_count to liRval 34366>>>>>>>>>// set array_value item liRval to lsValue 34366>>>>>>>>>// procedure_return liRval 34366>>>>>>>>>//end_procedure 34366>>>>>>>>>// 34366>>>>>>>>>//procedure Remove_Element string lsValue 34366>>>>>>>>>// integer liItm 34366>>>>>>>>>// get Find_Element item lsValue to liItm 34366>>>>>>>>>// if liItm gt -1 send delete_item liItm 34366>>>>>>>>>//end_procedure 34366>>>>>>>>>//// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- 34366>>>>>>>>>end_class 34367>>>>>>>>> 34367>>>>>>>>>class cStack is an cArray 34368>>>>>>>>> function Stack_Empty returns integer 34370>>>>>>>>> function_return (item_count(self)=0) 34371>>>>>>>>> end_function 34372>>>>>>>>> // *** Integer interface ************************************** 34372>>>>>>>>> procedure Push.i integer liValue 34374>>>>>>>>> set value item (item_count(self)) to liValue 34375>>>>>>>>> end_procedure 34376>>>>>>>>> function iPop returns integer 34378>>>>>>>>> integer liRval liItm 34378>>>>>>>>> move (item_count(self)-1) to liItm 34379>>>>>>>>> get value item liItm to liRval 34380>>>>>>>>> send delete_item liItm 34381>>>>>>>>> function_return liRval 34382>>>>>>>>> end_function 34383>>>>>>>>> function iCopy returns integer 34385>>>>>>>>> function_return (value(self,item_count(self)-1)) 34386>>>>>>>>> end_function 34387>>>>>>>>> function bIsOnStack.i integer liValue returns integer 34389>>>>>>>>> integer liMax liItm 34389>>>>>>>>> get item_count to liMax 34390>>>>>>>>> decrement liMax 34391>>>>>>>>> for liItm from 0 to liMax 34397>>>>>>>>>> 34397>>>>>>>>> if (integer(value(self,liItm))=liValue) function_return 1 34400>>>>>>>>> loop 34401>>>>>>>>>> 34401>>>>>>>>> function_return 0 34402>>>>>>>>> end_function 34403>>>>>>>>> // *** String interface *************************************** 34403>>>>>>>>> procedure Push.s string lsValue 34405>>>>>>>>> set value item (item_count(self)) to lsValue 34406>>>>>>>>> end_procedure 34407>>>>>>>>> function sPop returns string 34409>>>>>>>>> integer liItm 34409>>>>>>>>> string lsRval 34409>>>>>>>>> move (item_count(self)-1) to liItm 34410>>>>>>>>> get value item liItm to lsRval 34411>>>>>>>>> send delete_item liItm 34412>>>>>>>>> function_return lsRval 34413>>>>>>>>> end_function 34414>>>>>>>>> function sCopy returns string 34416>>>>>>>>> function_return (value(self,item_count(self)-1)) 34417>>>>>>>>> end_function 34418>>>>>>>>> procedure Drop 34420>>>>>>>>> string lsGrb 34420>>>>>>>>> get sPop to lsGrb 34421>>>>>>>>> end_procedure 34422>>>>>>>>> function bIsOnStack.s string lsValue returns integer 34424>>>>>>>>> integer liMax liItm 34424>>>>>>>>> get item_count to liMax 34425>>>>>>>>> decrement liMax 34426>>>>>>>>> for liItm from 0 to liMax 34432>>>>>>>>>> 34432>>>>>>>>> if (value(self,liItm)=lsValue) function_return 1 34435>>>>>>>>> loop 34436>>>>>>>>>> 34436>>>>>>>>> function_return 0 34437>>>>>>>>> end_function 34438>>>>>>>>>end_class 34439>>>>>>> 34439>>>>>Use Strings.nui // String manipulation for VDF Including file: strings.nui (C:\Apps\VDFQuery\AppSrc\strings.nui) 34439>>>>>>>// ********************************************************************** 34439>>>>>>>// Use Strings.nui // String manipulation for VDF (No User Interface) 34439>>>>>>>// 34439>>>>>>>// By Sture Andersen 34439>>>>>>>// 34439>>>>>>>// The file contains a number of global functions for manipulating 34439>>>>>>>// strings and converting numbers to strings. The package may be used 34439>>>>>>>// with DataFlex 3.2 and Visual DataFlex. This package is public domain. 34439>>>>>>>// 34439>>>>>>>// 34439>>>>>>>// Create: Fri 23-05-1997 - Merger of s_utl002, 006. 34439>>>>>>>// Update: Tue 25-08-1997 - Fixes by Magnus Bergh 34439>>>>>>>// Sun 14-12-1997 - Added the following functions: 34439>>>>>>>// ExtractWord ExtractInteger 34439>>>>>>>// HowManyWords HowManyIntegers 34439>>>>>>>// ExtractItemNeg IsIntegerPresent 34439>>>>>>>// Tue 31-03-1998 - Added the following functions: 34439>>>>>>>// Text_RemoveTrailingCr Text_CompressSubstCr 34439>>>>>>>// Text_RTrim Text_Format.sii 34439>>>>>>>// Text_Trim Text_FormattedLine.i 34439>>>>>>>// Text_Compress 34439>>>>>>>// Fri 06-11-1998 - Added function InsertThousandsSep 34439>>>>>>>// Sun 14-02-1999 - Added function Byte_ToHex 34439>>>>>>>// Wed 27-04-1999 - Added function CurrentDecimalSeparator 34439>>>>>>>// Mon 08-11-1999 - Added procedure Text_SetEditObjectValue and 34439>>>>>>>// function Text_EditObjectValue 34439>>>>>>>// Mon 22-11-1999 - Function Text_RemoveTrailingCr strengthened 34439>>>>>>>// Wed 01-12-1999 - Function StringFieldType added 34439>>>>>>>// Wed 12-01-2000 - Functions StringOemToAnsi and StringAnsiToOem 34439>>>>>>>// added when compiled using the Windows compiler 34439>>>>>>>// Wed 17-05-2000 - Function NumToStr fixed for use with VDF 6.0. 34439>>>>>>>// Mon 29-05-2000 - Attempt to fix function Text_EditObjectValue 34439>>>>>>>// Fri 21-07-2000 - InsertThousandsSep fixed for use with negative 34439>>>>>>>// numbers. 34439>>>>>>>// - Functions IntToStrRTS, NumToStrRTS and NumToStrTS 34439>>>>>>>// added. 34439>>>>>>>// Fri 25-08-2000 - Function NumToStrRzf added 34439>>>>>>>// Wed 28-02-2001 - Add function HexToByte, renamed existing function 34439>>>>>>>// Byte_ToHex to ByteToHex 34439>>>>>>>// Mon 19-03-2001 - Functions StringBeginsWith and StringEndsWith 34439>>>>>>>// added 34439>>>>>>>// Thu 19-07-2001 - StringIsInteger added 34439>>>>>>>// Sat 05-04-2002 - Global strings str.Chr10 and str.Chr1013 added. 34439>>>>>>>// Tue 04-06-2002 - Oem to ANSI and vice versa for DF3.2 UNIX/DOS/LINUX 34439>>>>>>>// Tue 09-09-2003 - Function StringFieldText added 34439>>>>>>>// Tue 18-01-2005 - Function String_NegateSortOrder added 34439>>>>>>>// Mon 14-03-2005 - Functions StringHead and StringTail added 34439>>>>>>>// Sun 12-11-2006 - Functions renamed: RightFromPos -> RightFromPos 34439>>>>>>>// ByteToHex -> ByteToHex 34439>>>>>>>// HexToByte -> HexToByte 34439>>>>>>>// StringToHex -> StringToHex 34439>>>>>>>// HexToString -> HexToString 34439>>>>>>>// WildCardMatch -> WildCardMatch 34439>>>>>>>// 34439>>>>>>>// 34439>>>>>>>// *********************************************************************** 34439>>>>>>> 34439>>>>>>>use ui 34439>>>>>>>Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes 34439>>>>>>> 34439>>>>>>>// Returns the string of length len# inside which src# is right justified: 34439>>>>>>>Function RightShift global string src# integer len# returns string 34441>>>>>>> trim src# to src# 34442>>>>>>>> 34442>>>>>>> if (length(src#)) lt len# insert (left(pad("",len#),len#-length(src#))) in src# at 1 34446>>>>>>> function_return (left(src#,len#)) 34447>>>>>>>End_Function 34448>>>>>>> 34448>>>>>>>// Returns the string of length len# inside which src# is centered: 34448>>>>>>>Function CenterString global string src# integer len# returns string 34450>>>>>>> trim src# to src# 34451>>>>>>>> 34451>>>>>>> if (length(src#)) lt len# insert (left(pad("",len#),len#-length(src#)/2)) in src# at 1 34455>>>>>>> function_return (left(src#,len#)) 34456>>>>>>>End_Function 34457>>>>>>> 34457>>>>>>>// Returns all characters to the right of position pos# (including the character at 34457>>>>>>>// posistion pos#) 34457>>>>>>>Function RightFromPos global string str# integer pos# returns string 34459>>>>>>> function_return (right(str#,length(str#)-pos#+1)) 34460>>>>>>>End_Function 34461>>>>>>> 34461>>>>>>>// Number converting functions: 34461>>>>>>> 34461>>>>>>>integer NumToStringConversionMode# 34461>>>>>>> 34461>>>>>>>string str.Chr10 1 34461>>>>>>>string str.Chr13 1 34461>>>>>>>string str.Chr1013 2 34461>>>>>>>move (character(13)) to str.Chr13 34462>>>>>>>move (character(10)) to str.Chr10 34463>>>>>>>move (character(10)+character(13)) to str.Chr1013 34464>>>>>>> 34464>>>>>>>move NUMTOSTR_THOUSANDS_SEPARATOR_OFF to NumToStringConversionMode# 34465>>>>>>>procedure set pNumToStringConversionMode global integer value# 34467>>>>>>> move value# to NumToStringConversionMode# 34468>>>>>>>end_procedure 34469>>>>>>>function pNumToStringConversionMode global returns integer 34471>>>>>>> function_return NumToStringConversionMode# 34472>>>>>>>end_function 34473>>>>>>> 34473>>>>>>>function InsertThousandsSep global string str# returns string 34475>>>>>>> integer pos# tmp# neg# 34475>>>>>>> string sep# 34475>>>>>>> trim str# to str# 34476>>>>>>>> 34476>>>>>>> move (left(str#,1)="-") to neg# 34477>>>>>>> if neg# get StringRightBut str# 1 to str# 34480>>>>>>> get_attribute DF_DECIMAL_SEPARATOR to pos# 34483>>>>>>> character pos# to sep# 34484>>>>>>>> 34484>>>>>>> move (pos(sep#,str#)) to pos# 34485>>>>>>> ifnot pos# move (length(str#)+1) to pos# 34488>>>>>>> get_attribute DF_THOUSANDS_SEPARATOR to tmp# 34491>>>>>>> character tmp# to sep# 34492>>>>>>>> 34492>>>>>>> while pos# gt 4 34496>>>>>>> move (pos#-3) to pos# 34497>>>>>>> insert sep# in str# at pos# 34499>>>>>>> loop 34500>>>>>>>> 34500>>>>>>> if neg# move ("-"+str#) to str# 34503>>>>>>> function_return str# 34504>>>>>>>end_function 34505>>>>>>> 34505>>>>>>>// Calling the function below will convert the number stored in src# to a 34505>>>>>>>// string containing dcp# decimals rounding excess decimals. Parameter dcp# 34505>>>>>>>// may be negative. The expression (NumToStr(1789,-3)) will evaluate to "2000". 34505>>>>>>>// The functions in this package all respects the value of global attribute 34505>>>>>>>// DF_DECIMAL_SEPARATOR. 34505>>>>>>>Function NumToStr global number src# integer dcp# returns string 34507>>>>>>> integer pos# 34507>>>>>>> number correction# 34507>>>>>>> string rval# radix# 34507>>>>>>> if dcp# lt 0 function_return (NumToStr(src#*(10^dcp#),0)+left("00000000",-dcp#)) 34510>>>>>>> move (0.5/(10^dcp#)) to correction# 34511>>>>>>>// move (0.5/(10^dcp#)+src#) to src# // This does not always work with VDF 6.x!!! 34511>>>>>>> if src# ge 0 move (correction#+src#) to src# 34514>>>>>>> else move (src#-correction#) to src# 34516>>>>>>> get_attribute DF_DECIMAL_SEPARATOR to pos# // Overload 34519>>>>>>> character pos# to radix# // End overload 34520>>>>>>>> 34520>>>>>>> move src# to rval# 34521>>>>>>> ifnot (pos(radix#,rval#)) append rval# radix# 34524>>>>>>> append rval# "00000000" 34525>>>>>>> move (pos(radix#,rval#)) to pos# 34526>>>>>>> if dcp# eq 0 decrement pos# 34529>>>>>>> move (left(rval#,pos#+dcp#)) to rval# 34530>>>>>>> if NumToStringConversionMode# move (InsertThousandsSep(rval#)) to rval# 34533>>>>>>> function_return rval# 34534>>>>>>>End_Function 34535>>>>>>> 34535>>>>>>>// This function is the same as NumToStr except that you have to specify 34535>>>>>>>// the length of the target string (len#). The number will be right 34535>>>>>>>// justified accordingly. Post-fix `R' means right justify: 34535>>>>>>>Function NumToStrR global number src# integer dcp# integer len# returns string 34537>>>>>>> function_return (RightShift(NumToStr(src#,dcp#),len#)) 34538>>>>>>>End_Function 34539>>>>>>> 34539>>>>>>>// Function NumToStrTS is the same as NumToStr except that thousand 34539>>>>>>>// separators are inserted. (TS=Thousand Separator) 34539>>>>>>>Function NumToStrTS global number src# integer dcp# returns string 34541>>>>>>> integer Org# 34541>>>>>>> string rval# 34541>>>>>>> move NumToStringConversionMode# to org# 34542>>>>>>> move NUMTOSTR_THOUSANDS_SEPARATOR_ON to NumToStringConversionMode# 34543>>>>>>> move (NumToStr(src#,dcp#)) to rval# 34544>>>>>>> move org# to NumToStringConversionMode# 34545>>>>>>> function_return rval# 34546>>>>>>>End_Function 34547>>>>>>> 34547>>>>>>>Function IntToStrTS global number src# returns string 34549>>>>>>> function_return (NumToStrTS(src#,0)) 34550>>>>>>>End_Function 34551>>>>>>> 34551>>>>>>>Function NumToStrRTS global number src# integer dcp# integer len# returns string 34553>>>>>>> function_return (RightShift(NumToStrTS(src#,dcp#),len#)) 34554>>>>>>>End_Function 34555>>>>>>> 34555>>>>>>>// This function is the same as NumToStrR except that you do not specify 34555>>>>>>>// the number of decimals: 34555>>>>>>>Function IntToStrR global number src# integer len# returns string 34557>>>>>>> function_return (NumToStrR(src#,0,len#)) // Fixed, Magnus Bergh 34558>>>>>>>End_Function 34559>>>>>>> 34559>>>>>>>// Same as IntToStrR (TS=Thousand Separator) 34559>>>>>>>Function IntToStrRTS global number src# integer len# returns string 34561>>>>>>> function_return (NumToStrRTS(src#,0,len#)) 34562>>>>>>>End_Function 34563>>>>>>> 34563>>>>>>>// Is the same as IntToStrR, except that leading blanks are substituted 34563>>>>>>>// for leading zeros (zf=zero fill): 34563>>>>>>>Function IntToStrRzf global number src# integer len# returns string 34565>>>>>>> function_return (replaces(" ",NumToStrR(src#,0,len#),"0")) // Fixed, Magnus Bergh 34566>>>>>>>End_Function 34567>>>>>>> 34567>>>>>>>Function NumToStrRzf global number src# integer dcp# integer len# returns string 34569>>>>>>> function_return (replaces(" ",NumToStrR(src#,dcp#,len#),"0")) 34570>>>>>>>End_Function 34571>>>>>>> 34571>>>>>>>// Use this to obtain the number of the least significant "non zero 34571>>>>>>>// decimal in src#. 0.702 will return 3 while 100 will return -2: 34571>>>>>>>Function NumberOfDecs global number src# returns integer 34573>>>>>>> integer count# 34573>>>>>>> string tmp# radix# 34573>>>>>>> if src# eq 0 function_return 0 // Special case 34576>>>>>>> move src# to tmp# // This removes superflous decimals 34577>>>>>>> get_attribute DF_DECIMAL_SEPARATOR to count# // Overload 34580>>>>>>> character count# to radix# // End overload 34581>>>>>>>> 34581>>>>>>> if radix# in src# function_return (length(tmp#)-pos(radix#,tmp#)) 34584>>>>>>> move 0 to count# 34585>>>>>>> while (right(tmp#,1)="0") 34589>>>>>>> move (left(tmp#,length(tmp#)-1)) to tmp# 34590>>>>>>> decrement count# 34591>>>>>>> end 34592>>>>>>>> 34592>>>>>>> function_return count# 34593>>>>>>>End_Function 34594>>>>>>> 34594>>>>>>>Function CurrentDecimalSeparator global returns string 34596>>>>>>> integer rval# 34596>>>>>>> get_attribute DF_DECIMAL_SEPARATOR to rval# 34599>>>>>>> function_return (character(rval#)) 34600>>>>>>>End_Function 34601>>>>>>> 34601>>>>>>>Procedure Set CurrentDecimalSeparator global string value# 34603>>>>>>> set_attribute DF_DECIMAL_SEPARATOR to (ascii(value#)) 34606>>>>>>>End_Procedure 34607>>>>>>> 34607>>>>>>> 34607>>>>>>>// StripFromLastOccurance takes two strings (src# and val#) as 34607>>>>>>>// arguments. src# is scanned backwards for occurrances of substring 34607>>>>>>>// val#. If found, the function will return a string equal to src# 34607>>>>>>>// truncated at the first character of the right most occurance of substring 34607>>>>>>>// val#. 34607>>>>>>>// 34607>>>>>>>// StripFromLastOccurance("To be or not to be...","be") = "To be or not to " 34607>>>>>>>// StripFromLastOccurance("Mary had a little lamb","white") = "" 34607>>>>>>>// StripFromLastOccurance("Mary had a little lamb","") = "Mary had a little lamb" 34607>>>>>>>// 34607>>>>>>>Function StripFromLastOccurance global string src# string val# returns string 34609>>>>>>> integer len# search_len# 34609>>>>>>> string tmp# 34609>>>>>>> length val# to search_len# 34610>>>>>>>> 34610>>>>>>> if search_len# eq 0 function_return src# 34613>>>>>>> repeat 34613>>>>>>>> 34613>>>>>>> length src# to len# 34614>>>>>>>> 34614>>>>>>> if len# le search_len# function_return "" 34617>>>>>>> move (right(src#,search_len#)) to tmp# 34618>>>>>>> if tmp# eq val# function_return (left(src#,len#-search_len#)) 34621>>>>>>> move (left(src#,len#-1)) to src# 34622>>>>>>> loop 34623>>>>>>>> 34623>>>>>>>End_Function 34624>>>>>>> 34624>>>>>>>Function GetFromLastOccurance global string src# string val# returns string 34626>>>>>>> function_return (replace(StripFromLastOccurance(src#,val#),src#,"")) 34627>>>>>>>End_Function 34628>>>>>>> 34628>>>>>>>// (ExtractWord("item1 item2"," ",0)) = "" 34628>>>>>>>// (ExtractWord("item1 item2"," ",1)) = "item1" 34628>>>>>>>// (ExtractWord("item1 item2"," ",2)) = "item2" 34628>>>>>>>// (ExtractWord("item1 item2"," ",3)) = "" 34628>>>>>>>// (ExtractWord(" item1 item2 "," ",x)) = 34628>>>>>>>// (ExtractWord("item1 item2"," ",x)) 34628>>>>>>>// 34628>>>>>>> // source delimiters item number 34628>>>>>>>Function ExtractWord global string src# string dlm# integer itm# returns string 34630>>>>>>> integer count# pos# in_item# len# 34630>>>>>>> string rval# atom# 34630>>>>>>> move "" to rval# 34631>>>>>>> move 0 to count# 34632>>>>>>> move 0 to in_item# 34633>>>>>>> move (length(src#)) to len# 34634>>>>>>> for pos# from 1 to len# 34640>>>>>>>> 34640>>>>>>> mid src# to atom# 1 pos# 34643>>>>>>>> 34643>>>>>>> if in_item# begin 34645>>>>>>> if atom# in dlm# move 0 to in_item# 34648>>>>>>> else if count# eq itm# append rval# atom# 34652>>>>>>> end 34652>>>>>>>> 34652>>>>>>> else begin 34653>>>>>>> ifnot atom# in dlm# begin 34655>>>>>>> increment count# 34656>>>>>>> move 1 to in_item# 34657>>>>>>> if count# eq itm# move atom# to rval# 34660>>>>>>> end 34660>>>>>>>> 34660>>>>>>> end 34660>>>>>>>> 34660>>>>>>> loop 34661>>>>>>>> 34661>>>>>>> function_return rval# 34662>>>>>>>End_Function 34663>>>>>>> 34663>>>>>>>Function ExtractItem global string src# string dlm# integer itm# returns string 34665>>>>>>> Function_Return (ExtractWord(src#,dlm#,itm#)) 34666>>>>>>>End_Function 34667>>>>>>> // source delimiters 34667>>>>>>>Function HowManyWords global string src# string dlm# returns integer 34669>>>>>>> integer count# pos# in_item# len# 34669>>>>>>> string atom# 34669>>>>>>> move 0 to count# 34670>>>>>>> move 0 to in_item# 34671>>>>>>> move (length(src#)) to len# 34672>>>>>>> for pos# from 1 to len# 34678>>>>>>>> 34678>>>>>>> mid src# to atom# 1 pos# 34681>>>>>>>> 34681>>>>>>> if in_item# begin 34683>>>>>>> if atom# in dlm# move 0 to in_item# 34686>>>>>>> end 34686>>>>>>>> 34686>>>>>>> else begin 34687>>>>>>> ifnot atom# in dlm# begin 34689>>>>>>> increment count# 34690>>>>>>> move 1 to in_item# 34691>>>>>>> end 34691>>>>>>>> 34691>>>>>>> end 34691>>>>>>>> 34691>>>>>>> loop 34692>>>>>>>> 34692>>>>>>> function_return count# 34693>>>>>>>end_function 34694>>>>>>>Function HowManyItems global string src# string dlm# returns integer 34696>>>>>>> function_return (HowManyWords(src#,dlm#)) 34697>>>>>>>end_function 34698>>>>>>> 34698>>>>>>>Function ExtractWord2 global string src# string dlm# integer itm# returns string 34700>>>>>>> integer count# pos# len# 34700>>>>>>> string rval# char# 34700>>>>>>> move "" to rval# 34701>>>>>>> move 1 to count# 34702>>>>>>> move (length(src#)) to len# 34703>>>>>>> for pos# from 1 to len# 34709>>>>>>>> 34709>>>>>>> mid src# to char# 1 pos# 34712>>>>>>>> 34712>>>>>>> if char# in dlm# begin 34714>>>>>>> if itm# eq count# function_return rval# 34717>>>>>>> increment count# 34718>>>>>>> end 34718>>>>>>>> 34718>>>>>>> else if itm# eq count# move (rval#+char#) to rval# 34722>>>>>>> loop 34723>>>>>>>> 34723>>>>>>> function_return rval# 34724>>>>>>>End_Function 34725>>>>>>> // source delimiters 34725>>>>>>>Function HowManyWords2 global string src# string dlm# returns integer 34727>>>>>>> integer count# pos# len# 34727>>>>>>> string char# 34727>>>>>>> move 1 to count# 34728>>>>>>> move (length(src#)) to len# 34729>>>>>>> for pos# from 1 to len# 34735>>>>>>>> 34735>>>>>>> mid src# to char# 1 pos# 34738>>>>>>>> 34738>>>>>>> if char# in dlm# increment count# 34741>>>>>>> loop 34742>>>>>>>> 34742>>>>>>> function_return count# 34743>>>>>>>end_function 34744>>>>>>> // source legal char item number 34744>>>>>>>Function ExtractItemNeg global string src# string lch# integer itm# returns string 34746>>>>>>> integer count# pos# in_item# len# 34746>>>>>>> string rval# atom# 34746>>>>>>> move "" to rval# 34747>>>>>>> move 0 to count# 34748>>>>>>> move 0 to in_item# 34749>>>>>>> move (length(src#)) to len# 34750>>>>>>> for pos# from 1 to len# 34756>>>>>>>> 34756>>>>>>> mid src# to atom# 1 pos# 34759>>>>>>>> 34759>>>>>>> if in_item# begin 34761>>>>>>> ifnot atom# in lch# move 0 to in_item# 34764>>>>>>> else if count# eq itm# append rval# atom# 34768>>>>>>> end 34768>>>>>>>> 34768>>>>>>> else begin 34769>>>>>>> if atom# in lch# begin 34771>>>>>>> increment count# 34772>>>>>>> move 1 to in_item# 34773>>>>>>> if count# eq itm# move atom# to rval# 34776>>>>>>> end 34776>>>>>>>> 34776>>>>>>> end 34776>>>>>>>> 34776>>>>>>> loop 34777>>>>>>>> 34777>>>>>>> function_return rval# 34778>>>>>>>end_function 34779>>>>>>> 34779>>>>>>>// ExtractInteger("123 456 789",0) = 0 34779>>>>>>>// ExtractInteger("123 456 789",2) = 456 34779>>>>>>>// ExtractInteger("123 456 789",4) = 0 34779>>>>>>> 34779>>>>>>>function ExtractInteger global string str# integer itm# returns integer 34781>>>>>>> function_return (integer(ExtractItemNeg(str#,"0123456789",itm#))) 34782>>>>>>>end_function 34783>>>>>>> 34783>>>>>>>function HowManyIntegers global string str# returns integer 34785>>>>>>> integer rval# pos# len# in_int# 34785>>>>>>> move 0 to in_int# //in integer? 34786>>>>>>> move 0 to rval# 34787>>>>>>> move (length(str#)) to len# 34788>>>>>>> for pos# from 1 to len# 34794>>>>>>>> 34794>>>>>>> if (mid(str#,1,pos#)) in "0123456789" begin 34796>>>>>>> ifnot in_int# begin 34798>>>>>>> increment rval# 34799>>>>>>> move 1 to in_int# 34800>>>>>>> end 34800>>>>>>>> 34800>>>>>>> end 34800>>>>>>>> 34800>>>>>>> else if in_int# move 0 to in_int# 34804>>>>>>> loop 34805>>>>>>>> 34805>>>>>>> function_return rval# 34806>>>>>>>end_function 34807>>>>>>> 34807>>>>>>>function IsIntegerPresent global string str# integer int# returns integer 34809>>>>>>> integer max# itm# 34809>>>>>>> if str# eq "" function_return 0 34812>>>>>>> move (HowManyIntegers(str#)) to max# 34813>>>>>>> for itm# from 1 to max# 34819>>>>>>>> 34819>>>>>>> if (ExtractInteger(str#,itm#)=int#) function_return 1 34822>>>>>>> loop 34823>>>>>>>> 34823>>>>>>> function_return 0 34824>>>>>>>end_function 34825>>>>>>> 34825>>>>>>>function AddIntegerToString global string str# integer int# returns string 34827>>>>>>> function_return (trim(str#+" "+string(int#))) 34828>>>>>>>end_function 34829>>>>>>> 34829>>>>>>>// This function is used to compose a new string from an existing string. This 34829>>>>>>>// is similar to the way Windows 95 generates 8.3 file names. 34829>>>>>>> 34829>>>>>>>// For example: StringIncrementId("STURE",8) = "STURE ~1" 34829>>>>>>>// StringIncrementId("STURE ~1",8) = "STURE ~2" 34829>>>>>>>// StringIncrementId("STURE ~2",8) = "STURE ~3" 34829>>>>>>>// etc... 34829>>>>>>>function StringIncrementId global string id# integer len# returns string 34831>>>>>>> string char# 34831>>>>>>> if (mid(id#,1,len#-1)) eq "~" begin 34833>>>>>>> move (mid(id#,1,len#)) to char# 34834>>>>>>> if (ascii(char#)) lt 93 function_return (overstrike(character(ascii(char#)+1),id#,len#)) 34837>>>>>>> else function_return "" 34839>>>>>>> end 34839>>>>>>>> 34839>>>>>>> function_return (overstrike("~1",id#,len#-1)) 34840>>>>>>>end_function 34841>>>>>>> 34841>>>>>>>function StringUppercaseFirstLetters global string str# returns string 34843>>>>>>> integer len# pos# in_word# 34843>>>>>>> string rval# char# 34843>>>>>>> move (lowercase(str#)) to str# 34844>>>>>>> move (length(str#)) to len# 34845>>>>>>> move 0 to in_word# 34846>>>>>>> for pos# from 1 to len# 34852>>>>>>>> 34852>>>>>>> move (mid(str#,1,pos#)) to char# 34853>>>>>>> if char# eq "" move 0 to in_word# 34856>>>>>>> else begin 34857>>>>>>> ifnot in_word# begin 34859>>>>>>> uppercase char# to char# 34860>>>>>>>> 34860>>>>>>> move 1 to in_word# 34861>>>>>>> end 34861>>>>>>>> 34861>>>>>>> end 34861>>>>>>>> 34861>>>>>>> move (rval#+char#) to rval# 34862>>>>>>> loop 34863>>>>>>>> 34863>>>>>>> function_return rval# 34864>>>>>>>end_function 34865>>>>>>> 34865>>>>>>>function StringLeftBut global string str# integer but# returns string 34867>>>>>>> function_return (left(str#,length(str#)-but# max 0)) 34868>>>>>>>end_function 34869>>>>>>> 34869>>>>>>>function StringRightBut global string str# integer but# returns string 34871>>>>>>> function_return (right(str#,length(str#)-but# max 0)) 34872>>>>>>>end_function 34873>>>>>>> 34873>>>>>>>//> This function returns 1 if lsString is an integer and 2 if it 34873>>>>>>>//> is a number (the function does not currently handle thousand seps) 34873>>>>>>>function StringIsNumber global string lsString integer liDecSep returns integer 34875>>>>>>> integer liLen liPos liDecSepFound liRval 34875>>>>>>> string lsChar 34875>>>>>>> move 1 to liRval 34876>>>>>>> move 0 to liDecSepFound 34877>>>>>>> move (trim(lsString)) to lsString 34878>>>>>>> if (left(lsString,1)="-") move (replace("-",lsString,"")) to lsString 34881>>>>>>> move (length(lsString)) to liLen 34882>>>>>>> for liPos from 1 to liLen 34888>>>>>>>> 34888>>>>>>> move (mid(lsString,1,liPos)) to lsChar 34889>>>>>>> if (ascii(lsChar)) eq liDecSep begin 34891>>>>>>> if liDecSepFound function_return 0 34894>>>>>>> move 1 to liDecSepFound 34895>>>>>>> end 34895>>>>>>>> 34895>>>>>>> else ifnot ("0123456789" contains lsChar) function_return 0 34899>>>>>>> loop 34900>>>>>>>> 34900>>>>>>> function_return liRval 34901>>>>>>>end_function 34902>>>>>>>function StringIsInteger global string lsString returns integer 34904>>>>>>> integer liPos liLen 34904>>>>>>> move (trim(lsString)) to lsString 34905>>>>>>> if (left(lsString,1)="-") move (replace("-",lsString,"")) to lsString 34908>>>>>>> move (length(lsString)) to liLen 34909>>>>>>> for liPos from 1 to liLen 34915>>>>>>>> 34915>>>>>>> ifnot (pos(mid(lsString,1,liPos),"0123456789")) function_return DFFALSE 34918>>>>>>> loop 34919>>>>>>>> 34919>>>>>>> function_return DFTRUE 34920>>>>>>>end_function 34921>>>>>>> 34921>>>>>>>function StringFieldType global integer liType returns string 34923>>>>>>> if liType eq DF_ASCII function_return "ASCII" 34926>>>>>>> if liType eq DF_BCD function_return "Number" 34929>>>>>>> if liType eq DF_DATE function_return "Date" 34932>>>>>>> if liType eq DF_OVERLAP function_return "Overlap" 34935>>>>>>> if liType eq DF_TEXT function_return "Text" 34938>>>>>>> if liType eq DF_BINARY function_return "Binary" 34941>>>>>>> function_return "Un-defined" 34942>>>>>>>end_function 34943>>>>>>> 34943>>>>>>>function StringFieldLenText global integer liType integer liLen integer liDec returns string 34945>>>>>>> if liType eq DF_BCD function_return (NumToStr(liLen+(liDec/10.0),1)) 34948>>>>>>> else function_return (string(liLen)) 34950>>>>>>>end_function 34951>>>>>>>function StringFieldText global integer liType integer liLen integer liDec returns string 34953>>>>>>> string lsRval 34953>>>>>>> move "# (#)" to lsRval 34954>>>>>>> replace "#" in lsRval with (StringFieldType(liType)) 34956>>>>>>> replace "#" in lsRval with (StringFieldLenText(liType,liLen,liDec)) 34958>>>>>>> function_return lsRval 34959>>>>>>>end_function 34960>>>>>>> 34960>>>>>>> 34960>>>>>>>function StringConsistsOf global string src# string tpl# returns integer 34962>>>>>>> integer count# len# 34962>>>>>>> trim src# to src# 34963>>>>>>>> 34963>>>>>>> move (length(src#)) to len# 34964>>>>>>> for count# from 1 to len# 34970>>>>>>>> 34970>>>>>>> ifnot (mid(src#,1,count#)) in tpl# function_return 0 34973>>>>>>> loop 34974>>>>>>>> 34974>>>>>>> function_return 1 34975>>>>>>>end_function 34976>>>>>>> 34976>>>>>>>function StringBeginsWith global string lsHostString string lsLeadInCharacters returns integer 34978>>>>>>> function_return (left(lsHostString,length(lsLeadInCharacters))=lsLeadInCharacters) 34979>>>>>>>end_function 34980>>>>>>> 34980>>>>>>>function StringEndsWith global string lsHostString string lsTrailingCharacters returns integer 34982>>>>>>> function_return (right(lsHostString,length(lsTrailingCharacters))=lsTrailingCharacters) 34983>>>>>>>end_function 34984>>>>>>> 34984>>>>>>>function StringReverse global string lsValue returns string 34986>>>>>>> integer liLen liPos 34986>>>>>>> string lsRval lsChar 34986>>>>>>> move "" to lsRval 34987>>>>>>> move (length(lsValue)) to liLen 34988>>>>>>> for_ex liPos from liLen down_to 1 34995>>>>>>> move (lsRval+mid(lsValue,1,liPos)) to lsRval 34996>>>>>>> loop 34997>>>>>>>> 34997>>>>>>> function_return lsRval 34998>>>>>>>end_function 34999>>>>>>> 34999>>>>>>>function StringHead global string lsValue string lsDlm returns string 35001>>>>>>> integer liLen liPos 35001>>>>>>> move (length(lsValue)) to liLen 35002>>>>>>> for liPos from 1 to liLen 35008>>>>>>>> 35008>>>>>>> if (lsDlm contains mid(lsValue,1,liPos)) function_return (left(lsValue,liPos-1)) 35011>>>>>>> loop 35012>>>>>>>> 35012>>>>>>> function_return lsValue 35013>>>>>>>end_function 35014>>>>>>> 35014>>>>>>>function StringTail global string lsValue string lsDlm returns string 35016>>>>>>> integer liLen liPos 35016>>>>>>> move (length(lsValue)) to liLen 35017>>>>>>> for liPos from 1 to liLen 35023>>>>>>>> 35023>>>>>>> if (lsDlm contains mid(lsValue,1,liPos)) function_return (right(lsValue,liLen-liPos)) 35026>>>>>>> loop 35027>>>>>>>> 35027>>>>>>> function_return "" 35028>>>>>>>end_function 35029>>>>>>> 35029>>>>>>>// If function ConvertChar is not already defined we define it here: 35029>>>>>>> use WinBase Including file: Winbase.pkg (c:\VDF12\Pkg\Winbase.pkg) 35029>>>>>>>>>Use VDfBase.pkg 35029>>>>>>>>> 35029>>>>>>>>> 35029>>>>>>>>>//************************************************************************* 35029>>>>>>>>>//* 35029>>>>>>>>>//* Copyright (c) 1997 Data Access Corporation, Miami Florida, 35029>>>>>>>>>//* All rights reserved. 35029>>>>>>>>>//* DataFlex is a registered trademark of Data Access Corporation. 35029>>>>>>>>>//* 35029>>>>>>>>>//************************************************************************* 35029>>>>>>>>>//* 35029>>>>>>>>>//* Module Name: 35029>>>>>>>>>//* WINDOWS.PKG 35029>>>>>>>>>//* 35029>>>>>>>>>//* Creator: 35029>>>>>>>>>//* DataFlex 4.0 Development Team 35029>>>>>>>>>//* 01/01/1997 35029>>>>>>>>>//* 35029>>>>>>>>>//* Purpose: 35029>>>>>>>>>//* DataFlex 4.0 Windows classes and constants 35029>>>>>>>>>//* 35029>>>>>>>>>//* 07/23/96 JJT - New Class names 35029>>>>>>>>>//************************************************************************* 35029>>>>>>>>> 35029>>>>>>>>>//use ui 35029>>>>>>>>> 35029>>>>>>>>>//// This replacement creates an alternate symbol for Current_Object as used 35029>>>>>>>>>//// in message addressing. Future revisions of VDF will use SELF as the 35029>>>>>>>>>//// preferred addressing reference. 35029>>>>>>>>>//// 35029>>>>>>>>>//#replace SELF CURRENT_OBJECT 35029>>>>>>>>> 35029>>>>>>>>>//// this allows meta system to know about the runtime classes. 35029>>>>>>>>> 35029>>>>>>>>>//Use BaseData_Set.pkg // defines RT baseData_set 35029>>>>>>>>> 35029>>>>>>>>>//// define class used throughout system for mixins 35029>>>>>>>>>//Class Mixin Is A cObject 35029>>>>>>>>>//End_Class 35029>>>>>>>>> 35029>>>>>>>>>//Use ErrorNum.inc // allows all packages to use symbolic names for errors. 35029>>>>>>>>>//use registry.pkg // (obsolete) this just has defintiions of registry commands and constants 35029>>>>>>>>>//use dll.pkg // support for Dll stuff 35029>>>>>>>>>//use InetTransfer.pkg // add defintions for Internet transfer classes 35029>>>>>>>>> 35029>>>>>>>>>////* Justification modes */ 35029>>>>>>>>> 35029>>>>>>>>>//#REPLACE JMODE_LEFT |CI0 35029>>>>>>>>>//#REPLACE JMODE_CENTER |CI1 35029>>>>>>>>>//#REPLACE JMODE_RIGHT |CI2 35029>>>>>>>>>//#REPLACE JMODE_TOP |CI4 35029>>>>>>>>>//#REPLACE JMODE_BOTTOM |CI8 35029>>>>>>>>>//#REPLACE JMODE_VCENTER |CI512 //12 35029>>>>>>>>>//#REPLACE JMODE_WRAP |CI16 35029>>>>>>>>> 35029>>>>>>>>>//// New Justification modes - undocumented vertical-center by MS 35029>>>>>>>>>////#REPLACE jmCenter $0001 35029>>>>>>>>>////#REPLACE jmVCenter $1000 35029>>>>>>>>>////#REPLACE jmAllCenter $1001 35029>>>>>>>>> 35029>>>>>>>>>////* Form Justificationmodes */ 35029>>>>>>>>>//#REPLACE FORM_DISPLAYLEFT |CI0 35029>>>>>>>>>//#REPLACE FORM_DISPLAYCENTER |CI$0001 35029>>>>>>>>>//#REPLACE FORM_DISPLAYRIGHT |CI$0002 35029>>>>>>>>>//#REPLACE FORM_EDITLEFT |CI$0000 35029>>>>>>>>>//#REPLACE FORM_EDITRIGHT |CI$0800 35029>>>>>>>>> 35029>>>>>>>>>////* Button Aspects */ 35029>>>>>>>>>//#REPLACE BASPECT_NONE |CI0 35029>>>>>>>>>//#REPLACE BASPECT_PUSHBUTTON |CI1 35029>>>>>>>>>//#REPLACE BASPECT_CHECKBOX |CI2 35029>>>>>>>>>//#REPLACE BASPECT_RADIO |CI3 35029>>>>>>>>>//#REPLACE BASPECT_TRISTATE |CI4 35029>>>>>>>>>//#REPLACE BASPECT_PULLDOWN |CI5 35029>>>>>>>>>//#REPLACE BASPECT_COMBOBUTTON |CI6 35029>>>>>>>>>//#REPLACE BASPECT_FORM |CI7 35029>>>>>>>>>//#REPLACE BASPECT_COMBOFORM |CI8 35029>>>>>>>>>//#REPLACE BASPECT_ACTIONBAR |CI9 35029>>>>>>>>> 35029>>>>>>>>> 35029>>>>>>>>>//#REPLACE BASPECT_MULTI |CI128 35029>>>>>>>>>//#REPLACE BASPECT_PUSHBUTTONLIST |CI129 35029>>>>>>>>>//#REPLACE BASPECT_CHECKLIST |CI130 35029>>>>>>>>>//#REPLACE BASPECT_RADIOLIST |CI131 35029>>>>>>>>>//#REPLACE BASPECT_TRISTATELIST |CI132 35029>>>>>>>>> 35029>>>>>>>>>//// Map modes 35029>>>>>>>>>//#REPLACE MAP_DEVICE |CI0 35029>>>>>>>>>//#REPLACE MAP_CHARACTER |CI1 35029>>>>>>>>>//#REPLACE MAP_DIALOG |CI2 35029>>>>>>>>>//#REPLACE MAP_RATIO |CI3 35029>>>>>>>>> 35029>>>>>>>>>////* Borders */ 35029>>>>>>>>>//#REPLACE BORDER_NONE |CI0 35029>>>>>>>>>//#REPLACE BORDER_NORMAL |CI1 35029>>>>>>>>>//#REPLACE BORDER_DIALOG |CI2 35029>>>>>>>>>//#REPLACE BORDER_THICK |CI3 35029>>>>>>>>>//#REPLACE BORDER_CLIENTEDGE |CI4 35029>>>>>>>>>//#REPLACE BORDER_WINDOWEDGE |CI5 35029>>>>>>>>>//#REPLACE BORDER_STATICEDGE |CI6 35029>>>>>>>>> 35029>>>>>>>>>////* View Modes */ 35029>>>>>>>>>//#REPLACE VIEWMODE_NORMAL |CI0 35029>>>>>>>>>//#REPLACE VIEWMODE_ICONIZE |CI1 35029>>>>>>>>>//#REPLACE VIEWMODE_ZOOM |CI2 35029>>>>>>>>> 35029>>>>>>>>>//// Data Types 35029>>>>>>>>>//#REPLACE DATE_WINDOW |CI128 35029>>>>>>>>>//#REPLACE ASCII_WINDOW |CI255 35029>>>>>>>>> 35029>>>>>>>>>//// Make Proportional constants 35029>>>>>>>>> 35029>>>>>>>>>//#REPLACE MP_SIZE |CI0 // the window was resized 35029>>>>>>>>>//#REPLACE MP_ACTIONBAR |CI1 // an action bar was added or deleted 35029>>>>>>>>>//#REPLACE MP_BORDER |CI2 // the border style was changed 35029>>>>>>>>>//#REPLACE MP_CAPTION |CI3 // the caption_bar was added or deleted 35029>>>>>>>>>//#REPLACE MP_MAPMODE |CI4 // switched to map_ratio 35029>>>>>>>>>//#REPLACE MP_MAPRATIOS |CI5 // program changed ratios with message 35029>>>>>>>>> 35029>>>>>>>>>//// ImageList constants 35029>>>>>>>>>//#REPLACE ILC_MASK |CI$0001 35029>>>>>>>>>//#REPLACE ILC_COLOR |CI$0000 35029>>>>>>>>>//#REPLACE ILC_COLORDDB |CI$00FE 35029>>>>>>>>>//#REPLACE ILC_COLOR4 |CI$0004 35029>>>>>>>>>//#REPLACE ILC_COLOR8 |CI$0008 35029>>>>>>>>>//#REPLACE ILC_COLOR16 |CI$0010 35029>>>>>>>>>//#REPLACE ILC_COLOR24 |CI$0018 35029>>>>>>>>>//#REPLACE ILC_COLOR32 |CI$0020 35029>>>>>>>>>//#REPLACE ILC_PALETTE |CI$0800 35029>>>>>>>>> 35029>>>>>>>>>//// Buttonbar constants 35029>>>>>>>>>//// Button Styles 35029>>>>>>>>>//#REPLACE TBSTYLE_BUTTON 0 35029>>>>>>>>>//#REPLACE TBSTYLE_SEP 1 35029>>>>>>>>>//#REPLACE TBSTYLE_CHECK 2 35029>>>>>>>>>//#REPLACE TBSTYLE_GROUP 4 35029>>>>>>>>>//#REPLACE TBSTYLE_CHECKGROUP (TBSTYLE_GROUP IOR TBSTYLE_CHECK) 35029>>>>>>>>> 35029>>>>>>>>>//#REPLACE IDB_STANDARD 1 35029>>>>>>>>>//#REPLACE IDB_VIEW 2 35029>>>>>>>>>//#REPLACE IDB_SMALL 0 35029>>>>>>>>>//#REPLACE IDB_LARGE 4 35029>>>>>>>>> 35029>>>>>>>>>//// icon indexes for standard bitmaps 35029>>>>>>>>>//#REPLACE ICO_STD_CUT 0 35029>>>>>>>>>//#REPLACE ICO_STD_COPY 1 35029>>>>>>>>>//#REPLACE ICO_STD_PASTE 2 35029>>>>>>>>>//#REPLACE ICO_STD_UNDO 3 35029>>>>>>>>>//#REPLACE ICO_STD_REDOW 4 35029>>>>>>>>>//#REPLACE ICO_STD_DELETE 5 35029>>>>>>>>>//#REPLACE ICO_STD_FILENEW 6 35029>>>>>>>>>//#REPLACE ICO_STD_FILEOPEN 7 35029>>>>>>>>>//#REPLACE ICO_STD_FILESAVE 8 35029>>>>>>>>>//#REPLACE ICO_STD_PRINTPRE 9 35029>>>>>>>>>//#REPLACE ICO_STD_PROPERTIES 10 35029>>>>>>>>>//#REPLACE ICO_STD_HELP 11 35029>>>>>>>>>//#REPLACE ICO_STD_FIND 12 35029>>>>>>>>>//#REPLACE ICO_STD_REPLACE 13 35029>>>>>>>>>//#REPLACE ICO_STD_PRINT 14 35029>>>>>>>>> 35029>>>>>>>>>//// icon indexes for standard view bitmaps 35029>>>>>>>>>//#REPLACE ICO_VIEW 15 35029>>>>>>>>>//#REPLACE ICO_VIEW_LARGEICONS (ICO_VIEW + 0) 35029>>>>>>>>>//#REPLACE ICO_VIEW_SMALLICONS (ICO_VIEW + 1) 35029>>>>>>>>>//#REPLACE ICO_VIEW_LIST (ICO_VIEW + 2) 35029>>>>>>>>>//#REPLACE ICO_VIEW_DETAILS (ICO_VIEW + 3) 35029>>>>>>>>>//#REPLACE ICO_VIEW_SORTNAME (ICO_VIEW + 4) 35029>>>>>>>>>//#REPLACE ICO_VIEW_SORTSIZE (ICO_VIEW + 5) 35029>>>>>>>>>//#REPLACE ICO_VIEW_SORTDATE (ICO_VIEW + 6) 35029>>>>>>>>>//#REPLACE ICO_VIEW_SORTTYPE (ICO_VIEW + 7) 35029>>>>>>>>>//#REPLACE ICO_VIEW_PARENTFOLDER (ICO_VIEW + 8) 35029>>>>>>>>>//#REPLACE ICO_VIEW_NETCONNECT (ICO_VIEW + 9) 35029>>>>>>>>>//#REPLACE ICO_VIEW_NETDISCONNECT (ICO_VIEW + 10) 35029>>>>>>>>>//#REPLACE ICO_VIEW_NEWFOLDER (ICO_VIEW + 11) 35029>>>>>>>>> 35029>>>>>>>>>//#REPLACE ICO_USER (ICO_VIEW_NEWFOLDER+1) 35029>>>>>>>>> 35029>>>>>>>>>//// MAPI constants 35029>>>>>>>>>//#REPLACE MAPI_ORIG 0 // Recipient is message originator 35029>>>>>>>>>//#REPLACE MAPI_TO 1 // Recipient is a primary recipient 35029>>>>>>>>>//#REPLACE MAPI_CC 2 // Recipient is a copy recipient 35029>>>>>>>>>//#REPLACE MAPI_BCC 3 // Recipient is blind copy recipient 35029>>>>>>>>> 35029>>>>>>>>>//#replace MAPI_DIALOG |CI$00000008 35029>>>>>>>>> 35029>>>>>>>>>//#replace MAPI_LOGON_UI |CI$00000001 35029>>>>>>>>>//#replace MAPI_PASSWORD_UI |CI$00020000 35029>>>>>>>>>//#replace MAPI_NEW_SESSION |CI$00000002 35029>>>>>>>>>//#replace MAPI_FORCE_DOWNLOAD |CI$00001000 35029>>>>>>>>>//#replace MAPI_ALLOW_OTHERS |CI$00000008 35029>>>>>>>>>//#replace MAPI_EXPLICIT_PROFILE |CI$00000010 35029>>>>>>>>>//#replace MAPI_EXTENDED |CI$00000020 35029>>>>>>>>>//#replace MAPI_USE_DEFAULT |CI$00000040 35029>>>>>>>>> 35029>>>>>>>>>//#replace MAPI_SIMPLE_DEFAULT (MAPI_LOGON_UI + MAPI_FORCE_DOWNLOAD + MAPI_ALLOW_OTHERS) 35029>>>>>>>>>//#replace MAPI_SIMPLE_EXPLICIT (MAPI_NEW_SESSION + MAPI_FORCE_DOWNLOAD + MAPI_EXPLICIT_PROFILE) 35029>>>>>>>>> 35029>>>>>>>>>//// MAPIFindNext() flags. 35029>>>>>>>>>//#replace MAPI_UNREAD_ONLY (|CI$00000020) 35029>>>>>>>>>//#replace MAPI_GUARANTEE_FIFO |CI$00000100 35029>>>>>>>>>//#replace MAPI_LONG_MSGID |CI$00004000 35029>>>>>>>>> 35029>>>>>>>>>//// MAPIReadMail() flags. 35029>>>>>>>>>//#replace MAPI_PEEK |CI$00000080 35029>>>>>>>>>//#replace MAPI_SUPPRESS_ATTACH |CI$00000800 35029>>>>>>>>>//#replace MAPI_BODY_AS_FILE |CI$00000200 35029>>>>>>>>> 35029>>>>>>>>>//#replace MAPI_ENVELOPE_ONLY |CI$00000040 35029>>>>>>>>> 35029>>>>>>>>>//// Masked Edit control constants 35029>>>>>>>>>//#REPLACE MASK_BOOLEAN_WINDOW 512 35029>>>>>>>>>//#REPLACE MASK_CLOCK_WINDOW 1024 35029>>>>>>>>>//#REPLACE MASK_CURRENCY_WINDOW 2048 35029>>>>>>>>>//#REPLACE MASK_DATE_WINDOW 4096 35029>>>>>>>>>//#REPLACE MASK_DATETIME_WINDOW 8192 35029>>>>>>>>>//#REPLACE MASK_WINDOW 16384 35029>>>>>>>>>//#REPLACE MASK_NUMERIC_WINDOW 32768 35029>>>>>>>>>//#REPLACE MASK_TIME 65536 35029>>>>>>>>> 35029>>>>>>>>>//// Form Button constants 35029>>>>>>>>>//#REPLACE FORM_BUTTON_NONE 0 35029>>>>>>>>>//#REPLACE FORM_BUTTON_PROMPT 1 35029>>>>>>>>>//#REPLACE FORM_BUTTON_SPIN 2 35029>>>>>>>>>//#REPLACE FORM_BUTTON_SPIN_WRAP 3 35029>>>>>>>>> 35029>>>>>>>>>//// Grid Modes 35029>>>>>>>>>//#REPLACE GRID_VISIBLE_NONE 0 35029>>>>>>>>>//#REPLACE GRID_VISIBLE_HORZ 1 35029>>>>>>>>>//#REPLACE GRID_VISIBLE_VERT 2 35029>>>>>>>>>//#REPLACE GRID_VISIBLE_BOTH (GRID_VISIBLE_HORZ+GRID_VISIBLE_VERT) 35029>>>>>>>>> 35029>>>>>>>>>//// Bitmap Styles 35029>>>>>>>>>//#REPLACE BITMAP_ACTUAL 0 // actual size 35029>>>>>>>>>//#REPLACE BITMAP_STRETCH 1 // stretch to client size 35029>>>>>>>>>//#REPLACE BITMAP_CENTER 2 // center in client 35029>>>>>>>>>//#REPLACE BITMAP_TILE 3 // tile inside client 35029>>>>>>>>> 35029>>>>>>>>> 35029>>>>>>>>>//Enum_List 35029>>>>>>>>>// Define anNone for 0 35029>>>>>>>>>// Define anTop for 1 35029>>>>>>>>>// Define anBottom for 2 35029>>>>>>>>>// Define anTopBottom for 3 35029>>>>>>>>>// Define anLeft for 4 35029>>>>>>>>>// Define anTopLeft for 5 35029>>>>>>>>>// Define anBottomLeft for 6 35029>>>>>>>>>// Define anTopBottomLeft for 7 35029>>>>>>>>>// Define anRight for 8 35029>>>>>>>>>// Define anTopRight for 9 35029>>>>>>>>>// Define anBottomRight for 10 35029>>>>>>>>>// Define anTopBottomRight for 11 35029>>>>>>>>>// Define anLeftRight for 12 35029>>>>>>>>>// Define anTopLeftRight for 13 35029>>>>>>>>>// Define anBottomLeftRight for 14 35029>>>>>>>>>// Define anAll for 15 35029>>>>>>>>>//End_Enum_List 35029>>>>>>>>> 35029>>>>>>>>>//// This symbol can be used to detect if an object is in its preconstruction 35029>>>>>>>>>//// phase - before Contruct_Object is called. If BuildingObjectID is GT 0, the 35029>>>>>>>>>//// object is being initialized. The value contained in BuildingObjectID is actually 35029>>>>>>>>>//// the ID of the object currently being initialized. 35029>>>>>>>>>//// 35029>>>>>>>>> 35029>>>>>>>>>//#REPLACE BuildingObjectID |VI105 35029>>>>>>>>> 35029>>>>>>>>>//// flags can be added together. 35029>>>>>>>>> 35029>>>>>>>>>//#replace SHIFT_KEY_DOWN 1 35029>>>>>>>>>//#replace CTRL_KEY_DOWN 2 35029>>>>>>>>>//#replace ALT_KEY_DOWN 4 35029>>>>>>>>> 35029>>>>>>>>> 35029>>>>>>>>> 35029>>>>>>>>>//#REPLACE DRIVE_NOT_AVAILABLE 0 35029>>>>>>>>>//#REPLACE DRIVE_ROOT_NOT_EXIST 1 35029>>>>>>>>>//#REPLACE DRIVE_REMOVABLE 2 35029>>>>>>>>>//#REPLACE DRIVE_FIXED 3 35029>>>>>>>>>//#REPLACE DRIVE_REMOTE 4 35029>>>>>>>>>//#REPLACE DRIVE_CDROM 5 35029>>>>>>>>>//#REPLACE DRIVE_RAMDISK 6 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND GETDSKINFO RS#DG RC#DG . 35029>>>>>>>>>// !A [] $541 !1 !2 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//// This command is the same as GET_CURRENT_DIRECTORY except that a 35029>>>>>>>>>//// new parameter has been provided to get the directory of any drive. 35029>>>>>>>>>//// if specified drive is 0, the current drive is used. Drive A is 1. 35029>>>>>>>>>//// Usage: Get_Drive_Directory DriveNum to DirString 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND GET_DRIVE_DIRECTORY _RUND "TO" _RUNRIDCE . 35029>>>>>>>>>// !A [] $54F !3 !1 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND GET_WINDOWS_DIRECTORY "TO" _RUDINEC 35029>>>>>>>>>// !A [] $548 !2 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND GET_PRINTER_SETUP _RUND "TEMP""PERM" "TO" _RUND 35029>>>>>>>>>// #IFSAME !2 PERM 35029>>>>>>>>>// MOVE 1 TO STRMARK 35029>>>>>>>>>// #ELSE 35029>>>>>>>>>// MOVE 0 TO STRMARK 35029>>>>>>>>>// #ENDIF 35029>>>>>>>>>// !A [] $549 !1 !4 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND GET_ICON_COUNT _R "TO" _R 35029>>>>>>>>>// !A [] $54A !1 !3 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND DESTROY_CLASS _RUND . 35029>>>>>>>>>// !A [] $466 !1 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND GRAPHICS_ADJUST_COORDS _R _R . 35029>>>>>>>>>// !A [] $3A9 !1 !2 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND SET_DEFAULT_MAP_MODE "TO" _RDU . 35029>>>>>>>>>// !A [] $54E !2 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>>//#COMMAND GET_DEFAULT_MAP_MODE "TO" _RDU . 35029>>>>>>>>>// !A [] $550 !2 35029>>>>>>>>>//#ENDCOMMAND 35029>>>>>>>>> 35029>>>>>>>>> 35029>>>>>>>>>//// The GetAddress Command returns the memory address of a DF string 35029>>>>>>>>>//// variable. The command is necessary where external function require 35029>>>>>>>>>//// The address of a string to be passed. 35029>>>>>>>>> 35029>>>>>>>>>Use windows.pkg // this now lives here. (you don't need to ever use this). 35029>>>>>>> Function ConvertChar Global integer bToAnsi String sString Returns String 35031>>>>>>> pointer psString 35031>>>>>>> integer iVoid bIsCString 35031>>>>>>> Move (ascii(Right(sString,1))=0) to bIsCString 35032>>>>>>> If Not bISCString Append sString (character(0)) 35035>>>>>>> GetAddress Of sString To psString 35036>>>>>>> if bToAnsi Move (OEMToANSI(psString,psString)) To iVoid 35039>>>>>>> else Move (ANSItoOEM(psString,psString)) To iVoid 35041>>>>>>> Function_Return (if(bIsCString, sString, cstring(sString))) 35042>>>>>>> End_Function 35043>>>>>>> 35043>>>>>>>function StringAnsiToOem global string str# returns string 35045>>>>>>> function_return (ConvertChar(0,str#)) 35046>>>>>>>end_function 35047>>>>>>> 35047>>>>>>>function StringOemToAnsi global string str# returns string 35049>>>>>>> function_return (ConvertChar(1,str#)) 35050>>>>>>>end_function 35051>>>>>>> 35051>>>>>>>function RemoveDblBlanks global string lsValue returns string 35053>>>>>>> integer fin# 35053>>>>>>> move 0 to fin# 35054>>>>>>> repeat 35054>>>>>>>> 35054>>>>>>> move (replaces(" ",lsValue," ")) to lsValue 35055>>>>>>> ifnot " " in lsValue move 1 to fin# 35058>>>>>>> until fin# 35060>>>>>>> function_return lsValue 35061>>>>>>>end_function 35062>>>>>>> 35062>>>>>>>function ByteToHex global integer byte# returns string 35064>>>>>>> function_return (mid("0123456789ABCDEF",1,byte#/16+1)+mid("0123456789ABCDEF",1,(byte# iand 15)+1)) 35065>>>>>>>end_function 35066>>>>>>> 35066>>>>>>>function HexToByte global string lsHex returns integer 35068>>>>>>> function_return (pos(left(lsHex,1),"0123456789ABCDEF")-1*16+pos(right(lsHex,1),"0123456789ABCDEF")-1) 35069>>>>>>>end_function 35070>>>>>>> 35070>>>>>>>function StringToHex global string lsValue returns string 35072>>>>>>> integer liLen liPos 35072>>>>>>> string lsRval 35072>>>>>>> move (length(lsValue)) to liLen 35073>>>>>>> move "" to lsRval 35074>>>>>>> for liPos from 1 to liLen 35080>>>>>>>> 35080>>>>>>> move (string(lsRval)+string(ByteToHex(ascii(mid(lsValue,1,liPos))))) to lsRval 35081>>>>>>> loop 35082>>>>>>>> 35082>>>>>>> function_return lsRval 35083>>>>>>>end_function 35084>>>>>>> 35084>>>>>>>function HexToString global string lsValue returns string 35086>>>>>>> integer liLen liPos 35086>>>>>>> string lsRval 35086>>>>>>> move (length(lsValue)/2) to liLen 35087>>>>>>> move "" to lsRval 35088>>>>>>> for liPos from 1 to liLen 35094>>>>>>>> 35094>>>>>>> move (string(lsRval)+string(HexToByte(ascii(mid(lsValue,2,liPos*2-1))))) to lsRval 35095>>>>>>> loop 35096>>>>>>>> 35096>>>>>>> function_return lsRval 35097>>>>>>>end_function 35098>>>>>>> 35098>>>>>>>function Text_RemoveTrailingCr global string lsValue returns string 35100>>>>>>> integer fin# 35100>>>>>>> string char# char10# char255# char13# 35100>>>>>>> move 0 to fin# 35101>>>>>>> move (character(10)) to char10# 35102>>>>>>> move (character(13)) to char13# 35103>>>>>>> move (character(255)) to char255# 35104>>>>>>> repeat 35104>>>>>>>> 35104>>>>>>> ifnot (length(lsValue)) function_return "" 35107>>>>>>> move (right(lsValue,1)) to char# 35108>>>>>>> if (char#=char10# or char#=" " or char#=char13# or char#=char255#) move (left(lsValue,(length(lsValue)-1))) to lsValue 35111>>>>>>> else move 1 to fin# 35113>>>>>>> until fin# 35115>>>>>>> function_return lsValue 35116>>>>>>>end_function 35117>>>>>>> 35117>>>>>>>function Text_RTrim global string lsValue returns string 35119>>>>>>> move (rtrim(replaces(character(255),lsValue," "))) to lsValue 35120>>>>>>> function_return (Text_RemoveTrailingCr(lsValue)) 35121>>>>>>>end_function 35122>>>>>>> 35122>>>>>>>function Text_Trim global string lsValue returns string 35124>>>>>>> move (trim(replaces(character(255),lsValue," "))) to lsValue 35125>>>>>>> function_return (Text_RemoveTrailingCr(lsValue)) 35126>>>>>>>end_function 35127>>>>>>> 35127>>>>>>>function Text_Compress global string lsValue returns string 35129>>>>>>> move (replaces(character(10),lsValue," ")) to lsValue 35130>>>>>>> trim lsValue to lsValue 35131>>>>>>>> 35131>>>>>>> move (RemoveDblBlanks(lsValue)) to lsValue 35132>>>>>>> function_return lsValue 35133>>>>>>>end_function 35134>>>>>>> 35134>>>>>>>function Text_CompressSubstCr global string lsValue string new_line# returns string 35136>>>>>>> move (replaces(character(13),lsValue,"")) to lsValue 35137>>>>>>> function_return (RemoveDblBlanks(trim(replaces(character(10),Text_RemoveTrailingCr(lsValue),new_line#)))) 35138>>>>>>>end_function 35139>>>>>>> 35139>>>>>>>class cText_Formatter is an array 35140>>>>>>> procedure construct_object integer img# 35142>>>>>>> forward send construct_object img# 35144>>>>>>> property integer pRmargin public 40 35145>>>>>>> property integer pCompress_state public 0 35146>>>>>>> property integer pTrim_state public 1 // 0=no trim, 1=trim, 2=rtrim 35147>>>>>>> property integer pSubst_below_32_state public 0 35148>>>>>>> end_procedure 35149>>>>>>> 35149>>>>>>> procedure add_item.s string lsValue 35151>>>>>>> integer char# 35151>>>>>>> if (pSubst_below_32_state(self)) begin 35153>>>>>>> for char# from 0 to 31 35159>>>>>>>> 35159>>>>>>> move (replaces(character(char#),lsValue," ")) to lsValue 35160>>>>>>> loop 35161>>>>>>>> 35161>>>>>>> end 35161>>>>>>>> 35161>>>>>>> set array_value item (item_count(self)) to lsValue 35162>>>>>>> end_procedure 35163>>>>>>> 35163>>>>>>> function split_word string lsValue integer len# returns string 35165>>>>>>> integer pos# 35165>>>>>>> string rval# 35165>>>>>>> move (pos("-",lsValue)) to pos# 35166>>>>>>> if (pos# and pos#<=len#) move (replace("-",lsValue," ")) to rval# 35169>>>>>>> else begin 35170>>>>>>> move (left(lsValue,len#)) to rval# 35171>>>>>>> move (rval#+" "+replace(rval#,lsValue,"")) to rval# 35172>>>>>>> end 35172>>>>>>>> 35172>>>>>>> function_return rval# // The space in the return value indicates 35173>>>>>>> end_function // where to split the word 35174>>>>>>> 35174>>>>>>> procedure format.s string lsValue 35176>>>>>>> integer Trim_state# done# pRmargin# word_done# pos# max# len# 35176>>>>>>> string word# line# lf# left# char# 35176>>>>>>> 35176>>>>>>> //pre-format: 35176>>>>>>> get pTrim_state to Trim_state# 35177>>>>>>> if Trim_state# eq 1 move (Text_Trim(lsValue)) to lsValue 35180>>>>>>> else if Trim_state# eq 2 move (Text_RTrim(lsValue)) to lsValue 35184>>>>>>> if (pCompress_state(self)) move (Text_Compress(lsValue)) to lsValue 35187>>>>>>> 35187>>>>>>> move (character(10)) to lf# 35188>>>>>>> get pRmargin to pRmargin# 35189>>>>>>> if pRmargin# gt 1 begin // Otherwise nothing makes sense! 35191>>>>>>> move 0 to done# 35192>>>>>>> move "" to line# 35193>>>>>>> move 1 to pos# 35194>>>>>>> move (length(lsValue)) to max# 35195>>>>>>> repeat 35195>>>>>>>> 35195>>>>>>> 35195>>>>>>> move "" to word# 35196>>>>>>> move 0 to word_done# 35197>>>>>>> repeat 35197>>>>>>>> 35197>>>>>>> if pos# gt max# move 1 to word_done# 35200>>>>>>> else begin 35201>>>>>>> mid lsValue to char# 1 pos# 35204>>>>>>>> 35204>>>>>>> if char# eq lf# begin // Line feed 35206>>>>>>> if word# eq "" begin 35208>>>>>>> move lf# to word# 35209>>>>>>> increment pos# 35210>>>>>>> end 35210>>>>>>>> 35210>>>>>>> move 1 to word_done# 35211>>>>>>> end 35211>>>>>>>> 35211>>>>>>> else begin 35212>>>>>>> if char# eq "" begin 35214>>>>>>> if word# eq "" increment pos# 35217>>>>>>> else move 1 to word_done# 35219>>>>>>> end 35219>>>>>>>> 35219>>>>>>> else begin 35220>>>>>>> move (word#+char#) to word# 35221>>>>>>> increment pos# 35222>>>>>>> end 35222>>>>>>>> 35222>>>>>>> end 35222>>>>>>>> 35222>>>>>>> end 35222>>>>>>>> 35222>>>>>>> until word_done# 35224>>>>>>> 35224>>>>>>> if word# eq "" move 1 to done# // We're done! 35227>>>>>>> else begin 35228>>>>>>> if word# eq lf# begin // If hard return: 35230>>>>>>> send add_item.s line# 35231>>>>>>> move "" to line# 35232>>>>>>> end 35232>>>>>>>> 35232>>>>>>> else begin // 35233>>>>>>> if (length(line#)+length(word#)+1) gt pRmargin# begin // Soft new line 35235>>>>>>> if line# ne "" begin 35237>>>>>>> send add_item.s line# // Could be that word is longer that pRmargin 35238>>>>>>> move "" to line# 35239>>>>>>> end 35239>>>>>>>> 35239>>>>>>> if (length(word#)) gt pRmargin# begin // Word IS longer that line! 35241>>>>>>> repeat 35241>>>>>>>> 35241>>>>>>> if line# eq "" move (pRmargin#-1) to len# 35244>>>>>>> else move (pRmargin#-length(line#)-2) to len# 35246>>>>>>> move (split_word(self,word#,len#)) to word# 35247>>>>>>> move (ExtractItem(word#," ",1)) to left# 35248>>>>>>> move (ExtractItem(word#," ",2)) to word# 35249>>>>>>> if word# eq "" move left# to line# 35252>>>>>>> else send add_item.s (left#+"-") 35254>>>>>>> until word# eq "" 35256>>>>>>> end 35256>>>>>>>> 35256>>>>>>> else move word# to line# 35258>>>>>>> end 35258>>>>>>>> 35258>>>>>>> else begin 35259>>>>>>> if line# ne "" move (line#+" "+word#) to line# // add word to line 35262>>>>>>> else move word# to line# 35264>>>>>>> end 35264>>>>>>>> 35264>>>>>>> end 35264>>>>>>>> 35264>>>>>>> end 35264>>>>>>>> 35264>>>>>>> until done# 35266>>>>>>> if line# ne "" send add_item.s line# 35269>>>>>>> end 35269>>>>>>>> 35269>>>>>>> end_procedure 35270>>>>>>>end_class // cText_Formatter 35271>>>>>>> 35271>>>>>>>desktop_section 35277>>>>>>> object oText_Formatter is a cText_Formatter no_image 35279>>>>>>> set pSubst_below_32_state to DFTRUE 35280>>>>>>> end_object 35281>>>>>>>end_desktop_section 35286>>>>>>> 35286>>>>>>>procedure Text_Format_Reset global 35288>>>>>>> send delete_data to (oText_Formatter(self)) 35289>>>>>>>end_procedure 35290>>>>>>> 35290>>>>>>>function Text_Format_LineCount global returns integer 35292>>>>>>> function_return (item_count(oText_Formatter(self))) 35293>>>>>>>end_function 35294>>>>>>> 35294>>>>>>>function Text_Format.sii global string lsValue integer liWidth integer lbReset returns integer 35296>>>>>>> integer lhObj 35296>>>>>>> if lbReset send Text_Format_Reset 35299>>>>>>> move (oText_Formatter(self)) to lhObj 35300>>>>>>> set pRmargin of lhObj to liWidth 35301>>>>>>> send format.s to lhObj lsValue 35302>>>>>>> function_return (item_count(lhObj)) 35303>>>>>>>end_function 35304>>>>>>> 35304>>>>>>>function Text_FormattedLine.i global integer liLine returns string 35306>>>>>>> function_return (string_value(oText_Formatter(self),liLine)) 35307>>>>>>>end_function 35308>>>>>>> 35308>>>>>>>function Text_FormattedText global returns string 35310>>>>>>> integer liItem liMax liObj 35310>>>>>>> string lsRval 35310>>>>>>> move "" to lsRval 35311>>>>>>> move (oText_Formatter(self)) to liObj 35312>>>>>>> get item_count of liObj to liMax 35313>>>>>>> get Text_Format_LineCount to liMax 35314>>>>>>> decrement liMax 35315>>>>>>> for liItem from 0 to liMax 35321>>>>>>>> 35321>>>>>>> move (lsRval+value(liObj,liItem)) to lsRval 35322>>>>>>> if liItem ne liMax move (lsRval+character(10)) to lsRval 35325>>>>>>> loop 35326>>>>>>>> 35326>>>>>>> function_return lsRval 35327>>>>>>>end_function 35328>>>>>>> 35328>>>>>>>string gs$CollateString 255 // Here's the string 35328>>>>>>> 35328>>>>>>>object oCollateStringBuilder is an Array 35330>>>>>>> procedure MakeCollateString 35333>>>>>>> integer liCharacter liMax liItem 35333>>>>>>> string lsRval 35333>>>>>>> for liCharacter from 32 to 255 35339>>>>>>>> 35339>>>>>>> set value item (liCharacter-32) to (character(liCharacter)) 35340>>>>>>> loop 35341>>>>>>>> 35341>>>>>>> send sort_items DESCENDING // We need them backwards 35342>>>>>>> get item_count to liMax 35343>>>>>>> decrement liMax 35344>>>>>>> move "" to lsRval 35345>>>>>>> for liItem from 0 to liMax 35351>>>>>>>> 35351>>>>>>> move (lsRval+value(self,liItem)) to lsRval 35352>>>>>>> loop 35353>>>>>>>> 35353>>>>>>> move (repeat(" ",31)+lsRval) to gs$CollateString 35354>>>>>>> send delete_data 35355>>>>>>> end_procedure 35356>>>>>>> send MakeCollateString 35357>>>>>>>end_object 35358>>>>>>> 35358>>>>>>>function String_NegateSortOrder global string lsValue returns string 35360>>>>>>> integer liPos liLen 35360>>>>>>> string lsRval lsChar 35360>>>>>>> move (length(lsValue)) to liLen 35361>>>>>>> move "" to lsRval 35362>>>>>>> for liPos from 1 to liLen 35368>>>>>>>> 35368>>>>>>> move (mid(lsValue,1,liPos)) to lsChar 35369>>>>>>> move (lsRval+mid(gs$CollateString,1,ascii(lsChar))) to lsRval 35370>>>>>>> loop 35371>>>>>>>> 35371>>>>>>> function_return lsRval 35372>>>>>>>end_function 35373>>>>>>> 35373>>>>>>>// The same function (StringEncrypt) is used to encrypt and decrypt a string: 35373>>>>>>>// 35373>>>>>>>// Ŀ 35373>>>>>>>// 35373>>>>>>>// StringEncrypt(string,code) 35373>>>>>>>// stringEncrypt(encrypted_string,code) 35373>>>>>>>// 35373>>>>>>>//   35373>>>>>>>// -- -- 35373>>>>>>>// 35373>>>>>>>// 35373>>>>>>>// 35373>>>>>>>// The code used to encrypt a string may be any integer value and must 35373>>>>>>>// be the same when decrypting 35373>>>>>>>// 35373>>>>>>> 35373>>>>>>> function iEncryptXor.iii global integer liX integer liY integer liBitCount returns integer 35375>>>>>>> integer liRval liBit liXbit liYbit liBitExp 35375>>>>>>> move 0 to liRval 35376>>>>>>> for liBit from 0 to (liBitCount-1) 35382>>>>>>>> 35382>>>>>>> move (2^liBit) to liBitExp 35383>>>>>>> move ((liX/liBitExp)-(((liX/liBitExp)/2)*2)) to liXbit 35384>>>>>>> move ((liY/liBitExp)-(((liY/liBitExp)/2)*2)) to liYbit 35385>>>>>>> if liXbit ne liYbit move (liRval+liBitExp) to liRval 35388>>>>>>> loop 35389>>>>>>>> 35389>>>>>>> function_return liRval 35390>>>>>>> end_function 35391>>>>>>> 35391>>>>>>>function StringEncrypt global string lsInput integer liCode integer liLen returns string 35393>>>>>>> integer liPos 35393>>>>>>> string lsRval 35393>>>>>>> move "" to lsRval 35394>>>>>>> for liPos from 1 to liLen 35400>>>>>>>> 35400>>>>>>> move (lsRval+character(iEncryptXor.iii(ascii(mid(pad(lsInput,liLen),1,liPos)),((liCode+(liPos*7)) iand 31),8))) to lsRval 35401>>>>>>> loop 35402>>>>>>>> 35402>>>>>>> function_return lsRval 35403>>>>>>>end_function 35404>>>>>>> 35404>>>>>>>// The function returns the number of items that the value was split into. Negative if parsing error 35404>>>>>>>// 35404>>>>>>>// lsValue is the string to split 35404>>>>>>>// lsSeparatorChar is the separating character 35404>>>>>>>// lbDiscardDblSeps determines whether succeeding separating characters are to be considered as one 35404>>>>>>>// lbProtectQuotes determines if items in quotes should be 35404>>>>>>>function StringSplitToArrayObj global string lsValue string lsSeparatorChar integer lbDiscardDblSeps integer lbProtectQuotes integer lhTargetArray returns integer 35406>>>>>>> integer liLen // Length of the string we are parsing 35406>>>>>>> integer liItem // Pointer to the next available index in the target array (lhTargetArray) 35406>>>>>>> integer liStartItem // Number of items originally in the target array 35406>>>>>>> integer liPos // The current position in the string (lsValue) we are parsing 35406>>>>>>> 35406>>>>>>> string lsChar // The character currently being examined by the loop 35406>>>>>>> string lsItem // The value of the next item as it is being built 35406>>>>>>> string lsQuoteChar // If " or ', we are currently in a quoted section of the string 35406>>>>>>> string lsQuotes // Quotation characters: "' 35406>>>>>>> 35406>>>>>>> move "" to lsQuoteChar 35407>>>>>>> get item_count of lhTargetArray to liStartItem // If the array is not empty, we just add to its current content. 35408>>>>>>> move liStartItem to liItem 35409>>>>>>> move (length(lsValue)) to liLen 35410>>>>>>> move "" to lsItem 35411>>>>>>> move ("'"+'"') to lsQuotes 35412>>>>>>> 35412>>>>>>> move 1 to liPos 35413>>>>>>> while (liPos<=liLen) 35417>>>>>>> move (mid(lsValue,1,liPos)) to lsChar 35418>>>>>>> increment liPos 35419>>>>>>> 35419>>>>>>> if (lsQuoteChar<>"") begin 35421>>>>>>> if (lsChar=lsQuoteChar) begin 35423>>>>>>> move "" to lsQuoteChar 35424>>>>>>> if (liPos<=liLen) begin // Next item MUST be a separating character or end of string 35426>>>>>>> move (mid(lsValue,1,liPos)) to lsChar 35427>>>>>>> if (lsChar<>lsSeparatorChar) function_return (0-liPos) // Error: Illegal character after quoted string 35430>>>>>>> end 35430>>>>>>>> 35430>>>>>>> // else it's the end of the string and we're therefore OK 35430>>>>>>> end 35430>>>>>>>> 35430>>>>>>> else begin 35431>>>>>>> move (lsItem+lsChar) to lsItem 35432>>>>>>> end 35432>>>>>>>> 35432>>>>>>> end 35432>>>>>>>> 35432>>>>>>> else begin // We're not in a quote 35433>>>>>>> if (lsChar=lsSeparatorChar) begin 35435>>>>>>> set value of lhTargetArray item liItem to lsItem 35436>>>>>>> increment liItem 35437>>>>>>> move "" to lsItem 35438>>>>>>> 35438>>>>>>> if lbDiscardDblSeps begin // succeeding separating characters are to be considered as one, we advance the position accordingly 35440>>>>>>> while (liPos>>>>>> increment liPos 35445>>>>>>> end 35446>>>>>>>> 35446>>>>>>> end 35446>>>>>>>> 35446>>>>>>> end 35446>>>>>>>> 35446>>>>>>> else if (lbProtectQuotes<>0 and lsQuotes contains lsChar) begin 35449>>>>>>> if (lsItem="") begin 35451>>>>>>> move lsChar to lsQuoteChar 35452>>>>>>> end 35452>>>>>>>> 35452>>>>>>> else function_return (0-liPos+1) // Error: Illegal position of quotation character 35454>>>>>>> end 35454>>>>>>>> 35454>>>>>>> else move (lsItem+lsChar) to lsItem 35456>>>>>>> end 35456>>>>>>>> 35456>>>>>>> end 35457>>>>>>>> 35457>>>>>>> 35457>>>>>>> if (lsItem<>"") begin 35459>>>>>>> set value of lhTargetArray item liItem to lsItem 35460>>>>>>> increment liItem 35461>>>>>>> end 35461>>>>>>>> 35461>>>>>>> 35461>>>>>>> if (lsQuoteChar<>"") function_return (0-liPos) // Error: Quoted string not terminated 35464>>>>>>> function_return (liItem-liStartItem) // Return number of items added to the target array 35465>>>>>>>end_function // StringSplitToArrayObj 35466>>>>>>> 35466>>>>> 35466>>>>>class cFieldInfoStuff is a cArray 35467>>>>> function array_id.i integer file# returns integer 35469>>>>> integer rval# 35469>>>>> get value item file# to rval# 35470>>>>> ifnot rval# begin 35472>>>>> object fldinf.array is an array 35474>>>>> move self to rval# 35475>>>>> end_object 35476>>>>> set value item file# to rval# 35477>>>>> end 35477>>>>>> 35477>>>>> function_return rval# 35478>>>>> end_function 35479>>>>> procedure set string_value.ii integer file# integer field# string str# 35481>>>>> set value of (array_id.i(self,file#)) item field# to str# 35482>>>>> end_procedure 35483>>>>> function string_value.ii integer file# integer field# returns string 35485>>>>> integer arr# 35485>>>>> get value item file# to arr# 35486>>>>> if arr# function_return (value(arr#,field#)) 35489>>>>> function_return "" 35490>>>>> end_function 35491>>>>> procedure set integer_value.ii integer file# integer field# integer int# 35493>>>>> set value of (array_id.i(self,file#)) item field# to int# 35494>>>>> end_procedure 35495>>>>> function integer_value.ii integer file# integer field# returns integer 35497>>>>> integer arr# 35497>>>>> get value item file# to arr# 35498>>>>> if arr# function_return (value(arr#,field#)) 35501>>>>> function_return 0 35502>>>>> end_function 35503>>>>> 35503>>>>> // The purpose of the make_alias procedure is to redirect references 35503>>>>> // to file number refer to file number instead. 35503>>>>> procedure make_alias integer master# integer alias# 35505>>>>> integer master_arr# 35505>>>>> get array_id.i master# to master_arr# 35506>>>>> set value item alias# to master_arr# 35507>>>>> end_procedure 35508>>>>> 35508>>>>> procedure delete_fieldinfo_data 35510>>>>> integer lhObj liMax liItm 35510>>>>> get item_count to liMax 35511>>>>> decrement liMax 35512>>>>> for liItm from 1 to liMax // Leave the abstract definitions 35518>>>>>> 35518>>>>> get value item liItm to lhObj 35519>>>>> if lhObj begin 35521>>>>> send request_destroy_object to lhObj 35522>>>>> set value item liItm to 0 35523>>>>> end 35523>>>>>> 35523>>>>> loop 35524>>>>>> 35524>>>>> end_procedure 35525>>>>>end_class 35526>>>>> 35526>>>>>integer field_labels_array# grid_labels_array# status_help_array# 35526>>>>>integer form_datatype_array# form_margin_array# abstract_array# 35526>>>>> 35526>>>>>object field_labels_array is a cFieldInfoStuff 35528>>>>> move self to field_labels_array# 35529>>>>>end_object 35530>>>>>object grid_labels_array is a cFieldInfoStuff 35532>>>>> move self to grid_labels_array# 35533>>>>>end_object 35534>>>>>object status_help_array is a cFieldInfoStuff 35536>>>>> move self to status_help_array# 35537>>>>>end_object 35538>>>>>object form_datatype_array is a cFieldInfoStuff 35540>>>>> move self to form_datatype_array# 35541>>>>>end_object 35542>>>>>object form_margin_array is a cFieldInfoStuff 35544>>>>> move self to form_margin_array# 35545>>>>>end_object 35546>>>>>object abtract_array is a cFieldInfoStuff 35548>>>>> // If a DBMS field (file,field) has an entry in this array it means 35548>>>>> // that its corresponding form_datatype and form_margin should be 35548>>>>> // looked up in the other arrays rather than using its original values. 35548>>>>> move self to abstract_array# 35549>>>>>end_object 35550>>>>>object capslocked_array is a cFieldInfoStuff 35552>>>>>// move self to abstract_array# 35552>>>>>end_object 35553>>>>> 35553>>>>>// Prefix "gl_" means "global" 35553>>>>>function gl_field_label for desktop integer file# integer field# returns string 35555>>>>> string rval# 35555>>>>> move (string_value.ii(field_labels_array#,file#,field#)) to rval# 35556>>>>> if rval# eq "" begin 35558>>>>> get_attribute df_field_name of file# field# to rval# 35561>>>>> move (replaces("_",rval#," ")) to rval# 35562>>>>> move (lowercase(rval#)) to rval# 35563>>>>> move (overstrike(uppercase(left(rval#,1)),rval#,1)) to rval# 35564>>>>> set string_value.ii of field_labels_array# file# field# to rval# 35565>>>>> end 35565>>>>>> 35565>>>>> function_return rval# 35566>>>>>end_function 35567>>>>>function gl_grid_label for desktop integer file# integer field# returns string 35569>>>>> string rval# 35569>>>>> move (string_value.ii(grid_labels_array#,file#,field#)) to rval# 35570>>>>> if rval# eq "" begin 35572>>>>> get_attribute df_field_name of file# field# to rval# 35575>>>>> move (replaces("_",rval#," ")) to rval# 35576>>>>> move (lowercase(rval#)) to rval# 35577>>>>> move (overstrike(uppercase(left(rval#,1)),rval#,1)) to rval# 35578>>>>> set string_value.ii of grid_labels_array# file# field# to rval# 35579>>>>> end 35579>>>>>> 35579>>>>> function_return rval# 35580>>>>>end_function 35581>>>>>function gl_status_help for desktop integer file# integer field# returns string 35583>>>>> function_return (string_value.ii(status_help_array#,file#,field#)) 35584>>>>>end_function 35585>>>>>function gl_datatype for desktop integer file# integer field# returns integer 35587>>>>> function_return (integer_value.ii(form_datatype_array#,file#,field#)) 35588>>>>>end_function 35589>>>>>function gl_margin for desktop integer file# integer field# returns integer 35591>>>>> function_return (integer_value.ii(form_margin_array#,file#,field#)) 35592>>>>>end_function 35593>>>>>function gl_abstract for desktop integer file# integer field# returns integer 35595>>>>> function_return (integer_value.ii(abstract_array#,file#,field#)) 35596>>>>>end_function 35597>>>>> 35597>>>>> 35597>>>>>// REGISTER_FIELD_LABEL dffile.field ; 35597>>>>>// [ []] 35597>>>>> 35597>>>>> 35597>>>>> 35597>>>>>// REGISTER_ABSTRACT_FIELD_TYPE ; 35597>>>>>// 35597>>>>> 35597>>>>> 35597>>>>> 35597>>>>>// REGISTER_ABSTRACT_FIELD_LABEL ; 35597>>>>>// [ []] 35597>>>>>// 35597>>>>>// Registrations done with the REGISTER_ABSTRACT_FIELD_LABEL are not 35597>>>>>// currently used by APS 35597>>>>> 35597>>>>> 35597>>>>> 35597>>>>>// MODIFY_FIELD_TYPE dffile.field 35597>>>>> 35597>>>>> 35597>>>>>// REGISTER_FILE_ALIAS 35597>>>>> 35597>>>>> 35597>>>>> 35597>>>>> function gl_generic_form_datatype global integer file# integer field# returns integer 35599>>>>> integer type# rval# 35599>>>>> get_attribute DF_FIELD_TYPE of file# field# to type# 35602>>>>> if type# eq DF_ASCII function_return ascii_window 35605>>>>> if type# eq DF_DATE function_return date_window 35608>>>>> if type# eq DF_BCD begin 35610>>>>> get_attribute DF_FIELD_PRECISION of file# field# to rval# 35613>>>>> function_return rval# 35614>>>>> end 35614>>>>>> 35614>>>>> function_return ascii_window // DF_OVERLAP DF_TEXT DF_BINARY 35615>>>>> end_function 35616>>>>> 35616>>>>> function gl_generic_form_margin global integer file# integer field# returns integer 35618>>>>> integer datatype# len# 35618>>>>> move (gl_generic_form_datatype(file#,field#)) to datatype# 35619>>>>> if datatype# eq date_window function_return 10 35622>>>>> get_attribute DF_FIELD_LENGTH of file# field# to len# 35625>>>>> if datatype# eq ascii_window function_return len# 35628>>>>> function_return (len#+1) // Room for comma 35629>>>>> end_function 35630>>>>> 35630>>>>> function gl_effective_form_datatype global integer file# integer field# returns integer 35632>>>>> integer abstract# 35632>>>>> get gl_abstract file# field# to abstract# 35633>>>>> if abstract# function_return (gl_datatype(self,0,abstract#)) 35636>>>>> function_return (gl_generic_form_datatype(file#,field#)) 35637>>>>> end_function 35638>>>>> function gl_effective_form_margin global integer file# integer field# returns integer 35640>>>>> integer rval# 35640>>>>> get gl_margin file# field# to rval# 35641>>>>> if rval# function_return rval# 35644>>>>> function_return (gl_generic_form_margin(file#,field#)) 35645>>>>> end_function 35646>>>>> 35646>>>>>register_abstract_field_type AFT_ASCII1 1 ascii_window 35648>>>>>register_abstract_field_type AFT_ASCII2 2 ascii_window 35650>>>>>register_abstract_field_type AFT_ASCII3 3 ascii_window 35652>>>>>register_abstract_field_type AFT_ASCII4 4 ascii_window 35654>>>>>register_abstract_field_type AFT_ASCII5 5 ascii_window 35656>>>>>register_abstract_field_type AFT_ASCII6 6 ascii_window 35658>>>>>register_abstract_field_type AFT_ASCII7 7 ascii_window 35660>>>>>register_abstract_field_type AFT_ASCII8 8 ascii_window 35662>>>>>register_abstract_field_type AFT_ASCII10 10 ascii_window 35664>>>>>register_abstract_field_type AFT_ASCII12 12 ascii_window 35666>>>>>register_abstract_field_type AFT_ASCII14 14 ascii_window 35668>>>>>register_abstract_field_type AFT_ASCII15 15 ascii_window 35670>>>>>register_abstract_field_type AFT_ASCII20 20 ascii_window 35672>>>>>register_abstract_field_type AFT_ASCII25 25 ascii_window 35674>>>>>register_abstract_field_type AFT_ASCII30 30 ascii_window 35676>>>>>register_abstract_field_type AFT_ASCII32 32 ascii_window 35678>>>>>register_abstract_field_type AFT_ASCII35 35 ascii_window 35680>>>>>register_abstract_field_type AFT_ASCII40 40 ascii_window 35682>>>>>register_abstract_field_type AFT_ASCII45 45 ascii_window 35684>>>>>register_abstract_field_type AFT_ASCII50 50 ascii_window 35686>>>>>register_abstract_field_type AFT_ASCII60 60 ascii_window 35688>>>>>register_abstract_field_type AFT_ASCII70 70 ascii_window 35690>>>>>register_abstract_field_type AFT_ASCII80 80 ascii_window 35692>>>>>register_abstract_field_type AFT_ASCII100 100 ascii_window 35694>>>>>register_abstract_field_type AFT_ASCII255 255 ascii_window 35696>>>>>register_abstract_field_type AFT_NUMERIC1.0 1 0 // Length 4, 2 decimal points 35698>>>>>register_abstract_field_type AFT_NUMERIC1.2 4 2 // Length 4, 2 decimal points 35700>>>>>register_abstract_field_type AFT_NUMERIC2.0 2 0 // Length 2, 0 decimal points 35702>>>>>register_abstract_field_type AFT_NUMERIC2.1 4 1 // Length 4, 1 decimal points 35704>>>>>register_abstract_field_type AFT_NUMERIC2.2 5 2 // Length 5, 2 decimal points 35706>>>>>register_abstract_field_type AFT_NUMERIC3.0 3 0 // Length 3, 0 decimal points 35708>>>>>register_abstract_field_type AFT_NUMERIC3.3 7 3 // Length 7, 3 decimal points 35710>>>>>register_abstract_field_type AFT_NUMERIC4.0 4 0 // Length 4, 0 decimal points 35712>>>>>register_abstract_field_type AFT_NUMERIC4.2 7 2 // Length 7, 2 decimal points 35714>>>>>register_abstract_field_type AFT_NUMERIC5.1 8 1 // Length 7, 2 decimal points 35716>>>>>register_abstract_field_type AFT_NUMERIC6.0 6 0 // Length 6, 0 decimal points 35718>>>>>register_abstract_field_type AFT_NUMERIC8.0 8 0 // Length 8, 0 decimal points 35720>>>>>register_abstract_field_type AFT_NUMERIC10.0 10 0 // Length 10, 0 decimal points 35722>>>>>register_abstract_field_type AFT_NUMERIC14.0 14 0 // Length 14, 0 decimal points 35724>>>>>register_abstract_field_type AFT_DATE 10 date_window 35726>>>>>register_abstract_field_type AFT_BOOLEAN 1 0 35728>>>>> 35728>>>>> 35728>>>>>// An extra feature allows specifying a replacement to the user display name 35728>>>>>// of files (df_File_Display_Name). APS makes no use of such registrations. 35728>>>>>// 35728>>>>>// REGISTER_FILE_DISPLAY_NAME dffile 35728>>>>> 35728>>>>>desktop_section 35733>>>>> object File_Display_Name_Array is a cArray 35735>>>>> end_object 35736>>>>>end_desktop_section 35741>>>>>procedure set File_Display_Name global integer file# string name# 35743>>>>> set value of (File_Display_Name_Array(self)) item file# to name# 35744>>>>>end_procedure 35745>>>>>function File_Display_Name global integer file# returns string 35747>>>>> string rval# 35747>>>>> move (value(File_Display_Name_Array(self),file#)) to rval# 35748>>>>> if rval# eq "" begin 35750>>>>> get_attribute DF_FILE_DISPLAY_NAME of file# to rval# 35753>>>>> move (rtrim(rval#)) to rval# 35754>>>>> set File_Display_Name file# to rval# 35755>>>>> end 35755>>>>>> 35755>>>>> function_return rval# 35756>>>>>end_function 35757>>>>> 35757>>>>> 35757>>>>>// In order for the aps_ObjectDynamo class to be able to use the 35757>>>>>// generic DD-classes a few lines is needed that will allow us to 35757>>>>>// register which classes to use when creating DDO's for the various 35757>>>>>// data files. 35757>>>>>// 35757>>>>>// Use like this: 35757>>>>>// 35757>>>>>// set DataDictionary_Class OrderHdr.file_number to U_OrderHdr_DD 35757>>>>>// 35757>>>>> 35757>>>>>desktop_section 35762>>>>> object oDataDictionary_Class_Array is a cArray 35764>>>>> end_object 35765>>>>>end_desktop_section 35770>>>>>function DataDictionary_Class global integer file# returns integer 35772>>>>> function_return (value(oDataDictionary_Class_Array(self),file#)) 35773>>>>>end_function 35774>>>>>procedure set DataDictionary_Class global integer file# integer class# 35776>>>>> set value of (oDataDictionary_Class_Array(self)) item file# to class# 35777>>>>>end_procedure 35778>>>>> 35778>>>>>desktop_section 35783>>>>> object oDataDictionary_Object_Array is a cArray 35785>>>>> end_object 35786>>>>>end_desktop_section 35791>>>>>function DataDictionary_Object global integer file# returns integer 35793>>>>> function_return (value(oDataDictionary_Object_Array(self),file#)) 35794>>>>>end_function 35795>>>>>procedure set DataDictionary_Object global integer file# integer obj# 35797>>>>> set value of (oDataDictionary_Object_Array(self)) item file# to obj# 35798>>>>>end_procedure 35799>>>>>procedure DataDictionary_Objects_Destroy global 35801>>>>> integer lhObj liItm liMax lhDD 35801>>>>> move (oDataDictionary_Object_Array(self)) to lhObj 35802>>>>> get item_count of lhObj to liMax 35803>>>>> for liItm from 0 to liMax 35809>>>>>> 35809>>>>> get value of lhObj item liItm to lhDD 35810>>>>> if lhDD send request_destroy_object to lhDD 35813>>>>> loop 35814>>>>>> 35814>>>>> send delete_data to lhObj 35815>>>>>end_procedure 35816>>>>> 35816>>>>>function iDD_Object global integer file# returns integer 35818>>>>> integer rval# class# self# 35818>>>>> get DataDictionary_Object file# to rval# 35819>>>>> ifnot rval# begin 35821>>>>> get DataDictionary_Class file# to class# 35822>>>>> if class# begin 35824>>>>> name class# U_fieldinf_class // Ŀ 35824>>>>> move self to self# // Push self 35825>>>>> move desktop to self // Create at desktop 35826>>>>> object dynamo_object is a fieldinf_class // Create an object of class 35828>>>>> move self to rval# // Get the object ID to rval# 35829>>>>> end_object // 35830>>>>> move self# to self // Pop self 35831>>>>> set DataDictionary_Object file# to rval# // Register the new object 35832>>>>> end 35832>>>>>> 35832>>>>> end 35832>>>>>> 35832>>>>> function_return rval# 35833>>>>>end_function 35834>>>>> 35834>>>>>class cVirtualFields is a cArray 35835>>>>> procedure construct_object integer img# 35837>>>>> forward send construct_object img# 35839>>>>> property integer pMainFile public 0 35840>>>>> property integer private.pCurrentRecord public -1 35841>>>>> property string pUserName public "Un-named" 35842>>>>> end_procedure 35843>>>>> item_property_list 35843>>>>> // VDFQuery only considers active fields 35843>>>>> item_property integer piFieldActive.i 35843>>>>> item_property string psFieldLabel.i 35843>>>>> item_property string psFieldLabel_Short.i 35843>>>>> item_property integer piFieldType.i 35843>>>>> item_property integer piFieldLength.i 35843>>>>> item_property integer piFieldDecPoint.i 35843>>>>> item_property integer piFieldCapslock.i 35843>>>>> item_property integer piFieldLoadMessage.i // Function to call in order to get the function value 35843>>>>> item_property integer piFieldLoadObject.i // Optional object in which to call the load-message 35843>>>>> item_property integer pbFieldLoadParamSpecified.i // Indicates whether piFieldLoadParam.i has been specified 35843>>>>> item_property integer piFieldLoadParam.i // If specified, is sent to the function 35843>>>>> item_property string psFieldValue.i 35843>>>>> item_property integer piFieldDirty.i 35843>>>>> item_property integer piDescriptionImage.i 35843>>>>> end_item_property_list cVirtualFields // When in class, class neame must be repeated here #REM 35911 DEFINE FUNCTION PIDESCRIPTIONIMAGE.I INTEGER LIROW RETURNS INTEGER #REM 35915 DEFINE PROCEDURE SET PIDESCRIPTIONIMAGE.I INTEGER LIROW INTEGER VALUE #REM 35919 DEFINE FUNCTION PIFIELDDIRTY.I INTEGER LIROW RETURNS INTEGER #REM 35923 DEFINE PROCEDURE SET PIFIELDDIRTY.I INTEGER LIROW INTEGER VALUE #REM 35927 DEFINE FUNCTION PSFIELDVALUE.I INTEGER LIROW RETURNS STRING #REM 35931 DEFINE PROCEDURE SET PSFIELDVALUE.I INTEGER LIROW STRING VALUE #REM 35935 DEFINE FUNCTION PIFIELDLOADPARAM.I INTEGER LIROW RETURNS INTEGER #REM 35939 DEFINE PROCEDURE SET PIFIELDLOADPARAM.I INTEGER LIROW INTEGER VALUE #REM 35943 DEFINE FUNCTION PBFIELDLOADPARAMSPECIFIED.I INTEGER LIROW RETURNS INTEGER #REM 35947 DEFINE PROCEDURE SET PBFIELDLOADPARAMSPECIFIED.I INTEGER LIROW INTEGER VALUE #REM 35951 DEFINE FUNCTION PIFIELDLOADOBJECT.I INTEGER LIROW RETURNS INTEGER #REM 35955 DEFINE PROCEDURE SET PIFIELDLOADOBJECT.I INTEGER LIROW INTEGER VALUE #REM 35959 DEFINE FUNCTION PIFIELDLOADMESSAGE.I INTEGER LIROW RETURNS INTEGER #REM 35963 DEFINE PROCEDURE SET PIFIELDLOADMESSAGE.I INTEGER LIROW INTEGER VALUE #REM 35967 DEFINE FUNCTION PIFIELDCAPSLOCK.I INTEGER LIROW RETURNS INTEGER #REM 35971 DEFINE PROCEDURE SET PIFIELDCAPSLOCK.I INTEGER LIROW INTEGER VALUE #REM 35975 DEFINE FUNCTION PIFIELDDECPOINT.I INTEGER LIROW RETURNS INTEGER #REM 35979 DEFINE PROCEDURE SET PIFIELDDECPOINT.I INTEGER LIROW INTEGER VALUE #REM 35983 DEFINE FUNCTION PIFIELDLENGTH.I INTEGER LIROW RETURNS INTEGER #REM 35987 DEFINE PROCEDURE SET PIFIELDLENGTH.I INTEGER LIROW INTEGER VALUE #REM 35991 DEFINE FUNCTION PIFIELDTYPE.I INTEGER LIROW RETURNS INTEGER #REM 35995 DEFINE PROCEDURE SET PIFIELDTYPE.I INTEGER LIROW INTEGER VALUE #REM 35999 DEFINE FUNCTION PSFIELDLABEL_SHORT.I INTEGER LIROW RETURNS STRING #REM 36003 DEFINE PROCEDURE SET PSFIELDLABEL_SHORT.I INTEGER LIROW STRING VALUE #REM 36007 DEFINE FUNCTION PSFIELDLABEL.I INTEGER LIROW RETURNS STRING #REM 36011 DEFINE PROCEDURE SET PSFIELDLABEL.I INTEGER LIROW STRING VALUE #REM 36015 DEFINE FUNCTION PIFIELDACTIVE.I INTEGER LIROW RETURNS INTEGER #REM 36019 DEFINE PROCEDURE SET PIFIELDACTIVE.I INTEGER LIROW INTEGER VALUE 36024>>>>> procedure FieldsCallBack integer lhMsg integer lhObj 36026>>>>> integer liRow liMax liFile 36026>>>>> get pMainFile to liFile 36027>>>>> get row_count to liMax 36028>>>>> decrement liMax 36029>>>>> for liRow from 0 to liMax 36035>>>>>> 36035>>>>> if (piFieldActive.i(self,liRow)) begin 36037>>>>> // procedure HandleField integer liFile integer liField string lsLabel integer liType integer liLenth integer liPrecision integer lhVF 36037>>>>> send lhMsg to lhObj liFile liRow (psFieldLabel.i(self,liRow)) (piFieldType.i(self,liRow)) (piFieldLength.i(self,liRow)) (piFieldDecPoint.i(self,liRow)) self 36038>>>>> end 36038>>>>>> 36038>>>>> loop 36039>>>>>> 36039>>>>> end_procedure 36040>>>>> procedure SetAllFieldsDirty integer lbState 36042>>>>> integer liMax liField 36042>>>>> get row_count to liMax 36043>>>>> for liField from 0 to (liMax-1) 36049>>>>>> 36049>>>>> set piFieldDirty.i liField to lbState 36050>>>>> loop 36051>>>>>> 36051>>>>> end_procedure 36052>>>>> procedure OnNewRecord 36054>>>>> end_procedure 36055>>>>> procedure set pCurrentRecord integer liRecnum 36057>>>>> integer liField liPreviousRecnum 36057>>>>> get private.pCurrentRecord to liPreviousRecnum 36058>>>>> if liRecnum ne liPreviousRecnum begin 36060>>>>> send SetAllFieldsDirty DFTRUE 36061>>>>> send OnNewRecord 36062>>>>> end 36062>>>>>> 36062>>>>> set private.pCurrentRecord to liRecnum 36063>>>>> end_procedure 36064>>>>> function pCurrentRecord returns integer 36066>>>>> function_return (private.pCurrentRecord(self)) 36067>>>>> end_function 36068>>>>> procedure LoadFieldValue integer liField 36070>>>>> integer lhGet lhObj 36070>>>>> string lsValue 36070>>>>> get piFieldLoadMessage.i liField to lhGet 36071>>>>> get piFieldLoadObject.i liField to lhObj 36072>>>>> 36072>>>>> if (pbFieldLoadParamSpecified.i(self,liField)) begin 36074>>>>> if lhObj get lhGet of lhObj (piFieldLoadParam.i(self,liField)) to lsValue 36077>>>>> else get lhGet (piFieldLoadParam.i(self,liField)) to lsValue 36079>>>>> end 36079>>>>>> 36079>>>>> else begin 36080>>>>> if lhObj get lhGet of lhObj to lsValue 36083>>>>> else get lhGet to lsValue 36085>>>>> end 36085>>>>>> 36085>>>>> 36085>>>>> set psFieldValue.i liField to lsValue 36086>>>>> set piFieldDirty.i liField to DFFALSE 36087>>>>> end_procedure 36088>>>>> procedure CheckCurrentRecord 36090>>>>> integer liFile liRecnum 36090>>>>> get pMainFile to liFile 36091>>>>> if liFile begin 36093>>>>> get_field_value liFile 0 to liRecnum 36096>>>>> if liRecnum ne (private.pCurrentRecord(self)) set pCurrentRecord to liRecnum 36099>>>>> end 36099>>>>>> 36099>>>>> end_procedure 36100>>>>> function sFieldValue.i integer liField returns string 36102>>>>> send CheckCurrentRecord 36103>>>>> if (piFieldDirty.i(self,liField)) send LoadFieldValue liField 36106>>>>> function_return (psFieldValue.i(self,liField)) 36107>>>>> end_function 36108>>>>> procedure define_field integer field# string Label# string Label_Short# integer Type# integer Length# integer DecPoint# integer LoadMessage# integer LoadObjectTmp# 36110>>>>> integer LoadObject# 36110>>>>> if num_arguments gt 7 move LoadObjectTmp# to LoadObject# 36113>>>>> else move 0 to LoadObject# 36115>>>>> set psFieldLabel.i field# to Label# 36116>>>>> 36116>>>>> if Label_Short# ne "" ; set psFieldLabel_Short.i field# to Label_Short# 36119>>>>> else set psFieldLabel_Short.i field# to Label# 36121>>>>> 36121>>>>> set piFieldType.i field# to Type# 36122>>>>> set piFieldLength.i field# to Length# 36123>>>>> set piFieldDecPoint.i field# to DecPoint# 36124>>>>> set piFieldLoadMessage.i field# to LoadMessage# 36125>>>>> set piFieldLoadObject.i field# to LoadObject# 36126>>>>> set piFieldDirty.i field# to DFTRUE 36127>>>>> set piFieldActive.i field# to DFTRUE 36128>>>>> set piFieldCapslock.i field# to DFFALSE 36129>>>>> end_procedure 36130>>>>> procedure set LoadParameter integer liField integer liAuxValue 36132>>>>> set pbFieldLoadParamSpecified.i liField to 1 36133>>>>> set piFieldLoadParam.i liField to liAuxValue 36134>>>>> end_procedure 36135>>>>>end_class // cVirtualFields 36136>>>>> 36136>>>>>integer oFieldInf_VitualFields# 36136>>>>>object oFieldInf_VitualFields is a cArray 36138>>>>> move self to oFieldInf_VitualFields# 36139>>>>>end_object 36140>>>>> 36140>>>>>function FieldInf_VirtualFields_Object global integer file# returns integer 36142>>>>> function_return (value(oFieldInf_VitualFields#,file#)) 36143>>>>>end_function 36144>>>>>procedure set FieldInf_VirtualFields_Object global integer file# integer value# 36146>>>>> set value of (oFieldInf_VitualFields#) item file# to value# 36147>>>>>end_procedure 36148>>>>>procedure FieldInf_VirtualFieldsCallBack global integer liFile integer lhMsg integer lhObj 36150>>>>> integer lhVF 36150>>>>> get FieldInf_VirtualFields_Object liFile to lhVF 36151>>>>> if lhVF send FieldsCallBack to lhVF lhMsg lhObj 36154>>>>>end_procedure 36155>>>>> 36155>>>>>function FieldInf_FieldType global integer liFile integer liField returns integer 36157>>>>> integer liFieldType 36157>>>>> if liField lt 256 get_attribute DF_FIELD_TYPE of liFile liField to liFieldType 36162>>>>> else move (piFieldType.i(FieldInf_VirtualFields_Object(liFile),liField-256)) to liFieldType 36164>>>>> function_return liFieldType 36165>>>>>end_function 36166>>>>>function FieldInf_FieldValue global integer liFile integer liField returns string 36168>>>>> integer liPushFieldindex liPushFieldnumber 36168>>>>> string lsValue 36168>>>>> move fieldindex to liPushFieldindex 36169>>>>> move fieldnumber to liPushFieldnumber 36170>>>>> if liField lt 256 get_field_value liFile liField to lsValue 36175>>>>> else move (sFieldValue.i(FieldInf_VirtualFields_Object(liFile),liField-256)) to lsValue 36177>>>>> move liPushFieldindex to fieldindex 36178>>>>> move liPushFieldnumber to fieldnumber 36179>>>>> function_return lsValue 36180>>>>>end_function 36181>>>>>function FieldInf_DecPoints global integer file# integer field# returns integer 36183>>>>> integer rval# 36183>>>>>// if field# lt 256 get_attribute DF_FIELD_PRECISION of file# field# to rval# 36183>>>>> if field# lt 256 get gl_effective_form_datatype file# field# to rval# 36186>>>>> else move (piFieldDecPoint.i(FieldInf_VirtualFields_Object(file#),field#-256)) to rval# 36188>>>>> function_return rval# 36189>>>>>end_function 36190>>>>>function FieldInf_FieldLabel_Long global integer file# integer field# returns string 36192>>>>> integer dd# 36192>>>>> string rval# 36192>>>>> move (string_value.ii(field_labels_array#,file#,field#)) to rval# 36193>>>>> if field# lt 256 begin 36195>>>>> if rval# eq "" begin // No global label was assigned 36197>>>>> get gl_field_label file# field# to rval# 36198>>>>> end 36198>>>>>> 36198>>>>> end 36198>>>>>> 36198>>>>> else move (psFieldLabel.i(FieldInf_VirtualFields_Object(file#),field#-256)) to rval# 36200>>>>> function_return rval# 36201>>>>>end_function 36202>>>>>function FieldInf_FieldLabel_Short global integer file# integer field# returns string 36204>>>>> integer dd# 36204>>>>> string rval# 36204>>>>> if field# lt 256 begin 36206>>>>> move (string_value.ii(grid_labels_array#,file#,field#)) to rval# 36207>>>>> if rval# eq "" begin // No global label was assigned 36209>>>>> get gl_field_label file# field# to rval# 36210>>>>> end 36210>>>>>> 36210>>>>> end 36210>>>>>> 36210>>>>> else move (psFieldLabel_Short.i(FieldInf_VirtualFields_Object(file#),field#-256)) to rval# 36212>>>>> function_return rval# 36213>>>>>end_function 36214>>>>> 36214>>>>>function FieldInf_Field_Length global integer liFile integer liField returns integer 36216>>>>> integer liLen lhVF 36216>>>>> move -1 to liLen 36217>>>>> if (liField<256) get_attribute DF_FIELD_LENGTH of liFile liField to liLen 36222>>>>> else begin 36223>>>>> move (liField-256) to liField 36224>>>>> get FieldInf_VirtualFields_Object liFile to lhVF 36225>>>>> if lhVF get piFieldLength.i of lhVF liField to liLen 36228>>>>> end 36228>>>>>> 36228>>>>> function_return liLen 36229>>>>>end_function 36230>>>>> 36230>>>>>function FieldInf_Field_Length_String global integer file# integer field# returns string 36232>>>>> integer fieldtype# len# dec# obj# 36232>>>>> string rval# 36232>>>>> if field# lt 256 begin 36234>>>>> get_attribute DF_FIELD_TYPE of file# field# to fieldtype# 36237>>>>> get_attribute DF_FIELD_LENGTH of file# field# to len# 36240>>>>> if fieldtype# eq DF_DATE move 10 to len# 36243>>>>> move len# to rval# 36244>>>>> if fieldtype# eq DF_BCD begin 36246>>>>> get gl_effective_form_datatype file# field# to dec# 36247>>>>> move "#.#" to rval# 36248>>>>> //if dec# decrement len# 36248>>>>> replace "#" in rval# with (string(len#-dec#)) 36250>>>>> replace "#" in rval# with (string(dec#)) 36252>>>>> end 36252>>>>>> 36252>>>>> end 36252>>>>>> 36252>>>>> else begin 36253>>>>> get FieldInf_VirtualFields_Object file# to obj# 36254>>>>> move (field#-256) to field# 36255>>>>> get piFieldType.i of obj# field# to fieldtype# 36256>>>>> get piFieldLength.i of obj# field# to len# 36257>>>>> if fieldtype# eq DF_DATE move 10 to len# 36260>>>>> move len# to rval# 36261>>>>> if fieldtype# eq DF_BCD begin 36263>>>>> get piFieldDecPoint.i of obj# field# to dec# 36264>>>>> move "#.#" to rval# 36265>>>>> replace "#" in rval# with (string(len#-dec#)) 36267>>>>> replace "#" in rval# with (string(dec#)) 36269>>>>> end 36269>>>>>> 36269>>>>> end 36269>>>>>> 36269>>>>> function_return rval# 36270>>>>>end_function 36271>>>>> 36271>>>>>function FieldInf_Field_Width global integer file# integer field# returns integer 36273>>>>> integer liDecs lbComma 36273>>>>> string lsLength 36273>>>>> get FieldInf_Field_Length_String file# field# to lsLength 36274>>>>> move (ExtractInteger(lsLength,2)) to liDecs 36275>>>>> move (liDecs<>0) to lbComma 36276>>>>> function_return (ExtractInteger(lsLength,1)+ExtractInteger(lsLength,2)+lbComma) 36277>>>>>end_function 36278>>>>> 36278>>>>>class cVirtualIndex is a cArray 36279>>>>> item_property_list 36279>>>>> item_property integer piFile.i 36279>>>>> item_property integer piField.i 36279>>>>> item_property string psValue.i 36279>>>>> end_item_property_list cVirtualIndex #REM 36314 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING #REM 36318 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE #REM 36322 DEFINE FUNCTION PIFIELD.I INTEGER LIROW RETURNS INTEGER #REM 36326 DEFINE PROCEDURE SET PIFIELD.I INTEGER LIROW INTEGER VALUE #REM 36330 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER #REM 36334 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE 36339>>>>> procedure ReadValues 36341>>>>> integer row# max# file# field# type# dec# 36341>>>>> string rval# value# 36341>>>>> move "" to rval# 36342>>>>> get row_count to max# 36343>>>>> for row# from 0 to (max#-1) 36349>>>>>> 36349>>>>> get piFile.i row# to file# 36350>>>>> get piField.i row# to field# 36351>>>>> get FieldInf_FieldValue file# field# to value# 36352>>>>> get FieldInf_FieldType file# field# to type# 36353>>>>> if type# eq DF_DATE begin 36355>>>>> move (integer(date(value#))) to value# 36356>>>>> move (NumToStrR(value#,0,6)) to value# 36357>>>>> end 36357>>>>>> 36357>>>>> if type# eq DF_BCD begin 36359>>>>> get FieldInf_DecPoints file# field# to dec# 36360>>>>> move (NumToStrR(value#,dec#,14)) to value# 36361>>>>> end 36361>>>>>> 36361>>>>> set psValue.i row# to value# 36362>>>>> loop 36363>>>>>> 36363>>>>> end_procedure 36364>>>>> function sIndexValue returns string 36366>>>>> integer row# max# 36366>>>>> string rval# 36366>>>>> move "" to rval# 36367>>>>> get row_count to max# 36368>>>>> decrement max# 36369>>>>> for row# from 0 to max# 36375>>>>>> 36375>>>>> move (rval#+psValue.i(self,row#)) to rval# 36376>>>>> if row# ne max# move (rval#+" ") to rval# 36379>>>>> loop 36380>>>>>> 36380>>>>> function_return rval# 36381>>>>> end_function 36382>>>>> function sSegmentName integer seg# returns string 36384>>>>> function_return (FieldInf_FieldLabel_Long(piFile.i(self,seg#),piField.i(self,seg#))) 36385>>>>> end_function 36386>>>>> function sIndexNames returns string // FieldInf_FieldLabel_Long 36388>>>>> integer row# max# 36388>>>>> string rval# 36388>>>>> move "" to rval# 36389>>>>> get row_count to max# 36390>>>>> decrement max# 36391>>>>> for row# from 0 to max# 36397>>>>>> 36397>>>>> move (rval#*FieldInf_FieldLabel_Long(piFile.i(self,row#),piField.i(self,row#))) to rval# 36398>>>>> if row# ne max# move (rval#+",") to rval# 36401>>>>> loop 36402>>>>>> 36402>>>>> function_return rval# 36403>>>>> end_function 36404>>>>> procedure reset 36406>>>>> send delete_data 36407>>>>> end_procedure 36408>>>>> procedure add_segment integer file# integer field# 36410>>>>> integer row# 36410>>>>> get row_count to row# 36411>>>>> set piFile.i row# to file# 36412>>>>> set piField.i row# to field# 36413>>>>> end_procedure 36414>>>>>end_class // cVirtualIndex 36415>>>>> 36415>>>>>class cVirtualIndices is a cArray 36416>>>>> procedure construct_object integer img# 36418>>>>> forward send construct_object img# 36420>>>>> property integer piCurrentIdx public 0 36421>>>>> end_procedure 36422>>>>> item_property_list 36422>>>>> item_property string psIndexName.i 36422>>>>> item_property integer piObj.i 36422>>>>> end_item_property_list cVirtualIndices #REM 36454 DEFINE FUNCTION PIOBJ.I INTEGER LIROW RETURNS INTEGER #REM 36458 DEFINE PROCEDURE SET PIOBJ.I INTEGER LIROW INTEGER VALUE #REM 36462 DEFINE FUNCTION PSINDEXNAME.I INTEGER LIROW RETURNS STRING #REM 36466 DEFINE PROCEDURE SET PSINDEXNAME.I INTEGER LIROW STRING VALUE 36471>>>>> function iObject.i integer index# returns integer 36473>>>>> integer rval# 36473>>>>> get piObj.i index# to rval# 36474>>>>> ifnot rval# begin 36476>>>>> object oVirtualIndex is a cVirtualIndex no_image 36478>>>>> move self to rval# 36479>>>>> end_object 36480>>>>> set piObj.i index# to rval# 36481>>>>> end 36481>>>>>> 36481>>>>> function_return rval# 36482>>>>> end_function 36483>>>>> procedure define_index integer index# string name# 36485>>>>> set psIndexName.i index# to name# 36486>>>>> set piObj.i index# to (iObject.i(self,index#)) 36487>>>>> set piCurrentIdx to index# 36488>>>>> end_procedure 36489>>>>> procedure add_segment integer file# integer field# 36491>>>>> integer idx# obj# 36491>>>>> get piCurrentIdx to idx# 36492>>>>> get piObj.i idx# to obj# 36493>>>>> send add_segment to obj# file# field# 36494>>>>> end_procedure 36495>>>>> procedure reset 36497>>>>> integer row# max# obj# 36497>>>>> get row_count to max# 36498>>>>> for row# from 0 to (max#-1) 36504>>>>>> 36504>>>>> get piObj.i row# to obj# 36505>>>>> if obj# send request_destroy_object to obj# 36508>>>>> loop 36509>>>>>> 36509>>>>> send delete_data 36510>>>>> end_procedure 36511>>>>>end_class // cVirtualIndices 36512>>>>> 36512>>>>>integer oFieldInf_VitualIndices# 36512>>>>>object oFieldInf_VitualIndices is a cArray 36514>>>>> move self to oFieldInf_VitualIndices# 36515>>>>>end_object 36516>>>>> 36516>>>>>function FieldInf_VirtualIndices_Object global integer file# returns integer 36518>>>>> function_return (value(oFieldInf_VitualIndices#,file#)) 36519>>>>>end_function 36520>>>>>procedure set FieldInf_VirtualIndices_Object global integer file# integer value# 36522>>>>> set value of oFieldInf_VitualIndices# item file# to value# 36523>>>>>end_procedure 36524>>>>>function FieldInf_VirtualIndex_Object global integer file# integer idx# returns integer 36526>>>>> integer obj# 36526>>>>> get FieldInf_VirtualIndices_Object file# to obj# 36527>>>>> if obj# get piObj.i of obj# idx# to obj# 36530>>>>> function_return obj# 36531>>>>>end_function 36532>>>>> 36532>>>>>function FieldInf_ValidationTableObject global integer liFile integer liField returns integer 36534>>>>> integer lhDD lhValTbl 36534>>>>> get iDD_Object liFile to lhDD 36535>>>>> if lhDD get Field_Table_Object of lhDD liField to lhValTbl 36538>>>>> else move 0 to lhValTbl 36540>>>>> function_return lhValTbl 36541>>>>>end_function 36542>>>>>function FieldInf_ValidationTableDecodeValue global integer liFile integer liField string lsValue returns string 36544>>>>> integer lhValTbl liMax liRow 36544>>>>> string lsData lsDescr 36544>>>>> get FieldInf_ValidationTableObject liFile liField to lhValTbl 36545>>>>> if lhValTbl begin 36547>>>>> send fill_list of lhValTbl 36548>>>>> get Data_Item_Count of lhValTbl to liMax 36549>>>>> decrement liMax 36550>>>>> for liRow from 0 to liMax 36556>>>>>> 36556>>>>> get Data_Value of lhValTbl liRow to lsData 36557>>>>> get Data_Description of lhValTbl liRow to lsDescr 36558>>>>> if (lsDescr="") move lsData to lsDescr 36561>>>>> if (lsValue=lsData) function_return lsDescr 36564>>>>> loop 36565>>>>>> 36565>>>>> 36565>>>>> end 36565>>>>>> 36565>>>>> function_return "N/A" 36566>>>>>end_function 36567>>>Use Macros.utl // Various macros (DESKTOP_SECTION command) 36567>>> 36567>>>Use cDbRichEdit.pkg // RTF classes Including file: cDbRichEdit.pkg (c:\VDF12\Pkg\cDbRichEdit.pkg) 36567>>>>>Use cRichEdit.pkg Including file: cRichEdit.pkg (c:\VDF12\Pkg\cRichEdit.pkg) 36567>>>>>>>use Windows.pkg 36567>>>>>>>Use cEdit_Mixin.pkg 36567>>>>>>> 36567>>>>>>>// DFO: cRichEdit.Dfo 36567>>>>>>>// DFC: cRichEdit.Dfc 36567>>>>>>> 36567>>>>>>>// constants used for RichEdit Properties 36567>>>>>>>// peAlignment 36567>>>>>>>Enum_List 36567>>>>>>> Define alLeft for 1 36567>>>>>>> Define alRight for 2 36567>>>>>>> Define alCenter for 3 36567>>>>>>>End_Enum_List 36567>>>>>>> 36567>>>>>>>// peBullets 36567>>>>>>>Enum_List 36567>>>>>>> Define buNone 36567>>>>>>> Define buBullets 36567>>>>>>> Define buArabicNumbers 36567>>>>>>> Define buLowerLetters 36567>>>>>>> Define buUpperLetters 36567>>>>>>> Define buLowerRomans 36567>>>>>>> Define buUpperRomans 36567>>>>>>>End_Enum_List 36567>>>>>>> 36567>>>>>>>// peBulletStyle 36567>>>>>>>Enum_List 36567>>>>>>> Define busRightParen for 0 36567>>>>>>> Define busEncloseParen for 256 36567>>>>>>> Define busPeriod for 512 36567>>>>>>> Define busNumberOnly for 768 36567>>>>>>> Define busNoDisplay for 1024 36567>>>>>>>End_Enum_List 36567>>>>>>> 36567>>>>>>>// peLineSpacingType 36567>>>>>>>Enum_List 36567>>>>>>> Define lstSingle 36567>>>>>>> Define lstSingleAndOneHalf 36567>>>>>>> Define lstDouble 36567>>>>>>>End_Enum_List 36567>>>>>>> 36567>>>>>>>Class cRichEdit Is A DFBaseRichEdit 36568>>>>>>> 36568>>>>>>> Procedure Construct_Object 36570>>>>>>> Forward Send Construct_Object 36572>>>>>>> Send Define_cEdit_Mixin 36573>>>>>>> 36573>>>>>>> On_key Key_Ctrl+Key_B send ToggleBold 36574>>>>>>> On_key Key_Ctrl+Key_I send ToggleItalics 36575>>>>>>> On_key Key_Ctrl+Key_U send ToggleUnderline 36576>>>>>>> 36576>>>>>>> End_Procedure // Construct_Object 36577>>>>>>> 36577>>>>>>> Import_Class_Protocol cEdit_Mixin 36578>>>>>>> 36578>>>>>>> Procedure ToggleBold 36580>>>>>>> Set pbBold to (not(pbBold(self))) 36581>>>>>>> end_procedure 36582>>>>>>> 36582>>>>>>> Procedure ToggleItalics 36584>>>>>>> Set pbItalics to (not(pbItalics(self))) 36585>>>>>>> end_procedure 36586>>>>>>> 36586>>>>>>> Procedure ToggleUnderline 36588>>>>>>> Set pbUnderLine to (not(pbUnderLine(self))) 36589>>>>>>> end_procedure 36590>>>>>>> 36590>>>>>>>End_Class 36591>>>>>>> 36591>>>>>Use Text_Win.pkg 36591>>>>>Use DFNav_mx.pkg // Navigation changes for DF DEOs 36591>>>>>Use DFCdDeo.pkg // DEO Code message support 36591>>>>>Use DD_Deomx.pkg // mixin support for dd classes 36591>>>>> 36591>>>>>// DFO: cDbRichEdit.Dfo 36591>>>>>// DFC: cDbRichEdit.Dfc 36591>>>>> 36591>>>>>Class cDbRichEdit_ is a cRichEdit 36592>>>>> 36592>>>>> Import_Class_Protocol Text_Window_mixin 36593>>>>> 36593>>>>> // 36593>>>>> // created for EntItem simulation and Server support: 36593>>>>> // if file# = 0, display only if Data_File is in Done-array 36593>>>>> // else display only if file# = Data_File 36593>>>>> // 36593>>>>> procedure Entry_Display integer iFile integer iFlag 36595>>>>> Boolean bUpdate bOld 36595>>>>> Integer iDataFile 36595>>>>> get data_file to iDataFile 36596>>>>> if (iDataFile) begin // if not data file, we have nothing to update 36598>>>>> if (iFile=0) begin 36600>>>>> is_file_included iDataFile 1 36601>>>>> Move (found) to bUpdate 36602>>>>> end 36602>>>>>> 36602>>>>> else begin 36603>>>>> Move (iFile=iDataFile or iFlag) to bUpdate 36604>>>>> end 36604>>>>>> 36604>>>>> 36604>>>>> If bUpdate begin 36606>>>>> get dynamic_update_state to bOld 36607>>>>> set dynamic_update_state to false 36608>>>>> send Delete_Data // init buffer 36609>>>>> send DisplayData // read buffer from file 36610>>>>> send beginning_of_data 36611>>>>> set dynamic_update_state to bOld 36612>>>>> end 36612>>>>>> 36612>>>>> end 36612>>>>>> 36612>>>>> end_procedure 36613>>>>> 36613>>>>> Procedure DisplayData 36615>>>>> integer iFile iField iFldLen 36615>>>>> Address pField 36615>>>>> Boolean bOk bOld 36615>>>>> Get Data_File to iFile 36616>>>>> Get Data_Field to iField 36617>>>>> If (iFile>0 and iField>0) begin 36619>>>>> Get Change_Disabled_State to bOld 36620>>>>> Set Change_Disabled_State to True 36621>>>>> Get_Attribute DF_FIELD_LENGTH of iFile iField to iFldLen 36624>>>>> Move (Alloc(iFldLen)) to pField 36625>>>>> Get_Field_value iFile iField to pField 36628>>>>> Set paValue to pField 36629>>>>> Move (Free(pField)) to bOk 36630>>>>> Set Change_Disabled_State to bOld 36631>>>>> end 36631>>>>>> 36631>>>>> End_procedure 36632>>>>> 36632>>>>> // 36632>>>>> // This is designed onlt to work with DDs. With DDs, this is called under 36632>>>>> // two conditons. 36632>>>>> // 1. Update for find (passes iFile and Flag=1). We never want to update for finds. Text is not indexed 36632>>>>> // 2. Update for save (passes iFile=0 and Flag=3). 36632>>>>> // Thus we update if a ddo save (iFlag=3) the field is changed, and the file is in done array 36632>>>>> // 36632>>>>> procedure Entry_Update integer iFile integer iFlag 36634>>>>> Integer iDataFile 36634>>>>> Boolean bUpdate 36634>>>>> If (iFlag=3 and changed_State(Self)) begin 36636>>>>> get Data_File to iDataFile 36637>>>>> If (iDataFile) begin 36639>>>>> is_file_included iDataFile 1 // is file in done array (will it get saved)? 36640>>>>> Move (found) to bUpdate 36641>>>>> end 36641>>>>>> 36641>>>>> If bUpdate begin 36643>>>>> send UpdateData 36644>>>>> end 36644>>>>>> 36644>>>>> end 36644>>>>>> 36644>>>>> end_procedure 36645>>>>> 36645>>>>> // Move data from Text Control to the File/field buffer 36645>>>>> Procedure UpdateData 36647>>>>> integer iFile iField iFldLen 36647>>>>> Address pField 36647>>>>> Boolean bOk 36647>>>>> Get Data_File to iFile 36648>>>>> Get Data_Field to iField 36649>>>>> If (iFile>0 and iField>0) begin 36651>>>>> Get paValue to pField 36652>>>>> //Move (Length(pField)) to iFldLen 36652>>>>> Move (CStringLength(pField)) to iFldLen 36653>>>>> Set_Field_Value iFile iField to pField LENGTH iFldLen 36656>>>>> Move (Free(pField)) to bOk 36657>>>>> end 36657>>>>>> 36657>>>>> End_procedure 36658>>>>> 36658>>>>>End_Class 36659>>>>> 36659>>>>>Class cDbRichEditDS_ is a cDbRichEdit_ 36660>>>>> 36660>>>>> Procedure Construct_Object 36662>>>>> Forward Send Construct_Object 36664>>>>> Send Define_DFNavigation // GUI navigate changes 36665>>>>> // restore standard begin/end of text window behavior (which 36665>>>>> // is altered by CM packages 36665>>>>> On_key kBegin_of_data send default_key 36666>>>>> On_key kEnd_of_data send default_key 36667>>>>> End_Procedure // Construct_Object 36668>>>>> 36668>>>>> Import_Class_Protocol DFNavigate_Mixin 36669>>>>> Import_Class_Protocol DFCode_DEO_Mixin 36670>>>>> Import_Class_Protocol DataFile_Help_Mixin 36671>>>>> 36671>>>>> // these should be in text_win.pkg All DEOs shoudld understand this 36671>>>>> // message. Needed for smart pulldown shadowing of these items 36671>>>>> // 36671>>>>> Function Prompt_Object integer item# returns integer 36673>>>>> End_Function 36674>>>>> 36674>>>>> Function Zoom_Object integer item# returns integer 36676>>>>> End_Function 36677>>>>> 36677>>>>> Procedure Bind_Data integer File# Integer Field# 36679>>>>> Set Data_File to File# 36680>>>>> Set Data_Field to Field# 36681>>>>> End_Procedure // Bind_Data 36682>>>>> 36682>>>>> // augment to raise an error if the field length is too long. With Rich edit we only know this when we try 36682>>>>> // to update the buffer 36682>>>>> function Validate_Items integer flag returns integer 36684>>>>> integer iFile iField iFldLen iEditLen 36684>>>>> Address pField 36684>>>>> Boolean bOk 36684>>>>> Get Data_File to iFile 36685>>>>> Get Data_Field to iField 36686>>>>> If (iFile>0 and iField>0) begin 36688>>>>> Get_Attribute DF_FIELD_LENGTH of iFile iField to iFldLen 36691>>>>> Get CharCount to iEditLen 36692>>>>> If (iEditLen>iFldLen) begin 36694>>>>> Send Activate_Area True 36695>>>>> Error DFERR_TEXT_TOO_LARGE_FOR_FIELD (sFormat(C_$MaxLenAndCurrentLen,iFldLen,iEditLen)) 36696>>>>>> 36696>>>>> Function_return 1 36697>>>>> end 36697>>>>>> 36697>>>>> end 36697>>>>>> 36697>>>>> end_function 36698>>>>> 36698>>>>> 36698>>>>>End_Class 36699>>>>> 36699>>>>> 36699>>>>> 36699>>>>>Class cDbRichEdit is a cDbRichEditDS_ 36700>>>>> Import_Class_Protocol Extended_DEO_Status_Help_Mixin 36701>>>>> 36701>>>>> Procedure Construct_Object 36703>>>>> Forward Send Construct_Object 36705>>>>> Property Integer Auto_Label_State False 36706>>>>> End_Procedure // Construct_Object 36707>>>>> 36707>>>>> //************************************************************************// 36707>>>>> // Copy_Item_Options // 36707>>>>> // Currently there is nothing to do except optionally support an auto- // 36707>>>>> // label. We maintain this format to keep in similar to the other DEOs // 36707>>>>> //************************************************************************// 36707>>>>> // 36707>>>>> Procedure Copy_Item_Options Integer iDSO Integer iFile Integer iField ; Integer iDEO Integer iItem 36709>>>>> If not (Extended_DSO_State(iDSO)) ; Procedure_Return 36712>>>>> If (Auto_Label_State(self)) ; Send Assign_DD_Label iDSO iFile iField iDEO iItem 36715>>>>> End_Procedure 36716>>>>> 36716>>>>> //************************************************************************// 36716>>>>> // Assign_DD_Label // 36716>>>>> // This assigns the DEO's from the DD. This uses long labels and // 36716>>>>> // and sets the label property // 36716>>>>> //************************************************************************// 36716>>>>> // 36716>>>>> Procedure Assign_DD_Label Integer iDSO Integer iFile Integer iField ; Integer iDEO Integer iItem 36718>>>>> string sName 36718>>>>> Get File_Field_Label of iDSO iFile iField DD_LABEL_LONG to sName 36719>>>>> Set Label to sName 36720>>>>> End_Procedure 36721>>>>> 36721>>>>>End_Class 36722>>>>> 36722>>>>> 36722>>>>> 36722>>> 36722>>> // location of objects runtime. 36722>>> 36722>>> // between tab pages using ctrl+PgUp/PgDn. 36722>>> // This is in sync. with standard MS beha. 36722>>> 36722>>> 36722>>>// Relative location of objects: 36722>>>define SL_DOWN for -1 36722>>>define SL_LEFT for -2 36722>>>define SL_LOWER_RIGHT_CORNER_EXTEND_ROW for -3 36722>>>define SL_CURRENT_POS_NO_LABEL_ADJUST for -4 36722>>>define SL_RIGHT for -5 36722>>>define SL_UP for -6 36722>>>define SL_LOWER_RIGHT_CORNER for -7 36722>>>define SL_XRIGHT for -8 36722>>>define SL_UPPER_RIGHT_CORNER_EXTEND_COLUMN for -9 36722>>>define SL_RIGHT_SPACE for -10 36722>>>define SL_CURRENT_POS for -11 36722>>> 36722>>>define SL_ALIGN_LEFT for 1 36722>>>define SL_ALIGN_RIGHT for 2 36722>>>define SL_ALIGN_TOP for 4 36722>>>define SL_ALIGN_BOTTOM for 8 36722>>>define SL_ALIGN_CENTER for 16 36722>>>define SL_ALIGN_VCENTER for 32 36722>>> 36722>>>define SL_HORIZONTAL for 1 36722>>>define SL_VERTICAL for 2 36722>>> 36722>>>define APS.ITEM_OPTION_CAPSLOCK for 19 36722>>> 36722>>>//> This function translates form_margin to form_width (or column_width). It 36722>>>//> does so taking into account the data type and whether or not the field 36722>>>//> is capslocked. 36722>>>function aps.form_width.iii for BaseClass integer typ# integer mrg# integer caps# returns integer 36724>>> integer rval# 36724>>> if typ# eq ASCII_WINDOW begin // Ascii: 36726>>> if caps# move (mrg#*8+5 max 20) to rval# // If capsl: 8 units per character. 36729>>> else move (mrg#*5+5 max 20) to rval# // Otherwise 5. At least 20. 36731>>> end 36731>>>> 36731>>> else begin 36732>>> if typ# eq DATE_WINDOW move 47 to rval# // Dates are 47, period! 36735>>> else begin 36736>>> move (mrg#*4+7) to rval# // Digits are easy. They always have the same width. 36737>>> if (mrg#=2) move (rval#+9) to rval# // Spooky correction! 36740>>> if (mrg#=4) move (rval#+9) to rval# // Spooky correction! 36743>>> if (mrg#=6) move (rval#+9) to rval# // Spooky correction! 36746>>> if (mrg#=8) move (rval#+9) to rval# // Spooky correction! 36749>>> end 36749>>>> 36749>>> end 36749>>>> 36749>>> function_return rval# 36750>>>end_function 36751>>> 36751>>>function FieldWidthMDU global integer liFile integer liField returns integer 36753>>> integer lhDD liType lbCaps liLen 36753>>> 36753>>> move FALSE to lbCaps 36754>>> if (liField<255) begin 36756>>> get DataDictionary_Object liFile to lhDD 36757>>> if lhDD get Field_Option of lhDD liField DD_CAPSLOCK to lbCaps 36760>>> end 36760>>>> 36760>>> 36760>>> get FieldInf_FieldType liFile liField to liType 36761>>> get FieldInf_Field_Length liFile liField to liLen 36762>>> 36762>>> if (liType=DF_DATE) function_return 47 36765>>> if (liType=DF_ASCII) begin 36767>>> if lbCaps function_return (liLen*8+5 max 20) // If capsl: 8 units per character. 36770>>> else function_return (liLen*5+5 max 20) // Otherwise 5. At least 20. 36772>>> end 36772>>>> 36772>>> if (liType=DF_BCD) begin 36774>>> function_return (liLen*4+7) // Digits are easy. They always have the same width. 36775>>> end 36775>>>> 36775>>> function_return 0 36776>>>end_function 36777>>> 36777>>>External_Function32 ApsOemToCharA "OemToCharA" User32.DLL Pointer hpszOem Pointer hpszWindow Returns Integer 36778>>>Function APS_OemToChar Global String OemStr Returns String 36780>>> String CharStr 36780>>> Integer OemAdress CharAdress grb# 36780>>> Append OemStr (Character(0)) 36781>>> Move (Repeat(Character(0), (Length(OemStr)))) To CharStr 36782>>> GetAddress Of OemStr To OemAdress 36783>>> GetAddress Of CharStr To CharAdress 36784>>> Move (ApsOemToCharA(OemAdress, CharAdress)) To grb# 36785>>> Function_Return (CString(CharStr)) 36786>>>End_Function 36787>>> 36787>>>// Insert: 36787>>>// I'm sure this can be done more gracefully. Still... 36787>>>number aps.gui2mdu_width# aps.gui2mdu_height# 36787>>> 36787>>>desktop_section 36792>>> object ApsTestGuiConv is a dfcontainer 36794>>> procedure damit 36797>>> integer low_h# low_w# 36797>>> integer hi_h# hi_w# 36797>>> set guisize to 20 20 36798>>> send adjust_logicals 36799>>> get size to low_w# 36800>>> move (hi(low_w#)) to low_h# 36801>>> move (low(low_w#)) to low_w# 36802>>> set guisize to 420 420 36803>>> send adjust_logicals 36804>>> get size to hi_w# 36805>>> move (hi(hi_w#)) to hi_h# 36806>>> move (low(hi_w#)) to hi_w# 36807>>> move (hi_h#-low_h#/400.0) to aps.gui2mdu_height# 36808>>> move (hi_w#-low_w#/400.0) to aps.gui2mdu_width# 36809>>> end_procedure 36810>>> send damit 36811>>> end_object 36812>>>end_desktop_section 36817>>> 36817>>>class aps.tabulator_array is an array 36818>>> procedure tab_column_define integer tab# integer val# integer label_width# integer label_just# 36820>>> integer base# 36820>>> move (tab#*3) to base# 36821>>> set value item base# to val# 36822>>> set value item (base#+1) to label_width# 36823>>> set value item (base#+2) to label_just# 36824>>> end_procedure 36825>>> procedure tab_label_column_goto integer tab# 36827>>> delegate set p_cur_column to (integer(value(self,tab#*3))-integer(value(self,tab#*3+1))) 36829>>> end_procedure 36830>>> procedure tab_column_goto integer tab# 36832>>> delegate set p_cur_column to (value(self,tab#*3)) 36834>>> end_procedure 36835>>> function ilabel_width.i integer tab# returns integer 36837>>> function_return (value(self,tab#*3+1)) 36838>>> end_function 36839>>> function ilabel_just.i integer tab# returns integer 36841>>> function_return (value(self,tab#*3+2)) 36842>>> end_function 36843>>>end_class 36844>>> 36844>>>//> Class aps_panel_mx is mixed into aps.(db)ModalPanel and aps.(db)View. All 36844>>>//> other APS objects must be nested inside one of these. 36844>>>class aps_panel_mx is a mixin 36845>>> procedure define_aps_panel_mx 36847>>> property integer p_resize_in_progress private DFTRUE 36848>>> property integer pMinimumSize private 0 36849>>> set p_auto_column to false 36850>>> end_procedure 36851>>> 36851>>> procedure set pMinimumSize integer x# integer y# 36853>>> set aps_panel_mx.pMinimumSize to (x#*65536+y#) 36854>>> end_procedure 36855>>> 36855>>> function pMinimumSize returns integer 36857>>> function_return (aps_panel_mx.pMinimumSize(self)) 36858>>> end_function 36859>>> 36859>>> procedure aps_MakeMinimumSize 36861>>> integer size# 36861>>> get size to size# 36862>>> set pMinimumSize to (hi(size#)) (low(size#)) 36863>>> end_procedure 36864>>> 36864>>> procedure end_define_aps_panel_mx 36866>>> send aps_beautify 36867>>> set aps_panel_mx.p_resize_in_progress to false 36868>>> end_procedure 36869>>> 36869>>> function aps_PanelID returns integer 36871>>> function_return self 36872>>> end_function 36873>>> 36873>>> procedure aps_beautify 36875>>> end_procedure 36876>>> 36876>>> procedure aps_onResize integer delta_rw# integer delta_cl# 36878>>> // SAMPLE09.SRC shows how to use this in a simple panel 36878>>> end_procedure 36879>>> 36879>>> procedure onResize // Event sent when panel is displayed or resized 36881>>> integer old_rw# old_cl# new_rw# new_cl# 36881>>> ifnot (aps_panel_mx.p_resize_in_progress(self)) begin 36883>>> set aps_panel_mx.p_resize_in_progress to true 36884>>> get size to old_cl# 36885>>> move (hi(old_cl#)) to old_rw# 36886>>> move (low(old_cl#)) to old_cl# 36887>>> send adjust_logicals 36888>>> get size to new_cl# 36889>>> move (hi(new_cl#)) to new_rw# 36890>>> move (low(new_cl#)) to new_cl# 36891>>> send aps_init 36892>>> if new_rw# lt (hi(aps_panel_mx.pMinimumSize(self))) move (hi(aps_panel_mx.pMinimumSize(self))) to new_rw# 36895>>> if new_cl# lt (low(aps_panel_mx.pMinimumSize(self))) move (low(aps_panel_mx.pMinimumSize(self))) to new_cl# 36898>>> send aps_onResize (new_rw#-old_rw#) (new_cl#-old_cl#) 36899>>> set aps_panel_mx.p_resize_in_progress to false 36900>>> end 36900>>>> 36900>>> end_procedure 36901>>>end_class 36902>>> 36902>>>desktop_section 36907>>> object oAPS_Stack is an array 36909>>> procedure Push.i integer value# 36912>>> set value item (item_count(self)) to value# 36913>>> end_procedure 36914>>> function iPop returns integer 36917>>> integer rval# itm# 36917>>> move (item_count(self)-1) to itm# 36918>>> get value item itm# to rval# 36919>>> send delete_item itm# 36920>>> function_return rval# 36921>>> end_function 36922>>> end_object 36923>>> object oAPS_PresetColumnWidths is a array 36925>>> end_object 36926>>>end_desktop_section 36931>>> 36931>>>//> Class aps_container_mx is mixed into all visual container classes. That 36931>>>//> means that all APS container classes have the properties and the methods 36931>>>//> defined by this class: 36931>>>class aps_container_mx is a mixin 36932>>> procedure define_aps_container_mx 36934>>> property integer p_left_margin public 5 //These are all 36935>>> property integer p_right_margin public 5 // measured in 36936>>> property integer p_top_margin public 5 // map_dialog- 36937>>> property integer p_bottom_margin public 5 // units 36938>>> property integer p_form_height public 13 // 36939>>> property integer p_cur_row public 5 // 36940>>> property integer p_cur_column public 5 // 36941>>> property integer p_max_row public 0 // 36942>>> property integer p_max_column public 0 // 36943>>> property integer p_row_space public 2 // 36944>>> property integer p_column_space public 2 // 36945>>> property integer p_last_object public 0 // Last object positioned 36946>>> // by container. 36946>>> //> p_lrcer_offset is used to determine the amount of extra row space 36946>>> //> inserted when snapping to SL_LOWER_RIGHT_CORNER_EXTEND_ROW (lrcer) 36946>>> property integer p_lrcer_offset public 3 36947>>> //> p_urcec_offset is used to determine the amount of extra column space 36947>>> //> inserted when snapping to SL_UPPER_RIGHT_CORNER_EXTEND_COLUMN (urcec) 36947>>> property integer p_urcec_offset public 3 36948>>> 36948>>> property integer p_auto_column private 1 36949>>> property integer p_auto_column_just_set private 1 36950>>> 36950>>> //> Should the container auto size?: 36950>>> property integer p_auto_size_container_state public true 36951>>> 36951>>> object column_array is an aps.tabulator_array 36953>>> send tab_column_define 1 60 55 JMODE_LEFT // Default column setting 36954>>> end_object 36955>>> end_procedure 36956>>> 36956>>> function aps_parent returns integer 36958>>> function_return self 36959>>> end_function 36960>>> 36960>>> procedure set p_auto_column integer col# 36962>>> set aps_container_mx.p_auto_column to col# 36963>>> set aps_container_mx.p_auto_column_just_set to true // No automatic lf! 36964>>> end_procedure 36965>>> function p_auto_column returns integer 36967>>> function_return (aps_container_mx.p_auto_column(self)) 36968>>> end_function 36969>>> 36969>>> procedure end_define_aps_container_mx 36971>>> if (p_auto_size_container_state(self)) send aps_auto_size_container 36974>>> end_procedure 36975>>> 36975>>> procedure tab_column_define integer tab# integer val# integer label_width# integer label_just# 36977>>> send tab_column_define to (column_array(self)) tab# val# label_width# label_just# 36978>>> end_procedure 36979>>> 36979>>> procedure tab_column_define_adhoc integer tab# 36981>>> integer lhObj loc# 36981>>> get p_last_object to lhObj 36982>>> get location of lhObj to loc# 36983>>> move (low(loc#)) to loc# 36984>>> send tab_column_define tab# loc# 100 jmode_right 36985>>> end_procedure 36986>>> 36986>>> procedure aps_push_current_position 36988>>> integer lhObj 36988>>> move (oAPS_Stack(self)) to lhObj 36989>>> send push.i to lhObj (p_cur_row(self)) 36990>>> send push.i to lhObj (p_cur_column(self)) 36991>>> send push.i to lhObj (p_last_object(self)) 36992>>> end_procedure 36993>>> 36993>>> procedure aps_pop_current_position 36995>>> integer lhObj 36995>>> move (oAPS_Stack(self)) to lhObj 36996>>> set p_last_object to (iPop(lhObj)) 36997>>> set p_cur_column to (iPop(lhObj)) 36998>>> set p_cur_row to (iPop(lhObj)) 36999>>> end_procedure 37000>>> 37000>>> procedure aps_push_max_positions 37002>>> integer lhObj 37002>>> move (oAPS_Stack(self)) to lhObj 37003>>> send push.i to lhObj (p_max_row(self)) 37004>>> send push.i to lhObj (p_max_column(self)) 37005>>> end_procedure 37006>>> 37006>>> procedure aps_pop_max_positions 37008>>> integer lhObj p_max_row# p_max_column# 37008>>> move (oAPS_Stack(self)) to lhObj 37009>>> move (iPop(lhObj)) to p_max_column# 37010>>> move (iPop(lhObj)) to p_max_row# 37011>>> if p_max_column# gt (p_max_column(self)) set p_max_column to p_max_column# 37014>>> if p_max_row# gt (p_max_row(self)) set p_max_row to p_max_row# 37017>>> end_procedure 37018>>> 37018>>> procedure tab_column_goto integer tab# 37020>>> send tab_column_goto to (column_array(self)) tab# 37021>>> end_procedure 37022>>> procedure tab_label_column_goto integer tab# 37024>>> send tab_label_column_goto to (column_array(self)) tab# 37025>>> end_procedure 37026>>> 37026>>> procedure make_row_space integer amount# // Move the cursor down 37028>>> integer tmp# 37028>>> ifnot num_arguments move (p_row_space(self)) to tmp# 37031>>> else move amount# to tmp# 37033>>> set p_cur_row to (tmp#+p_cur_row(self)) 37034>>> end_procedure 37035>>> 37035>>> procedure make_column_space integer amount# // Advance cursor to the left 37037>>> integer tmp# 37037>>> ifnot num_arguments move (p_column_space(self)) to tmp# 37040>>> else move amount# to tmp# 37042>>> set p_cur_column to (tmp#+p_cur_column(self)) 37043>>> end_procedure 37044>>> 37044>>> //> Because combo forms are the only objects (until now) that 37044>>> //> does not have a visual size corresponding to their size-setting, 37044>>> //> we have to treat combo's much differently. Therefore this 37044>>> //> function is provided to help determine whether we are dealing 37044>>> //> with a combo form or not. 37044>>> function is_comboform integer lhObj returns integer 37046>>> integer dm# rval# 37046>>> get delegation_mode of lhObj to dm# 37047>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 37048>>> get p_is_comboform of lhObj to rval# 37049>>> set delegation_mode of lhObj to dm# 37050>>> function_return rval# 37051>>> end_function 37052>>> 37052>>> //> The idea of this function is to retrieve value of property 37052>>> //> p_extra_external_width. But since we are not sure that 37052>>> //> is one of ours (meaning and APS object), we retrieve it this way: 37052>>> function extra_external_width integer lhObj returns integer 37054>>> integer dm# rval# 37054>>> get delegation_mode of lhObj to dm# 37055>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 37056>>> get p_extra_external_width of lhObj to rval# 37057>>> set delegation_mode of lhObj to dm# 37058>>> function_return rval# 37059>>> end_function 37060>>> 37060>>> //> The idea of this function is to retrieve value of property 37060>>> //> p_extra_internal_width. But since we are not sure that 37060>>> //> is one of ours (APS), we retrieve it this way. 37060>>> function extra_internal_width integer lhObj returns integer 37062>>> integer dm# rval# 37062>>> get delegation_mode of lhObj to dm# 37063>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 37064>>> get p_extra_internal_width of lhObj to rval# 37065>>> set delegation_mode of lhObj to dm# 37066>>> function_return rval# 37067>>> end_function 37068>>> 37068>>> //> This one is used internally by the mixin classes to update properties 37068>>> //> p_max_row and p_max_column with respect to a (control) object. It 37068>>> //> may be used externally to make the container aware of an object that 37068>>> //> has been sized and located manually. 37068>>> procedure aps_register_max_rc integer lhObj 37070>>> integer row# col# size# loc# 37070>>> get size of lhObj to size# 37071>>> 37071>>> // The next line fools APS into thinking that the control is only 37071>>> // 13 units high if it is a combo form. 37071>>> if (is_comboform(self,lhObj)) move (13*65536+low(size#)) to size# 37074>>> move (size#+extra_external_width(self,lhObj)) to size# 37075>>> 37075>>> get location of lhObj to loc# 37076>>> move (hi(size#)+hi(loc#)) to row# 37077>>> move (low(size#)+low(loc#)) to col# 37078>>> if (row#>p_max_row(self)) set p_max_row to row# 37081>>> if (col#>p_max_column(self)) set p_max_column to col# 37084>>> end_procedure 37085>>> 37085>>> procedure new_field_row 37087>>> // Carriage return 37087>>> set p_cur_row to (p_cur_row(self)+p_form_height(self)+p_row_space(self)) 37088>>> set p_cur_column to (p_left_margin(self)) 37089>>> end_procedure 37090>>> 37090>>> procedure increment_max_row integer val# 37092>>> integer incr# 37092>>> if num_arguments move val# to incr# 37095>>> else get p_row_space to incr# 37097>>> set p_max_row to (p_max_row(self)+incr#) 37098>>> end_procedure 37099>>> 37099>>> procedure increment_max_column integer val# 37101>>> integer incr# 37101>>> if num_arguments move val# to incr# 37104>>> else get p_column_space to incr# 37106>>> set p_max_column to (p_max_column(self)+incr#) 37107>>> end_procedure 37108>>> 37108>>> procedure aps_init 37110>>> set p_cur_row to (p_top_margin(self)) 37111>>> set p_cur_column to (p_left_margin(self)) 37112>>> set p_max_row to 0 37113>>> set p_max_column to 0 37114>>> // To let each tab-page start a new, we must set p_auto_column_just_set: 37114>>> set aps_container_mx.p_auto_column_just_set to true 37115>>> set p_last_object to 0 37116>>> end_procedure 37117>>> 37117>>> procedure aps_auto_size_container 37119>>> integer cap_height# lhObj 37119>>> move 0 to cap_height# 37120>>> move self to lhObj 37121>>> if (caption_bar(lhObj)) move (GetSystemMetrics (SM_CYSMCAPTION)) to cap_height# // 15 37124>>> set size to (p_max_row(lhObj)+p_bottom_margin(lhObj)+cap_height#) (p_max_column(lhObj)+p_right_margin(lhObj)) 37125>>> end_procedure 37126>>> 37126>>> function p_snap_location returns integer 37128>>> // Default value for controls without property p_snap_location (non aps.-objects) 37128>>> end_function 37129>>> 37129>>> register_function p_extra_external_width returns integer 37129>>> procedure aps_adjust_to_snap_location integer lhObj integer dictate_snap# 37131>>> integer snap_location# label_size# label_offset# column_array# label_just# last_object# 37131>>> integer vertical_offset# dm# label_obj# jmode_top_vert_offset# 37131>>> 37131>>> get delegation_mode of lhObj to dm# 37132>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 37133>>> 37133>>> get p_snap_location of lhObj to snap_location# 37134>>> if num_arguments gt 1 move dictate_snap# to snap_location# 37137>>> ifnot snap_location# begin 37139>>> // If no snap_location has been defined we try to obtain one 37139>>> // from our container. If we still have no snap_location 37139>>> // we default to SL_RIGHT. 37139>>> get p_auto_column to snap_location# 37140>>> if snap_location# begin 37142>>> ifnot (aps_container_mx.p_auto_column_just_set(self)) send new_field_row 37145>>> else set aps_container_mx.p_auto_column_just_set to false 37147>>> end 37147>>>> 37147>>> else move SL_RIGHT to snap_location# 37149>>> end 37149>>>> 37149>>> 37149>>> get label_object of lhObj to label_obj# 37150>>> move (if(label_obj#,low(size(label_obj#)),0)) to label_size# 37151>>> 37151>>> // Make sure to make a vertical adjustment if a label is present 37151>>> // and it is positioned above the control: 37151>>> if (label_size# and label_justification_mode(lhObj)=jmode_top) begin 37153>>> get p_jmode_top_vert_offset of lhObj to jmode_top_vert_offset# 37154>>> move (hi(label_offset(lhObj))+jmode_top_vert_offset#) to vertical_offset# 37155>>> end 37155>>>> 37155>>> else move 0 to vertical_offset# 37157>>> 37157>>> if snap_location# gt 0 begin // Means that we should locate relative to tabulator 37159>>> move (column_array(self)) to column_array# 37160>>> send tab_column_goto to column_array# snap_location# 37161>>> if label_size# begin 37163>>> move (ilabel_just.i(column_array#,snap_location#)) to label_just# 37164>>> set label_justification_mode of lhObj to label_just# 37165>>> if label_just# eq jmode_left set label_offset of lhObj to 0 (ilabel_width.i(column_array#,snap_location#)) 37168>>> else set label_offset of lhObj to 0 0 37170>>> end 37170>>>> 37170>>> // If snap_column and no label, we just go there (and we already have). 37170>>> end 37170>>>> 37170>>> else begin 37171>>> get p_last_object to last_object# 37172>>> if (snap_location#=SL_RIGHT or snap_location#=SL_RIGHT_SPACE or snap_location#=SL_CURRENT_POS) begin 37174>>> //if last_object# begin // ???? 37174>>> // set p_cur_column to (low(location(last_object#))+low(size(last_object#))+extra_external_width(self,last_object#)+p_column_space(self)) 37174>>> // set p_cur_row to (hi(location(last_object#))) 37174>>> //end // ???? 37174>>> if label_size# begin 37176>>> if (label_justification_mode(lhObj)=JMODE_TOP) begin 37178>>> set p_cur_row to (p_cur_row(self)+vertical_offset#) 37179>>> set label_offset of lhObj to 0 0 37180>>> end 37180>>>> 37180>>> else begin 37181>>> // Advance p_cur_column: 37181>>> set p_cur_column to (p_cur_column(self)+label_size#) 37182>>> set label_justification_mode of lhObj to jmode_right 37183>>> set label_offset of lhObj to 0 0 37184>>> end 37184>>>> 37184>>> end 37184>>>> 37184>>> if snap_location# eq SL_RIGHT_SPACE set p_cur_column to (p_cur_column(self)+10) 37187>>> // If no label and no tab column, we don't do a thing! 37187>>> end 37187>>>> 37187>>> else begin 37188>>> if (snap_location#=SL_XRIGHT and last_object#) begin 37190>>> set p_cur_column to (low(location(last_object#))+low(size(last_object#))+extra_external_width(self,last_object#)+p_column_space(self)) 37191>>> set p_cur_row to (hi(location(last_object#))+vertical_offset#) 37192>>> end 37192>>>> 37192>>> if snap_location# eq SL_DOWN begin 37194>>> set p_cur_column to (low(location(last_object#))) 37195>>> ifnot (is_comboform(self,last_object#)) ; set p_cur_row to (hi(location(last_object#))+hi(size(last_object#))+p_row_space(self)+vertical_offset#) 37198>>> else ; set p_cur_row to (hi(location(last_object#))+13+p_row_space(self)+vertical_offset#) 37200>>> end 37200>>>> 37200>>> if snap_location# eq SL_UP begin 37202>>> set p_cur_column to (low(location(last_object#))) 37203>>> set p_cur_row to (hi(location(last_object#))-p_row_space(self)-hi(size(lhObj))-vertical_offset#) 37204>>> end 37204>>>> 37204>>> if snap_location# eq SL_LEFT begin 37206>>> set p_cur_column to (low(location(last_object#))-p_column_space(self)-low(size(lhObj))-p_extra_external_width(lhObj)) 37207>>> set p_cur_row to (hi(location(last_object#))+vertical_offset#) 37208>>> end 37208>>>> 37208>>> if snap_location# eq SL_LOWER_RIGHT_CORNER_EXTEND_ROW begin 37210>>> set p_cur_column to (p_max_column(self)-low(size(lhObj))) 37211>>> set p_cur_row to (p_max_row(self)+p_row_space(self)+vertical_offset#+p_lrcer_offset(self)) 37212>>> end 37212>>>> 37212>>> if snap_location# eq SL_LOWER_RIGHT_CORNER begin 37214>>> set p_cur_column to (p_max_column(self)-low(size(lhObj))) 37215>>> set p_cur_row to (p_max_row(self)-hi(size(lhObj))-vertical_offset#) 37216>>> end 37216>>>> 37216>>> if snap_location# eq SL_UPPER_RIGHT_CORNER_EXTEND_COLUMN begin 37218>>> set p_cur_column to (p_max_column(self)+p_column_space(self)+p_urcec_offset(self)) 37219>>> set p_cur_row to (p_top_margin(self)+vertical_offset#) 37220>>> end 37220>>>> 37220>>> if snap_location# eq SL_CURRENT_POS begin 37222>>> //set p_cur_column to (p_max_column(self)) 37222>>> //set p_cur_row to (p_top_margin(self)+vertical_offset#) 37222>>> end 37222>>>> 37222>>> end 37222>>>> 37222>>> end 37222>>>> 37222>>> set delegation_mode of lhObj to dm# 37223>>> end_procedure 37224>>> 37224>>> procedure aps_auto_locate_control integer lhObj integer dictate_snap# integer dictate_last_object# 37226>>> integer extra_external_width# dm# 37226>>> get delegation_mode of lhObj to dm# 37227>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 37228>>> if num_arguments gt 1 begin 37230>>> if num_arguments gt 2 set p_last_object to dictate_last_object# 37233>>> send aps_adjust_to_snap_location lhObj dictate_snap# 37234>>> end 37234>>>> 37234>>> else send aps_adjust_to_snap_location lhObj 37236>>> get p_extra_external_width of lhObj to extra_external_width# 37237>>> set location of lhObj to (p_cur_row(self)) (p_cur_column(self)) 37238>>> set p_cur_column to (p_cur_column(self)+low(size(lhObj))+p_column_space(self)+extra_external_width#) 37239>>> set p_last_object to lhObj 37240>>> send aps_register_max_rc lhObj 37241>>> set delegation_mode of lhObj to dm# 37242>>> end_procedure 37243>>> 37243>>> procedure aps_goto_max_row integer row_space# 37245>>> // Position the cursor on a new line below the 37245>>> set p_cur_row to (p_max_row(self)+p_row_space(self)) 37246>>> set p_cur_column to (p_left_margin(self)) 37247>>> set aps_container_mx.p_auto_column_just_set to true // No automatic lf! 37248>>> if num_arguments send make_row_space row_space# 37251>>> end_procedure 37252>>> 37252>>> function aps_grid_column_start integer lhObj integer col# returns integer 37254>>> integer itm# column# 37254>>> move (low(location(lhObj))) to column# // Left edge of grid 37255>>> for itm# from 0 to (col#-1) 37261>>>> 37261>>> move (column#+form_width(lhObj,itm#)) to column# 37262>>> loop 37263>>>> 37263>>> function_return column# 37264>>> end_function 37265>>> 37265>>> procedure aps_goto_grid_column integer lhObj integer col# 37267>>> // Position the object cursor by the left edge of column 37267>>> // (0-base) in grid . 37267>>> set p_cur_column to (aps_grid_column_start(self,lhObj,col#)) 37268>>> end_procedure 37269>>> 37269>>> procedure aps_resize integer lhObj integer delta_rw# integer delta_cl# integer tmp# 37271>>> integer old_rw# old_cl# register# 37271>>> if num_arguments gt 3 move tmp# to register# 37274>>> else move 1 to register# 37276>>> get size of lhObj to old_cl# 37277>>> move (hi(old_cl#)) to old_rw# 37278>>> move (low(old_cl#)) to old_cl# 37279>>> set size of lhObj to ((old_rw#+delta_rw#) max 0) ((old_cl#+delta_cl#) max 0) 37280>>> if register# send aps_register_max_rc lhObj 37283>>> set p_last_object to lhObj 37284>>> end_procedure 37285>>> 37285>>> procedure aps_relocate integer lhObj integer delta_rw# integer delta_cl# integer lbRegister 37287>>> integer old_rw# old_cl# register# 37287>>> if num_arguments gt 3 move lbRegister to register# 37290>>> else move 1 to register# 37292>>> get location of lhObj to old_cl# 37293>>> move (hi(old_cl#)) to old_rw# 37294>>> move (low(old_cl#)) to old_cl# 37295>>> set location of lhObj to ((old_rw#+delta_rw#) max 0) ((old_cl#+delta_cl#) max 0) 37296>>> if register# send aps_register_max_rc lhObj 37299>>> set p_last_object to lhObj 37300>>> end_procedure 37301>>>end_class // aps_container_mx 37302>>> 37302>>>//> Class aps_control_mx is mixed into all control classes and all 37302>>>//> containers that are not panel containers. That means that all the 37302>>>//> classes mentioned have the properties and the methods defined by 37302>>>//> this mix-in class: 37302>>>class aps_control_mx is a mixin 37303>>> procedure define_aps_control_mx 37305>>> //> Should the control attempt to auto size?: 37305>>> property integer p_auto_size_control_state public true 37306>>> //> Should the control attempt to locate itself 37306>>> //> within the container? 37306>>> property integer p_auto_locate_control_state public true 37307>>> //> Objects of class dbForm may or may not have 37307>>> //> prompt buttons attached. When they do, this 37307>>> //> button is created outside the form, and so 37307>>> //> APS must reserve extra space. This is the purpose 37307>>> //> of property p_extra_external_width. 37307>>> property integer p_extra_external_width public 0 37308>>> property integer p_extra_internal_width public 0 37309>>> //> p_snap_location: 0 means current position 37309>>> //> >0 means adjust to column 37309>>> //> <0 means special adjustments 37309>>> property integer p_snap_location public 0 37310>>> //> In the context of APS you can never trust the size of 37310>>> //> a comboform. Therefore this property is provided to 37310>>> //> let APS know when to handle a control as a comboform. 37310>>> property integer p_is_comboform public 0 // You ain't no friend of mine! 37311>>> //> Should the object try to obtain a label from the global 37311>>> //> label mechanism? 37311>>> property integer p_auto_label_state public true 37312>>> property integer p_auto_label_add_colon_state public true 37313>>> //> Should the object conform to an abstract field type? 37313>>> property integer p_auto_abstract_state public 1 37314>>> //> If yes, which? 37314>>> property integer p_abstract public 0 37315>>> //> APS needs to know the ID of the server of each control. 37315>>> //> Unfortunatly it is not possible to use the server function 37315>>> //> to get that at the time of creation. Therefore this property 37315>>> //> is used to store the server once manually found. 37315>>> property integer p_server private -1 // -1=not checked, 0=not found, >0=svr# 37316>>> // 37316>>> property integer p_jmode_top_vert_offset public 10 37317>>> 37317>>> 37317>>> property integer p_dbControl public 0 // 37318>>> 37318>>> end_procedure 37319>>> 37319>>> 37319>>> // ******************************************************************* 37319>>> procedure aps_auto_label 37321>>> integer file# field# dm# 37321>>> string label# 37321>>> get delegation_mode to dm# 37322>>> set delegation_mode to NO_DELEGATE_OR_ERROR 37323>>> get label to label# 37324>>> if label# eq "" begin 37326>>> get data_file item 0 to file# 37327>>> get data_field item 0 to field# 37328>>> if (file# and field#) begin 37330>>> // If p_auto_label_state lt 0 we obtain the short version of the label 37330>>> if (p_auto_label_state(self)) ge 0 get FieldInf_FieldLabel_Long file# field# to label# 37333>>> else get FieldInf_FieldLabel_Short file# field# to label# 37335>>> if label# ne "" set label to (label#+if(p_auto_label_add_colon_state(self),":","")) 37338>>> end 37338>>>> 37338>>> end 37338>>>> 37338>>> set delegation_mode to dm# 37339>>> end_procedure 37340>>> 37340>>> //> This function manually retrieves the server of a control. This is 37340>>> //> necessary because the DSO structure is not connected at the time 37340>>> //> of object creation. 37340>>> function aps_server returns integer 37342>>> integer PanelID# rval# lhObj dm# 37342>>> get aps_control_mx.p_server to rval# 37343>>> if rval# eq -1 begin // If we have not looked for it yet 37345>>> move self to lhObj 37346>>> get server of lhObj to rval# 37347>>> ifnot rval# begin 37349>>> get aps_PanelID to PanelID# 37350>>> repeat // This loop does a manual delegation 37350>>>> 37350>>> get parent of lhObj to lhObj 37351>>> // If db-controls are nested inside non db-panels errors will occur 37351>>> // from asking what the server is. Thus we set delegation_mode while 37351>>> // asking: 37351>>> get delegation_mode of lhObj to dm# 37352>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 37353>>> get server of lhObj to rval# 37354>>> set delegation_mode of lhObj to dm# 37355>>> until (lhObj=PanelID# or rval#) // Delegation stops when we hit the panel 37357>>> end 37357>>>> 37357>>> set aps_control_mx.p_server to rval# 37358>>> end 37358>>>> 37358>>> function_return rval# 37359>>> end_function 37360>>> 37360>>> // Wow! Try to hand-trace this function down, and you will see what kind of 37360>>> // load it is to _really_ figure out if a field is capslock'ed or not: 37360>>> function is_capslocked integer itm# returns integer 37362>>> integer caps# svr# file# field# lhObj 37362>>> if (p_dbControl(self)) begin 37364>>> get prototype_object to lhObj // ???Why no invalid message from this??? 37365>>> ifnot lhObj move self to lhObj 37368>>> 37368>>> get item_option of lhObj item itm# APS.ITEM_OPTION_CAPSLOCK to caps# 37369>>> // extended_deo_state is not set yet! 37369>>> ifnot caps# begin 37371>>> get aps_server to svr# 37372>>> if svr# begin 37374>>> get data_file of lhObj item itm# to file# 37375>>> get data_field of lhObj item itm# to field# 37376>>> if (file# and field#) begin 37378>>> get which_data_set of svr# file# to svr# 37379>>> if (svr# and file# eq main_file(svr#) and Extended_DSO_State(svr#)) ; get Field_Option of svr# field# dd_capslock to caps# 37382>>> end 37382>>>> 37382>>> end 37382>>>> 37382>>> end 37382>>>> 37382>>> end 37382>>>> 37382>>> function_return caps# 37383>>> end_function 37384>>> 37384>>> procedure aps_auto_size_control 37386>>> integer type# marg# caps# lhObj 37386>>> move self to lhObj 37387>>> 37387>>> get form_datatype item 0 to type# 37388>>> get form_margin item 0 to marg# 37389>>> 37389>>> if type# eq ASCII_WINDOW get is_capslocked 0 to caps# 37392>>> else move 0 to caps# // If not ascii_window it can't be capslocked! 37394>>> 37394>>> ifnot (is_comboform(lhObj,lhObj)) ; set size to (p_form_height(lhObj)) (aps.form_width.iii(lhObj,type#,marg#,caps#)+extra_internal_width(lhObj,lhObj)) 37397>>> else ; // button width  set size to (hi(size(lhObj))) (aps.form_width.iii(lhObj,type#,marg#,caps#)+10+extra_internal_width(lhObj,lhObj)) 37399>>> end_procedure 37400>>> 37400>>> procedure aps_copy_abstract integer abstract# 37402>>> integer file# field# dm# type# marg# 37402>>> ifnot abstract# begin 37404>>> if (p_auto_abstract_state(self)) begin 37406>>> // If an explicit abstract is not specified, we try to obtain one 37406>>> // from the "global field info"-arrangement: 37406>>> get delegation_mode to dm# 37407>>> set delegation_mode to NO_DELEGATE_OR_ERROR 37408>>> get data_file item 0 to file# 37409>>> get data_field item 0 to field# 37410>>> set delegation_mode to dm# 37411>>> if (file# and field#) get gl_abstract file# field# to abstract# 37414>>> end 37414>>>> 37414>>> end 37414>>>> 37414>>> if abstract# begin 37416>>> if abstract# gt 0 begin 37418>>> get gl_datatype 0 abstract# to type# 37419>>> get gl_margin 0 abstract# to marg# 37420>>> set form_datatype item 0 to type# 37421>>> set form_margin item 0 to marg# 37422>>> end 37422>>>> 37422>>> else begin // Copy abstract from file.field 37423>>> move ((0-abstract#)/4096) to file# 37424>>> move (0-abstract#-(file#*4096)) to field# 37425>>> move 0 to abstract# 37426>>> if (file# and field#) begin 37428>>> get gl_abstract file# field# to abstract# 37429>>> if abstract# begin // if MODIFY_FIELD_TYPE has been applied 37431>>> get gl_datatype 0 abstract# to type# 37432>>> get gl_margin 0 abstract# to marg# 37433>>> set form_datatype item 0 to type# 37434>>> set form_margin item 0 to marg# 37435>>> end 37435>>>> 37435>>> else begin // We have to ask the DBMS 37436>>> get gl_generic_form_datatype file# field# to type# 37437>>> get gl_generic_form_margin file# field# to marg# 37438>>> set form_datatype item 0 to type# 37439>>> set form_margin item 0 to marg# 37440>>> end 37440>>>> 37440>>> end 37440>>>> 37440>>> end 37440>>>> 37440>>> end 37440>>>> 37440>>> end_procedure 37441>>> 37441>>> procedure end_define_aps_control_mx 37443>>> integer lhObj 37443>>> move self to lhObj 37444>>> if (p_auto_label_state(self)) send aps_auto_label 37447>>> send aps_copy_abstract (p_abstract(self)) 37448>>> if (p_auto_size_control_state(self)) send aps_auto_size_control 37451>>> if (p_auto_locate_control_state(self)) delegate send aps_auto_locate_control lhObj 37455>>> end_procedure 37456>>> 37456>>> function caption_bar returns integer // Controls do not have captions 37458>>> end_function 37459>>>end_class 37460>>> 37460>>>// Class aps_grid_mx is mixed into the APS grid classes: 37460>>>class aps_grid_mx is a mixin 37461>>> procedure define_aps_grid_mx 37463>>> property integer p_auto_size_columns_state public true 37464>>> property integer p_max_column_width public 999 37465>>> set size to 100 0 // Default height 37466>>> end_procedure 37467>>> procedure aps_auto_grid_labels 37469>>> integer file# field# itm# max# p_obj# 37469>>> string label# 37469>>> move (low(matrix_size(self))-1) to max# // Get number of columns 37470>>> get prototype_object to p_obj# // Get object id of prototype 37471>>> for itm# from 0 to max# 37477>>>> 37477>>> get header_label item itm# to label# 37478>>> if label# eq "" begin 37480>>> get data_file of p_obj# item itm# to file# 37481>>> get data_field of p_obj# item itm# to field# 37482>>> if (file# and field#) begin 37484>>> get FieldInf_FieldLabel_Short file# field# to label# 37485>>> if label# ne "" set header_label item itm# to label# 37488>>> end 37488>>>> 37488>>> end 37488>>>> 37488>>> loop 37489>>>> 37489>>> if (p_extra_internal_width(self)) eq 0 ; if max# eq 0 set p_extra_internal_width to 5 37494>>> set p_auto_label_state to false // Disable standard auto_label 37495>>> end_procedure 37496>>> 37496>>> procedure aps_auto_grid_abstracts 37498>>> integer file# field# itm# max# p_obj# abstract# type# marg# 37498>>> move (low(matrix_size(self))-1) to max# // Get number of columns 37499>>> get prototype_object to p_obj# // Get object id of prototype 37500>>> for itm# from 0 to max# 37506>>>> 37506>>> get data_file of p_obj# item itm# to file# 37507>>> get data_field of p_obj# item itm# to field# 37508>>> if (file# and field#) begin 37510>>> get gl_abstract file# field# to abstract# 37511>>> if abstract# begin 37513>>> get gl_datatype 0 abstract# to type# 37514>>> get gl_margin 0 abstract# to marg# 37515>>> set form_datatype item itm# to type# 37516>>> set form_margin item itm# to marg# 37517>>> end 37517>>>> 37517>>> end 37517>>>> 37517>>> loop 37518>>>> 37518>>> set p_auto_abstract_state to false // Disable standard auto_label 37519>>> end_procedure 37520>>> 37520>>> procedure set aps_fixed_column_width integer column# integer value# 37522>>> set value of (oAPS_PresetColumnWidths(self)) item column# to value# 37523>>> end_procedure 37524>>> 37524>>> procedure set aps_column_abstract integer column# integer file# integer field# 37526>>> set form_margin item column# to (gl_margin(self,file#,field#)) 37527>>> set form_datatype item column# to (gl_datatype(self,file#,field#)) 37528>>> end_procedure 37529>>> 37529>>> function aps_ColumnCorrection integer liColumn returns integer 37531>>> end_function 37532>>> 37532>>> procedure aps_auto_size_columns 37534>>> // This will not size perfectly, but pretty close! 37534>>> integer itm# max# tbl_sz# tbl_width# fld# lhObj 37534>>> integer column_width# type# marg# caps# label_size# field_width# label_width# 37534>>> integer max_column_width# auto_create_prompt_button# 37534>>> integer svr# dd# file# field# p_obj# len# add_it# dm# 37534>>> integer oFixedWidths# liColumnCorrection 37534>>> string label_value# pbv# // pbv# is prompt_button_value 37534>>> 37534>>> move (oAPS_PresetColumnWidths(self)) to oFixedWidths# 37535>>> 37535>>> if (p_dbControl(self)) begin 37537>>> get aps_server to svr# 37538>>> get prototype_object to p_obj# // Get object id of prototype 37539>>> get delegation_mode to dm# // dbList's do not understand what we about to do: 37540>>> set delegation_mode to NO_DELEGATE_OR_ERROR 37541>>> get prompt_button_value to pbv# 37542>>> get auto_create_prompt_button to auto_create_prompt_button# 37543>>> if (auto_create_prompt_button#<>0 and pbv#<>'') length pbv# to len# 37546>>> set delegation_mode to dm# 37547>>> end 37547>>>> 37547>>> 37547>>> move self to lhObj 37548>>> move (hi(size(lhObj))) to tbl_sz# // Get height of grid 37549>>> move (low(matrix_size(lhObj))-1) to max# // Get number of columns 37550>>> move (extra_internal_width(lhObj,lhObj)) to tbl_width# // Initialize total width 37551>>> get p_max_column_width to max_column_width# 37552>>> for itm# from 0 to max# 37558>>>> 37558>>> get header_label item itm# to label_value# 37559>>> // We have to try to figure out if we need to append ">>" to the label 37559>>> if (svr# and len# and right(label_value#,len#)<>pbv#) begin // If dbControl: 37561>>> get data_file of lhObj item itm# to file# 37562>>> get data_field of lhObj item itm# to field# 37563>>> if (file# and field#) begin 37565>>> if (Prompt_Object(p_obj#,itm#) and not(Shadow_State(p_obj#,itm#))) ; move 1 to add_it# 37568>>> else begin 37569>>> get which_data_set of svr# file# to dd# 37570>>> if (dd# and file# eq main_file(dd#) and Extended_DSO_State(dd#)) ; get field_prompt_object of dd# field# dd_capslock to add_it# 37573>>> end 37573>>>> 37573>>> if add_it# move (label_value#*pbv#) to label_value# 37576>>> end 37576>>>> 37576>>> end 37576>>>> 37576>>> 37576>>> move (value(oFixedWidths#,itm#)) to column_width# 37577>>> 37577>>> ifnot column_width# begin 37579>>> get form_datatype item itm# to type# 37580>>> get form_margin item itm# to marg# 37581>>> 37581>>> if type# eq ascii_window get is_capslocked itm# to caps# 37584>>> else move 0 to caps# // If not ascii_window it can't be capslocked! 37586>>> 37586>>> get aps.form_width.iii type# marg# caps# to field_width# 37587>>> if label_value# ne "" get text_extent label_value# to label_size# 37590>>> else move 0 to label_size# 37592>>> move (low(label_size#)*aps.gui2mdu_width#+12.5) to label_width# 37593>>> if itm# eq 0 move (label_width#+2) to label_width# 37596>>> 37596>>> move ((field_width# max label_width#) min max_column_width#) to column_width# 37597>>> end 37597>>>> 37597>>> get aps_ColumnCorrection itm# to liColumnCorrection 37598>>> move (column_width#+liColumnCorrection) to column_width# 37599>>> if column_width# lt 0 move 0 to column_width# 37602>>> move (tbl_width#+column_width#) to tbl_width# 37603>>> set size to tbl_sz# (tbl_width#+5) 37604>>> set form_width item itm# to column_width# 37605>>> loop 37606>>>> 37606>>> send delete_data to oFixedWidths# 37607>>> end_procedure 37608>>>end_class 37609>>> 37609>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- 37609>>>// Global procedures for manipulating size and location 37609>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- 37609>>> 37609>>>procedure aps_align_objects$help for BaseClass integer obj1# integer obj2# integer alignment_mode# integer move# 37611>>> // This procedure should not be called directly from your component code. 37611>>> // It is used by the aps_align_by_moving and aps_align_by_sizing procedures 37611>>> // that are defined just below it. 37611>>> // 37611>>> // We assume that they have a common visible container. 37611>>> // (What this procedure really needed to do is to find a common ancestor 37611>>> // for obj1# and obj2# and then go through all of it to really figure 37611>>> // location offsets out.) 37611>>> integer sz_rw2# sz_cl2# sz_rw1# sz_cl1# 37611>>> integer lc_rw2# lc_cl2# lc_rw1# lc_cl1# eew# 37611>>> get size of obj2# to sz_rw2# 37612>>> get size of obj1# to sz_rw1# 37613>>> move (low(sz_rw2#)) to sz_cl2# 37614>>> move (hi(sz_rw2#)) to sz_rw2# 37615>>> move (low(sz_rw1#)) to sz_cl1# 37616>>> move (hi(sz_rw1#)) to sz_rw1# 37617>>> 37617>>> move (extra_external_width(obj1#,obj1#)) to eew# 37618>>> move (sz_cl1#+eew#) to sz_cl1# 37619>>> move (sz_cl2#+extra_external_width(obj2#,obj2#)) to sz_cl2# 37620>>> 37620>>> get location of obj2# to lc_rw2# 37621>>> get location of obj1# to lc_rw1# 37622>>> move (low(lc_rw2#)) to lc_cl2# 37623>>> move (hi(lc_rw2#)) to lc_rw2# 37624>>> move (low(lc_rw1#)) to lc_cl1# 37625>>> move (hi(lc_rw1#)) to lc_rw1# 37626>>> if move# begin 37628>>> if (alignment_mode# iand SL_ALIGN_LEFT ) move lc_cl2# to lc_cl1# 37631>>> if (alignment_mode# iand SL_ALIGN_TOP ) move lc_rw2# to lc_rw1# 37634>>> if (alignment_mode# iand SL_ALIGN_RIGHT ) move (lc_cl2#+sz_cl2#-sz_cl1#) to lc_cl1# 37637>>> if (alignment_mode# iand SL_ALIGN_BOTTOM ) move (lc_rw2#+sz_rw2#-sz_rw1#) to lc_rw1# 37640>>> if (alignment_mode# iand SL_ALIGN_CENTER ) move (sz_cl2#-sz_cl1#/2+lc_cl2#) to lc_cl1# 37643>>> if (alignment_mode# iand SL_ALIGN_VCENTER) move (sz_rw2#-sz_rw1#/2+lc_rw2#) to lc_rw1# 37646>>> end 37646>>>> 37646>>> else begin 37647>>> if (alignment_mode# iand SL_ALIGN_LEFT ) move lc_cl2# to lc_cl1# 37650>>> if (alignment_mode# iand SL_ALIGN_TOP ) move lc_rw2# to lc_rw1# 37653>>> if (alignment_mode# iand SL_ALIGN_RIGHT ) move (lc_cl2#+sz_cl2#-lc_cl1#) to sz_cl1# 37656>>> if (alignment_mode# iand SL_ALIGN_BOTTOM) move (lc_rw2#+sz_rw2#-lc_rw1#) to sz_rw1# 37659>>> end 37659>>>> 37659>>> set size of obj1# to sz_rw1# (sz_cl1#-eew#) 37660>>> set location of obj1# to lc_rw1# lc_cl1# 37661>>>end_procedure 37662>>> 37662>>>procedure aps_align_by_moving for BaseClass integer obj1# integer obj2# integer alignment_mode# 37664>>> // Align object 1 relative to object 2, by re-locating object 1 37664>>> send aps_align_objects$help obj1# obj2# alignment_mode# 1 37665>>>end_procedure 37666>>> 37666>>>procedure aps_align_by_sizing for BaseClass integer obj1# integer obj2# integer alignment_mode# 37668>>> // Align object 1 relative to object 2, by re-sizing object 1 37668>>> send aps_align_objects$help obj1# obj2# alignment_mode# 0 37669>>>end_procedure 37670>>> 37670>>>procedure aps_size_identical_max for BaseClass integer obj1# integer obj2# integer sizing_mode# 37672>>> // Objects are sized to the bigger of the two. 37672>>> integer sz_rw1# sz_cl1# sz_rw2# sz_cl2# 37672>>> get size of obj1# to sz_rw1# 37673>>> get size of obj2# to sz_rw2# 37674>>> move (low(sz_rw1#)) to sz_cl1# 37675>>> move (hi(sz_rw1#)) to sz_rw1# 37676>>> move (low(sz_rw2#)) to sz_cl2# 37677>>> move (hi(sz_rw2#)) to sz_rw2# 37678>>> if (sizing_mode# iand SL_HORIZONTAL) begin 37680>>> move (sz_cl1# max sz_cl2#) to sz_cl1# 37681>>> move sz_cl1# to sz_cl2# 37682>>> end 37682>>>> 37682>>> if (sizing_mode# iand SL_VERTICAL) begin 37684>>> move (sz_rw1# max sz_rw2#) to sz_rw1# 37685>>> move sz_rw1# to sz_rw2# 37686>>> end 37686>>>> 37686>>> set size of obj1# to sz_rw1# sz_cl1# 37687>>> set size of obj2# to sz_rw2# sz_cl2# 37688>>>end_procedure 37689>>> 37689>>>procedure aps_align_inside_container$help for BaseClass integer ctrl# integer jmode# integer move# 37691>>> // This procedure should not be called directly from your component 37691>>> // code. It is used by the aps_align_inside_container_by_moving and 37691>>> // the aps_align_inside_container_by_sizing procedures that are defined, 37691>>> // just below it. 37691>>> integer ctrl_sz_rw# ctrl_sz_cl# cont_sz_rw# cont_sz_cl# cap_height# 37691>>> integer ctrl_lc_rw# ctrl_lc_cl# cont# dm# eew# 37691>>> get delegation_mode of ctrl# to dm# 37692>>> set delegation_mode of ctrl# to NO_DELEGATE_OR_ERROR 37693>>> get p_extra_external_width of ctrl# to eew# 37694>>> set delegation_mode of ctrl# to dm# 37695>>> // There has to be an APS-container out there! This way we go through 37695>>> // non visible containers and TabPages: 37695>>> get aps_parent of (parent(ctrl#)) to cont# 37696>>> get size of ctrl# to ctrl_sz_rw# 37697>>> move (low(ctrl_sz_rw#)+eew#) to ctrl_sz_cl# 37698>>> move (hi(ctrl_sz_rw#)) to ctrl_sz_rw# 37699>>> 37699>>> get size of cont# to cont_sz_rw# 37700>>> move (low(cont_sz_rw#)) to cont_sz_cl# 37701>>> move (hi(cont_sz_rw#)) to cont_sz_rw# 37702>>> 37702>>> get location of ctrl# to ctrl_lc_rw# 37703>>> move (low(ctrl_lc_rw#)) to ctrl_lc_cl# 37704>>> move (hi(ctrl_lc_rw#)) to ctrl_lc_rw# 37705>>> 37705>>> if (caption_bar(cont#)) move (GetSystemMetrics(SM_CYSMCAPTION)) to cap_height# // 15 37708>>> else move 0 to cap_height# 37710>>> 37710>>> if move# begin 37712>>> if (jmode# iand SL_ALIGN_LEFT ) move (p_left_margin(cont#)) to ctrl_lc_cl# 37715>>> if (jmode# iand SL_ALIGN_RIGHT ) move (cont_sz_cl#-ctrl_sz_cl#-p_right_margin(cont#)) to ctrl_lc_cl# 37718>>> if (jmode# iand SL_ALIGN_CENTER ) move (cont_sz_cl#-ctrl_sz_cl#-p_left_margin(cont#)-p_right_margin(cont#)/2+p_left_margin(cont#)) to ctrl_lc_cl# 37721>>> if (jmode# iand SL_ALIGN_TOP ) move (p_top_margin(cont#)) to ctrl_lc_rw# 37724>>> if (jmode# iand SL_ALIGN_BOTTOM ) move (cont_sz_rw#-ctrl_sz_rw#-p_bottom_margin(cont#)-cap_height#) to ctrl_lc_rw# 37727>>> if (jmode# iand SL_ALIGN_VCENTER) move (cont_sz_rw#-ctrl_sz_rw#-p_top_margin(cont#)-p_bottom_margin(cont#)/2+p_top_margin(cont#)) to ctrl_lc_rw# 37730>>> end 37730>>>> 37730>>> else begin // sizing (and moving) 37731>>> if (jmode# iand SL_ALIGN_LEFT) begin 37733>>> move (ctrl_sz_cl#+ctrl_lc_cl#-p_left_margin(cont#)) to ctrl_sz_cl# 37734>>> move (p_left_margin(cont#)) to ctrl_lc_cl# 37735>>> end 37735>>>> 37735>>> if (jmode# iand SL_ALIGN_RIGHT) move (cont_sz_cl#-ctrl_lc_cl#-p_right_margin(cont#)) to ctrl_sz_cl# 37738>>> 37738>>> if (jmode# iand SL_ALIGN_TOP) begin 37740>>> move (ctrl_sz_rw#+ctrl_lc_rw#-p_top_margin(cont#)) to ctrl_sz_rw# 37741>>> move (p_top_margin(cont#)) to ctrl_lc_rw# 37742>>> end 37742>>>> 37742>>> if (jmode# iand SL_ALIGN_BOTTOM) move (cont_sz_rw#-ctrl_lc_rw#-p_bottom_margin(cont#)) to ctrl_sz_rw# 37745>>> 37745>>> if (jmode# iand SL_ALIGN_TOP or jmode# iand SL_ALIGN_BOTTOM or jmode# iand SL_ALIGN_VCENTER) ; set size of ctrl# to (ctrl_sz_rw#-cap_height#) (ctrl_sz_cl#-eew#) 37748>>> else ; set size of ctrl# to ctrl_sz_rw# (ctrl_sz_cl#-eew#) 37750>>> end 37750>>>> 37750>>> set location of ctrl# to ctrl_lc_rw# ctrl_lc_cl# 37751>>>end_procedure 37752>>> 37752>>>procedure aps_align_inside_container_by_moving for BaseClass integer ctrl# integer jmode# 37754>>> // Align an object (with ID ctrl#) inside its parent by re-locating it. 37754>>> send aps_align_inside_container$help ctrl# jmode# 1 37755>>>end_procedure 37756>>>procedure aps_align_inside_container_by_sizing for BaseClass integer ctrl# integer jmode# 37758>>> // Align an object (with ID ctrl#) inside its parent by re-sizing it. 37758>>> send aps_align_inside_container$help ctrl# jmode# 0 37759>>>end_procedure 37760>>> 37760>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- 37760>>>// This section defines a number of macros that are used for binding 37760>>>// object command line parameters. These are: 37760>>>// 37760>>>// Keywords covered: 37760>>>// 37760>>>// SNAP ; This will make the object locate itself 37760>>>// [RELATIVE_TO obj] relative to a previous objects within the 37760>>>// current container. Valid 's are: 37760>>>// 37760>>>// SL_DOWN 37760>>>// SL_LEFT 37760>>>// SL_LOWER_RIGHT_CORNER_EXTEND_ROW 37760>>>// SL_CURRENT_POS_NO_LABEL_ADJUST 37760>>>// SL_RIGHT 37760>>>// SL_RIGHT_SPACE 37760>>>// SL_UP 37760>>>// SL_LOWER_RIGHT_CORNER 37760>>>// SL_UPPER_RIGHT_CORNER_EXTEND_COLUMN 37760>>>// 37760>>>// Default action is to locate the object 37760>>>// relative to the previous (APS) object in 37760>>>// the current container. It is possible to 37760>>>// change that by adding key word RELATIVE_TO 37760>>>// to the object command line: 37760>>>// 37760>>>// ...snap SL_DOWN relative_to (xx(self)) 37760>>>// 37760>>>// NEXT_ROW Is the equivalent of: "send new_field_row" 37760>>>// before the object declaration. 37760>>>// 37760>>>// NEW_COLUMN Seldom used. Will make the object cursor 37760>>>// go back to the top of the container. 37760>>>// 37760>>>// MAX_ROW Is the equivalent of: send aps_goto_max_row 37760>>>// before the object declaration. 37760>>>// 37760>>>// (1) LABEL "label" Will make the object use label as its label. 37760>>>// Same as: set label to "label" 37760>>>// 37760>>>// (2) LABEL NONE Will disable automatic label assignment. Is the 37760>>>// equivalent of setting p_auto_label_state to 37760>>>// false. 37760>>>// 37760>>>// (3) LABEL SHORT Will make the control use the short (grid-) 37760>>>// version of its standard label. Is the 37760>>>// equivalent of setting p_auto_label_state to -1. 37760>>>// 37760>>>// (4) LABEL COPY ; Will make the control use the standard label 37760>>>// dffile.field of another DBMS field. This is the equivalent 37760>>>// of setting label to: 37760>>>// 37760>>>// (FieldInf_FieldLabel_Long(file#,field#)) 37760>>>// 37760>>>// for the dffile.field desired. 37760>>>// 37760>>>// ABSTRACT (Re-)defines the form_margin and form_type for 37760>>>// that (db)Form to be equal to those defined 37760>>>// for abstract field type . 37760>>>// 37760>>>// Also works with (db)SpinForms and (db)Comboform. 37760>>>// 37760>>> 37760>>> 37760>>> 37760>>> 37760>>> 37760>>> 37760>>> 37760>>> 37760>>> 37760>>> 37760>>> 37760>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 37760>>>// Panel containers 37760>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 37760>>> 37760>>>class aps.View is a View startmac APS.STARTMAC_LABEL 37761>>> procedure construct_object 37763>>> forward send construct_object 37765>>> send define_aps_container_mx 37766>>> send define_aps_panel_mx 37767>>> set p_right_margin to 8 37768>>> send aps_init 37769>>> end_procedure 37770>>> import_class_protocol aps_container_mx 37771>>> import_class_protocol aps_panel_mx 37772>>> procedure end_construct_object 37774>>> forward send end_construct_object 37776>>> send end_define_aps_container_mx 37777>>> send end_define_aps_panel_mx 37778>>> end_procedure 37779>>>end_class 37780>>> 37780>>>class aps.dbView is a dbView startmac APS.STARTMAC_LABEL 37781>>> procedure construct_object 37783>>> forward send construct_object 37785>>> send define_aps_container_mx 37786>>> send define_aps_panel_mx 37787>>> property integer p_auto_label_state public true 37788>>> set p_right_margin to 8 37789>>> send aps_init 37790>>> end_procedure 37791>>> import_class_protocol aps_container_mx 37792>>> import_class_protocol aps_panel_mx 37793>>> procedure end_construct_object 37795>>> forward send end_construct_object 37797>>> send end_define_aps_container_mx 37798>>> send end_define_aps_panel_mx 37799>>> if (p_auto_label_state(self) and label(self)="" and main_dd(self)) ; set label to (File_Display_Name(main_file(main_dd(self)))) 37802>>> end_procedure 37803>>>end_class 37804>>> 37804>>>class aps.ModalPanel is a ModalPanel startmac APS.STARTMAC_LABEL 37805>>> procedure construct_object 37807>>> forward send construct_object 37809>>> send define_aps_container_mx 37810>>> send define_aps_panel_mx 37811>>> set p_right_margin to 8 37812>>> send aps_init 37813>>> end_procedure 37814>>> import_class_protocol aps_container_mx 37815>>> import_class_protocol aps_panel_mx 37816>>> procedure end_construct_object 37818>>> forward send end_construct_object 37820>>> send end_define_aps_container_mx 37821>>> send end_define_aps_panel_mx 37822>>> end_procedure 37823>>>end_class 37824>>> 37824>>>//> Unlike ModalPanel's, dbModalPanel's have a mechanism for adding buttons 37824>>>//> to the panel. This means that the APS augmentation needs an extra 37824>>>//> procedure for positioning the buttons that are added this way. The 37824>>>//> procedure is a re-write of the position_child_objects method in the 37824>>>//> super class. 37824>>>class aps.dbModalPanel is a dbModalPanel startmac APS.STARTMAC_LABEL 37825>>> procedure construct_object 37827>>> forward send construct_object 37829>>> send define_aps_container_mx 37830>>> send define_aps_panel_mx 37831>>> set p_right_margin to 8 37832>>> end_procedure 37833>>> import_class_protocol aps_container_mx 37834>>> import_class_protocol aps_panel_mx 37835>>> procedure position_child_objects // Position add_button-buttons: 37837>>> integer button_count# btn_obj# lhObj itm# max# 37837>>> move (button_ids(self)) to lhObj 37838>>> get item_count of lhObj to max# 37839>>> if max# begin 37841>>> for itm# from 0 to (max#-1) 37847>>>> 37847>>> move (value(lhObj,max#-1-itm#)) to btn_obj# 37848>>> if itm# send aps_auto_locate_control btn_obj# SL_LEFT 37851>>> else send aps_auto_locate_control btn_obj# SL_LOWER_RIGHT_CORNER_EXTEND_ROW 37853>>> loop 37854>>>> 37854>>> end 37854>>>> 37854>>> end_procedure 37855>>> procedure end_construct_object 37857>>> forward send end_construct_object 37859>>> send end_define_aps_container_mx 37860>>> send end_define_aps_panel_mx 37861>>> end_procedure 37862>>>end_class 37863>>> 37863>>> 37863>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 37863>>>// Other containers 37863>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 37863>>> 37863>>>class aps.Group is a Group startmac APS.STARTMAC_LABEL_SNAP 37864>>> procedure construct_object 37866>>> forward send construct_object 37868>>> send define_aps_container_mx 37869>>> send define_aps_control_mx 37870>>> set p_auto_size_control_state to false // Do not autosize as control 37871>>> set p_top_margin to 10 // Set non-default top margin 37872>>> send aps_init // Reflect this in object cursor position 37873>>> end_procedure 37874>>> import_class_protocol aps_container_mx 37875>>> import_class_protocol aps_control_mx 37876>>> procedure end_construct_object 37878>>> forward send end_construct_object 37880>>> send end_define_aps_container_mx // Size the object 37881>>> send end_define_aps_control_mx // Locate the object 37882>>> end_procedure 37883>>>end_class 37884>>> 37884>>>class aps.dbGroup is a dbGroup startmac APS.STARTMAC_LABEL_SNAP 37885>>> procedure construct_object 37887>>> forward send construct_object 37889>>> send define_aps_container_mx 37890>>> send define_aps_control_mx 37891>>> set p_auto_size_control_state to false // Do not autosize as control 37892>>> set p_top_margin to 10 // Set non-default top margin 37893>>> send aps_init // Reflect this in object cursor position 37894>>> end_procedure 37895>>> import_class_protocol aps_container_mx 37896>>> import_class_protocol aps_control_mx 37897>>> procedure end_construct_object 37899>>> forward send end_construct_object 37901>>> send end_define_aps_container_mx // Size the object 37902>>> send end_define_aps_control_mx // Locate the object 37903>>> end_procedure 37904>>>end_class 37905>>> 37905>>>class aps.Container3D is a Container3D startmac APS.STARTMAC_SNAP 37906>>> procedure construct_object 37908>>> forward send construct_object 37910>>> send define_aps_container_mx 37911>>> send define_aps_control_mx 37912>>> set p_auto_size_control_state to false // Do not autosize as control 37913>>> set p_bottom_margin to 7 // Set non-default margins 37914>>> set p_right_margin to 8 37915>>> send aps_init // Reflect this in object cursor position 37916>>> end_procedure 37917>>> import_class_protocol aps_container_mx 37918>>> import_class_protocol aps_control_mx 37919>>> procedure end_construct_object 37921>>> forward send end_construct_object 37923>>> send end_define_aps_container_mx // Size the object 37924>>> send end_define_aps_control_mx // Locate the object 37925>>> end_procedure 37926>>>end_class 37927>>> 37927>>>class aps.dbContainer3D is a dbContainer3D startmac APS.STARTMAC_SNAP 37928>>> procedure construct_object 37930>>> forward send construct_object 37932>>> send define_aps_container_mx 37933>>> send define_aps_control_mx 37934>>> set p_auto_size_control_state to false // Do not autosize as control 37935>>> set p_bottom_margin to 7 // Set non-default margins 37936>>> set p_right_margin to 8 37937>>> send aps_init // Reflect this in object cursor position 37938>>> end_procedure 37939>>> import_class_protocol aps_container_mx 37940>>> import_class_protocol aps_control_mx 37941>>> procedure end_construct_object 37943>>> forward send end_construct_object 37945>>> send end_define_aps_container_mx // Size the object 37946>>> send end_define_aps_control_mx // Locate the object 37947>>> end_procedure 37948>>>end_class 37949>>> 37949>>>class aps.TabDialog is a TabDialog startmac APS.STARTMAC_LABEL_SNAP 37950>>> procedure construct_object 37952>>> forward send construct_object 37954>>> send define_aps_container_mx 37955>>> send define_aps_control_mx 37956>>> set p_auto_size_control_state to false 37957>>> set p_right_margin to 8 37958>>> set p_bottom_margin to 20 37959>>> property integer p_max_row_on_tabdialog public 0 37960>>> property integer p_max_column_on_tabdialog public 0 37961>>> on_key KEY_CTRL+KEY_PGUP send request_previous_tab 37962>>> on_key KEY_CTRL+KEY_PGDN send request_next_tab 37963>>> end_procedure 37964>>> import_class_protocol aps_container_mx 37965>>> import_class_protocol aps_control_mx 37966>>> procedure end_construct_object 37968>>> set p_max_row to (p_max_row_on_tabdialog(self)) 37969>>> set p_max_column to (p_max_column_on_tabdialog(self)) 37970>>> forward send end_construct_object 37972>>> send end_define_aps_container_mx // Size the object 37973>>> send end_define_aps_control_mx // Locate the object 37974>>> end_procedure 37975>>>end_class 37976>>> 37976>>>class aps.dbTabDialog is a dbTabDialog startmac APS.STARTMAC_LABEL_SNAP 37977>>> procedure construct_object 37979>>> forward send construct_object 37981>>> send define_aps_container_mx 37982>>> send define_aps_control_mx 37983>>> set p_auto_size_control_state to false 37984>>> set p_right_margin to 8 37985>>> set p_bottom_margin to 20 37986>>> property integer p_max_row_on_tabdialog public 0 37987>>> property integer p_max_column_on_tabdialog public 0 37988>>> on_key KEY_CTRL+KEY_PGUP send request_previous_tab 37989>>> on_key KEY_CTRL+KEY_PGDN send request_next_tab 37990>>> end_procedure 37991>>> import_class_protocol aps_container_mx 37992>>> import_class_protocol aps_control_mx 37993>>> procedure end_construct_object 37995>>> set p_max_row to (p_max_row_on_tabdialog(self)) 37996>>> set p_max_column to (p_max_column_on_tabdialog(self)) 37997>>> forward send end_construct_object 37999>>> send end_define_aps_container_mx // Size the object 38000>>> send end_define_aps_control_mx // Locate the object 38001>>> end_procedure 38002>>>end_class 38003>>> 38003>>>class aps.TabPage is a TabPage startmac APS.STARTMAC_LABEL 38004>>> procedure construct_object 38006>>> forward send construct_object 38008>>> send aps_init 38009>>> end_procedure 38010>>> procedure end_construct_object 38012>>> integer max_row# max_column# 38012>>> get p_max_row to max_row# 38013>>> get p_max_column to max_column# 38014>>> if max_row# gt (p_max_row_on_tabdialog(self)) ; set p_max_row_on_tabdialog to max_row# 38017>>> if max_column# gt (p_max_column_on_tabdialog(self)) ; set p_max_column_on_tabdialog to max_column# 38020>>> forward send end_construct_object 38022>>> end_procedure 38023>>>end_class 38024>>> 38024>>>class aps.dbTabPage is a dbTabPage startmac APS.STARTMAC_LABEL 38025>>> procedure construct_object 38027>>> forward send construct_object 38029>>> send aps_init 38030>>> end_procedure 38031>>> procedure end_construct_object 38033>>> integer max_row# max_column# 38033>>> get p_max_row to max_row# 38034>>> get p_max_column to max_column# 38035>>> if max_row# gt (p_max_row_on_tabdialog(self)) ; set p_max_row_on_tabdialog to max_row# 38038>>> if max_column# gt (p_max_column_on_tabdialog(self)) ; set p_max_column_on_tabdialog to max_column# 38041>>> forward send end_construct_object 38043>>> end_procedure 38044>>>end_class 38045>>> 38045>>>class aps.RadioGroup is a RadioGroup startmac APS.STARTMAC_LABEL_SNAP 38046>>> procedure construct_object 38048>>> forward send construct_object 38050>>> send define_aps_container_mx 38051>>> send define_aps_control_mx 38052>>> property integer p_radio_minimum_label_width public 0 38053>>> set p_auto_size_control_state to false // Do not autosize as control 38054>>> set p_top_margin to 10 // Set non-default top margin 38055>>> send aps_init // Reflect this in object cursor position 38056>>> send tab_column_define 1 5 0 jmode_left 38057>>> end_procedure 38058>>> import_class_protocol aps_container_mx 38059>>> import_class_protocol aps_control_mx 38060>>> procedure end_construct_object 38062>>> forward send end_construct_object 38064>>> send end_define_aps_container_mx // Size the object 38065>>> send end_define_aps_control_mx // Locate the object 38066>>> end_procedure 38067>>>end_class 38068>>> 38068>>>//> Child objects to this class (aps.radio's) will have their 38068>>>//> label set from either DD settings or from values set in 38068>>>//> the Fill_list procedure. 38068>>>//> The label value will then not have been set on object 38068>>>//> creation time, and this class (the container) will not be 38068>>>//> able to size correct. To prevent the container object to 38068>>>//> be sized too narrow the property p_radio_minimum_label_width 38068>>>//> can be used to set a minimum width for the radio's label. 38068>>>class aps.dbRadioGroup is a dbRadioGroup startmac APS.STARTMAC_LABEL_SNAP 38069>>> procedure construct_object 38071>>> forward send construct_object 38073>>> send define_aps_container_mx 38074>>> send define_aps_control_mx 38075>>> property integer p_radio_minimum_label_width public 0 38076>>> set p_auto_size_control_state to false // Do not autosize as control 38077>>> set p_top_margin to 10 // Set non-default top margin 38078>>> send aps_init // Reflect this in object cursor position 38079>>> send tab_column_define 1 5 0 jmode_left 38080>>> end_procedure 38081>>> import_class_protocol aps_container_mx 38082>>> import_class_protocol aps_control_mx 38083>>> procedure end_construct_object 38085>>> forward send end_construct_object 38087>>> send end_define_aps_container_mx // Size the object 38088>>> send end_define_aps_control_mx // Locate the object 38089>>> end_procedure 38090>>>end_class 38091>>> 38091>>>class aps.RadioContainer is a RadioContainer 38092>>> function p_radio_minimum_label_width returns integer 38094>>> end_function 38095>>>end_class 38096>>> 38096>>>class aps.dbRadioContainer is a dbRadioContainer 38097>>> function p_radio_minimum_label_width returns integer 38099>>> end_function 38100>>>end_class 38101>>> 38101>>> 38101>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38101>>>// Controls 38101>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38101>>> 38101>>>class aps.Form is a form startmac APS.STARTMAC_LABEL_SNAP 38102>>> procedure construct_object 38104>>> forward send construct_object 38106>>> send define_aps_control_mx 38107>>> end_procedure 38108>>> procedure set form_button integer itm# integer val# 38110>>> forward set form_button item itm# to val# 38112>>> // val#= 0: Create if needed, and expand size 38112>>> // val#= 1: Create prompt button, period! Do not expand size. 38112>>> // val#= 2: Remove prompt button (Don't use this) 38112>>> if (val#=1 and not(p_extra_internal_width(self))) ; set p_extra_internal_width to 10 38115>>> end_procedure 38116>>> import_class_protocol aps_control_mx 38117>>> procedure end_construct_object 38119>>> forward send end_construct_object 38121>>> send end_define_aps_control_mx 38122>>> end_procedure 38123>>>end_class 38124>>> 38124>>>class aps.dbForm is a dbForm startmac APS.STARTMAC_LABEL_SNAP 38125>>> procedure construct_object 38127>>> forward send construct_object 38129>>> send define_aps_control_mx 38130>>> set p_dbControl to true 38131>>> end_procedure 38132>>> 38132>>> procedure auto_extra_external_width 38134>>> integer svr# prompt_object# file# field# 38134>>> if (not(p_extra_external_width(self)) and auto_create_prompt_button(self)) begin 38136>>> get aps_server to svr# 38137>>> if svr# begin 38139>>> get data_file item 0 to file# 38140>>> get data_field item 0 to field# 38141>>> if (file# and field#) begin 38143>>> get which_data_set of svr# file# to svr# 38144>>> if (svr# and file# eq main_file(svr#) and Extended_DSO_State(svr#)) begin 38146>>> get Field_Prompt_Object of svr# field# to prompt_object# 38147>>> if prompt_object# set p_extra_internal_width to (p_extra_internal_width(self)+13) // Makes APS resize the object 38150>>> end 38150>>>> 38150>>> end 38150>>>> 38150>>> end 38150>>>> 38150>>> end 38150>>>> 38150>>> end_procedure 38151>>> 38151>>> procedure set form_button integer itm# integer val# 38153>>> forward set form_button item itm# to val# 38155>>> if (val#=1 and not(p_extra_internal_width(self))) ; set p_extra_internal_width to 13 38158>>> end_procedure 38159>>> import_class_protocol aps_control_mx 38160>>> procedure end_construct_object 38162>>> forward send end_construct_object 38164>>> send auto_extra_external_width 38165>>> send end_define_aps_control_mx 38166>>> end_procedure 38167>>>end_class 38168>>> 38168>>>class aps.ComboForm is a ComboForm startmac APS.STARTMAC_LABEL_SNAP 38169>>> procedure construct_object 38171>>> forward send construct_object 38173>>> send define_aps_control_mx 38174>>> set p_is_comboform to true 38175>>> end_procedure 38176>>> import_class_protocol aps_control_mx 38177>>> procedure end_construct_object 38179>>> forward send end_construct_object 38181>>> send end_define_aps_control_mx 38182>>> end_procedure 38183>>>end_class 38184>>> 38184>>>class aps.dbComboForm is a dbComboForm startmac APS.STARTMAC_LABEL_SNAP 38185>>> procedure construct_object 38187>>> forward send construct_object 38189>>> send define_aps_control_mx 38190>>> set p_dbControl to true 38191>>> set p_is_comboform to true 38192>>> end_procedure 38193>>> procedure set form_button integer itm# integer val# 38195>>> forward set form_button item itm# to val# 38197>>> ifnot (p_extra_external_width(self)) ; set p_extra_external_width to 10 // It always has a button 38200>>> end_procedure 38201>>> import_class_protocol aps_control_mx 38202>>> procedure end_construct_object 38204>>> forward send end_construct_object 38206>>> send end_define_aps_control_mx 38207>>> end_procedure 38208>>>end_class 38209>>> 38209>>>class aps.SpinForm is a dbSpinForm startmac APS.STARTMAC_LABEL_SNAP 38210>>> procedure construct_object 38212>>> forward send construct_object 38214>>> send define_aps_control_mx 38215>>> set p_dbControl to true 38216>>> set p_extra_internal_width to 10 // It always has a button 38217>>> end_procedure 38218>>> import_class_protocol aps_control_mx 38219>>> procedure end_construct_object 38221>>> forward send end_construct_object 38223>>> send end_define_aps_control_mx 38224>>> end_procedure 38225>>>end_class 38226>>> 38226>>>class aps.dbSpinForm is a dbSpinForm startmac APS.STARTMAC_LABEL_SNAP 38227>>> procedure construct_object 38229>>> forward send construct_object 38231>>> send define_aps_control_mx 38232>>> set p_dbControl to true 38233>>> set p_extra_internal_width to 10 // It always has a button 38234>>> end_procedure 38235>>> import_class_protocol aps_control_mx 38236>>> procedure end_construct_object 38238>>> forward send end_construct_object 38240>>> send end_define_aps_control_mx 38241>>> end_procedure 38242>>>end_class 38243>>> 38243>>>class aps.CheckBox is a CheckBox startmac APS.STARTMAC_LABEL_SNAP 38244>>> procedure construct_object 38246>>> forward send construct_object 38248>>> send define_aps_control_mx 38249>>> set p_auto_label_add_colon_state to false 38250>>> end_procedure 38251>>> import_class_protocol aps_control_mx 38252>>> procedure aps_auto_size_control 38254>>> integer sz# 38254>>> get size to sz# 38255>>> set size to (p_form_height(self)) (low(sz#) max 9) 38256>>> end_procedure 38257>>> procedure end_construct_object 38259>>> forward send end_construct_object 38261>>> send end_define_aps_control_mx 38262>>> end_procedure 38263>>>end_class 38264>>> 38264>>>class aps.dbCheckBox is a dbCheckBox startmac APS.STARTMAC_LABEL_SNAP 38265>>> procedure construct_object 38267>>> forward send construct_object 38269>>> send define_aps_control_mx 38270>>> set p_dbControl to true 38271>>> set p_auto_label_add_colon_state to false 38272>>> end_procedure 38273>>> import_class_protocol aps_control_mx 38274>>> procedure aps_auto_size_control 38276>>> integer sz# 38276>>> get size to sz# 38277>>> set auto_size_state to false 38278>>> set size to (p_form_height(self)) (low(sz#) max 9) 38279>>> end_procedure 38280>>> procedure end_construct_object 38282>>> forward send end_construct_object 38284>>> send end_define_aps_control_mx 38285>>> end_procedure 38286>>>end_class 38287>>> 38287>>>class aps.Edit is an Edit startmac APS.STARTMAC_LABEL_SNAP 38288>>> procedure construct_object 38290>>> forward send construct_object 38292>>> send define_aps_control_mx 38293>>> set p_auto_size_control_state to false 38294>>> set label_justification_mode to default_label_jmode // Default is jmode_top 38295>>> end_procedure 38296>>> import_class_protocol aps_control_mx 38297>>> procedure end_construct_object 38299>>> forward send end_construct_object 38301>>> send end_define_aps_control_mx 38302>>> end_procedure 38303>>>end_class 38304>>> 38304>>>class aps.dbEdit is a dbEdit startmac APS.STARTMAC_LABEL_SNAP 38305>>> procedure construct_object 38307>>> forward send construct_object 38309>>> send define_aps_control_mx 38310>>> set p_dbControl to true 38311>>> set p_auto_size_control_state to false 38312>>> set label_justification_mode to default_label_jmode // (dflblmx.pkg) 38313>>> end_procedure 38314>>> import_class_protocol aps_control_mx 38315>>> procedure end_construct_object 38317>>> forward send end_construct_object 38319>>> send end_define_aps_control_mx 38320>>> end_procedure 38321>>>end_class 38322>>> 38322>>>class aps.RichEdit is an cRichEdit startmac APS.STARTMAC_LABEL_SNAP 38323>>> procedure construct_object 38325>>> forward send construct_object 38327>>> send define_aps_control_mx 38328>>> set p_auto_size_control_state to false 38329>>> set label_justification_mode to default_label_jmode // Default is jmode_top 38330>>> end_procedure 38331>>> import_class_protocol aps_control_mx 38332>>> procedure end_construct_object 38334>>> forward send end_construct_object 38336>>> send end_define_aps_control_mx 38337>>> end_procedure 38338>>>end_class 38339>>> 38339>>>class aps.dbRichEdit is a cdbRichEdit startmac APS.STARTMAC_LABEL_SNAP 38340>>> procedure construct_object 38342>>> forward send construct_object 38344>>> send define_aps_control_mx 38345>>> set p_dbControl to true 38346>>> set p_auto_size_control_state to false 38347>>> set label_justification_mode to default_label_jmode // (dflblmx.pkg) 38348>>> end_procedure 38349>>> import_class_protocol aps_control_mx 38350>>> procedure end_construct_object 38352>>> forward send end_construct_object 38354>>> send end_define_aps_control_mx 38355>>> end_procedure 38356>>>end_class 38357>>> 38357>>>class aps.TextEdit is an cTextEdit startmac APS.STARTMAC_LABEL_SNAP 38358>>> procedure construct_object 38360>>> forward send construct_object 38362>>> send define_aps_control_mx 38363>>> set p_auto_size_control_state to false 38364>>> set label_justification_mode to default_label_jmode // Default is jmode_top 38365>>> end_procedure 38366>>> import_class_protocol aps_control_mx 38367>>> procedure end_construct_object 38369>>> forward send end_construct_object 38371>>> send end_define_aps_control_mx 38372>>> end_procedure 38373>>>end_class 38374>>> 38374>>>class aps.dbTextEdit is a cdbTextEdit startmac APS.STARTMAC_LABEL_SNAP 38375>>> procedure construct_object 38377>>> forward send construct_object 38379>>> send define_aps_control_mx 38380>>> set p_dbControl to true 38381>>> set p_auto_size_control_state to false 38382>>> set label_justification_mode to default_label_jmode // (dflblmx.pkg) 38383>>> end_procedure 38384>>> import_class_protocol aps_control_mx 38385>>> procedure end_construct_object 38387>>> forward send end_construct_object 38389>>> send end_define_aps_control_mx 38390>>> end_procedure 38391>>>end_class 38392>>> 38392>>>class aps.TextBox is a TextBox startmac APS.STARTMAC_LABEL_SNAP 38393>>> procedure construct_object 38395>>> forward send construct_object 38397>>> send define_aps_control_mx 38398>>> // set justification_mode to (JMODE_CENTER+JMODE_VCENTER) 38398>>> set p_auto_size_control_state to false 38399>>> property integer p_fixed_width public 0 38400>>> property integer p_fixed_height public 0 38401>>> end_procedure 38402>>> procedure set fixed_size integer h# integer w# 38404>>> set p_fixed_height to h# 38405>>> set p_fixed_width to w# 38406>>> end_procedure 38407>>> import_class_protocol aps_control_mx 38408>>> procedure end_construct_object 38410>>> integer fixed_width# fixed_height# 38410>>> forward send end_construct_object 38412>>> set auto_size_state to false 38413>>> get p_fixed_width to fixed_width# 38414>>> get p_fixed_height to fixed_height# 38415>>> set size to (if(fixed_height#,fixed_height#,p_form_height(self))) (if(fixed_width#,fixed_width#,low(size(self)))) 38416>>> send end_define_aps_control_mx 38417>>> end_procedure 38418>>>end_class 38419>>> 38419>>>// This is a stupid class that will probably go away! 38419>>>class aps.TextBoxEx is an aps.Edit startmac APS.STARTMAC_LABEL_SNAP 38420>>> procedure construct_object 38422>>> forward send construct_object 38424>>> set object_shadow_state to true 38425>>> set border_style to BORDER_NONE 38426>>> set scroll_bar_visible_state to false 38427>>> end_procedure 38428>>>end_class 38429>>> 38429>>>class aps.Button is a Button startmac APS.STARTMAC_LABEL_SNAP 38430>>> procedure construct_object 38432>>> forward send construct_object 38434>>> set size to 14 60 38435>>> send define_aps_control_mx 38436>>> set p_auto_size_control_state to false 38437>>> end_procedure 38438>>> import_class_protocol aps_control_mx 38439>>> procedure end_construct_object 38441>>> forward send end_construct_object 38443>>> send end_define_aps_control_mx 38444>>> end_procedure 38445>>>end_class 38446>>> 38446>>>//> When objects of this class are used within a aps.dbRadioGroup 38446>>>//> the label value will be set from either DD settings or from 38446>>>//> values set in the Fill_list procedure in the group 38446>>>//> The label value will then not have been set on object 38446>>>//> creation time, and this class will not be able to size correct. 38446>>>//> To prevent this the container object has a property called 38446>>>//> p_radio_minimum_label_width that will be used to set a minimum 38446>>>//> width for the radio objects label. 38446>>>//> OBS! If you want to place aps.Radio objects within an object 38446>>>//> of the RadioContainer or the dbRadioContainer class you must 38446>>>//> manually place a function in the container object to return 38446>>>//> the value of p_radio_minimum_label_width. 38446>>>class aps.Radio is a Radio startmac APS.STARTMAC_LABEL_SNAP 38447>>> procedure construct_object 38449>>> forward send construct_object 38451>>> send define_aps_control_mx 38452>>> set p_auto_label_add_colon_state to false 38453>>> end_procedure 38454>>> import_class_protocol aps_control_mx 38455>>> procedure aps_auto_size_control 38457>>> integer sz# 38457>>> get size to sz# 38458>>> set auto_size_state to false 38459>>> set size to (p_form_height(self)) (low(sz#) MAX p_radio_minimum_label_width(self)) 38460>>> end_procedure 38461>>> procedure end_construct_object 38463>>> forward send end_construct_object 38465>>> send end_define_aps_control_mx 38466>>> end_procedure 38467>>>end_class 38468>>> 38468>>> 38468>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38468>>>// Grid controls 38468>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38468>>> 38468>>>class aps.List is a List startmac APS.STARTMAC_LABEL_SNAP 38469>>> procedure construct_object 38471>>> forward send construct_object 38473>>> send define_aps_control_mx 38474>>> set p_auto_size_control_state to false 38475>>> end_procedure 38476>>> import_class_protocol aps_control_mx 38477>>> procedure end_construct_object 38479>>> forward send end_construct_object 38481>>> send end_define_aps_control_mx 38482>>> end_procedure 38483>>>end_class 38484>>> 38484>>>class aps.dbList is a dbList startmac APS.STARTMAC_SNAP 38485>>> procedure construct_object 38487>>> forward send construct_object 38489>>> send define_aps_control_mx 38490>>> set p_dbControl to true 38491>>> send define_aps_grid_mx 38492>>> set p_auto_size_control_state to false 38493>>> end_procedure 38494>>> import_class_protocol aps_control_mx 38495>>> import_class_protocol aps_grid_mx 38496>>> procedure end_construct_object 38498>>> forward send end_construct_object 38500>>> if (p_auto_label_state(self)) send aps_auto_grid_labels 38503>>> if (p_auto_abstract_state(self)) send aps_auto_grid_abstracts 38506>>> if (p_auto_size_columns_state(self)) send aps_auto_size_columns 38509>>> send end_define_aps_control_mx 38510>>> end_procedure 38511>>>end_class 38512>>> 38512>>>class aps.Grid is a Grid startmac APS.STARTMAC_SNAP 38513>>> procedure construct_object 38515>>> forward send construct_object 38517>>> send define_aps_control_mx 38518>>> send define_aps_grid_mx 38519>>> set p_auto_label_state to false 38520>>> set p_auto_size_control_state to false 38521>>> end_procedure 38522>>> import_class_protocol aps_control_mx 38523>>> import_class_protocol aps_grid_mx 38524>>> procedure end_construct_object 38526>>> forward send end_construct_object 38528>>>// if (p_auto_abstract_state(self)) send aps_auto_grid_abstracts 38528>>> if (p_auto_size_columns_state(self)) send aps_auto_size_columns // Defined in define_aps_grid_mx 38531>>> send end_define_aps_control_mx 38532>>> end_procedure 38533>>>end_class 38534>>> 38534>>>class aps.dbGrid is a dbGrid startmac APS.STARTMAC_SNAP 38535>>> procedure construct_object 38537>>> forward send construct_object 38539>>> send define_aps_control_mx 38540>>> set p_dbControl to true 38541>>> send define_aps_grid_mx 38542>>> set p_auto_size_control_state to false 38543>>> end_procedure 38544>>> import_class_protocol aps_control_mx 38545>>> import_class_protocol aps_grid_mx 38546>>> procedure entry_display integer iFile integer iType 38548>>> forward send entry_display iFile iType 38550>>> end_procedure 38551>>> procedure end_construct_object 38553>>> forward send end_construct_object 38555>>> if (p_auto_label_state(self)) send aps_auto_grid_labels 38558>>> if (p_auto_abstract_state(self)) send aps_auto_grid_abstracts 38561>>> if (p_auto_size_columns_state(self)) send aps_auto_size_columns // Defined in define_aps_grid_mx 38564>>> send end_define_aps_control_mx 38565>>> end_procedure 38566>>>end_class 38567>>> 38567>>> 38567>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38567>>>// Freaks 38567>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38567>>> 38567>>>class aps.dbTabView is a dbTabView startmac APS.STARTMAC_LABEL 38568>>> procedure construct_object 38570>>> forward send construct_object 38572>>> send aps_init 38573>>> end_procedure 38574>>> procedure end_construct_object 38576>>> integer max_row# max_column# 38576>>> get p_max_row to max_row# 38577>>> get p_max_column to max_column# 38578>>> if max_row# gt (p_max_row_on_tabdialog(self)) set p_max_row_on_tabdialog to max_row# 38581>>> if max_column# gt (p_max_column_on_tabdialog(self)) set p_max_column_on_tabdialog to max_column# 38584>>> forward send end_construct_object 38586>>> end_procedure 38587>>>end_class 38588>>> 38588>>>//> The aps.DataDictionary class only differs from the standard VDF class 38588>>>//> in that when queried about field specific status help, it will first 38588>>>//> check its internal array (this is standard class behavior). If that 38588>>>//> does not return a value the global status_help array (defined in 38588>>>//> fieldinf.pkg) will be checked. Don't use it. 38588>>> 38588>>>class aps.DataDictionary is a DataDictionary 38589>>> function status_help integer fld# returns string 38591>>> string rval# 38591>>> forward get status_help fld# to rval# 38593>>> if rval# eq "" get gl_status_help (main_file(self)) fld# to rval# 38596>>> function_return rval# 38597>>> end_function 38598>>>end_class 38599>>> 38599>>> 38599>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38599>>>// Multi Buttons 38599>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38599>>>// 38599>>>// aps.Multi_Button 38599>>>// 38599>>>//> An aps.Multi_Button does not have a name equivalent in the standard VDF 38599>>>//> class hierarchy. It is a normal button and it is only "multi" in that 38599>>>//> you often declare a number of them in a row. What makes it special is 38599>>>//> that APS is capable of locating them more easily than normal aps.Buttons. 38599>>>//> 38599>>>//> aps.Multi_Buttons are not "snapped" anywhere. They are all located at 38599>>>//> the same time, when sending the aps_locate_multi_buttons message. 38599>>>//> 38599>>>//> One word of WARNING: If more aps.Multi_Button's are defined than 38599>>>//> will fit in the container (horizontally) the container will collapse 38599>>>//> (negative size). No check is built into APS for this condition. It's one 38599>>>//> of those oddities you'll have to know about. 38599>>> 38599>>>desktop_section 38604>>> object aps.multi_button_array is an array 38606>>> // Upon declaration of a multi_button its object ID is registered in this 38606>>> // global array. This way all multi_buttons are collected and when 38606>>> // sending the message aps_locate_multi_buttons all multi_buttons are 38606>>> // located, and the array is reset. 38606>>> set delegation_mode to delegate_to_parent 38607>>> property integer p_aps_container public 0 38609>>> property integer p_mb_height public 0 38611>>> property integer p_mb_width public 0 38613>>> property integer p_mb_space public -1 38615>>> procedure register_button.i integer lhObj 38618>>> integer item_count# 38618>>> get item_count to item_count# 38619>>> set value item item_count# to lhObj 38620>>> // If first object, we retrieve the obj_id of the container in which 38620>>> // the buttons are located: 38620>>> ifnot item_count# set p_aps_container to (aps_parent(lhObj)) 38623>>> end_procedure 38624>>> procedure arrange_objects.iii integer snap_tmp# integer orientation_tmp# integer relative_to_tmp# 38627>>> integer relative_to# aps_cont# max# orientation# itm# lhObj dm# spc# org_spc# 38627>>> integer backwards# trailing_snap# snap# 38627>>> integer restore_spc# 38627>>> get item_count to max# 38628>>> if max# begin // If there is any objects registered at all? 38630>>> get p_aps_container to aps_cont# 38631>>> 38631>>> if num_arguments gt 0 move snap_tmp# to snap# 38634>>> else move SL_LOWER_RIGHT_CORNER_EXTEND_ROW to snap# 38636>>> if num_arguments gt 1 move orientation_tmp# to orientation# 38639>>> else move SL_HORIZONTAL to orientation# 38641>>> if num_arguments gt 2 move relative_to_tmp# to relative_to# 38644>>> else get p_last_object of aps_cont# to relative_to# 38646>>> 38646>>> move 0 to restore_spc# 38647>>> if snap# eq SL_VERTICAL begin 38649>>> move SL_UPPER_RIGHT_CORNER_EXTEND_COLUMN to snap# 38650>>> move SL_VERTICAL to orientation# 38651>>> get p_mb_space to spc# 38652>>> if spc# ne -1 begin 38654>>> get p_row_space of aps_cont# to org_spc# 38655>>> set p_row_space of aps_cont# to spc# 38656>>> move 1 to restore_spc# 38657>>> end 38657>>>> 38657>>> end 38657>>>> 38657>>> if snap# eq SL_HORIZONTAL begin 38659>>> move SL_LOWER_RIGHT_CORNER_EXTEND_ROW to snap# 38660>>> move SL_HORIZONTAL to orientation# 38661>>> get p_mb_space to spc# 38662>>> if spc# ne -1 begin 38664>>> get p_column_space of aps_cont# to org_spc# 38665>>> set p_column_space of aps_cont# to spc# 38666>>> move 2 to restore_spc# 38667>>> end 38667>>>> 38667>>> end 38667>>>> 38667>>> 38667>>> // Now we have to figure out in which order to locate the 38667>>> // objects (forwards or backwards). 38667>>> 38667>>> if orientation# eq SL_HORIZONTAL begin 38669>>> if (snap#=SL_LEFT or snap#=SL_LOWER_RIGHT_CORNER_EXTEND_ROW or snap#=SL_LOWER_RIGHT_CORNER) begin 38671>>> move 1 to backwards# 38672>>> move SL_LEFT to trailing_snap# 38673>>> end 38673>>>> 38673>>> else begin // Forward horizontal 38674>>> move 0 to backwards# 38675>>> move SL_RIGHT to trailing_snap# 38676>>> end 38676>>>> 38676>>> end 38676>>>> 38676>>> else begin // vertical 38677>>> if (snap#=SL_LOWER_RIGHT_CORNER_EXTEND_ROW or snap#=SL_UP) begin 38679>>> move 1 to backwards# 38680>>> move SL_UP to trailing_snap# 38681>>> end 38681>>>> 38681>>> else begin // Forward vertical 38682>>> move 0 to backwards# 38683>>> move SL_DOWN to trailing_snap# 38684>>> end 38684>>>> 38684>>> end 38684>>>> 38684>>> 38684>>> set p_last_object of aps_cont# to relative_to# 38685>>> if backwards# get value item (max#-1) to lhObj 38688>>> else get value item 0 to lhObj 38690>>> send aps_auto_locate_control to aps_cont# lhObj snap# 38691>>> send aps_push_current_position to aps_cont# 38692>>> if lhObj begin 38694>>> get delegation_mode of lhObj to dm# 38695>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 38696>>> send Locate_Extra_Label to lhObj 38697>>> set delegation_mode of lhObj to dm# 38698>>> end 38698>>>> 38698>>> send aps_pop_current_position to aps_cont# 38699>>> 38699>>> for itm# from 1 to (max#-1) 38705>>>> 38705>>> if backwards# get value item (max#-1-itm#) to lhObj 38708>>> else get value item itm# to lhObj 38710>>> send aps_auto_locate_control to aps_cont# lhObj trailing_snap# 38711>>> send aps_push_current_position to aps_cont# 38712>>> get delegation_mode of lhObj to dm# 38713>>> set delegation_mode of lhObj to NO_DELEGATE_OR_ERROR 38714>>> send Locate_Extra_Label to lhObj 38715>>> set delegation_mode of lhObj to dm# 38716>>> send aps_pop_current_position to aps_cont# 38717>>> loop 38718>>>> 38718>>> send delete_data 38719>>> end 38719>>>> 38719>>> set p_mb_height to 0 // Reset temporary Multi_Button size 38720>>> set p_mb_width to 0 38721>>> set p_mb_space to -1 38722>>> if restore_spc# eq 1 set p_row_space of aps_cont# to org_spc# 38725>>> if restore_spc# eq 2 set p_column_space of aps_cont# to org_spc# 38728>>> end_procedure 38729>>> end_object 38730>>>end_desktop_section 38735>>> 38735>>>procedure aps_locate_multi_buttons global integer snap_tmp# integer orientation_tmp# integer relative_to_tmp# 38737>>> if num_arguments gt 2 send arrange_objects.iii to (aps.multi_button_array(self)) snap_tmp# orientation_tmp# relative_to_tmp# 38740>>> else begin 38741>>> if num_arguments gt 1 send arrange_objects.iii to (aps.multi_button_array(self)) snap_tmp# orientation_tmp# 38744>>> else begin 38745>>> if num_arguments gt 0 send arrange_objects.iii to (aps.multi_button_array(self)) snap_tmp# 38748>>> else send arrange_objects.iii to (aps.multi_button_array(self)) 38750>>> end 38750>>>> 38750>>> end 38750>>>> 38750>>>end_procedure 38751>>> 38751>>>procedure aps_register_multi_button global integer lhObj 38753>>> send register_button.i to (aps.multi_button_array(self)) lhObj 38754>>>end_procedure 38755>>> 38755>>>procedure set multi_button_size global integer x# integer y# 38757>>> set p_mb_height of (aps.multi_button_array(self)) to x# 38758>>> set p_mb_width of (aps.multi_button_array(self)) to y# 38759>>>end_procedure 38760>>> 38760>>>procedure set multi_button_spacing global integer x# 38762>>> set p_mb_space of (aps.multi_button_array(self)) to x# 38763>>>end_procedure 38764>>> 38764>>>class aps.Multi_Button is a aps.Button 38765>>> procedure construct_object 38767>>> forward send construct_object 38769>>> set p_auto_locate_control_state to false 38770>>> on_key kleftarrow send previous // Since buttons of this class are 38771>>> on_key krightarrow send next // arranged in a row (horizontally or 38772>>> on_key kuparrow send previous // vertically), we make them respond 38773>>> on_key kdownarrow send next // to the arrow keys. 38774>>> property string psExtraLabel public "" 38775>>> property integer piExtraLabelID public 0 38776>>> end_procedure 38777>>> procedure Locate_Extra_Label 38779>>> string str# 38779>>> integer lhObj parent# self# liAnchorValue 38779>>> set delegation_mode to DELEGATE_TO_PARENT 38780>>> get psExtraLabel to str# 38781>>> if str# ne "" begin 38783>>> get piExtraLabelID to lhObj 38784>>> move self to self# 38785>>> get peAnchors to liAnchorValue 38786>>> ifnot lhObj begin 38788>>> get parent to parent# 38789>>> move parent# to self 38790>>> object oExtraLabel is a aps.TextBox label str# snap SL_DOWN relative_to self# 38799>>> set auto_size_state to false 38800>>> set fixed_size to 8 0 38801>>> move self to lhObj 38802>>> set peAnchors to liAnchorValue 38803>>> end_object 38804>>> set piExtraLabelID of self# to lhObj 38805>>> move self# to self 38806>>> end 38806>>>> 38806>>> send aps_auto_locate_control lhObj SL_DOWN self# 38807>>> send aps_align_by_moving lhObj self# SL_ALIGN_CENTER 38808>>> end 38808>>>> 38808>>> end_procedure 38809>>> procedure end_construct_object 38811>>> integer self# 38811>>> forward send end_construct_object 38813>>> move self to self# 38814>>> send aps_register_multi_button self# 38815>>> if (p_mb_height(aps.multi_button_array(self))) set size to (p_mb_height(aps.multi_button_array(self))) (p_mb_width(aps.multi_button_array(self))) 38818>>> end_procedure 38819>>>end_class 38820>>> 38820>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38820>>>// Exotics 38820>>>// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 38820>>> 38820>>>function aps_read_bitmap_guisize global string bitmap# integer ch# returns integer 38822>>> integer guisize# 38822>>> string str# // The method used for reading the size 38822>>> direct_input channel ch# bitmap# // of a bitmap has been stolen from 38824>>> [~seqeof] begin // splash.pkg by Andrew S. Kaplan 38826>>>> 38826>>> set_channel_position ch# to 18 38827>>>> 38827>>> read_block channel ch# str# 6 38829>>> move ( ascii(mid(str#,1,6))) to guisize# 38830>>> move (guisize#*256+ascii(mid(str#,1,5))) to guisize# 38831>>> move (guisize#*256+ascii(mid(str#,1,2))) to guisize# 38832>>> move (guisize#*256+ascii(mid(str#,1,1))) to guisize# 38833>>> end 38833>>>> 38833>>> close_input channel ch# 38835>>> function_return guisize# 38836>>>end_function 38837>>> 38837>>>class aps.BitmapContainer is a BitmapContainer startmac APS.STARTMAC_SNAP 38838>>> procedure construct_object 38840>>> forward send construct_object 38842>>> send define_aps_container_mx 38843>>> send define_aps_control_mx 38844>>> set p_auto_size_control_state to false // Do not autosize as control 38845>>> set p_bottom_margin to 7 // Set non-default bottom margin 38846>>> set p_right_margin to 8 38847>>> send aps_init // Reflect this in object cursor position 38848>>> end_procedure 38849>>> import_class_protocol aps_container_mx 38850>>> import_class_protocol aps_control_mx 38851>>> 38851>>> function read_channel returns integer // Objects of this class needs to read 38853>>> function_return 5 // from a file via a channel. These 38854>>> end_function // hooks are provided for augmentation 38855>>> procedure release_channel integer ch# // purposes, if you do not want to use 38857>>> end_procedure // channel 5. 38858>>> 38858>>> procedure end_construct_object 38860>>> integer size_h# size_w# bitmap_h# bitmap_w# ch# 38860>>> forward send end_construct_object 38862>>> get read_channel to ch# 38863>>> get aps_read_bitmap_guisize (bitmap(self)) ch# to bitmap_h# 38864>>> send release_channel ch# 38865>>> move (low(bitmap_h#)) to bitmap_w# 38866>>> move (hi(bitmap_h#)) to bitmap_h# 38867>>> set guisize to bitmap_h# bitmap_w# 38868>>> send adjust_logicals 38869>>> get size to bitmap_h# 38870>>> move (low(bitmap_h#)) to bitmap_w# 38871>>> move (hi(bitmap_h#)) to bitmap_h# // Now we have the bitmap size 38872>>> 38872>>> send end_define_aps_container_mx // Size the object 38873>>> send end_define_aps_control_mx // Locate the object 38874>>> 38874>>> get size to size_h# 38875>>> move (low(size_h#)) to size_w# 38876>>> move (hi(size_h#)) to size_h# 38877>>> 38877>>> set size to (size_h# max bitmap_h#) (size_w# max bitmap_w#) 38878>>> delegate send aps_register_max_rc self 38880>>> end_procedure 38881>>>end_class 38882>>> 38882>>>define APS.TBSTYLE_WRAPABLE for |CI$200 // Mystery! Got it from Sam Cannone 38882>>> 38882>>>//> aps.ToolButton is not an authorized class. I invented it for use within 38882>>>//> Views and ModalPanels. Its purpose is that of a normal button, but 38882>>>//> instead of a text it should display bitmaps (like toolbar's). What 38882>>>//> further differentiates it from a normal button is its ability to 38882>>>//> display tool-tips and status help. It will not take focus! 38882>>>//> 38882>>>//> Its interface is that of a BasicToolbar except that only the following 38882>>>//> messages are implemented: 38882>>>//> 38882>>>//> imagelist_add, add_button, add_tooltip and set status_help 38882>>>//> 38882>>>//> If you add more than one button they will appear next to each other 38882>>>//> horizontally. However, you may set property p_horizontal_button_count to 38882>>>//> x to make it wrap after x buttons. (Set it to 1 to make the buttons 38882>>>//> appear vertically). 38882>>>//> 38882>>>//> It will probably only work with small bitmaps. SAMPLE06.SRC displays 38882>>>//> an example. 38882>>>// 38882>>> 38882>>>class aps.ToolButton is a Container3D startmac APS.STARTMAC_SNAP 38883>>> procedure construct_object 38885>>> forward send construct_object 38887>>> send define_aps_container_mx 38888>>> send define_aps_control_mx 38889>>> set p_auto_size_control_state to false // Do not autosize as control 38890>>> set border_style to border_none // No visible border 38891>>> object oToolBar is a basictoolbar 38893>>> set window_style to APS.TBSTYLE_WRAPABLE true // Wrap if necessary 38894>>> set focus_mode to pointer_only // Do not take focus 38895>>> set window_style to CCS_NODIVIDER true // Do not display line above buttons 38896>>> end_object 38897>>> property integer p_horizontal_button_count public 999 38898>>> end_procedure 38899>>> import_class_protocol aps_container_mx 38900>>> import_class_protocol aps_control_mx 38901>>> 38901>>> procedure aps_auto_size_container // Augmented to calculate size from 38903>>> // number of buttons in the object 38903>>> integer tb# count# sz# buttons_w# buttons_h# 38903>>> move (oToolBar(self)) to tb# 38904>>> get p_horizontal_button_count to buttons_w# 38905>>> get item_count of tb# to count# 38906>>> if buttons_w# gt count# begin 38908>>> move count# to buttons_w# 38909>>> move 1 to buttons_h# 38910>>> end 38910>>>> 38910>>> else move (count#-1/buttons_w#+1) to buttons_h# 38912>>> get guisize of tb# to sz# 38913>>> set guisize to (hi(sz#)-5*buttons_h#+1) (low(sz#)-5*buttons_w#) 38914>>> send adjust_logicals 38915>>> end_procedure 38916>>> 38916>>> procedure end_construct_object 38918>>> forward send end_construct_object 38920>>> send end_define_aps_container_mx // Size the object 38921>>> send end_define_aps_control_mx // Locate the object 38922>>> end_procedure 38923>>> 38923>>> // Redirect the following messages to embedded toolbar object: 38923>>> procedure set status_help string itm# string str# 38925>>> if num_arguments gt 1 set status_help of (oToolBar(self)) item itm# to str# 38928>>> else set status_help of (oToolBar(self)) to itm# 38930>>> end_procedure 38931>>> procedure add_button integer bmp# integer msg# integer lhObj 38933>>> if num_arguments gt 2 send add_button to (oToolBar(self)) bmp# msg# lhObj 38936>>> else send add_button to (oToolBar(self)) bmp# msg# 38938>>> end_procedure 38939>>> procedure add_tooltip string tip# 38941>>> send add_tooltip to (oToolBar(self)) tip# 38942>>> end_procedure 38943>>> procedure imagelist_add string bmp# 38945>>> send imagelist_add to (oToolBar(self)) bmp# 38946>>> end_procedure 38947>>>end_class 38948>>> 38948>>>class aps.ComboFormAux is a aps.ComboForm 38949>>> procedure construct_object 38951>>> forward send construct_object 38953>>> object oAux_Values is an array 38955>>> end_object 38956>>> set combo_sort_state to false 38957>>> end_procedure 38958>>> // Private message: 38958>>> procedure set aux_value integer liItm integer liValue 38960>>> set value of (oAux_Values(self)) item liItm to liValue 38961>>> end_procedure 38962>>> // Private message: 38962>>> function aux_value integer liItm returns integer 38964>>> function_return (value(oAux_Values(self),liItm)) 38965>>> end_function 38966>>> // Augmented Combo_Add_Item: 38966>>> Procedure Combo_Add_Item string lsValue integer liAuxValue 38968>>> integer liAux liItm 38968>>> forward send Combo_Add_Item lsValue 38970>>> if num_arguments gt 1 move liAuxValue to liAux 38973>>> get Combo_Item_Count to liItm 38974>>> set aux_value item (liItm-1) to liAux 38975>>> End_Procedure 38976>>> // Returns the aux value of the currently selected value: 38976>>> Function Combo_Current_Aux_Value returns integer 38978>>> integer liItm 38978>>> get Combo_Item_Matching (value(self,0)) to liItm 38979>>> function_return (aux_value(self,liItm)) 38980>>> End_Function 38981>>> // Set the value corresponding to aux value passed in liAuxValue 38981>>> Procedure set Combo_Current_Aux_Value integer liAuxValue 38983>>> integer liItm liMax lhObj 38983>>> move (oAux_Values(self)) to lhObj 38984>>> get item_count of lhObj to liMax 38985>>> for liItm from 0 to (liMax-1) 38991>>>> 38991>>> if (value(lhObj,liItm)=liAuxValue) Set Value item 0 to (Combo_Value(self,liItm)) 38994>>> loop 38995>>>> 38995>>> End_Procedure 38996>>> 38996>>> function iFindAuxValue integer liAuxValue returns integer 38998>>> integer liItem liMax lhObj 38998>>> move (oAux_Values(self)) to lhObj 38999>>> get item_count of lhObj to liMax 39000>>> decrement liMax 39001>>> for liItem from 0 to liMax 39007>>>> 39007>>> if (value(lhObj,liItem)=liAuxValue) function_return liItem 39010>>> loop 39011>>>> 39011>>> function_return -1 39012>>> end_function 39013>>> 39013>>> 39013>>> 39013>>> // Augmented Combo_Delete_Data 39013>>> Procedure Combo_Delete_Data 39015>>> forward send Combo_Delete_Data 39017>>> send delete_data to (oAux_Values(self)) 39018>>> End_Procedure 39019>>>end_class // aps.ComboFormAux 39020>>> 39020>>>// The SetWindowPos external function and the constants below it are as 39020>>>// defined in the WinUser.pkg DAC package. 39020>>>External_Function ApsSetWindowPos "SetWindowPos" User32.dll Handle hWnd# Handle hWndAfter# Integer x# Integer y# Integer cx# Integer cy# Integer uFlags# Returns Integer 39021>>> 39021>>>class aps.TopMostModalPanel is a aps.ModalPanel 39022>>> Procedure Popup_Group 39024>>> Integer swp# 39024>>> Forward Send Popup_Group 39026>>> Move (ApsSetWindowPos(Window_Handle(self), APS.HWND_TOPMOST, 0, 0, 0, 0, APS.SWP_NOMOVE ior APS.SWP_NOSIZE)) to swp# 39027>>> End_Procedure 39028>>>End_Class 39029>>> 39029>>>class aps.dbTopMostModalPanel is a aps.dbModalPanel 39030>>> //procedure popup 39030>>> // Set Extended_Window_Style to WS_EX_TOOLWINDOW False 39030>>> // forward send popup 39030>>> //end_procedure 39030>>> Procedure Popup_Group 39032>>> Integer swp# 39032>>> Forward Send Popup_Group 39034>>> Move (ApsSetWindowPos(Window_Handle(self), APS.HWND_TOPMOST, 0, 0, 0, 0, APS.SWP_NOMOVE ior APS.SWP_NOSIZE)) to swp# 39035>>> End_Procedure 39036>>>End_Class 39037>>> 39037>>>class aps.BasicPanel is a BasicPanel startmac APS.STARTMAC_LABEL 39038>>> procedure construct_object 39040>>> forward send construct_object 39042>>> send define_aps_container_mx 39043>>> send define_aps_panel_mx 39044>>> set p_right_margin to 8 39045>>> send aps_init // Reflect this in object cursor position 39046>>> end_procedure 39047>>> import_class_protocol aps_container_mx 39048>>> import_class_protocol aps_panel_mx 39049>>> procedure end_construct_object 39051>>> forward send end_construct_object 39053>>> send end_define_aps_container_mx 39054>>> send end_define_aps_panel_mx 39055>>> end_procedure 39056>>>end_class 39057>>> 39057>>>class aps.LineControl is a LineControl 39058>>> procedure construct_object 39060>>> forward send construct_object 39062>>> set location to (p_cur_row(self)) (p_cur_column(self)) 39063>>> set guisize to 2 25 39064>>> send adjust_logicals 39065>>> end_procedure 39066>>> procedure set size integer height# integer width# 39068>>> integer gui# 39068>>> forward set size to height# width# 39070>>> get guisize to gui# 39071>>> set guisize to 2 (low(gui#)) 39072>>> send adjust_logicals 39073>>> end_procedure 39074>>> procedure end_construct_object 39076>>> forward send end_construct_object 39078>>> send aps_register_max_rc self 39079>>> end_procedure 39080>>>end_class 39081>>> 39081>>>procedure aps_SetMinimumDialogSize global integer lhPanel 39083>>> set piMinSize of lhPanel to (hi(size(lhPanel))) (low(size(lhPanel))) 39084>>>end_procedure 39085>>> 39085>>>// class aps.ReportView is a ReportView startmac APS.STARTMAC_LABEL 39085>>>// procedure construct_object 39085>>>// forward send construct_object 39085>>>// send define_aps_container_mx 39085>>>// send define_aps_panel_mx 39085>>>// set p_right_margin to 8 39085>>>// send aps_init 39085>>>// end_procedure 39085>>>// import_class_protocol aps_container_mx 39085>>>// import_class_protocol aps_panel_mx 39085>>>// procedure end_construct_object 39085>>>// forward send end_construct_object 39085>>>// send end_define_aps_container_mx 39085>>>// send end_define_aps_panel_mx 39085>>>// end_procedure 39085>>>// end_class 39085>>> 39085>>> 39085>>>// Subclass all APS classes 39085>>>// 39085>>>// You are encouraged to sub-class the APS classes since these only 39085>>>// addresses APS-issues. You probably want to add further customization. 39085>>>// 39085>>>// class my.View is a aps.View 39085>>>// end_class 39085>>>// class my.dbView is a aps.dbView 39085>>>// end_class 39085>>>// class my.ModalPanel is a aps.ModalPanel 39085>>>// end_class 39085>>>// class my.dbModalPanel is a aps.dbModalPanel 39085>>>// end_class 39085>>>// class my.Group is a aps.Group 39085>>>// end_class 39085>>>// class my.dbGroup is a aps.dbGroup 39085>>>// end_class 39085>>>// class my.Container3D is a aps.Container3D 39085>>>// end_class 39085>>>// class my.dbContainer3D is a aps.dbContainer3D 39085>>>// end_class 39085>>>// class my.TabDialog is a aps.TabDialog 39085>>>// end_class 39085>>>// class my.dbTabDialog is a aps.dbTabDialog 39085>>>// end_class 39085>>>// class my.TabPage is a aps.TabPage 39085>>>// end_class 39085>>>// class my.dbTabPage is a aps.dbTabPage 39085>>>// end_class 39085>>>// class my.RadioGroup is a aps.RadioGroup 39085>>>// end_class 39085>>>// class my.dbRadioGroup is a aps.dbRadioGroup 39085>>>// end_class 39085>>>// class my.RadioContainer is a aps.RadioContainer 39085>>>// end_class 39085>>>// class my.dbRadioContainer is a aps.dbRadioContainer 39085>>>// end_class 39085>>>// class my.Form is a aps.Form 39085>>>// end_class 39085>>>// class my.dbForm is a aps.dbForm 39085>>>// end_class 39085>>>// class my.ComboForm is a aps.ComboForm 39085>>>// end_class 39085>>>// class my.dbComboForm is a aps.dbComboForm 39085>>>// end_class 39085>>>// class my.SpinForm is a aps.SpinForm 39085>>>// end_class 39085>>>// class my.dbSpinForm is a aps.dbSpinForm 39085>>>// end_class 39085>>>// class my.CheckBox is a aps.CheckBox 39085>>>// end_class 39085>>>// class my.dbCheckBox is a aps.dbCheckBox 39085>>>// end_class 39085>>>// class my.Edit is a aps.Edit 39085>>>// end_class 39085>>>// class my.dbEdit is a aps.dbEdit 39085>>>// end_class 39085>>>// class my.TextBox is a aps.TextBox 39085>>>// end_class 39085>>>// class my.Button is a aps.Button 39085>>>// end_class 39085>>>// class my.Radio is a aps.Radio 39085>>>// end_class 39085>>>// class my.List is a aps.List 39085>>>// end_class 39085>>>// class my.dbList is a aps.dbList 39085>>>// end_class 39085>>>// class my.Grid is a aps.Grid 39085>>>// end_class 39085>>>// class my.dbGrid is a aps.dbGrid 39085>>>// end_class 39085>>>// class my.Multi_Button is a aps.Multi_Button 39085>>>// end_class 39085>>>// class my.BitmapContainer is a aps.BitmapContainer 39085>>>// end_class 39085>>>// class my.ToolButton is a aps.ToolButton 39085>>>// end_class 39085> 39085>// This is how to force the program to compile into a specific language (english) 39085>// without regard to the falue of symbol LNG_DEFAULT in language.pkg: 39085>Use LangSymb.pkg // Language symbols Including file: langsymb.pkg (C:\Apps\VDFQuery\AppSrc\langsymb.pkg) 39085>>>// Use LangSymb.pkg // Language symbols 39085>>>// 39085>>>// This package file is part of VDFQuery. 39085>>> 39085>>>define LNG_DUTCH for 0 // 131 39085>>>define LNG_FRENCH for 1 // 133 39085>>>define LNG_SPANISH for 2 // 134 39085>>>define LNG_ITALIAN for 3 // 139 // NOT TRANSLATED. DO NOT SELECT! 39085>>>define LNG_ENGLISH for 4 // 144 39085>>>define LNG_DANISH for 5 // 145 39085>>>define LNG_SWEDISH for 6 // 146 39085>>>define LNG_NORWEGIAN for 7 // 147 39085>>>define LNG_GERMAN for 8 // 149 39085>>>define LNG_PORTUGUESE for 9 // 155 39085>>>define LNG_PAPIAMENTU for 10 // 199 // NOT TRANSLATED. DO NOT SELECT! 39085>>>define LNG_MAX for 11 // Points one higher than the highest language 39085>define lng_default for LNG_ENGLISH 39085>// end enforcement. 39085> 39085>Use Splash.utl // Graphic splish-splash Including file: splash.utl (C:\Apps\VDFQuery\AppSrc\splash.utl) 39085>>>// Use Splash.utl // 39085>>> 39085>>>Use VdfGraph.utl // Graphics for Visual DataFlex Including file: vdfgraph.utl (C:\Apps\VDFQuery\AppSrc\vdfgraph.utl) 39085>>>>>// ********************************************************************** 39085>>>>>// Use VdfGraph.utl // Graphics for Visual DataFlex 39085>>>>>// 39085>>>>>// by Sture Andersen and friends 39085>>>>>// Version: 1.4 39085>>>>>// 39085>>>>>// The basic mechanism of this package is derived from standard DAC package 39085>>>>>// dfshape.pkg by Stuart Booth. Some of the comments in here stems from that. 39085>>>>>// 39085>>>>>// 39085>>>>>// Create: Tue 27-05-1997 - 39085>>>>>// Update: Tue 10-06-1997 - cAutoScaler class added 39085>>>>>// Fri 13-06-1997 - cCoordinateSystem class added 39085>>>>>// Wed 25-06-1997 - Fixed various errors in coordinate 39085>>>>>// transformation functions 39085>>>>>// Sun 21-09-1997 - Leak identified and fixed 39085>>>>>// Wed 15-10-1997 - Bar chart added 39085>>>>>// Sat 06-12-1997 - External paint mode added 39085>>>>>// Wed 18-02-1998 - APS taken out (class now in apsgraph.pkg). 39085>>>>>// Sat 28-03-1998 - Polylines and polygons added (Geoff Furlong 39085>>>>>// of MSG Systems implemented the methods needed) 39085>>>>>// Fri 16-10-1998 - Added True Type font ability 39085>>>>>// Mon 19-10-1998 - Re-worked mthd_TextOut to be able to vertically 39085>>>>>// center a text (using DrawText instead of TextOut) 39085>>>>>// Wed 21-10-1998 - Properties that specified number of steps are 39085>>>>>// now of type integer 39085>>>>>// - Better control of axis texts 39085>>>>>// - Eliminated lack of precision when printing 39085>>>>>// to VPE (rectangles) 39085>>>>>// - Character conversion error fixed 39085>>>>>// --- Ver 1.1 --- 39085>>>>>// Fri 06-11-1998 - Fixed a leak in TT fonts. 39085>>>>>// - Procedure WMSG_GrphPaint source of pen and 39085>>>>>// brush leak. Procedure fixed. 39085>>>>>// - Procedure Add4Angle added 39085>>>>>// --- Ver 1.2 --- 39085>>>>>// Mon 30-11-1998 - Polylines may now consist of more than 32 39085>>>>>// points (thanks to Ben Weijers). 39085>>>>>// Mon 21-12-1998 - Dots implemented 39085>>>>>// Wed 23-12-1998 - Procedures DrawAxisTextX and DrawAxisTextY of 39085>>>>>// the cCoordinateSystem class have been changed 39085>>>>>// (now works in parent coordinates). 39085>>>>>// - Properties pxTextOffset and pyTextOffset have 39085>>>>>// been added to the cCoordinateSystem. 39085>>>>>// - Properties pViewPortX and pViewPortY added. 39085>>>>>// - Global functions RGB_Darken, RGB_Brighten, 39085>>>>>// RGB_Blend and RGB_Negate added. 39085>>>>>// Sat 02-01-1999 - Procedures Write_To_File and Read_From_File 39085>>>>>// added. 39085>>>>>// Wed 06-01-1999 - Events onMouseDown, onMouseDrag, onMouseMove 39085>>>>>// and onMouseUp are now captured. 39085>>>>>// Wed 13-01-1999 - Procedure AddDot added to cCoordinateSystem class. 39085>>>>>// Thu 05-10-2000 - Mouse trackable objects implemented (grtest25.pkg) 39085>>>>>// --- Ver 1.3 --- 39085>>>>>// Wed 19-09-2001 - Now updates global variable gr$TrackArray correctly 39085>>>>>// Tue 02-10-2001 - Fixed incorrect mouse tracking on resize event. This 39085>>>>>// caused the "Number too large to convert to integer" 39085>>>>>// error seen when re-zising long enough. 39085>>>>>// - Added double click event (Doesn't work) 39085>>>>>// - Four new properties on GraphArea: 39085>>>>>// piX_Offset, piY_Offset (Pixel offset) 39085>>>>>// piX_Range, piY_Range (Default for both is 10000) 39085>>>>>// Don't use these!! 39085>>>>>// --- Ver 1.4 --- 39085>>>>>// Wed 09-02-2005 - Release_All_Content procedure added 39085>>>>>// Clears all added objects. (Note: You have to repaint 39085>>>>>// manually after cleaning up). May be handy for some reason. 39085>>>>>// (Chris Stammen) 39085>>>>>// Tue 15-02-2005 - Offscreen image processing added (no more flickering) 39085>>>>>// Eraseback doesnt erase anymore. 39085>>>>>// Some GDI functions added for doing the job. 39085>>>>>// SRCCOPY defined for bitblitting the screen. 39085>>>>>// See GrphPaint procedure for changes (Chris Stammen) 39085>>>>>// 39085>>>>>// Tue 15-02-2005 - Added new mechanism for setting background color (and 39085>>>>>// making sure it is ignored when printed via VPE). 39085>>>>>// - Updated grdemo.src a bit. 39085>>>>>// 39085>>>>>// Tue 15-03-2005 - Changed procedure draw_background (Chris Stammen) 39085>>>>>// 39085>>>>>// Mon 28-11-2005 - Added property pbPixelScale that will change the 39085>>>>>// coordinate system of a GraphicArea object from 39085>>>>>// 10000x10000 no matter its visible size to the actual 39085>>>>>// number of pixels. 39085>>>>>// 39085>>>>>// 39085>>>>>// Jakob Kruse has been a great help on GDI issues. 39085>>>>>// Chris Stammen added some very clever code to get rid of screen flicker 39085>>>>>// when resizing and dragging. 39085>>>>>// 39085>>>>>// Drawing is what we do when we specify what is going to be inside 39085>>>>>// the area. Painting is what the object does to present our drawing 39085>>>>>// on the screen. 39085>>>>>// 39085>>>>>// By reasonable convention the origin of a graphic area is in the upper 39085>>>>>// left corner with the cursor moving down for increasing values of X and 39085>>>>>// moving right with increasing values of Y. 39085>>>>>// 39085>>>>>// *********************************************************************** 39085>>>>> 39085>>>>>use dfallent // I cannot figure out which packages to use so we use 'em all 39085>>>>>use font_dlg // Standard DAC package. Contains useful constant declarations. 39085>>>>>use Strings.nui // String manipulation for VDF 39085>>>>>Use RGB.utl // Some color functions Including file: rgb.utl (C:\Apps\VDFQuery\AppSrc\rgb.utl) 39085>>>>>>>// This package is obsolete. Use rgb.nui instead 39085>>>>>>>Use RGB.nui // Some color functions Including file: rgb.nui (C:\Apps\VDFQuery\AppSrc\rgb.nui) 39085>>>>>>>>>// Use RGB.nui // Some basic RGB color functions 39085>>>>>>>>>// Part of VDFQuery by Sture ApS 39085>>>>>>>>> 39085>>>>>>>>>//> pkgdoc.begin 39085>>>>>>>>>//> This package contains some global functions to manipulate RGB colors. 39085>>>>>>>>>//> The RGB color model is an additive color model in which red, green, and blue light are combined in various ways 39085>>>>>>>>>//> to create other colors. The very idea for the model itself and the abbreviation "RGB" come from the three primary 39085>>>>>>>>>//> colors in additive light models (check: http://www.wordiq.com/definition/RGB). 39085>>>>>>>>>//> pkgdoc.end 39085>>>>>>>>> 39085>>>>>>>>>Use Strings.nui // String manipulation for VDF 39085>>>>>>>>> 39085>>>>>>>>>//> Return a RGB color composed from red, green and blue components (each of a value between 0 and 255) 39085>>>>>>>>>function RGB_Compose global integer liRed integer liGreen integer liBlue returns integer 39087>>>>>>>>> function_return (liBlue*256+liGreen*256+liRed) 39088>>>>>>>>>end_function 39089>>>>>>>>> 39089>>>>>>>>>//> Brighten a RGB color by a percentage. 39089>>>>>>>>>function RGB_Brighten global integer liColor integer liPercent returns integer 39091>>>>>>>>> integer liRed liGreen liBlue 39091>>>>>>>>> move (liColor IAND $0000FF) to liRed 39092>>>>>>>>> move (liColor IAND $00FF00/256) to liGreen 39093>>>>>>>>> move (liColor IAND $FF0000/65536) to liBlue 39094>>>>>>>>> move (255-liRed*liPercent/100+liRed) to liRed 39095>>>>>>>>> move (255-liGreen*liPercent/100+liGreen) to liGreen 39096>>>>>>>>> move (255-liBlue*liPercent/100+liBlue) to liBlue 39097>>>>>>>>> function_return (liBlue*256+liGreen*256+liRed) 39098>>>>>>>>>end_function 39099>>>>>>>>> 39099>>>>>>>>>//> Darken a RGB color by a percentage. 39099>>>>>>>>>function RGB_Darken global integer liColor integer liPercent returns integer 39101>>>>>>>>> integer liRed liGreen liBlue 39101>>>>>>>>> move (liColor IAND $0000FF) to liRed 39102>>>>>>>>> move (liColor IAND $00FF00/256) to liGreen 39103>>>>>>>>> move (liColor IAND $FF0000/65536) to liBlue 39104>>>>>>>>> move (-liRed*liPercent/100+liRed) to liRed 39105>>>>>>>>> move (-liGreen*liPercent/100+liGreen) to liGreen 39106>>>>>>>>> move (-liBlue*liPercent/100+liBlue) to liBlue 39107>>>>>>>>> function_return (liBlue*256+liGreen*256+liRed) 39108>>>>>>>>>end_function 39109>>>>>>>>> 39109>>>>>>>>>//> Blend two RGB colors weighing color1 by a percentage. 39109>>>>>>>>>function RGB_Blend global integer liColor1 integer liColor2 integer liPercent1 returns integer 39111>>>>>>>>> integer liRed1 liGreen1 liBlue1 39111>>>>>>>>> integer liRed2 liGreen2 liBlue2 39111>>>>>>>>> move (liColor1 IAND $0000FF) to liRed1 39112>>>>>>>>> move (liColor1 IAND $00FF00/256) to liGreen1 39113>>>>>>>>> move (liColor1 IAND $FF0000/65536) to liBlue1 39114>>>>>>>>> move (liColor2 IAND $0000FF) to liRed2 39115>>>>>>>>> move (liColor2 IAND $00FF00/256) to liGreen2 39116>>>>>>>>> move (liColor2 IAND $FF0000/65536) to liBlue2 39117>>>>>>>>> move (liRed1*liPercent1+(100-liPercent1*liRed2)/100) to liRed1 39118>>>>>>>>> move (liGreen1*liPercent1+(100-liPercent1*liGreen2)/100) to liGreen1 39119>>>>>>>>> move (liBlue1*liPercent1+(100-liPercent1*liBlue2)/100) to liBlue1 39120>>>>>>>>> function_return (liBlue1*256+liGreen1*256+liRed1) 39121>>>>>>>>>end_function 39122>>>>>>>>> 39122>>>>>>>>>//> Negate a RGB color 39122>>>>>>>>>function RGB_Negate global integer liColor returns integer 39124>>>>>>>>> integer liRed liGreen liBlue 39124>>>>>>>>> move (liColor IAND $0000FF) to liRed 39125>>>>>>>>> move (liColor IAND $00FF00/256) to liGreen 39126>>>>>>>>> move (liColor IAND $FF0000/65536) to liBlue 39127>>>>>>>>> move (255-liRed) to liRed 39128>>>>>>>>> move (255-liGreen) to liGreen 39129>>>>>>>>> move (255-liBlue) to liBlue 39130>>>>>>>>> function_return (liBlue*256+liGreen*256+liRed) 39131>>>>>>>>>end_function 39132>>>>>>>>> 39132>>>>>>>>>//> Translate a RGB color to HTML syntax. 39132>>>>>>>>>function RGB_ToHTML global integer liColor returns string 39134>>>>>>>>> integer liRed liGreen liBlue 39134>>>>>>>>> move (liColor IAND $0000FF) to liRed 39135>>>>>>>>> move (liColor IAND $00FF00/256) to liGreen 39136>>>>>>>>> move (liColor IAND $FF0000/65536) to liBlue 39137>>>>>>>>> function_return ("#"+ByteToHex(liRed)+ByteToHex(liGreen)+ByteToHex(liBlue)) 39138>>>>>>>>>end_function 39139>>>>>>>>> 39139>>>>>>>>>function RGB_HTMLToRgb global string lsColor returns integer 39141>>>>>>>>> integer liRed liGreen liBlue 39141>>>>>>>>> move (uppercase(replace("#",lsColor,""))) to lsColor 39142>>>>>>>>> get HexToByte (mid(lsColor,2,1)) to liRed 39143>>>>>>>>> get HexToByte (mid(lsColor,2,3)) to liGreen 39144>>>>>>>>> get HexToByte (mid(lsColor,2,5)) to liBlue 39145>>>>>>>>> function_return (RGB_Compose(liRed,liGreen,liBlue)) 39146>>>>>>>>>end_function 39147>>>>>Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes 39147>>>>> 39147>>>>>Define SRCCOPY For |CI$00CC0020 //* dest = source */ 39147>>>>> 39147>>>>>External_Function32 GrphDeleteDC "DeleteDC" GDI32.DLL Handle hDC Returns Integer 39148>>>>>External_Function32 GrphBitBlt "BitBlt" GDI32.DLL Handle hDC_Dest dWord D_x dWord D_y dWord width dWord height Handle hDC_Source dWord S_x dWord S_y dWord dwType returns Integer 39149>>>>>External_Function32 GrphCreateCompatibleBitmap "CreateCompatibleBitmap" GDI32.DLL Handle hDC dWord dwWidth dWord dwHeight returns dWord 39150>>>>>External_Function32 GrphCreateCompatibleDC "CreateCompatibleDC" GDI32.DLL Handle hDC returns Integer 39151>>>>> 39151>>>>>External_Function32 GrphOemToCharA "OemToCharA" USER32.DLL Pointer hpszOem Pointer hpszWindow Returns Integer 39152>>>>>External_Function32 GrphSetTextAlign "SetTextAlign" GDI32.DLL Handle hDC dWord TextAlign RETURNS integer 39153>>>>>External_Function32 GrphCreateHatchBrush "CreateHatchBrush" GDI32.DLL dWord nHatchStyle dWord crColor Returns Integer 39154>>>>>External_Function32 GrphPolygon "Polygon" GDI32.DLL Handle hDC Pointer lpPolyRect dWord dwPoints Returns Integer 39155>>>>>External_Function32 GrphPolyLine "Polyline" GDI32.DLL Handle hDC Pointer lpPolyRect dWord dwPoints Returns Integer 39156>>>>>External_Function32 GrphSetPolyFillMode "SetPolyFillMode" GDI32.DLL Handle hDC Integer iFillMode Returns Integer 39157>>>>>// This version became too much (long) for the compiler: 39157>>>>>//External_Function32 GrphCreateFontA "CreateFontA" GDI32.DLL dWord nHt# dWord nWd# dWord nEsc# dWord nOri# dWord fnW# dWord Ita# dWord Und# dWord Strike# dWord CharSet# dWord OutPrec# dWord ClpPrec# dWord Qual# dWord Pitch# Pointer font# 39157>>>>>// This version is OK (just): 39157>>>>>External_Function32 GrphCFA "CreateFontA" GDI32.DLL dWord v1# dWord v2# dWord v3# dWord v4# dWord v5# dWord v6# dWord v7# dWord v8# dWord v9# dWord va# dWord vb# dWord vc# dWord vd# Pointer ve# returns dWord 39158>>>>>External_Function32 GrphSetViewportOrgEx "SetViewportOrgEx" GDI32.DLL Handle hDC dWord x# dWord y# pointer lpRect returns integer 39159>>>>> 39159>>>>>TYPE tPOINTS3 39159>>>>> Field tPOINTS3.x1 as DWORD 39159>>>>> Field tPOINTS3.y1 as DWORD 39159>>>>> Field tPOINTS3.x2 as DWORD 39159>>>>> Field tPOINTS3.y2 as DWORD 39159>>>>> Field tPOINTS3.x3 as DWORD 39159>>>>> Field tPOINTS3.y3 as DWORD 39159>>>>>END_TYPE 39159>>>>>TYPE tPOINTS4 39159>>>>> Field tPOINTS4.x1 as DWORD 39159>>>>> Field tPOINTS4.y1 as DWORD 39159>>>>> Field tPOINTS4.x2 as DWORD 39159>>>>> Field tPOINTS4.y2 as DWORD 39159>>>>> Field tPOINTS4.x3 as DWORD 39159>>>>> Field tPOINTS4.y3 as DWORD 39159>>>>> Field tPOINTS4.x4 as DWORD 39159>>>>> Field tPOINTS4.y4 as DWORD 39159>>>>>END_TYPE 39159>>>>> 39159>>>>>Function Grph_OemToChar Global String OemStr Returns String 39161>>>>> string CharStr 39161>>>>> integer OemAdress CharAdress Grb# 39161>>>>> Append OemStr (Character(0)) 39162>>>>> Move (Repeat(Character(0), (Length(OemStr)))) To CharStr 39163>>>>> GetAddress Of OemStr To OemAdress 39164>>>>> GetAddress Of CharStr To CharAdress 39165>>>>> Move (GrphOemToCharA(OemAdress, CharAdress)) To grb# 39166>>>>> Function_Return (CString(CharStr)) 39167>>>>>End_Function 39168>>>>> 39168>>>>>Use version.nui 39168>>>>> 39168>>>>> 39168>>>>> 39168>>>>>// Text Alignments 39168>>>>>DEFINE TA_LEFT FOR 0 //|CI$0000 39168>>>>>DEFINE TA_RIGHT FOR 2 //|CI$0002 39168>>>>>DEFINE TA_CENTER FOR 6 //|CI$0006 39168>>>>>DEFINE TA_TOP FOR 0 //|CI$0000 39168>>>>>DEFINE TA_BOTTOM FOR 8 //|CI$0008 39168>>>>>DEFINE TA_NOUPDATECP FOR 0 //|CI$0000 39168>>>>>DEFINE TA_UPDATECP FOR 1 //|CI$0001 39168>>>>>DEFINE TA_BASELINE FOR 24 //|CI$0024 39168>>>>> 39168>>>>> 39168>>>>> 39168>>>>>// Hatch Styles: 39168>>>>>DEFINE HS_NONE FOR -1 //* */ 39168>>>>>DEFINE HS_HORIZONTAL FOR 0 //* ----- */ 39168>>>>>DEFINE HS_VERTICAL FOR 1 //* ||||| */ 39168>>>>>DEFINE HS_FDIAGONAL FOR 2 //* \\\\\ */ 39168>>>>>DEFINE HS_BDIAGONAL FOR 3 //* ///// */ 39168>>>>>DEFINE HS_CROSS FOR 4 //* +++++ */ 39168>>>>>DEFINE HS_DIAGCROSS FOR 5 //* xxxxx */ 39168>>>>> 39168>>>>>// Axis text states: 39168>>>>>DEFINE AT_NONE FOR 0 39168>>>>>DEFINE AT_AUTO FOR 1 39168>>>>>DEFINE AT_TEXT FOR 2 39168>>>>> 39168>>>>>// Polygon fill modes: 39168>>>>>DEFINE FM_WINDING FOR 0 39168>>>>>DEFINE FM_ALTERNATE FOR 1 39168>>>>> 39168>>>>>// DrawText Format Flags 39168>>>>>DEFINE XDT_TOP FOR 0 // 0x00000000 39168>>>>>DEFINE XDT_LEFT FOR 0 // 0x00000000 39168>>>>>DEFINE XDT_CENTER FOR 1 // 0x00000001 39168>>>>>DEFINE XDT_RIGHT FOR 2 // 0x00000002 39168>>>>>DEFINE XDT_VCENTER FOR 4 // 0x00000004 39168>>>>>DEFINE XDT_BOTTOM FOR 8 // 0x00000008 39168>>>>>DEFINE XDT_WORDBREAK FOR 16 // 0x00000010 39168>>>>>DEFINE XDT_SINGLELINE FOR 32 // 0x00000020 39168>>>>>DEFINE XDT_EXPANDTABS FOR 64 // 0x00000040 39168>>>>>DEFINE XDT_TABSTOP FOR 128 // 0x00000080 39168>>>>>DEFINE XDT_NOCLIP FOR 256 // 0x00000100 39168>>>>>DEFINE XDT_EXTERNALLEADING FOR 512 // 0x00000200 39168>>>>>DEFINE XDT_CALCRECT FOR 1024 // 0x00000400 39168>>>>>DEFINE XDT_NOPREFIX FOR 2048 // 0x00000800 39168>>>>>DEFINE XDT_INTERNAL FOR 4096 // 0x00001000 39168>>>>> 39168>>>>>enumeration_list // Dot types 39168>>>>> define DT_PIXEL // 39168>>>>> define DT_CROSS // x 39168>>>>> define DT_PLUS // + 39168>>>>> define DT_HORIZONTAL // - 39168>>>>> define DT_VERTICAL // | 39168>>>>> define DT_CIRCLE // o 39168>>>>> define DT_TRIANGLE_UP //  39168>>>>> define DT_TRIANGLE_DOWN //  39168>>>>> define DT_TRIANGLE_RIGHT //  39168>>>>> define DT_TRIANGLE_LEFT //  39168>>>>> define DT_SQUARE // 39168>>>>> define DT_DIAMOND //  39168>>>>>end_enumeration_list 39168>>>>> 39168>>>>>// Graphic Operations 39168>>>>>enumeration_list 39168>>>>> define GO_SetPenColor 39168>>>>> define GO_SetPenWidth 39168>>>>> define GO_SetPenStyle 39168>>>>> define GO_SetFillColor 39168>>>>> define GO_SetHatchStyle 39168>>>>> define GO_SetBackColor 39168>>>>> define GO_SetRoundRectFactor 39168>>>>> define GO_SetPolyGonFillMode 39168>>>>> define GO_SetTextAlign 39168>>>>> define GO_SetTextColor 39168>>>>> define GO_SetStockFont 39168>>>>> define GO_SetTTFont 39168>>>>> define GO_AddDot 39168>>>>> define GO_SetDotStyle 39168>>>>> define GO_SetDotSize 39168>>>>> define GO_SetDotAlign 39168>>>>> define GO_Rectangle 39168>>>>> define GO_Ellipse 39168>>>>> define GO_RoundRect 39168>>>>> define GO_LineTo 39168>>>>> define GO_MoveTo 39168>>>>> define GO_TextOut 39168>>>>> define GO_Polygon 39168>>>>> define GO_PolyLine 39168>>>>>end_enumeration_list 39168>>>>> 39168>>>>>integer gr$PenColor // Global variables used for speed 39168>>>>>integer gr$PenWidth 39168>>>>>integer gr$PenStyle 39168>>>>>integer gr$HatchStyle 39168>>>>>integer gr$FillColor 39168>>>>>integer gr$RoundRectFactor 39168>>>>>integer gr$PolyGonFillMode 39168>>>>>integer gr$BackColor 39168>>>>>integer gr$DotSize 39168>>>>>integer gr$DotType 39168>>>>>integer gr$DotAlign 39168>>>>>integer gr$CPU$RAM 39168>>>>>integer gr$CPU$PC 39168>>>>>handle gr$hCurrentDC 39168>>>>>handle gr$hCurrentPen 39168>>>>>handle gr$hCurrentBrush 39168>>>>>handle gr$hCurrentTemp 39168>>>>>handle gr$hCurrentTTFont gr$PreviousFont 39168>>>>>integer gr$vCenterActive 39168>>>>>integer gr$PenDirty 39168>>>>>integer gr$BrushDirty 39168>>>>>integer gr$Void 39168>>>>>integer gr$CoordXY1# 39168>>>>>integer gr$CoordXY2# 39168>>>>>integer gr$Tmp# 39168>>>>>integer gr$GuiSizeX# 39168>>>>>integer gr$GuiSizeY# 39168>>>>>integer gr$TrackArray 39168>>>>>string gr$Point 32 39168>>>>> 39168>>>>>number gr$X_Range 39168>>>>>number gr$Y_Range 39168>>>>>move 20000.0 to gr$X_Range 39169>>>>>move 20000.0 to gr$Y_Range 39170>>>>>integer gr$GuiOffsetX# 39170>>>>>integer gr$GuiOffsetY# 39170>>>>>move 0 to gr$GuiOffsetX# 39171>>>>>move 0 to gr$GuiOffsetY# 39172>>>>> 39172>>>>>if DFFALSE begin // Do not execution this on program start up. 39174>>>>> // Good old fashioned subroutines also used for speed. 39174>>>>> vdfgraph$Update_GDI_Objects: 39174>>>>> if gr$PenDirty begin 39176>>>>> move gr$hCurrentPen to gr$hCurrentTemp 39177>>>>> move (CreatePen(gr$PenStyle,gr$PenWidth,gr$PenColor)) to gr$hCurrentPen 39178>>>>> move (SelectObject(gr$hCurrentDC,gr$hCurrentPen)) to gr$Void 39179>>>>> move 0 to gr$PenDirty 39180>>>>> move (DeleteObject(gr$hCurrentTemp)) to gr$Void 39181>>>>> graph_res$showln ("DeleteObject 1 "+string(gr$Void)) 39181>>>>> end 39181>>>>>> 39181>>>>> if gr$BrushDirty begin 39183>>>>> move gr$hCurrentBrush to gr$hCurrentTemp 39184>>>>> if gr$HatchStyle ne HS_NONE ; move (GrphCreateHatchBrush(gr$HatchStyle,gr$FillColor)) to gr$hCurrentBrush 39187>>>>> else ; move (CreateSolidBrush(gr$FillColor)) to gr$hCurrentBrush 39189>>>>> move (SelectObject(gr$hCurrentDC,gr$hCurrentBrush)) to gr$Void 39190>>>>> move 0 to gr$BrushDirty 39191>>>>> move (DeleteObject(gr$hCurrentTemp)) to gr$Void 39192>>>>> graph_res$showln ("DeleteObject 2 "+string(gr$Void)) 39192>>>>> end 39192>>>>>> 39192>>>>> return 39193>>>>> vdfgraph$DeletePreviousTTFont: 39193>>>>> if gr$hCurrentTTFont ne 0 begin 39195>>>>> move (SelectObject(gr$hCurrentDC,gr$PreviousFont)) to gr$Void 39196>>>>> move (DeleteObject(gr$hCurrentTTFont)) to gr$Void 39197>>>>> graph_res$showln ("DeleteObject 6 "+string(gr$Void)) 39197>>>>> end 39197>>>>>> 39197>>>>> return 39198>>>>> vdfgraph$PreparePoint: 39198>>>>> gosub vdfgraph$Update_GDI_Objects 39199>>>>>> 39199>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$CoordXY1# 39200>>>>> gosub vdfgraph$ConvertToGUI1 39201>>>>>> 39201>>>>> increment gr$CPU$PC 39202>>>>> return 39203>>>>> vdfgraph$Prepare2Points: 39203>>>>> gosub vdfgraph$Update_GDI_Objects 39204>>>>>> 39204>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$CoordXY1# 39205>>>>> gosub vdfgraph$ConvertToGUI1 39206>>>>>> 39206>>>>> increment gr$CPU$PC 39207>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$CoordXY2# 39208>>>>> increment gr$CPU$PC 39209>>>>> gosub vdfgraph$ConvertToGUI2 39210>>>>>> 39210>>>>> return 39211>>>>> vdfgraph$ConvertToGui1: 39211>>>>> move (integer(hi(gr$CoordXY1#)*gr$GuiSizeX#/gr$X_Range)+gr$GuiOffsetX#*65536+(low(gr$CoordXY1#)*gr$GuiSizeY#/gr$Y_Range)+gr$GuiOffsetY#) to gr$CoordXY1# 39212>>>>> return 39213>>>>> vdfgraph$ConvertToGui2: 39213>>>>> move (integer(hi(gr$CoordXY2#)*gr$GuiSizeX#/gr$X_Range)+gr$GuiOffsetX#*65536+(low(gr$CoordXY2#)*gr$GuiSizeY#/gr$Y_Range)+gr$GuiOffsetY#) to gr$CoordXY2# 39214>>>>> return 39215>>>>> vdfgraph$ConvertToVirtual: 39215>>>>> if gr$CoordXY1# lt 0 move 0 to gr$CoordXY1# 39218>>>>> move (integer(hi(gr$CoordXY1#)-gr$GuiOffsetX#*gr$X_Range/gr$GuiSizeX#)*65536+(low(gr$CoordXY1#)-gr$GuiOffsetY#*gr$Y_Range/gr$GuiSizeY#)) to gr$CoordXY1# 39219>>>>> return 39220>>>>>end 39220>>>>>> 39220>>>>> 39220>>>>> 39220>>>>> 39220>>>>>Register_Procedure WMSG_GrphPaint dWord wParam dWord lParam 39220>>>>>Register_Procedure WMSG_GrphEraseBkGnd dWord wParam dWord lParam 39220>>>>>Register_Procedure WMSG_OnMouseDown 39220>>>>>Register_Procedure WMSG_OnMouseUp 39220>>>>>Register_Procedure WMSG_OnMouse2Down 39220>>>>>Register_Procedure WMSG_OnMouse2Up 39220>>>>>Register_Procedure WMSG_OnMouseMove 39220>>>>>Register_Procedure WMSG_OnMouseDblClick 39220>>>>>Register_Object oGraphOperationMsgTabel 39220>>>>> 39220>>>>>enumeration_list 39220>>>>> define GR_TRACK_RECTANGLE 39220>>>>> define GR_TRACK_LINE 39220>>>>> define GR_TRACK_ELLIPSE 39220>>>>>end_enumeration_list 39220>>>>> 39220>>>>>class cTrackableObjects is a cArray 39221>>>>> item_property_list 39221>>>>> item_property integer piType.i // RECTANGLE_CHECK LINE_CHECK ELLIPSE_CHECK 39221>>>>> item_property integer piX1.i 39221>>>>> item_property integer piY1.i 39221>>>>> item_property integer piX2.i 39221>>>>> item_property integer piY2.i 39221>>>>> item_property integer piCB_Value.i // Callback value (when clicked) 39221>>>>> end_item_property_list cTrackableObjects #REM 39265 DEFINE FUNCTION PICB_VALUE.I INTEGER LIROW RETURNS INTEGER #REM 39269 DEFINE PROCEDURE SET PICB_VALUE.I INTEGER LIROW INTEGER VALUE #REM 39273 DEFINE FUNCTION PIY2.I INTEGER LIROW RETURNS INTEGER #REM 39277 DEFINE PROCEDURE SET PIY2.I INTEGER LIROW INTEGER VALUE #REM 39281 DEFINE FUNCTION PIX2.I INTEGER LIROW RETURNS INTEGER #REM 39285 DEFINE PROCEDURE SET PIX2.I INTEGER LIROW INTEGER VALUE #REM 39289 DEFINE FUNCTION PIY1.I INTEGER LIROW RETURNS INTEGER #REM 39293 DEFINE PROCEDURE SET PIY1.I INTEGER LIROW INTEGER VALUE #REM 39297 DEFINE FUNCTION PIX1.I INTEGER LIROW RETURNS INTEGER #REM 39301 DEFINE PROCEDURE SET PIX1.I INTEGER LIROW INTEGER VALUE #REM 39305 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER #REM 39309 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE 39314>>>>> procedure add_track integer type# integer x1# integer y1# integer x2# integer y2# integer cb_val# 39316>>>>> integer row# 39316>>>>> get row_count to row# 39317>>>>> set piType.i row# to type# 39318>>>>> set piX1.i row# to x1# 39319>>>>> set piY1.i row# to y1# 39320>>>>> set piX2.i row# to x2# 39321>>>>> set piY2.i row# to y2# 39322>>>>> set piCB_Value.i row# to cb_val# 39323>>>>> end_procedure 39324>>>>> procedure delete_data 39326>>>>> forward send delete_data 39328>>>>> end_procedure 39329>>>>> procedure TestTrackHit integer track_msg# 39331>>>>> integer row# max# x# y# level# 39331>>>>> get row_count to max# 39332>>>>> move (low(gr$CoordXY1#)) to x# 39333>>>>> move (hi(gr$CoordXY1#)) to y# 39334>>>>> decrement max# 39335>>>>> move 0 to level# 39336>>>>> // GRAPH$SHOWLN 39336>>>>> for_ex row# from max# down_to 0 39343>>>>> GRAPH$SHOWLN "Test: " x# "," y# " against: " (piX1.i(self,row#)) "," (piX2.i(self,row#)) " " (piY1.i(self,row#)) "," (piY2.i(self,row#)) 39343>>>>> if (piType.i(self,row#)) eq GR_TRACK_RECTANGLE if ((x#>=piX1.i(self,row#)) and (x#<=piX2.i(self,row#)) and (y#>=piY1.i(self,row#)) and (y#<=piY2.i(self,row#))) begin 39347>>>>> send track_msg# (piCB_Value.i(self,row#)) level# 39348>>>>> increment level# 39349>>>>> end 39349>>>>>> 39349>>>>> loop 39350>>>>>> 39350>>>>> end_procedure 39351>>>>>end_class // cTrackableObjects 39352>>>>> 39352>>>>>use cWinControl.pkg 39352>>>>> 39352>>>>> 39352>>>>>class GraphicArea is a cWinControl //dfControl 39353>>>>> Procedure Construct_Object 39355>>>>> Set External_Class_Name "GraphicArea" to "static" 39356>>>>> Forward Send Construct_Object 39358>>>>> 39358>>>>> set window_style to SS_NOTIFY DFTRUE 39359>>>>> 39359>>>>> set border_style to BORDER_STATICEDGE 39360>>>>>// set border_style to BORDER_NONE 39360>>>>> set delegation_mode to DELEGATE_TO_PARENT 39361>>>>> 39361>>>>> property integer pPenColor public clBlack 39362>>>>> property integer pPenWidth public 1 39363>>>>> property integer pFillColor public clRed 39364>>>>> property integer pPenStyle public PS_SOLID 39365>>>>> property integer pBackColor public (GetSysColor(COLOR_BTNFACE)) 39366>>>>> property integer pRoundRectFactor public (25*65536+25) 39367>>>>> property integer pHatchStyle public HS_NONE 39368>>>>> property integer pPolyPointsOffS public 0 39369>>>>> 39369>>>>> property integer pOemToAnsi_State public DFTRUE 39370>>>>> 39370>>>>> property string pTitle public "" 39371>>>>> property string pHeaderLeft public "" 39372>>>>> property string pHeaderMid public "" 39373>>>>> property string pHeaderRight public "" 39374>>>>> property string pFooterLeft public "" 39375>>>>> property string pFooterMid public "" 39376>>>>> property string pFooterRight public "" 39377>>>>> property integer pHeaderHeight public 1000 39378>>>>> property integer pFooterHeight public 1000 39379>>>>> property integer pHeaderBackColor public 0 39380>>>>> property integer pFooterBackColor public 0 39381>>>>> 39381>>>>> property integer piX_Offset public 0 39382>>>>> property integer piY_Offset public 0 39383>>>>> property integer piX_Range public 10000 39384>>>>> property integer piY_Range public 10000 39385>>>>> 39385>>>>> property integer pbPixelScale public FALSE 39386>>>>> 39386>>>>> Set Focus_Mode To NONFOCUSABLE 39387>>>>> 39387>>>>> object Program_RAM is an array 39389>>>>> end_object 39390>>>>> property integer piProgram_RAM 39391>>>>> set piProgram_RAM to (Program_RAM(self)) 39392>>>>> 39392>>>>> object oColors is an array 39394>>>>> set value item 0 to (rgb(255, 0, 0)) // Red Normal 39395>>>>> set value item 1 to (rgb( 0, 0,255)) // Blue 39396>>>>> set value item 2 to (rgb( 0,255, 0)) // Green 39397>>>>> set value item 3 to (rgb(255,255, 0)) // Yellow 39398>>>>> set value item 4 to (rgb( 0,255,255)) // Turkis 39399>>>>> set value item 5 to (rgb(255, 0,255)) // Purple 39400>>>>> set value item 6 to (rgb(128,128,128)) // Grey 39401>>>>> set value item 7 to (rgb(255,128, 0)) // Orange 39402>>>>> 39402>>>>> set value item 8 to (rgb(255,128,128)) // Red Bright 39403>>>>> set value item 9 to (rgb(128,128,255)) // Blue 39404>>>>> set value item 10 to (rgb(128,255,128)) // Green 39405>>>>> set value item 11 to (rgb(255,255,128)) // Yellow 39406>>>>> set value item 12 to (rgb(128,255,255)) // Turkis 39407>>>>> set value item 13 to (rgb(255,128,255)) // Purple 39408>>>>> set value item 14 to (rgb(192,192,192)) // Grey 39409>>>>> set value item 15 to (rgb(255,192,128)) // Orange 39410>>>>> 39410>>>>> set value item 16 to (rgb(128, 0, 0)) // Red Dark 39411>>>>> set value item 17 to (rgb( 0, 0,128)) // Blue 39412>>>>> set value item 18 to (rgb( 0,128, 0)) // Green 39413>>>>> set value item 19 to (rgb(128,128, 0)) // Yellow 39414>>>>> set value item 20 to (rgb( 0,128,128)) // Turkis 39415>>>>> set value item 21 to (rgb(128, 0,128)) // Purple 39416>>>>> set value item 22 to (rgb( 64, 64, 64)) // Grey 39417>>>>> set value item 23 to (rgb(128, 64, 0)) // Orange 39418>>>>> 39418>>>>> set value item 24 to (rgb( 64, 0, 0)) // Red Very dark 39419>>>>> set value item 25 to (rgb( 0, 0, 64)) // Blue 39420>>>>> set value item 26 to (rgb( 0, 64, 0)) // Green 39421>>>>> set value item 27 to (rgb( 64, 64, 0)) // Yellow 39422>>>>> set value item 28 to (rgb( 0, 64, 64)) // Turkis 39423>>>>> set value item 29 to (rgb( 64, 0, 64)) // Purple 39424>>>>> set value item 30 to (rgb( 32, 32, 32)) // Grey 39425>>>>> set value item 31 to (rgb( 64, 32, 0)) // Orange 39426>>>>> end_object 39427>>>>> 39427>>>>> object oHatches is an array 39429>>>>> set value item 0 to HS_NONE 39430>>>>> set value item 1 to HS_DIAGCROSS 39431>>>>> set value item 2 to HS_CROSS 39432>>>>> set value item 3 to HS_FDIAGONAL 39433>>>>> set value item 4 to HS_BDIAGONAL 39434>>>>> set value item 5 to HS_VERTICAL 39435>>>>> set value item 6 to HS_HORIZONTAL 39436>>>>> end_object 39437>>>>> 39437>>>>> object xyObjects is an array 39439>>>>> end_object 39440>>>>> 39440>>>>> Set External_Message WM_PAINT to msg_WMSG_GrphPaint // We want to trap WM_PAINT for efficient painting. 39441>>>>> Set External_Message WM_ERASEBKGND to msg_WMSG_GrphEraseBkGnd // The Windows-Class will not have a brush set, so let's 'brush' the object ourselves. 39442>>>>> Set External_Message WM_LBUTTONDOWN to msg_WMSG_OnMouseDown 39443>>>>> Set External_Message WM_LBUTTONUP to msg_WMSG_OnMouseUp 39444>>>>> Set External_Message WM_MOUSEMOVE to msg_WMSG_OnMouseMove 39445>>>>> Set External_Message WM_RBUTTONDOWN to msg_WMSG_OnMouse2Down 39446>>>>> Set External_Message WM_RBUTTONUP to msg_WMSG_OnMouse2Up 39447>>>>> // This one doesn't work. Why not????: 39447>>>>> Set External_Message WM_LBUTTONDBLCLK to msg_WMSG_OnMouseDblClick 39448>>>>> 39448>>>>> property integer pViewPortX public 0 39449>>>>> property integer pViewPortY public 0 39450>>>>> 39450>>>>> object oTrackableObjects is a cTrackableObjects 39452>>>>> end_object 39453>>>>> 39453>>>>> property integer pbIncrementalPaint public DFFALSE 39454>>>>> property integer pbNeverBeenPainted public DFTRUE 39455>>>>> property integer piPreviousMaxCount public 0 39456>>>>> property integer piPreviousPenColor public 0 39457>>>>> property integer piPreviousPenWidth public 0 39458>>>>> property integer piPreviousFillColor public 0 39459>>>>> property integer piPreviousHatchStyle public 0 39460>>>>> property integer piPreviousPenStyle public 0 39461>>>>> property integer piPreviousRoundRectFactor public 0 39462>>>>> property integer piPreviousBackColor public 0 39463>>>>> property integer piPreviousvCenterActive public 0 39464>>>>> property integer piPreviousDotSize public 0 39465>>>>> property integer piPreviousDotType public 0 39466>>>>> property integer piPreviousDotAlign public 0 39467>>>>> End_Procedure 39468>>>>> 39468>>>>> procedure DoSetPixelCoords 39470>>>>> integer liGuiSize 39470>>>>> get GuiSize to liGuiSize 39471>>>>> set piX_Range to (hi(liGuiSize)) 39472>>>>> set piY_Range to (low(liGuiSize)) 39473>>>>> end_procedure 39474>>>>> 39474>>>>> procedure end_construct_object 39476>>>>> forward send end_construct_object 39478>>>>> Set External_Message WM_PAINT to msg_WMSG_GrphPaint // We want to trap WM_PAINT for efficient painting. 39479>>>>> Set External_Message WM_ERASEBKGND to msg_WMSG_GrphEraseBkGnd // The Windows-Class will not have a brush set, so let's 'brush' the object ourselves. 39480>>>>> Set External_Message WM_LBUTTONDOWN to msg_WMSG_OnMouseDown 39481>>>>> Set External_Message WM_LBUTTONUP to msg_WMSG_OnMouseUp 39482>>>>> Set External_Message WM_MOUSEMOVE to msg_WMSG_OnMouseMove 39483>>>>> Set External_Message WM_RBUTTONDOWN to msg_WMSG_OnMouse2Down 39484>>>>> Set External_Message WM_RBUTTONUP to msg_WMSG_OnMouse2Up 39485>>>>> Set External_Message WM_LBUTTONDBLCLK to msg_WMSG_OnMouseDblClick 39486>>>>> end_procedure 39487>>>>> 39487>>>>> Procedure Reset_Viewport 39489>>>>> set pViewPortX to 0 39490>>>>> set pViewPortY to 0 39491>>>>> End_Procedure 39492>>>>> 39492>>>>> procedure register_xy_object integer obj# // GraphicArea 39494>>>>> integer arr# 39494>>>>> move (xyObjects(self)) to arr# 39495>>>>> set value of arr# item (item_count(arr#)) to obj# 39496>>>>> end_procedure 39497>>>>> 39497>>>>> Function iColor integer color# returns integer 39499>>>>> function_return (value(oColors(self),color#)) 39500>>>>> End_Function 39501>>>>> Function iColorNuance.ii integer color# integer nuance# returns integer 39503>>>>> integer base# 39503>>>>> if nuance# eq 0 move 24 to base# // Very dark 39506>>>>> if nuance# eq 1 move 16 to base# // Dark 39509>>>>> if nuance# eq 2 move 0 to base# // Normal 39512>>>>> if nuance# eq 3 move 8 to base# // Ligth 39515>>>>> function_return (value(oColors(self),base#+color#)) 39516>>>>> End_Function 39517>>>>> Function iColorNuance.iii integer color# integer nuance# integer maxnuance# returns integer 39519>>>>> if maxnuance# ne 3 increment nuance# 39522>>>>> function_return (iColorNuance.ii(self,color#,nuance#)) 39523>>>>> End_Function 39524>>>>> Function iHatch integer hatch# returns integer 39526>>>>> function_return (value(oHatches(self),hatch#)) 39527>>>>> End_Function 39528>>>>> 39528>>>>> Procedure WMSG_GrphEraseBkGnd dWord wParam dWord lParam 39530>>>>> handle hDC# hPen# hBrush# // This msg is sent if the fErase member of tPAINTSTRUCT is TRUE 39530>>>>> integer iSize# // during the WM_PAINT/BeginPaint() phase. This will be set 39530>>>>> Move wParam To hDC# // automatically by Windows, or explicitly by InvalidateRect() with 39531>>>>> Get guiSize To iSize# // TRUE as its 3rd arg 39532>>>>> 39532>>>>> get pBackColor to gr$BackColor 39533>>>>> Move (GetStockObject(NULL_PEN)) To hPen# // we don't want an outline 39534>>>>> Move (CreateSolidBrush(gr$BackColor)) To hBrush# 39535>>>>> 39535>>>>> Move (SelectObject(hDC#,hPen#)) To gr$Void // select into Device Context 39536>>>>> Move (SelectObject(hDC#,hBrush#)) To gr$Void 39537>>>>> 39537>>>>> // Use a rectangle to draw-over entire window. Note the addition of 39537>>>>> // one to both X & Y end-points, this is because Windows' Rectangle() 39537>>>>> // function excludes the end-points in its drawing 39537>>>>> 39537>>>>> //Move (Rectangle(hDC#,0,0,Low(iSize#)+1,Hi(iSize#)+1)) To gr$Void 39537>>>>> 39537>>>>> // we must delete any GDI objects we create. Note, we don't delete the 39537>>>>> // hPen object because it is a Windows' StockObject. 39537>>>>> Move (DeleteObject(hBrush#)) To gr$Void 39538>>>>> graph_res$showln ("DeleteObject 3 "+string(gr$Void)) 39538>>>>> move 1 to gr$PenDirty 39539>>>>> move 1 to gr$BrushDirty 39540>>>>> set pbNeverBeenPainted to DFTRUE 39541>>>>> End_Procedure 39542>>>>> 39542>>>>> // When this message is called the global integers defined in the top 39542>>>>> // of this package are initialized and used by this class. They should 39542>>>>> // be left very much alone while this procedure is running. 39542>>>>> Procedure PaintArea 39544>>>>> integer max# msg# 39544>>>>> get item_count of gr$CPU$RAM to max# 39545>>>>> while gr$CPU$PC lt max# // If this works well, it could be changed to 39549>>>>> get value of gr$CPU$RAM item gr$CPU$PC to msg# // GOSUB label# instead 39550>>>>> increment gr$CPU$PC // Increment beyond op-code 39551>>>>> send msg# 39552>>>>> end 39553>>>>>> 39553>>>>> set piPreviousMaxCount to max# 39554>>>>> End_Procedure 39555>>>>> 39555>>>>> Procedure WMSG_GrphPaint dWord wParam dWord lParam 39557>>>>> handle hWnd# OriginalPen# OriginalBrush# hBrush# 39557>>>>> pointer lpStruc# 39557>>>>> string sStruc# struct# 39557>>>>> integer lbIncrementalPaint cxyValue 39557>>>>> 39557>>>>> handle hDC# //for offscreen 39557>>>>> pointer address# //for offscreen 39557>>>>> handle hdcMem# hbmOld# //for offscreen 39557>>>>> dword hbmMem# //for offscreen 39557>>>>> 39557>>>>> graph$showln "Paint" 39557>>>>> ZeroType tPAINTSTRUCT To sStruc# 39558>>>>> GetAddress of sStruc# To lpStruc# 39559>>>>> Get Window_Handle To hWnd# 39560>>>>> move (piProgram_RAM(self)) to gr$CPU$RAM // Array of instructions 39561>>>>> move (oTrackableObjects(self)) to gr$TrackArray // Array of instructions 39562>>>>> 39562>>>>> Get GuiSize to gr$Tmp# 39563>>>>> move (hi(gr$Tmp#)) to gr$GuiSizeX# 39564>>>>> move (low(gr$Tmp#)) to gr$GuiSizeY# 39565>>>>> 39565>>>>> if (pbPixelScale(self)) send DoSetPixelCoords 39568>>>>> 39568>>>>> get piX_Offset to gr$GuiOffsetX# 39569>>>>> get piY_Offset to gr$GuiOffsetY# 39570>>>>> get piX_Range to gr$X_Range 39571>>>>> get piY_Range to gr$Y_Range 39572>>>>> set pViewPortX to gr$GuiOffsetX# 39573>>>>> set pViewPortY to gr$GuiOffsetY# 39574>>>>> move 0 to gr$GuiOffsetX# 39575>>>>> move 0 to gr$GuiOffsetY# 39576>>>>> 39576>>>>> move (BeginPaint(hWnd#, lpStruc#)) to gr$hCurrentDC 39577>>>>> 39577>>>>> //Double buffered actions: 39577>>>>> Get GuiSize to cxyValue 39578>>>>> move (GetDC(hWnd#)) to hDC# 39579>>>>> 39579>>>>> //make a compatible copy for offscreen processing: 39579>>>>> move (GrphCreateCompatibleDC(hDC#)) to hdcMem# 39580>>>>> move (GrphCreateCompatibleBitmap(hDC#, Low(cxyValue)+1, Hi(cxyValue)+1)) to hbmMem# 39581>>>>> move (SelectObject(hdcMem#,hbmMem#)) to hbmOld# 39582>>>>> 39582>>>>> //fill it with nice white space: 39582>>>>> move (CreateSolidBrush(clWhite)) to hBrush# 39583>>>>> move (SelectObject(hdcMem#,hBrush#)) to gr$Void 39584>>>>> Move (Rectangle(hdcMem#,0,0,Low(cxyValue)+1,Hi(cxyValue)+1)) To gr$Void 39585>>>>> move (DeleteObject(hBrush#)) to gr$Void 39586>>>>> move hdcMem# to gr$hCurrentDC 39587>>>>> 39587>>>>> // The hDC returned by BeginPaint(), will have its 'Clipping-Region' 39587>>>>> // set, and is much more efficient than the old Flex msg_Paint, 39587>>>>> // where a generic hDC had to be obtained. The 'Invalid-region' can 39587>>>>> // be obtained from the tPAINTSTRUCT (sStruc) structure, and used in 39587>>>>> // calculations for optimum efficiency. 39587>>>>> 39587>>>>> get pbIncrementalPaint to lbIncrementalPaint 39588>>>>> if lbIncrementalPaint begin 39590>>>>> get piPreviousMaxCount to gr$CPU$PC 39591>>>>> get piPreviousPenColor to gr$PenColor 39592>>>>> get piPreviousPenWidth to gr$PenWidth 39593>>>>> get piPreviousFillColor to gr$FillColor 39594>>>>> get piPreviousHatchStyle to gr$HatchStyle 39595>>>>> get piPreviousPenStyle to gr$PenStyle 39596>>>>> get piPreviousRoundRectFactor to gr$RoundRectFactor 39597>>>>> get piPreviousBackColor to gr$BackColor 39598>>>>> get piPreviousvCenterActive to gr$vCenterActive 39599>>>>> get piPreviousDotSize to gr$DotSize 39600>>>>> get piPreviousDotType to gr$DotType 39601>>>>> get piPreviousDotAlign to gr$DotAlign 39602>>>>> end 39602>>>>>> 39602>>>>> else begin 39603>>>>> set piPreviousMaxCount to 0 39604>>>>> send delete_data to gr$TrackArray 39605>>>>> move 0 to gr$CPU$PC // Program counter 39606>>>>> get pPenColor to gr$PenColor 39607>>>>> get pPenWidth to gr$PenWidth 39608>>>>> get pFillColor to gr$FillColor 39609>>>>> get pHatchStyle to gr$HatchStyle 39610>>>>> get pPenStyle to gr$PenStyle 39611>>>>> get pRoundRectFactor to gr$RoundRectFactor 39612>>>>> get pBackColor to gr$BackColor 39613>>>>> move 0 to gr$vCenterActive 39614>>>>> move 10 to gr$DotSize 39615>>>>> move DT_SQUARE to gr$DotType 39616>>>>> move (VDFGR_DA_CENTER+VDFGR_DA_VCENTER) to gr$DotAlign 39617>>>>> end 39617>>>>>> 39617>>>>> 39617>>>>> move (GrphSetViewportOrgEx(gr$hCurrentDC,pViewPortY(self),pViewPortX(self),0)) to windowindex 39618>>>>> move (setBkMode(gr$hCurrentDC,TRANSPARENT)) to gr$Void 39619>>>>> 39619>>>>> // Create and select GDI objects 39619>>>>> move (CreatePen(gr$PenStyle,gr$PenWidth,gr$PenColor)) to gr$hCurrentPen 39620>>>>> move (SelectObject(gr$hCurrentDC,gr$hCurrentPen)) to OriginalPen# 39621>>>>> move 0 to gr$PenDirty 39622>>>>> 39622>>>>> move (CreateSolidBrush(gr$FillColor)) to gr$hCurrentBrush 39623>>>>> move (SelectObject(gr$hCurrentDC,gr$hCurrentBrush)) to OriginalBrush# 39624>>>>> move 0 to gr$BrushDirty 39625>>>>> move 0 to gr$hCurrentTTFont 39626>>>>> 39626>>>>> send PaintArea 39627>>>>> 39627>>>>> //here we copy the complete offscreen image to the screen. 39627>>>>> move (GrphBitBlt(hDC#,0,0,Low(cxyValue),Hi(cxyValue),gr$hCurrentDC,0,0,SRCcopy)) to gr$Void 39628>>>>> set pbNeverBeenPainted to DFFALSE 39629>>>>> 39629>>>>> // Delete GDI objects: 39629>>>>> 39629>>>>> move (DeleteObject(hbmMem#)) to gr$Void //for offscreen 39630>>>>> move (GrphDeleteDC(hdcMem#)) to gr$Void //for offscreen 39631>>>>> move (ReleaseDC(hWnd#, hDC#)) to gr$Void //for offscreen 39632>>>>> 39632>>>>> move (SelectObject(gr$hCurrentDC,OriginalPen#)) to gr$Void 39633>>>>> move (DeleteObject(gr$hCurrentPen)) to gr$Void // Overload 39634>>>>> graph_res$showln ("DeleteObject 4 "+string(gr$Void)) 39634>>>>> move (SelectObject(gr$hCurrentDC,OriginalBrush#)) to gr$Void 39635>>>>> move (DeleteObject(gr$hCurrentBrush)) to gr$Void // Overload 39636>>>>> graph_res$showln ("DeleteObject 5 "+string(gr$Void)) 39636>>>>> gosub vdfgraph$DeletePreviousTTFont // Delete TT font, if any 39637>>>>>> 39637>>>>> move (EndPaint(hWnd#, lpStruc#)) To gr$Void 39638>>>>> set pbIncrementalPaint to DFFALSE 39639>>>>> set piPreviousPenColor to gr$PenColor 39640>>>>> set piPreviousPenWidth to gr$PenWidth 39641>>>>> set piPreviousFillColor to gr$FillColor 39642>>>>> set piPreviousHatchStyle to gr$HatchStyle 39643>>>>> set piPreviousPenStyle to gr$PenStyle 39644>>>>> set piPreviousRoundRectFactor to gr$RoundRectFactor 39645>>>>> set piPreviousBackColor to gr$BackColor 39646>>>>> set piPreviousvCenterActive to gr$vCenterActive 39647>>>>> set piPreviousDotSize to gr$DotSize 39648>>>>> set piPreviousDotType to gr$DotType 39649>>>>> set piPreviousDotAlign to gr$DotAlign 39650>>>>> End_Procedure 39651>>>>> 39651>>>>> Procedure Release_All_Content 39653>>>>> //set pbIncrementalPaint to DFFALSE 39653>>>>> //handle hDC# 39653>>>>> //Move (Rectangle(hDC#,0,0,Low(iSize#)+1,Hi(iSize#)+1)) To gr$Void 39653>>>>> Move 0 to gr$CPU$PC 39654>>>>> send delete_data to gr$CPU$RAM 39655>>>>> End_Procedure 39656>>>>> 39656>>>>> 39656>>>>> Procedure RePaint 39658>>>>> handle hWnd hVoid 39658>>>>> Get Window_Handle To hWnd 39659>>>>> If hWnd Move (InvalidateRect(hWnd, 0, FALSE)) To hVoid 39662>>>>> // InvalidateRect() inflates the Invalid-Region for the hWnd. 39662>>>>> // the second arg, 0, means invalidate the whole window-rect. 39662>>>>> // the third arg, TRUE|FALSE, determines if window cleared prior 39662>>>>> // to re-draw. 39662>>>>> End_Procedure 39663>>>>> 39663>>>>> Procedure RePaintFull 39665>>>>> handle hWnd hVoid 39665>>>>> Get Window_Handle To hWnd 39666>>>>> If hWnd Move (InvalidateRect(hWnd, 0, TRUE)) To hVoid 39669>>>>> End_Procedure 39670>>>>> 39670>>>>> Procedure RePaintIncremental 39672>>>>> handle hWnd hVoid 39672>>>>> if (pbNeverBeenPainted(self)) send RePaintFull 39675>>>>> else begin 39676>>>>> Get Window_Handle To hWnd 39677>>>>> If hWnd begin 39679>>>>> set pbIncrementalPaint to DFTRUE 39680>>>>> Move (InvalidateRect(hWnd, 0, DFFALSE)) To hVoid 39681>>>>> end 39681>>>>>> 39681>>>>> end 39681>>>>>> 39681>>>>> End_Procedure 39682>>>>> 39682>>>>> Procedure Draw_Background 39684>>>>> //send SetFillColor (pBackColor(self)) 39684>>>>> //send SetPenStyle PS_NULL 39684>>>>> //send AddRectangleBackground 0 0 10000 10000 39684>>>>> //send SetPenStyle PS_SOLID 39684>>>>> send SetFillColor (pBackColor(self)) 39685>>>>> send SetPenColor (pBackColor(self)) 39686>>>>> send SetPenStyle PS_SOLID 39687>>>>> send AddRectangleBackground 0 0 (piX_Range(self)) (piY_Range(self)) 39688>>>>> 39688>>>>> send SetPenColor (pPenColor(self)) 39689>>>>> End_Procedure 39690>>>>> 39690>>>>> Procedure Draw_Data // GraphicArea 39692>>>>> integer arr# itm# max# obj# 39692>>>>> string title# 39692>>>>> send BeginDraw 39693>>>>> send Draw_Background 39694>>>>> get pTitle to title# 39695>>>>> 39695>>>>> if title# ne "" begin 39697>>>>> send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_BOTTOM) 39698>>>>> send SetTextColor clBlack 39699>>>>> send SetStockFont SYSTEM_FONT 39700>>>>> send AddText title# 800 5000 39701>>>>> end 39701>>>>>> 39701>>>>> move (xyObjects(self)) to arr# 39702>>>>> get item_count of arr# to max# 39703>>>>> for itm# from 0 to (max#-1) 39709>>>>>> 39709>>>>> send Draw_Data to (value(arr#,itm#)) 39710>>>>> loop 39711>>>>>> 39711>>>>> End_Procedure 39712>>>>> 39712>>>>> procedure mthd_MakeAreaTrackable 39714>>>>> integer cb_val# type# 39714>>>>> move (value(gr$CPU$RAM,gr$CPU$PC)) to type# 39715>>>>> increment gr$CPU$PC 39716>>>>> gosub vdfgraph$Prepare2Points 39717>>>>>> 39717>>>>> move (value(gr$CPU$RAM,gr$CPU$PC)) to cb_val# 39718>>>>> increment gr$CPU$PC 39719>>>>> send add_track to gr$TrackArray type# (low(gr$CoordXY1#)) (hi(gr$CoordXY1#)) (low(gr$CoordXY2#)) (hi(gr$CoordXY2#)) cb_val# 39720>>>>> end_procedure 39721>>>>> procedure mthd_SetPenColor 39723>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$PenColor 39724>>>>> move 1 to gr$PenDirty 39725>>>>> increment gr$CPU$PC 39726>>>>> end_procedure 39727>>>>> procedure mthd_SetPenWidth 39729>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$PenWidth 39730>>>>> move 1 to gr$PenDirty 39731>>>>> increment gr$CPU$PC 39732>>>>> end_procedure 39733>>>>> procedure mthd_SetPenStyle 39735>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$PenStyle 39736>>>>> move 1 to gr$PenDirty 39737>>>>> increment gr$CPU$PC 39738>>>>> end_procedure 39739>>>>> procedure mthd_SetFillColor 39741>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$FillColor 39742>>>>> move 1 to gr$BrushDirty 39743>>>>> increment gr$CPU$PC 39744>>>>> end_procedure 39745>>>>> procedure mthd_SetHatchStyle 39747>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$HatchStyle 39748>>>>> move 1 to gr$BrushDirty 39749>>>>> increment gr$CPU$PC 39750>>>>> end_procedure 39751>>>>> procedure mthd_SetBackColor 39753>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$BackColor 39754>>>>> increment gr$CPU$PC 39755>>>>> end_procedure 39756>>>>> procedure mthd_SetRoundRectFactor 39758>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$RoundRectFactor 39759>>>>> increment gr$CPU$PC 39760>>>>> end_procedure 39761>>>>> procedure mthd_SetPolyGonFillMode 39763>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$PolyGonFillMode 39764>>>>> increment gr$CPU$PC 39765>>>>> end_procedure 39766>>>>> procedure mthd_SetTextAlign 39768>>>>> dword tAlign# tmp# vert# horz# 39768>>>>> get value of gr$CPU$RAM item gr$CPU$PC to tAlign# 39769>>>>> increment gr$CPU$PC 39770>>>>> move (tAlign# iand 3) to horz# // 1:left 2:center 3:right 39771>>>>> move ((tAlign# iand 12)/4) to vert# // 1:top 2:vcenter 3:bottom 39772>>>>> if vert# ne 2 begin 39774>>>>> // Left: 39774>>>>> if (horz#=1 and vert#=1) move (TA_LEFT+TA_TOP) to tAlign# 39777>>>>> if (horz#=1 and vert#=2) move (TA_LEFT+TA_BASELINE) to tAlign# 39780>>>>> if (horz#=1 and vert#=3) move (TA_LEFT+TA_BASELINE) to tAlign# 39783>>>>> // Center: 39783>>>>> if (horz#=2 and vert#=1) move (TA_CENTER+TA_TOP) to tAlign# 39786>>>>> if (horz#=2 and vert#=2) move (TA_CENTER+TA_BASELINE) to tAlign# 39789>>>>> if (horz#=2 and vert#=3) move (TA_CENTER+TA_BASELINE) to tAlign# 39792>>>>> // Right: 39792>>>>> if (horz#=3 and vert#=1) move (TA_RIGHT+TA_TOP) to tAlign# 39795>>>>> if (horz#=3 and vert#=2) move (TA_RIGHT+TA_BASELINE) to tAlign# 39798>>>>> if (horz#=3 and vert#=3) move (TA_RIGHT+TA_BASELINE) to tAlign# 39801>>>>> move (GrphSetTextAlign(gr$hCurrentDC,tAlign#)) to gr$Void 39802>>>>> move 0 to gr$vCenterActive 39803>>>>> end 39803>>>>>> 39803>>>>> else begin 39804>>>>> move (GrphSetTextAlign(gr$hCurrentDC,0)) to gr$Void 39805>>>>> if horz# eq 1 move (XDT_LEFT +XDT_VCENTER+XDT_NOCLIP+XDT_SINGLELINE) to gr$vCenterActive // Left 39808>>>>> if horz# eq 2 move (XDT_CENTER+XDT_VCENTER+XDT_NOCLIP+XDT_SINGLELINE) to gr$vCenterActive // Center 39811>>>>> if horz# eq 3 move (XDT_RIGHT +XDT_VCENTER+XDT_NOCLIP+XDT_SINGLELINE) to gr$vCenterActive // Right 39814>>>>> end 39814>>>>>> 39814>>>>> end_procedure 39815>>>>> procedure mthd_SetTextColor 39817>>>>> dword tColor# 39817>>>>> get value of gr$CPU$RAM item gr$CPU$PC to tColor# 39818>>>>> increment gr$CPU$PC 39819>>>>> move (SetTextColor(gr$hCurrentDC,tColor#)) to gr$Void 39820>>>>> end_procedure 39821>>>>> procedure mthd_SetStockFont 39823>>>>> handle hFont# 39823>>>>> integer StockFont# 39823>>>>> get value of gr$CPU$RAM item gr$CPU$PC to StockFont# 39824>>>>> increment gr$CPU$PC 39825>>>>> gosub vdfgraph$DeletePreviousTTFont 39826>>>>>> 39826>>>>> Move (GetStockObject(StockFont#)) To hFont# 39827>>>>> Move (SelectObject(gr$hCurrentDC, hFont#)) To gr$Void // select into Device Context 39828>>>>> end_procedure 39829>>>>> procedure mthd_SetTTFont 39831>>>>> handle hFont# 39831>>>>> integer pitch# angle# bold# italic# underline# 39831>>>>> pointer address# 39831>>>>> string name# 39831>>>>> gosub vdfgraph$DeletePreviousTTFont 39832>>>>>> 39832>>>>> get value of gr$CPU$RAM item (gr$CPU$PC) to name# 39833>>>>> get value of gr$CPU$RAM item (gr$CPU$PC+1) to pitch# 39834>>>>> get value of gr$CPU$RAM item (gr$CPU$PC+2) to angle# 39835>>>>> get value of gr$CPU$RAM item (gr$CPU$PC+3) to bold# 39836>>>>> get value of gr$CPU$RAM item (gr$CPU$PC+4) to italic# 39837>>>>> get value of gr$CPU$RAM item (gr$CPU$PC+5) to underline# 39838>>>>> move (gr$CPU$PC+6) to gr$CPU$PC 39839>>>>> getaddress of name# to address# 39840>>>>> move (GrphCFA(-pitch#,0,angle#,0,if(bold#,700,0),italic#,underline#,0,ANSI_CHARSET,OUT_TT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,DEFAULT_PITCH ior FF_DONTCARE,address#)) to hFont# 39841>>>>> move (SelectObject(gr$hCurrentDC, hFont#)) To gr$PreviousFont // select into Device Context 39842>>>>> move hFont# to gr$hCurrentTTFont 39843>>>>> end_procedure 39844>>>>> procedure mthd_AddDot 39846>>>>> integer dsz# address# type# corr_x# corr_y# just# x# y# 39846>>>>> string struct# 39846>>>>> move (gr$DotSize/2) to dsz# 39847>>>>> if type# eq DT_SQUARE move (dsz#/1.2) to dsz# 39850>>>>> if dsz# lt 1 move 1 to dsz# 39853>>>>> move gr$DotType to type# 39854>>>>> gosub vdfgraph$PreparePoint 39855>>>>>> 39855>>>>> if type# eq DT_PIXEL begin 39857>>>>> move 1 to dsz# 39858>>>>> move DT_PLUS to type# 39859>>>>> end 39859>>>>>> 39859>>>>> 39859>>>>> if type# ne DT_PIXEL begin // If dot type is pixel, we do no aligning 39861>>>>> // Check for horizontal alignment 39861>>>>> if type# ne DT_VERTICAL begin 39863>>>>> move (gr$DotAlign iand 7) to just# // 1:left_sp 2:left 3:center 4:right 5:right_sp 39864>>>>> if just# eq 1 move (dsz#*2) to corr_y# 39867>>>>> if just# eq 2 move dsz# to corr_y# 39870>>>>> if just# eq 4 move (-dsz#) to corr_y# 39873>>>>> if just# eq 5 move (-dsz#*2) to corr_y# 39876>>>>> end 39876>>>>>> 39876>>>>> // Check for vertical alignment 39876>>>>> if type# ne DT_HORIZONTAL begin 39878>>>>> move ((gr$DotAlign iand 56)/8) to just# // 1:top_sp 2:top 3:vcenter 4:bottom 5:bottom_sp 39879>>>>> if just# eq 1 move (-dsz#*2) to corr_x# 39882>>>>> if just# eq 2 move (-dsz#) to corr_x# 39885>>>>> if just# eq 4 move dsz# to corr_x# 39888>>>>> if just# eq 5 move (dsz#*2) to corr_x# 39891>>>>> end 39891>>>>>> 39891>>>>> end 39891>>>>>> 39891>>>>> move (low(gr$CoordXY1#)+corr_y#) to y# 39892>>>>> move (hi(gr$CoordXY1#)+corr_x#) to x# 39893>>>>> if type# eq DT_CROSS begin 39895>>>>> move (MoveTo(gr$hCurrentDC,y#-dsz#+1,x#-dsz#+1,0)) to gr$Void 39896>>>>> move (LineTo(gr$hCurrentDC,y#+dsz#,x#+dsz#)) to gr$Void 39897>>>>> move (MoveTo(gr$hCurrentDC,y#-dsz#+1,x#+dsz#-1,0)) to gr$Void 39898>>>>> move (LineTo(gr$hCurrentDC,y#+dsz#,x#-dsz#)) to gr$Void 39899>>>>> end 39899>>>>>> 39899>>>>> if type# eq DT_PLUS begin 39901>>>>> move (MoveTo(gr$hCurrentDC,y#-dsz#+1,x#,0)) to gr$Void 39902>>>>> move (LineTo(gr$hCurrentDC,y#+dsz#,x#)) to gr$Void 39903>>>>> move (MoveTo(gr$hCurrentDC,y#,x#+dsz#-1,0)) to gr$Void 39904>>>>> move (LineTo(gr$hCurrentDC,y#,x#-dsz#)) to gr$Void 39905>>>>> end 39905>>>>>> 39905>>>>> if type# eq DT_HORIZONTAL begin 39907>>>>> move (MoveTo(gr$hCurrentDC,y#-dsz#+1,x#,0)) to gr$Void 39908>>>>> move (LineTo(gr$hCurrentDC,y#+dsz#,x#)) to gr$Void 39909>>>>> end 39909>>>>>> 39909>>>>> if type# eq DT_VERTICAL begin 39911>>>>> move (MoveTo(gr$hCurrentDC,y#,x#+dsz#-1,0)) to gr$Void 39912>>>>> move (LineTo(gr$hCurrentDC,y#,x#-dsz#)) to gr$Void 39913>>>>> end 39913>>>>>> 39913>>>>> if type# eq DT_CIRCLE begin 39915>>>>> move (Ellipse(gr$hCurrentDC,y#-dsz#,x#-dsz#,y#+dsz#,x#+dsz#)) To gr$Void 39916>>>>> end 39916>>>>>> 39916>>>>> if type# eq DT_TRIANGLE_UP begin 39918>>>>> zerotype tPOINTS3 to struct# 39919>>>>> put (y#+dsz#) to struct# at tPOINTS3.x1 39920>>>>> put (x#+dsz#) to struct# at tPOINTS3.y1 39921>>>>> put y# to struct# at tPOINTS3.x2 39922>>>>> put (x#-dsz#) to struct# at tPOINTS3.y2 39923>>>>> put (y#-dsz#) to struct# at tPOINTS3.x3 39924>>>>> put (x#+dsz#) to struct# at tPOINTS3.y3 39925>>>>> getaddress of struct# to address# 39926>>>>> move (GrphPolyGon(gr$hCurrentDC,address#,3)) to gr$Void 39927>>>>> end 39927>>>>>> 39927>>>>> if type# eq DT_TRIANGLE_DOWN begin 39929>>>>> zerotype tPOINTS3 to struct# 39930>>>>> put (y#-dsz#) to struct# at tPOINTS3.x1 39931>>>>> put (x#-dsz#) to struct# at tPOINTS3.y1 39932>>>>> put y# to struct# at tPOINTS3.x2 39933>>>>> put (x#+dsz#) to struct# at tPOINTS3.y2 39934>>>>> put (y#+dsz#) to struct# at tPOINTS3.x3 39935>>>>> put (x#-dsz#) to struct# at tPOINTS3.y3 39936>>>>> getaddress of struct# to address# 39937>>>>> move (GrphPolyGon(gr$hCurrentDC,address#,3)) to gr$Void 39938>>>>> end 39938>>>>>> 39938>>>>> if type# eq DT_TRIANGLE_RIGHT begin 39940>>>>> zerotype tPOINTS3 to struct# 39941>>>>> put (y#-dsz#) to struct# at tPOINTS3.x1 39942>>>>> put (x#-dsz#) to struct# at tPOINTS3.y1 39943>>>>> put (y#+dsz#) to struct# at tPOINTS3.x2 39944>>>>> put x# to struct# at tPOINTS3.y2 39945>>>>> put (y#-dsz#) to struct# at tPOINTS3.x3 39946>>>>> put (x#+dsz#) to struct# at tPOINTS3.y3 39947>>>>> getaddress of struct# to address# 39948>>>>> move (GrphPolyGon(gr$hCurrentDC,address#,3)) to gr$Void 39949>>>>> end 39949>>>>>> 39949>>>>> if type# eq DT_TRIANGLE_LEFT begin 39951>>>>> zerotype tPOINTS3 to struct# 39952>>>>> put (y#+dsz#) to struct# at tPOINTS3.x1 39953>>>>> put (x#+dsz#) to struct# at tPOINTS3.y1 39954>>>>> put (y#-dsz#) to struct# at tPOINTS3.x2 39955>>>>> put x# to struct# at tPOINTS3.y2 39956>>>>> put (y#+dsz#) to struct# at tPOINTS3.x3 39957>>>>> put (x#-dsz#) to struct# at tPOINTS3.y3 39958>>>>> getaddress of struct# to address# 39959>>>>> move (GrphPolyGon(gr$hCurrentDC,address#,3)) to gr$Void 39960>>>>> end 39960>>>>>> 39960>>>>> if type# eq DT_SQUARE begin 39962>>>>> zerotype tPOINTS4 to struct# 39963>>>>> move (dsz#/1.2) to dsz# 39964>>>>> if dsz# lt 1 move 1 to dsz# 39967>>>>> put (y#-dsz#) to struct# at tPOINTS4.x1 39968>>>>> put (x#-dsz#) to struct# at tPOINTS4.y1 39969>>>>> put (y#-dsz#) to struct# at tPOINTS4.x2 39970>>>>> put (x#+dsz#) to struct# at tPOINTS4.y2 39971>>>>> put (y#+dsz#) to struct# at tPOINTS4.x3 39972>>>>> put (x#+dsz#) to struct# at tPOINTS4.y3 39973>>>>> put (y#+dsz#) to struct# at tPOINTS4.x4 39974>>>>> put (x#-dsz#) to struct# at tPOINTS4.y4 39975>>>>> getaddress of struct# to address# 39976>>>>> move (GrphPolyGon(gr$hCurrentDC,address#,4)) to gr$Void 39977>>>>> end 39977>>>>>> 39977>>>>> if type# eq DT_DIAMOND begin 39979>>>>> zerotype tPOINTS4 to struct# 39980>>>>> put (y#-dsz#) to struct# at tPOINTS4.x1 39981>>>>> put x# to struct# at tPOINTS4.y1 39982>>>>> put y# to struct# at tPOINTS4.x2 39983>>>>> put (x#+dsz#) to struct# at tPOINTS4.y2 39984>>>>> put (y#+dsz#) to struct# at tPOINTS4.x3 39985>>>>> put x# to struct# at tPOINTS4.y3 39986>>>>> put y# to struct# at tPOINTS4.x4 39987>>>>> put (x#-dsz#) to struct# at tPOINTS4.y4 39988>>>>> getaddress of struct# to address# 39989>>>>> move (GrphPolyGon(gr$hCurrentDC,address#,4)) to gr$Void 39990>>>>> end 39990>>>>>> 39990>>>>> end_procedure 39991>>>>> procedure mthd_SetDotStyle 39993>>>>> move (value(gr$CPU$RAM,gr$CPU$PC)) to gr$DotType 39994>>>>> increment gr$CPU$PC 39995>>>>> end_procedure 39996>>>>> procedure mthd_SetDotSize 39998>>>>> move (value(gr$CPU$RAM,gr$CPU$PC)) to gr$DotSize 39999>>>>> increment gr$CPU$PC 40000>>>>> end_procedure 40001>>>>> procedure mthd_SetDotAlign 40003>>>>> move (value(gr$CPU$RAM,gr$CPU$PC)) to gr$DotAlign 40004>>>>> increment gr$CPU$PC 40005>>>>> end_procedure 40006>>>>> procedure mthd_Rectangle 40008>>>>> gosub vdfgraph$Prepare2Points 40009>>>>>> 40009>>>>> move (Rectangle(gr$hCurrentDC,low(gr$CoordXY1#),hi(gr$CoordXY1#),Low(gr$CoordXY2#),Hi(gr$CoordXY2#))) To gr$Void 40010>>>>> end_procedure 40011>>>>> procedure mthd_RectangleBackground // The only point about this is that we can kill it in the VPE version 40013>>>>> gosub vdfgraph$Prepare2Points 40014>>>>>> 40014>>>>> move (Rectangle(gr$hCurrentDC,low(gr$CoordXY1#),hi(gr$CoordXY1#),Low(gr$CoordXY2#),Hi(gr$CoordXY2#))) To gr$Void 40015>>>>> end_procedure 40016>>>>> procedure mthd_Ellipse 40018>>>>> gosub vdfgraph$Prepare2Points 40019>>>>>> 40019>>>>> move (Ellipse(gr$hCurrentDC,low(gr$CoordXY1#),hi(gr$CoordXY1#),Low(gr$CoordXY2#),Hi(gr$CoordXY2#))) To gr$Void 40020>>>>> end_procedure 40021>>>>> procedure mthd_RoundRect 40023>>>>> gosub vdfgraph$Prepare2Points 40024>>>>>> 40024>>>>> move (RoundRect(gr$hCurrentDC,low(gr$CoordXY1#),hi(gr$CoordXY1#),Low(gr$CoordXY2#),Hi(gr$CoordXY2#),Low(gr$RoundRectFactor),Hi(gr$RoundRectFactor))) To gr$Void 40025>>>>> end_procedure 40026>>>>> procedure mthd_LineTo 40028>>>>> gosub vdfgraph$PreparePoint 40029>>>>>> 40029>>>>> move (LineTo(gr$hCurrentDC,low(gr$CoordXY1#),hi(gr$CoordXY1#))) to gr$Void 40030>>>>> end_procedure 40031>>>>> procedure mthd_MoveTo 40033>>>>> gosub vdfgraph$PreparePoint 40034>>>>>> 40034>>>>> move (MoveTo(gr$hCurrentDC,low(gr$CoordXY1#),hi(gr$CoordXY1#),0)) to gr$Void 40035>>>>> end_procedure 40036>>>>> procedure mthd_TextOut 40038>>>>> pointer address# pRect# 40038>>>>> string str# rect# 40038>>>>> get value of gr$CPU$RAM item gr$CPU$PC to str# 40039>>>>> if (pOemToAnsi_State(self)) move (Grph_OemToChar(str#)) to str# 40042>>>>> getaddress of str# to address# 40043>>>>> increment gr$CPU$PC 40044>>>>> gosub vdfgraph$PreparePoint 40045>>>>>> 40045>>>>> if gr$vCenterActive begin 40047>>>>> zerotype tRECT to rect# 40048>>>>> put (low(gr$CoordXY1#)) to rect# at tRECT.left 40049>>>>> put (low(gr$CoordXY1#)) to rect# at tRECT.right 40050>>>>> put (hi(gr$CoordXY1#)) to rect# at tRECT.top 40051>>>>> put (hi(gr$CoordXY1#)) to rect# at tRECT.bottom 40052>>>>> getaddress of rect# to pRect# 40053>>>>> move (DrawText(gr$hCurrentDC,address#,-1,pRect#,gr$vCenterActive)) to gr$Void 40054>>>>> end 40054>>>>>> 40054>>>>> else move (TextOut(gr$hCurrentDC,low(gr$CoordXY1#),hi(gr$CoordXY1#),address#,length(str#))) to gr$Void 40056>>>>> end_procedure 40057>>>>> 40057>>>>> procedure do_polygonline integer line# 40059>>>>> // Creates a string of (x,y) points and returns a pointer to the string 40059>>>>> // This value can then be used as the array argument to the Polygon WinGDI 40059>>>>> // function 40059>>>>> pointer address# 40059>>>>> integer Points# iPoint argument_size# size_needed# 40059>>>>> gosub vdfgraph$Update_GDI_Objects 40060>>>>>> 40060>>>>> get value of gr$CPU$RAM item gr$CPU$PC to Points# 40061>>>>> move (Points#*8) to size_needed# 40062>>>>> get_argument_size to argument_size# 40063>>>>> if argument_size# lt size_needed# set_argument_size size_needed# 40066>>>>> string gr$Polygon_Points# // Must be declared here, I think (I don't know) 40066>>>>> increment gr$CPU$PC 40067>>>>> ZeroType tPOINT To gr$Point 40068>>>>> move (repeat(character(0),Points#*8)) to gr$Polygon_Points# 40069>>>>> for iPoint from 0 To (Points#-1) 40075>>>>>> 40075>>>>> get value of gr$CPU$RAM item gr$CPU$PC to gr$CoordXY1# 40076>>>>> increment gr$CPU$PC 40077>>>>> gosub vdfgraph$ConvertToGUI1 40078>>>>>> 40078>>>>> put (low(gr$CoordXY1#)) To gr$Point at tPOINT.X 40079>>>>> put (hi(gr$CoordXY1#)) To gr$Point at tPOINT.Y 40080>>>>> move (overstrike(gr$Point,gr$Polygon_Points#,iPoint*8+1)) to gr$Polygon_Points# 40081>>>>> loop 40082>>>>>> 40082>>>>> append gr$Polygon_Points# (character(0)) // Add a null-terminator character to end of the string/array 40083>>>>> GetAddress Of gr$Polygon_Points# To address# 40084>>>>> 40084>>>>> if line# move (GrphPolyline(gr$hCurrentDC,address#,points#)) to gr$Void 40087>>>>> else move (GrphPolyGon(gr$hCurrentDC,address#,points#)) to gr$Void 40089>>>>> set_argument_size argument_size# 40090>>>>>> 40090>>>>> end_procedure 40091>>>>> 40091>>>>> procedure mthd_PolyLine 40093>>>>> send do_polygonline 1 40094>>>>> end_procedure 40095>>>>> 40095>>>>> procedure mthd_PolyGon 40097>>>>> Move (GrphSetPolyFillMode(gr$hCurrentDC,gr$PolyGonFillMode)) To gr$Void 40098>>>>> send do_polygonline 0 40099>>>>> end_procedure 40100>>>>> 40100>>>>> procedure BeginDraw 40102>>>>> move (piProgram_RAM(self)) to gr$CPU$RAM 40103>>>>> move (oTrackableObjects(self)) to gr$TrackArray 40104>>>>> send delete_data to gr$CPU$RAM 40105>>>>> send delete_data to gr$TrackArray 40106>>>>> move 0 to gr$CPU$PC 40107>>>>> end_procedure 40108>>>>> 40108>>>>> procedure AddRectangleTrack integer x1# integer y1# integer x2# integer y2# integer cb_val# 40110>>>>> send AddRectangle x1# y1# x2# y2# 40111>>>>> send MakeAreaTrackable GR_TRACK_RECTANGLE x1# y1# x2# y2# cb_val# 40112>>>>> end_procedure 40113>>>>> procedure MakeAreaTrackable integer type# integer x1# integer y1# integer x2# integer y2# integer trackobjid# 40115>>>>> integer liTemp 40115>>>>> set value of gr$CPU$RAM item gr$CPU$PC to msg_mthd_MakeAreaTrackable 40116>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+1) to type# 40117>>>>> if (x1#>x2#) begin 40119>>>>> move x2# to liTemp 40120>>>>> move x1# to x2# 40121>>>>> move liTemp to x1# 40122>>>>> end 40122>>>>>> 40122>>>>> if (y1#>y2#) begin 40124>>>>> move y2# to liTemp 40125>>>>> move y1# to y2# 40126>>>>> move liTemp to y1# 40127>>>>> end 40127>>>>>> 40127>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+2) to (x1#*65536+y1#) 40128>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+3) to (x2#*65536+y2#) 40129>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+4) to trackobjid# 40130>>>>> move (gr$CPU$PC+5) to gr$CPU$PC 40131>>>>> end_procedure 40132>>>>> 40132>>>>> vdfgraph$Procedure_OneArg SetPenColor msg_mthd_SetPenColor 40138>>>>> vdfgraph$Procedure_OneArg SetPenWidth msg_mthd_SetPenWidth 40144>>>>> vdfgraph$Procedure_OneArg SetPenStyle msg_mthd_SetPenStyle 40150>>>>> vdfgraph$Procedure_OneArg SetFillColor msg_mthd_SetFillColor 40156>>>>> vdfgraph$Procedure_OneArg SetHatchStyle msg_mthd_SetHatchStyle 40162>>>>> vdfgraph$Procedure_OneArg SetBackColor msg_mthd_SetBackColor 40168>>>>> vdfgraph$Procedure_OneArg SetTextAlign msg_mthd_SetTextAlign 40174>>>>> vdfgraph$Procedure_OneArg SetTextColor msg_mthd_SetTextColor 40180>>>>> vdfgraph$Procedure_OneArg SetStockFont msg_mthd_SetStockFont 40186>>>>> 40186>>>>> procedure SetTTFont string name# integer pitch# integer angle# integer bold# integer italic# integer underline# 40188>>>>> set value of gr$CPU$RAM item gr$CPU$PC to msg_mthd_SetTTFont 40189>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+1) to name# 40190>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+2) to pitch# 40191>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+3) to angle# 40192>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+4) to bold# 40193>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+5) to italic# 40194>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+6) to underline# 40195>>>>> move (gr$CPU$PC+7) to gr$CPU$PC 40196>>>>> end_procedure 40197>>>>> vdfgraph$Procedure_OneArg SetRoundRectFactor msg_mthd_SetRoundRectFactor 40203>>>>> vdfgraph$Procedure_OneArg SetPolyGonFillMode msg_mthd_SetPolyGonFillMode 40209>>>>> vdfgraph$Procedure_PlaneArg AddRectangle msg_mthd_Rectangle 40216>>>>> vdfgraph$Procedure_PlaneArg AddRectangleBackground msg_mthd_RectangleBackground 40223>>>>> procedure Add4Angle integer x1# integer y1# integer x2# integer y2# integer x3# integer y3# integer x4# integer y4# 40225>>>>> send AddPolyPoint x1# y1# 40226>>>>> send AddPolyPoint x2# y2# 40227>>>>> send AddPolyPoint x3# y3# 40228>>>>> send AddPolyPoint x4# y4# 40229>>>>> send AddPolyGon 40230>>>>> end_procedure 40231>>>>> vdfgraph$Procedure_PlaneArg AddEllipse msg_mthd_Ellipse 40238>>>>> vdfgraph$Procedure_PlaneArg AddRoundRect msg_mthd_RoundRect 40245>>>>> vdfgraph$Procedure_LineArg AddLineMvTo msg_mthd_MoveTo 40251>>>>> vdfgraph$Procedure_LineArg AddLineGoTo msg_mthd_LineTo 40257>>>>> 40257>>>>> procedure AddLine integer x1# integer y1# integer x2# integer y2# 40259>>>>> send AddLineMvTo x1# y1# 40260>>>>> send AddLineGoTo x2# y2# 40261>>>>> graph$showln ("Line: "+string(x1#)+","+string(y1#)+" to "+string(x2#)+","+string(y2#)) 40261>>>>> end_procedure 40262>>>>> 40262>>>>> procedure AddText string str# integer x1# integer y1# 40264>>>>> if str# ne "" begin // If an empty string is added the program may GPF 40266>>>>> set value of gr$CPU$RAM item gr$CPU$PC to msg_mthd_TextOut 40267>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+1) to str# 40268>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+2) to (x1#*65536+y1#) 40269>>>>> move (gr$CPU$PC+3) to gr$CPU$PC 40270>>>>> end 40270>>>>>> 40270>>>>> end_procedure 40271>>>>> 40271>>>>> procedure AddPolyLine 40273>>>>> integer iPolyPointsOffS# 40273>>>>> get pPolyPointsOffS to iPolyPointsOffS# 40274>>>>> ifnot iPolyPointsOffS# error 666 "No points specified for polyline! (vdfgraph.utl)" 40277>>>>> set value of gr$CPU$RAM item (iPolyPointsOffS#-1) to msg_mthd_PolyLine 40278>>>>> set value of gr$CPU$RAM item iPolyPointsOffS# to (gr$CPU$PC-iPolyPointsOffS#-1) 40279>>>>> set pPolyPointsOffS to 0 40280>>>>> end_procedure 40281>>>>> 40281>>>>> procedure AddPolyGon 40283>>>>> integer iPolyPointsOffS# 40283>>>>> get pPolyPointsOffS to iPolyPointsOffS# 40284>>>>> ifnot iPolyPointsOffS# error 666 "No points specified for polygon! (vdfgraph.utl)" 40287>>>>> set value of gr$CPU$RAM item (iPolyPointsOffS#-1) to msg_mthd_PolyGon 40288>>>>> set value of gr$CPU$RAM item iPolyPointsOffS# to (gr$CPU$PC-iPolyPointsOffS#-1) 40289>>>>> set pPolyPointsOffS to 0 40290>>>>> end_procedure 40291>>>>> 40291>>>>> procedure AddDot integer x# integer y# 40293>>>>> set value of gr$CPU$RAM item gr$CPU$PC to msg_mthd_AddDot 40294>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+1) to (x#*65536+y#) 40295>>>>> move (gr$CPU$PC+2) to gr$CPU$PC 40296>>>>> end_procedure 40297>>>>> procedure SetDotStyle integer x# 40299>>>>> set value of gr$CPU$RAM item gr$CPU$PC to msg_mthd_SetDotStyle 40300>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+1) to x# 40301>>>>> move (gr$CPU$PC+2) to gr$CPU$PC 40302>>>>> end_procedure 40303>>>>> procedure SetDotSize integer x# 40305>>>>> set value of gr$CPU$RAM item gr$CPU$PC to msg_mthd_SetDotSize 40306>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+1) to x# 40307>>>>> move (gr$CPU$PC+2) to gr$CPU$PC 40308>>>>> end_procedure 40309>>>>> procedure SetDotAlign integer x# 40311>>>>> set value of gr$CPU$RAM item gr$CPU$PC to msg_mthd_SetDotAlign 40312>>>>> set value of gr$CPU$RAM item (gr$CPU$PC+1) to x# 40313>>>>> move (gr$CPU$PC+2) to gr$CPU$PC 40314>>>>> end_procedure 40315>>>>> 40315>>>>> procedure AddPolyPoint integer x# integer y# 40317>>>>> ifnot (pPolyPointsOffS(self)) begin 40319>>>>> set pPolyPointsOffS to (gr$CPU$PC+1) 40320>>>>> move (gr$CPU$PC+2) to gr$CPU$PC // Reserve space for method and number of points 40321>>>>> end 40321>>>>>> 40321>>>>> set value of gr$CPU$RAM item gr$CPU$PC to (x#*65536+y#) 40322>>>>> increment gr$CPU$PC 40323>>>>> end_procedure 40324>>>>> 40324>>>>> procedure onMouseUp integer x# integer y# 40326>>>>> end_procedure 40327>>>>> procedure onMouseDown integer x# integer y# 40329>>>>> end_procedure 40330>>>>> procedure onMouse2Up integer x# integer y# 40332>>>>> end_procedure 40333>>>>> procedure onMouse2Down integer x# integer y# 40335>>>>> end_procedure 40336>>>>> procedure onMouseDrag integer x# integer y# 40338>>>>> end_procedure 40339>>>>> procedure onMouseMove integer x# integer y# 40341>>>>> end_procedure 40342>>>>> procedure onMouseDblClick integer x# integer y# 40344>>>>> end_procedure 40345>>>>> procedure onMouseUpTrack integer cb_value# integer level# 40347>>>>> end_procedure 40348>>>>> procedure onMouseDownTrack integer cb_value# integer level# 40350>>>>> end_procedure 40351>>>>> procedure onMouse2UpTrack integer cb_value# integer level# 40353>>>>> end_procedure 40354>>>>> procedure onMouse2DownTrack integer cb_value# integer level# 40356>>>>> end_procedure 40357>>>>> procedure onMouseDragTrack integer cb_value# integer level# 40359>>>>> end_procedure 40360>>>>> procedure onMouseMoveTrack integer cb_value# integer level# 40362>>>>> end_procedure 40363>>>>> procedure onMouseDblClickTrack integer cb_value# integer level# 40365>>>>> end_procedure 40366>>>>> 40366>>>>> procedure translate_to_onEvent integer msg# integer track_msg# 40368>>>>> get absolute_mouse_location to gr$CoordXY1# 40369>>>>> // In this place it would make more sense to ask if high and low 40369>>>>> // 16 bits were gt 0, but that you can't. Instead we ask if they 40369>>>>> // are less than 5000 (pixels from the edge): 40369>>>>> 40369>>>>>// Three of the lines below were taken out for test purposes on 2/10-2001: 40369>>>>> 40369>>>>>// if (hi(gr$CoordXY1#)<=5000 and low(gr$CoordXY1#)<5000) begin 40369>>>>> 40369>>>>> get piX_Offset to gr$GuiOffsetX# 40370>>>>> get piY_Offset to gr$GuiOffsetY# 40371>>>>> get piX_Range to gr$X_Range 40372>>>>> get piY_Range to gr$Y_Range 40373>>>>> 40373>>>>> Get GuiSize to gr$Tmp# 40374>>>>> move (hi(gr$Tmp#)) to gr$GuiSizeX# 40375>>>>> move (low(gr$Tmp#)) to gr$GuiSizeY# 40376>>>>> move (oTrackableObjects(self)) to gr$TrackArray 40377>>>>> send TestTrackHit to gr$TrackArray track_msg# 40378>>>>> gosub vdfgraph$ConvertToVirtual 40379>>>>>> 40379>>>>>// if (hi(gr$CoordXY1#)<=10000 and low(gr$CoordXY1#)<=10000) ; 40379>>>>> send msg# (hi(gr$CoordXY1#)) (low(gr$CoordXY1#)) 40380>>>>>// end 40380>>>>> end_procedure 40381>>>>> // Left mouse button down: 40381>>>>> procedure WMSG_OnMouseDown Integer wParam Integer lParam 40383>>>>> send translate_to_onEvent msg_onMouseDown msg_onMouseDownTrack 40384>>>>> end_procedure 40385>>>>> // Left mouse button up: 40385>>>>> procedure WMSG_OnMouseUp Integer wParam Integer lParam 40387>>>>> send translate_to_onEvent msg_onMouseUp msg_onMouseUpTrack 40388>>>>> end_procedure 40389>>>>> // Right mouse button down: 40389>>>>> procedure WMSG_OnMouse2Down Integer wParam Integer lParam 40391>>>>> send translate_to_onEvent msg_onMouse2Down msg_onMouse2DownTrack 40392>>>>> end_procedure 40393>>>>> // right mouse button down: 40393>>>>> procedure WMSG_OnMouse2Up Integer wParam Integer lParam 40395>>>>> send translate_to_onEvent msg_onMouse2Up msg_onMouse2UpTrack 40396>>>>> end_procedure 40397>>>>> // Mouse move: 40397>>>>> procedure WMSG_OnMouseMove Integer wParam Integer lParam 40399>>>>> // If left mouse button is depressed: 40399>>>>> if (wParam iand MK_LBUTTON) send translate_to_onEvent msg_onMouseDrag msg_onMouseDragTrack 40402>>>>> else send translate_to_onEvent msg_onMouseMove msg_onMouseMoveTrack 40404>>>>> end_procedure 40405>>>>> procedure WMSG_OnMouseDblClick Integer wParam Integer lParam 40407>>>>> send translate_to_onEvent msg_onMouseDblClick msg_onMouseDblClickTrack 40408>>>>> end_procedure 40409>>>>> 40409>>>>> procedure Read_From_File integer channel# integer reset_tmp# 40411>>>>> integer grb# reset# 40411>>>>> if num_arguments gt 1 move reset_tmp# to reset# 40414>>>>> else move 0 to reset# 40416>>>>> if reset# send BeginDraw 40419>>>>> get Read_Program_RAM of (oGraphOperationMsgTabel(self)) (piProgram_RAM(self)) 1 to grb# 40420>>>>> end_procedure 40421>>>>> procedure Write_To_File integer channel# 40423>>>>> integer grb# 40423>>>>> get Write_Program_RAM of (oGraphOperationMsgTabel(self)) (piProgram_RAM(self)) channel# to grb# 40424>>>>> end_procedure 40425>>>>> 40425>>>>> procedure DoZoom number lnZoomFactorX number lnZoomFactorY 40427>>>>> send RepaintFull 40428>>>>> end_procedure 40429>>>>> procedure DoViewPort integer lhVert integer lhHorz 40431>>>>> end_procedure 40432>>>>> procedure ResetZoom 40434>>>>> end_procedure 40435>>>>> procedure ResetViewPort 40437>>>>> end_procedure 40438>>>>>end_class // GraphicArea 40439>>>>> 40439>>>>>//> The purpose of the oGraphOperationMsgTabel object is to facilitate 40439>>>>>//> writing the graphics stored in out useal array to a sequential file. 40439>>>>>//> The reason that we cannot just dump our array to file, is that the array 40439>>>>>//> contains message identifiers that may change each time we compile. 40439>>>>>//> Therefore a mechanism, that will translate message ID's to recognizable 40439>>>>>//> symbols is needed to do this. 40439>>>>>object oGraphOperationMsgTabel is an array 40441>>>>> item_property_list 40441>>>>> item_property string psName.i 40441>>>>> item_property integer piMsg_Id.i 40441>>>>> item_property integer piNum_Arguments.i 40441>>>>> end_item_property_list #REM 40481 DEFINE FUNCTION PINUM_ARGUMENTS.I INTEGER LIROW RETURNS INTEGER #REM 40486 DEFINE PROCEDURE SET PINUM_ARGUMENTS.I INTEGER LIROW INTEGER VALUE #REM 40491 DEFINE FUNCTION PIMSG_ID.I INTEGER LIROW RETURNS INTEGER #REM 40496 DEFINE PROCEDURE SET PIMSG_ID.I INTEGER LIROW INTEGER VALUE #REM 40501 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING #REM 40506 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE 40512>>>>> procedure Define_Graphic_Message integer no# string name# integer msg# integer args# 40515>>>>> set psName.i no# to name# 40516>>>>> set piMsg_Id.i no# to msg# 40517>>>>> set piNum_Arguments.i no# to args# 40518>>>>> end_procedure 40519>>>>> send Define_Graphic_Message GO_SetPenColor "Pen color" msg_mthd_SetPenColor 1 40520>>>>> send Define_Graphic_Message GO_SetPenWidth "Pen width" msg_mthd_SetPenWidth 1 40521>>>>> send Define_Graphic_Message GO_SetPenStyle "Pen style" msg_mthd_SetPenStyle 1 40522>>>>> send Define_Graphic_Message GO_SetFillColor "Fill color" msg_mthd_SetFillColor 1 40523>>>>> send Define_Graphic_Message GO_SetHatchStyle "Hatch style" msg_mthd_SetHatchStyle 1 40524>>>>> send Define_Graphic_Message GO_SetBackColor "Back color" msg_mthd_SetBackColor 1 40525>>>>> send Define_Graphic_Message GO_SetRoundRectFactor "Round rect factor" msg_mthd_SetRoundRectFactor 1 40526>>>>> send Define_Graphic_Message GO_SetPolyGonFillMode "Polygon fill mode" msg_mthd_SetPolyGonFillMode 1 40527>>>>> send Define_Graphic_Message GO_SetTextAlign "Text alignment" msg_mthd_SetTextAlign 1 40528>>>>> send Define_Graphic_Message GO_SetTextColor "Text color" msg_mthd_SetTextColor 1 40529>>>>> send Define_Graphic_Message GO_SetStockFont "Stock font" msg_mthd_SetStockFont 1 40530>>>>> send Define_Graphic_Message GO_SetTTFont "TT font" msg_mthd_SetTTFont 6 40531>>>>> send Define_Graphic_Message GO_AddDot "Dot" msg_mthd_AddDot 1 40532>>>>> send Define_Graphic_Message GO_SetDotStyle "Dot style" msg_mthd_SetDotStyle 1 40533>>>>> send Define_Graphic_Message GO_SetDotSize "Dot size" msg_mthd_SetDotSize 1 40534>>>>> send Define_Graphic_Message GO_SetDotAlign "Dot alignment" msg_mthd_SetDotAlign 1 40535>>>>> send Define_Graphic_Message GO_Rectangle "Rectangle" msg_mthd_Rectangle 2 40536>>>>> send Define_Graphic_Message GO_Ellipse "Ellipse" msg_mthd_Ellipse 2 40537>>>>> send Define_Graphic_Message GO_RoundRect "Round rectangle" msg_mthd_RoundRect 2 40538>>>>> send Define_Graphic_Message GO_LineTo "Line to" msg_mthd_LineTo 1 40539>>>>> send Define_Graphic_Message GO_MoveTo "Move to" msg_mthd_MoveTo 1 40540>>>>> send Define_Graphic_Message GO_TextOut "Text" msg_mthd_TextOut 2 40541>>>>> send Define_Graphic_Message GO_Polygon "Polygon" msg_mthd_Polygon -1 40542>>>>> send Define_Graphic_Message GO_PolyLine "Polyline" msg_mthd_PolyLine -1 40543>>>>> function MsgToGO integer msg# returns integer 40546>>>>> integer row# max# 40546>>>>> move 0 to row# 40547>>>>> get row_count to max# 40548>>>>> while row# lt max# 40552>>>>> if (piMsg_Id.i(self,row#)) eq msg# function_return row# 40555>>>>> increment row# 40556>>>>> loop 40557>>>>>> 40557>>>>> function_return -1 40558>>>>> end_function 40559>>>>> function Write_Program_RAM integer obj# integer ch# returns integer 40562>>>>> integer itm# max# msg# err# GO# args# 40562>>>>> string str# 40562>>>>> get item_count of obj# to max# 40563>>>>> move 0 to itm# 40564>>>>> move 0 to err# 40565>>>>> while itm# lt max# 40569>>>>> get value of obj# item itm# to msg# 40570>>>>> increment itm# 40571>>>>> move (MsgToGO(self,msg#)) to GO# 40572>>>>> if GO# ne -1 begin 40574>>>>> writeln channel ch# GO# 40577>>>>> move (piNum_Arguments.i(self,GO#)) to args# 40578>>>>> if args# eq -1 begin 40580>>>>> get value of obj# item itm# to args# 40581>>>>> increment itm# 40582>>>>> writeln args# 40584>>>>> end 40584>>>>>> 40584>>>>> while args# gt 0 40588>>>>> get value of obj# item itm# to str# 40589>>>>> increment itm# 40590>>>>> writeln str# 40592>>>>> decrement args# 40593>>>>> loop 40594>>>>>> 40594>>>>> end 40594>>>>>> 40594>>>>> else move 1 to err# 40596>>>>> loop 40597>>>>>> 40597>>>>> function_return err# 40598>>>>> end_function 40599>>>>> function Read_Program_RAM integer obj# integer ch# returns integer 40602>>>>> integer msg# err# GO# args# seqeof# 40602>>>>> string str# 40602>>>>> move 0 to err# 40603>>>>> repeat 40603>>>>>> 40603>>>>> readln channel ch# GO# 40605>>>>> move (seqeof) to seqeof# 40606>>>>> ifnot seqeof# begin 40608>>>>> move (piMsg_Id.i(self,GO#)) to msg# 40609>>>>> if msg# begin 40611>>>>> set value of obj# item (item_count(obj#)) to msg# 40612>>>>> move (piNum_Arguments.i(self,GO#)) to args# 40613>>>>> if args# eq -1 begin 40615>>>>> readln args# 40616>>>>> set value of obj# item (item_count(obj#)) to args# 40617>>>>> end 40617>>>>>> 40617>>>>> while args# gt 0 40621>>>>> readln str# 40622>>>>> set value of obj# item (item_count(obj#)) to str# 40623>>>>> decrement args# 40624>>>>> loop 40625>>>>>> 40625>>>>> end 40625>>>>>> 40625>>>>> else move 1 to err# 40627>>>>> end 40627>>>>>> 40627>>>>> until seqeof# 40629>>>>> function_return err# 40630>>>>> end_function 40631>>>>>end_object 40632>>>>> 40632>>>>>class cAutoScaler is an array 40633>>>>> procedure construct_object 40635>>>>> forward send construct_object 40637>>>>> set delegation_mode to delegate_to_parent 40638>>>>> 40638>>>>> // Parameter properties: 40638>>>>> property number pMinValue public 0 // minimum value 40639>>>>> property number pMaxValue public 0 // maximum value 40640>>>>> property integer pZeroBased public 0 // is the scale zero based? 40641>>>>> property number pAirPct public 5 // default: 5% air 40642>>>>> property integer pMinSteps public 8 // lowest acceptable number of steps 40643>>>>> property integer pMaxSteps public 11 // highest acceptable number of steps 40644>>>>> 40644>>>>> // Local properties: 40644>>>>> property number pMinValue private 0 // minimum value 40645>>>>> property number pMaxValue private 0 // maximum value 40646>>>>> property number pMinValueTmp private 0 // minimum value 40647>>>>> property number pMaxValueTmp private 0 // maximum value 40648>>>>> property integer pStepsTmp private 0 // maximum value 40649>>>>> 40649>>>>> property integer pCorrection private 0 // 0=no corr, 1=positive corr, 40650>>>>> // 2=neg corr, -1=negative scale. 40650>>>>> set value item 0 to 0 40651>>>>> set value item 1 to 0.1 40652>>>>> set value item 2 to 0.2 40653>>>>> set value item 3 to 0.25 40654>>>>> set value item 4 to 0.5 40655>>>>> set value item 5 to 1 40656>>>>> set value item 6 to 2 40657>>>>> set value item 7 to 2.5 40658>>>>> set value item 8 to 5 40659>>>>> set value item 9 to 10 40660>>>>> 40660>>>>> // Result properties 40660>>>>> property number pLowValue public 0 // lower value 40661>>>>> property number pStepSize public 0 // step size 40662>>>>> property integer pSteps public 0 // number of steps 40663>>>>> property integer pDecimals public 0 // max number of decimals 40664>>>>> end_procedure 40665>>>>> 40665>>>>> function ScaleEfficiency returns number 40667>>>>> function_return (!$.pMaxValue(self)-!$.pMinValue(self)/(pSteps(self)*pStepSize(self))) 40668>>>>> end_function 40669>>>>> 40669>>>>> function AirAmount returns number 40671>>>>> function_return (!$.pMaxValue(self)-!$.pMinValue(self)*pAirPct(self)/100) 40672>>>>> end_function 40673>>>>> 40673>>>>> procedure ApplyAir // apply air (and zero base, if specified) 40675>>>>> number AirAmount# 40675>>>>> if (pZeroBased(self)) begin 40677>>>>> if (!$.pMinValue(self)>=0 and !$.pMaxValue(self)>=0) begin 40679>>>>> set !$.pMinValue to 0 40680>>>>> set !$.pMaxValue to (!$.pMaxValue(self)+AirAmount(self)) 40681>>>>> end 40681>>>>>> 40681>>>>> else begin 40682>>>>> if (!$.pMinValue(self)<=0 and !$.pMaxValue(self)<=0) begin 40684>>>>> set !$.pMaxValue to 0 40685>>>>> set !$.pMinValue to (!$.pMinValue(self)-AirAmount(self)) 40686>>>>> end 40686>>>>>> 40686>>>>> else begin 40687>>>>> get AirAmount to AirAmount# 40688>>>>> set !$.pMaxValue to (!$.pMaxValue(self)+AirAmount#) 40689>>>>> set !$.pMinValue to (!$.pMinValue(self)-AirAmount#) 40690>>>>> end 40690>>>>>> 40690>>>>> end 40690>>>>>> 40690>>>>> end 40690>>>>>> 40690>>>>> else begin 40691>>>>> get AirAmount to AirAmount# 40692>>>>> set !$.pMaxValue to (!$.pMaxValue(self)+AirAmount#) 40693>>>>> set !$.pMinValue to (!$.pMinValue(self)-AirAmount#) 40694>>>>> end 40694>>>>>> 40694>>>>> end_procedure 40695>>>>> 40695>>>>> procedure UndoCorrections // Undo corrections done by SetupScaleParams 40697>>>>> integer correction# 40697>>>>> number tmp# 40697>>>>> get !$.pCorrection to correction# 40698>>>>> // Negative scale: 40698>>>>> if correction# eq -1 set pLowValue to (0-(pLowValue(self)+(pStepSize(self)*pSteps(self)))) 40701>>>>> // Scale based on positive part: 40701>>>>> if correction# eq 1 set pLowValue to (pLowValue(self)-(pStepSize(self)*(pSteps(self)-!$.pStepsTmp(self)))) 40704>>>>> // Scale based on negative part: 40704>>>>> if correction# eq 2 begin 40706>>>>> move (pLowValue(self)-(pStepSize(self)*(pSteps(self)-!$.pStepsTmp(self)))) to tmp# 40707>>>>> set pLowValue to (0-tmp#-(pSteps(self)*pStepSize(self))) 40708>>>>> end 40708>>>>>> 40708>>>>> end_procedure 40709>>>>> 40709>>>>> procedure SetupScaleParams integer steps# 40711>>>>> number temp# 40711>>>>> // This procedure acts only if there is both positive and negativ values 40711>>>>> // on the scale. Then the number of steps# passed to the procedure is 40711>>>>> // distributed between the positive and the negative part. 40711>>>>> // 40711>>>>> // The effect is that the scaling problem is reduced to one with only 40711>>>>> // positive values in a way that ensures that the value 0 is included 40711>>>>> 40711>>>>> set !$.pMinValueTmp to (!$.pMinValue(self)) 40712>>>>> set !$.pMaxValueTmp to (!$.pMaxValue(self)) 40713>>>>> set pSteps to steps# 40714>>>>> set !$.pStepsTmp to steps# 40715>>>>> set !$.pCorrection to 0 // no correction 40716>>>>> if (!$.pMaxValueTmp(self)>0 and !$.pMinValueTmp(self)<0) begin 40718>>>>> if (!$.pMaxValueTmp(self)>(0-!$.pMinValueTmp(self))) begin // major part on positive side 40720>>>>> move (!$.pMaxValueTmp(self)/(!$.pMaxValueTmp(self)-!$.pMinValueTmp(self))) to temp# // fraction on positive side 40721>>>>> set !$.pStepsTmp to (integer(temp#*steps#)) 40722>>>>> set !$.pMinValueTmp to 0 40723>>>>> set !$.pCorrection to 1 // scale based on positive part 40724>>>>> end 40724>>>>>> 40724>>>>> else begin // major part on negative side 40725>>>>> move (!$.pMinValueTmp(self)/(!$.pMinValueTmp(self)-!$.pMaxValueTmp(self))) to temp# // fraction on negative side 40726>>>>> set !$.pStepsTmp to (integer(temp#*steps#)) 40727>>>>> set !$.pMaxValueTmp to (0-!$.pMinValueTmp(self)) 40728>>>>> set !$.pMinValueTmp to 0 40729>>>>> set !$.pCorrection to 2 // scale based on negative part 40730>>>>> end 40730>>>>>> 40730>>>>> end 40730>>>>>> 40730>>>>> if (!$.pMaxValueTmp(self)<0 and !$.pMinValueTmp(self)<0) begin 40732>>>>> move (-!$.pMaxValueTmp(self)) to temp# 40733>>>>> set !$.pMaxValueTmp to (-!$.pMinValueTmp(self)) 40734>>>>> set !$.pMinValueTmp to temp# 40735>>>>> set !$.pCorrection to -1 // scale negation 40736>>>>> end 40736>>>>>> 40736>>>>> end_procedure 40737>>>>> 40737>>>>> function StepSize number StepSize# integer OffSet# returns number 40739>>>>> integer itm# max# 40739>>>>> get item_count to max# 40740>>>>> for itm# from 0 to (max#-1-OffSet#) 40746>>>>>> 40746>>>>> if (StepSize#>number_value(self,itm#) and ; StepSize#>>>> loop 40750>>>>>> 40750>>>>> if OffSet# begin 40752>>>>> for itm# from 0 to (max#-1-OffSet#) 40758>>>>>> 40758>>>>> if StepSize# eq (number_value(self,itm#)) ; function_return (number_value(self,itm#+OffSet#)) 40761>>>>> loop 40762>>>>>> 40762>>>>> end 40762>>>>>> 40762>>>>> function_return StepSize# 40763>>>>> end_function 40764>>>>> 40764>>>>> function RoundOff number temp# returns number 40766>>>>> function_return (integer((temp#+0.00005)*10000)/10000.0) 40767>>>>> end_function 40768>>>>> 40768>>>>> function Exp10 integer base# returns number 40770>>>>> integer count# 40770>>>>> number rval# 40770>>>>> move 1 to rval# 40771>>>>> if base# ge 0 begin 40773>>>>> for count# from 1 to base# 40779>>>>>> 40779>>>>> move (rval#*10) to rval# 40780>>>>> loop 40781>>>>>> 40781>>>>> end 40781>>>>>> 40781>>>>> else begin 40782>>>>> for count# from 1 to (0-base#) 40788>>>>>> 40788>>>>> move (rval#/10) to rval# 40789>>>>> loop 40790>>>>>> 40790>>>>> end 40790>>>>>> 40790>>>>> function_return rval# 40791>>>>> end_function 40792>>>>> 40792>>>>> // This procedure acts on the values of !$.pMinValueTmp, !$.pMaxValueTmp 40792>>>>> // and !$.pStepsTmp setting the values of pLowValue and pStepSize. 40792>>>>> // The OffSet# variable is used to make the StepSize function return a 40792>>>>> // larger step size than necessary to cover the range passed to it. This 40792>>>>> // happens when the correction of the LowValue makes the MaxValue go off 40792>>>>> // the top. 40792>>>>> procedure TmpScale 40794>>>>> number StepSize# Range# LowValue# 40794>>>>> integer Base# OffSet# Max# MaxOffSet# 40794>>>>> move 0 to OffSet# 40795>>>>> move (item_count(self)-2) to MaxOffSet# 40796>>>>> repeat 40796>>>>>> 40796>>>>> // Calculate step size: 40796>>>>> move ((!$.pMaxValueTmp(self)-!$.pMinValueTmp(self))/!$.pStepsTmp(self)) to Range# 40797>>>>> if range# gt 0 begin 40799>>>>> move (log(range#)/log(10)) to base# 40800>>>>> move (range#/(Exp10(self,base#))) to StepSize# 40801>>>>> //showln (string(range#)) " " (string(base#)) " " (string(StepSize#)) 40801>>>>> move (RoundOff(self,StepSize#)) to StepSize# 40802>>>>> move (StepSize(self,StepSize#,OffSet#)) to StepSize# 40803>>>>> move (StepSize#*Exp10(self,base#)) to StepSize# 40804>>>>> move (StepSize#*(integer(!$.pMinValueTmp(self)/StepSize#))) to LowValue# 40805>>>>> if (StepSize#*!$.pStepsTmp(self)+LowValue#) ge (!$.pMaxValueTmp(self)) begin 40807>>>>> set pLowValue to (StepSize#*(integer(!$.pMinValueTmp(self)/StepSize#))) 40808>>>>> set pStepSize to StepSize# 40809>>>>> procedure_return 40810>>>>> end 40810>>>>>> 40810>>>>> end 40810>>>>>> 40810>>>>> increment OffSet# 40811>>>>> until OffSet# gt MaxOffSet# 40813>>>>> end_procedure 40814>>>>> 40814>>>>> procedure MaxDecimals 40816>>>>> // This procedure sets the property maximum number of decimals (pDecimals) 40816>>>>> integer count# dec# maxdec# 40816>>>>> number value# 40816>>>>> move 0 to dec# 40817>>>>> move -20 to maxdec# 40818>>>>> for count# from 0 to (pSteps(self)) 40824>>>>>> 40824>>>>> move (pLowValue(self)+(count#*pStepSize(self))) to value# 40825>>>>> if value# ne 0 begin 40827>>>>> move (NumberOfDecs(value#)) to dec# 40828>>>>> if dec# gt maxdec# move dec# to maxdec# 40831>>>>> end 40831>>>>>> 40831>>>>> loop 40832>>>>>> 40832>>>>> set pDecimals to (maxdec# max 0) 40833>>>>> end_procedure 40834>>>>> 40834>>>>> procedure AutoScale 40836>>>>> integer count# best_eff_stps# 40836>>>>> number best_eff# best_eff_tmp# 40836>>>>> set !$.pMinValue to (pMinValue(self)) 40837>>>>> set !$.pMaxValue to (pMaxValue(self)) 40838>>>>> send ApplyAir 40839>>>>> move 0 to best_eff# 40840>>>>> move 0 to best_eff_stps# 40841>>>>> for count# from (pMinSteps(self)) to (pMaxSteps(self)) 40847>>>>>> 40847>>>>> send SetupScaleParams count# 40848>>>>> send TmpScale 40849>>>>> send UndoCorrections 40850>>>>> get ScaleEfficiency to best_eff_tmp# 40851>>>>> if best_eff_tmp# gt best_eff# begin 40853>>>>> move best_eff_tmp# to best_eff# 40854>>>>> move count# to best_eff_stps# 40855>>>>> end 40855>>>>>> 40855>>>>> loop 40856>>>>>> 40856>>>>> send SetupScaleParams best_eff_stps# 40857>>>>> send TmpScale 40858>>>>> send UndoCorrections 40859>>>>> send MaxDecimals 40860>>>>> end_procedure 40861>>>>>end_class // cAutoScaler 40862>>>>> 40862>>>>> 40862>>>>>//#REPLACE GLS_None 1 40862>>>>>//#REPLACE GLS_Major 2 40862>>>>>//#REPLACE GLS_Minor 3 40862>>>>> 40862>>>>>integer gr$xCoordMin 40862>>>>>number gr$xLowValue 40862>>>>>number gr$xFactor 40862>>>>>number gr$xConvValue 40862>>>>>integer gr$yCoordMin 40862>>>>>number gr$yHiValue 40862>>>>>number gr$yFactor 40862>>>>>number gr$yConvValue 40862>>>>>number gr$yConvValueTemp 40862>>>>> 40862>>>>>if dfFalse begin // Do not execution this on program start up. 40864>>>>> vdfgraph$Convert: 40864>>>>> move (gr$yHiValue-gr$yConvValue*gr$yFactor+gr$xCoordMin) to gr$yConvValueTemp 40865>>>>> move (gr$xConvValue-gr$xLowValue*gr$xFactor+gr$yCoordMin) to gr$yConvValue 40866>>>>> move gr$yConvValueTemp to gr$xConvValue 40867>>>>> return 40868>>>>>end 40868>>>>>> 40868>>>>> 40868>>>>>object oGridStyles is an array 40870>>>>> item_property_list 40870>>>>> item_property string psName.i 40870>>>>> item_property integer piColor.i 40870>>>>> item_property integer pixMajorScale.i 40870>>>>> item_property integer pixMinorScale.i 40870>>>>> item_property integer pixMinorDiv.i 40870>>>>> item_property integer piyMajorScale.i 40870>>>>> item_property integer piyMinorScale.i 40870>>>>> item_property integer piyMinorDiv.i 40870>>>>> item_property integer piMajorScaleColor.i 40870>>>>> item_property integer piMinorScaleColor.i 40870>>>>> end_item_property_list #REM 40931 DEFINE FUNCTION PIMINORSCALECOLOR.I INTEGER LIROW RETURNS INTEGER #REM 40936 DEFINE PROCEDURE SET PIMINORSCALECOLOR.I INTEGER LIROW INTEGER VALUE #REM 40941 DEFINE FUNCTION PIMAJORSCALECOLOR.I INTEGER LIROW RETURNS INTEGER #REM 40946 DEFINE PROCEDURE SET PIMAJORSCALECOLOR.I INTEGER LIROW INTEGER VALUE #REM 40951 DEFINE FUNCTION PIYMINORDIV.I INTEGER LIROW RETURNS INTEGER #REM 40956 DEFINE PROCEDURE SET PIYMINORDIV.I INTEGER LIROW INTEGER VALUE #REM 40961 DEFINE FUNCTION PIYMINORSCALE.I INTEGER LIROW RETURNS INTEGER #REM 40966 DEFINE PROCEDURE SET PIYMINORSCALE.I INTEGER LIROW INTEGER VALUE #REM 40971 DEFINE FUNCTION PIYMAJORSCALE.I INTEGER LIROW RETURNS INTEGER #REM 40976 DEFINE PROCEDURE SET PIYMAJORSCALE.I INTEGER LIROW INTEGER VALUE #REM 40981 DEFINE FUNCTION PIXMINORDIV.I INTEGER LIROW RETURNS INTEGER #REM 40986 DEFINE PROCEDURE SET PIXMINORDIV.I INTEGER LIROW INTEGER VALUE #REM 40991 DEFINE FUNCTION PIXMINORSCALE.I INTEGER LIROW RETURNS INTEGER #REM 40996 DEFINE PROCEDURE SET PIXMINORSCALE.I INTEGER LIROW INTEGER VALUE #REM 41001 DEFINE FUNCTION PIXMAJORSCALE.I INTEGER LIROW RETURNS INTEGER #REM 41006 DEFINE PROCEDURE SET PIXMAJORSCALE.I INTEGER LIROW INTEGER VALUE #REM 41011 DEFINE FUNCTION PICOLOR.I INTEGER LIROW RETURNS INTEGER #REM 41016 DEFINE PROCEDURE SET PICOLOR.I INTEGER LIROW INTEGER VALUE #REM 41021 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING #REM 41026 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE 41032>>>>> function iAddGridStyle string name# integer Col# integer xMajScl# integer xMinScl# integer xMinDiv# integer yMajScl# integer yMinScl# integer yMinDiv# integer MajSclCol# integer MinSclCol# returns integer 41035>>>>> integer rval# 41035>>>>> get row_count to rval# 41036>>>>> set psName.i item rval# to name# 41037>>>>> set piColor.i item rval# to Col# 41038>>>>> set pixMajorScale.i item rval# to xMajScl# 41039>>>>> set pixMinorScale.i item rval# to xMinScl# 41040>>>>> set pixMinorDiv.i item rval# to xMinDiv# 41041>>>>> set piyMajorScale.i item rval# to yMajScl# 41042>>>>> set piyMinorScale.i item rval# to yMinScl# 41043>>>>> set piyMinorDiv.i item rval# to yMinDiv# 41044>>>>> set piMajorScaleColor.i item rval# to MajSclCol# 41045>>>>> set piMinorScaleColor.i item rval# to MinSclCol# 41046>>>>> function_return rval# 41047>>>>> end_function 41048>>>>> procedure ApplyGridStyle integer row# integer obj# 41051>>>>> set pColor of obj# to (piColor.i(self,row#)) // Backgnd color 41052>>>>> set pxMajorScale of obj# to (pixMajorScale.i(self,row#)) // 41053>>>>> set pxMinorScale of obj# to (pixMinorScale.i(self,row#)) // 41054>>>>> set pxMinorDiv of obj# to (pixMinorDiv.i(self,row#)) // Number of minors per major 41055>>>>> set pyMajorScale of obj# to (piyMajorScale.i(self,row#)) // 41056>>>>> set pyMinorScale of obj# to (piyMinorScale.i(self,row#)) // 41057>>>>> set pyMinorDiv of obj# to (piyMinorDiv.i(self,row#)) // Number of minors per major 41058>>>>> set pMajorScaleColor of obj# to (piMajorScaleColor.i(self,row#)) // Color (x and y) 41059>>>>> set pMinorScaleColor of obj# to (piMinorScaleColor.i(self,row#)) // Color (x and y) 41060>>>>> end_procedure 41061>>>>> procedure AddDefaults 41064>>>>> integer grb# 41064>>>>> DEFINE GS_DEFAULT FOR 0 41064>>>>> get iAddGridStyle "Default" -1 GLS_Line GLS_Dot 2 GLS_Line GLS_Dot 2 clDkGray clGray to grb# 41065>>>>> DEFINE GS_BARCHART1 FOR 1 41065>>>>> get iAddGridStyle "Barchart 1" clWhite GLS_None GLS_None 2 GLS_Line GLS_Dot 1 clBlack clGray to grb# 41066>>>>> DEFINE GS_BARCHART_YMARKERS_ONLY FOR 2 41066>>>>> get iAddGridStyle "Y-markers only" clWhite GLS_None GLS_None 2 GLS_Line GLS_None 1 clBlack clGray to grb# 41067>>>>> end_procedure 41068>>>>> send AddDefaults 41069>>>>>end_object // oGridStyles 41070>>>>> 41070>>>>>Class cCoordinateSystem is an array 41071>>>>> procedure construct_object 41073>>>>> forward send construct_object 41075>>>>> set delegation_mode to delegate_to_parent 41076>>>>> 41076>>>>> // Properties regarding the grid: 41076>>>>> property integer pxAreaLoc public 2000 // These values indicates 41077>>>>> property integer pyAreaLoc public 2000 // inside the graph area. 41078>>>>> property integer pxAreaSiz public 6000 // the area of the graph 41079>>>>> property integer pyAreaSiz public 7000 // 41080>>>>> 41080>>>>> property integer pColor public -1 // Transparent 41081>>>>> property integer pxMajorScale public GLS_Line // 41082>>>>> property integer pxMinorScale public GLS_Dot // 41083>>>>> property integer pxMinorDiv public 2 // number of minors per major 41084>>>>> property integer pyMajorScale public GLS_Line // 41085>>>>> property integer pyMinorScale public GLS_Dot // 41086>>>>> property integer pyMinorDiv public 2 // number of minors per major 41087>>>>> property integer pMinorScaleColor public clGray // color (x and y) 41088>>>>> property integer pMajorScaleColor public clDkGray // color (x and y) 41089>>>>> 41089>>>>> // ******************************************************************** 41089>>>>> // *** Properties regarding scaling *** 41089>>>>> // ******************************************************************** 41089>>>>> 41089>>>>> property integer pxAutoScale public 0 // automatic auto scale (x)? 41090>>>>> property number pxMinValue public 0 // minimum value 41091>>>>> property number pxMaxValue public 100 // maximum value 41092>>>>> property integer pxZeroBased public 0 // is the scale zero based? 41093>>>>> property number pxAirPct public 0 // default: 0% air 41094>>>>> property integer pxMinSteps public 8 // lowest acceptable number of steps 41095>>>>> property integer pxMaxSteps public 11 // highest acceptable number of steps 41096>>>>> property number pxLowValue public 0 // lower value 41097>>>>> property integer pxSteps public 10 // number of steps 41098>>>>> property number pxStepSize public 10 // step size 41099>>>>> property integer pxDecimals public 0 // max number of decimals 41100>>>>> 41100>>>>> property integer pyAutoScale public 1 // automatic auto scale (y)? 41101>>>>> property number pyMinValue public 0 // minimum value 41102>>>>> property number pyMaxValue public 100 // maximum value 41103>>>>> property integer pyZeroBased public 1 // is the scale zero based? 41104>>>>> property number pyAirPct public 5 // default: 5% air 41105>>>>> property integer pyMinSteps public 8 // lowest acceptable number of steps 41106>>>>> property integer pyMaxSteps public 11 // highest acceptable number of steps 41107>>>>> property number pyLowValue public 0 // lower value 41108>>>>> property integer pySteps public 10 // number of steps 41109>>>>> property number pyStepSize public 10 // step size 41110>>>>> property integer pyDecimals public 0 // max number of decimals 41111>>>>> 41111>>>>> object AutoScaler is an cAutoScaler 41113>>>>> end_object 41114>>>>> 41114>>>>> property integer pBarChartState public 0 41115>>>>> property integer pxAutoAxisText public AT_AUTO 41116>>>>> property integer pyAutoAxisText public AT_AUTO 41117>>>>> 41117>>>>> property string pTitleX public "" 41118>>>>> property string pTitleY public "" 41119>>>>> 41119>>>>> object xyObjects is an array 41121>>>>> end_object 41122>>>>> 41122>>>>> object oAxisTexts is an array 41124>>>>> end_object 41125>>>>> 41125>>>>> property integer pxTextStockFont public ANSI_VAR_FONT 41126>>>>> property string pxTextTTFontName private "Arial" 41127>>>>> property integer pxTextTTFontSize public 14 41128>>>>> property integer pxTextTTFontAngle public 0 41129>>>>> property integer pxTextTTFontBold public 0 41130>>>>> property integer pxTextTTFontItalic public 0 41131>>>>> property integer pxTextColor public clBlack 41132>>>>> property integer pxTextAlign public 0 41133>>>>> property integer pxTextOffSet public 50 41134>>>>> property integer pyTextStockFont public ANSI_VAR_FONT 41135>>>>> property string pyTextTTFontName private "Arial" 41136>>>>> property integer pyTextTTFontSize public 14 41137>>>>> property integer pyTextTTFontAngle public 0 41138>>>>> property integer pyTextTTFontBold public 0 41139>>>>> property integer pyTextTTFontItalic public 0 41140>>>>> property integer pyTextColor public clBlack 41141>>>>> property integer pyTextAlign public 0 41142>>>>> property integer pyTextOffSet public 50 41143>>>>> end_procedure 41144>>>>> 41144>>>>> procedure set pxTextTTFontName string str# 41146>>>>> set !$.pxTextTTFontName to str# 41147>>>>> set pxTextStockFont to 0 41148>>>>> end_procedure 41149>>>>> function pxTextTTFontName returns string 41151>>>>> if (pxTextStockFont(self)) function_return 0 41154>>>>> function_return (!$.pxTextTTFontName(self)) 41155>>>>> end_function 41156>>>>> procedure set pyTextTTFontName string str# 41158>>>>> set !$.pyTextTTFontName to str# 41159>>>>> set pyTextStockFont to 0 41160>>>>> end_procedure 41161>>>>> function pyTextTTFontName returns string 41163>>>>> if (pyTextStockFont(self)) function_return 0 41166>>>>> function_return (!$.pyTextTTFontName(self)) 41167>>>>> end_function 41168>>>>> 41168>>>>> procedure set area_location integer x# integer y# 41170>>>>> set pxAreaLoc to x# 41171>>>>> set pyAreaLoc to y# 41172>>>>> end_procedure 41173>>>>> procedure set area_size integer x# integer y# 41175>>>>> set pxAreaSiz to x# 41176>>>>> set pyAreaSiz to y# 41177>>>>> end_procedure 41178>>>>> 41178>>>>> procedure ApplyGridStyle integer no# 41180>>>>> integer self# 41180>>>>> move self to self# 41181>>>>> send ApplyGridStyle to (oGridStyles(self)) no# self# 41182>>>>> end_procedure 41183>>>>> 41183>>>>> procedure Set AxisTextX integer column# string str# 41185>>>>> set pxAutoAxisText to AT_TEXT 41186>>>>> set value of (oAxisTexts(self)) item (column#*2) to str# 41187>>>>> end_procedure 41188>>>>> procedure Set AxisTextY integer column# string str# 41190>>>>> set pyAutoAxisText to AT_TEXT 41191>>>>> set value of (oAxisTexts(self)) item (column#*2+1) to str# 41192>>>>> end_procedure 41193>>>>> function AxisTextX integer column# returns string 41195>>>>> function_return (value(oAxisTexts(self),column#*2)) 41196>>>>> end_function 41197>>>>> function AxisTextY integer column# returns string 41199>>>>> function_return (value(oAxisTexts(self),column#*2+1)) 41200>>>>> end_function 41201>>>>> procedure DeleteAxisText 41203>>>>> send delete_data to (oAxisTexts(self)) 41204>>>>> end_procedure 41205>>>>> 41205>>>>> procedure register_xy_object integer obj# // cCoordinateSystem 41207>>>>> integer arr# 41207>>>>> move (xyObjects(self)) to arr# 41208>>>>> set value of arr# item (item_count(arr#)) to obj# 41209>>>>> end_procedure 41210>>>>> 41210>>>>> procedure end_construct_object 41212>>>>> integer self# 41212>>>>> move self to self# 41213>>>>> forward send end_construct_object 41215>>>>> delegate send register_xy_object self# 41217>>>>> end_procedure 41218>>>>> 41218>>>>> procedure DrawGraphFrame 41220>>>>> integer x1# y1# x2# y2# 41220>>>>> move (pxAreaLoc(self)) to x1# 41221>>>>> move (pyAreaLoc(self)) to y1# 41222>>>>> move (x1#+pxAreaSiz(self)) to x2# 41223>>>>> move (y1#+pyAreaSiz(self)) to y2# 41224>>>>> delegate send AddLineMvTo x1# y1# 41226>>>>> delegate send AddLineGoTo x1# y2# 41228>>>>> delegate send AddLineGoTo x2# y2# 41230>>>>> delegate send AddLineGoTo x2# y1# 41232>>>>> delegate send AddLineGoTo x1# y1# 41234>>>>> end_procedure 41235>>>>> 41235>>>>> 41235>>>>> procedure MakeAreaTrackable integer type# number x1# number y1# number x2# number y2# integer trackobjid# 41237>>>>> move x1# to gr$xConvValue 41238>>>>> move y1# to gr$yConvValue 41239>>>>> gosub vdfgraph$Convert 41240>>>>>> 41240>>>>> move gr$xConvValue to x1# 41241>>>>> move gr$yConvValue to y1# 41242>>>>> move x2# to gr$xConvValue 41243>>>>> move y2# to gr$yConvValue 41244>>>>> gosub vdfgraph$Convert 41245>>>>>> 41245>>>>> delegate send MakeAreaTrackable type# x1# y1# gr$xConvValue gr$yConvValue trackobjid# 41247>>>>> end_procedure 41248>>>>> procedure AddRectangleTrack number x1# number y1# number x2# number y2# integer cb_val# 41250>>>>> send AddRectangle x1# y1# x2# y2# 41251>>>>> send MakeAreaTrackable GR_TRACK_RECTANGLE x1# y1# x2# y2# cb_val# 41252>>>>> end_procedure 41253>>>>> procedure AddRectangle number x1# number y1# number x2# number y2# 41255>>>>> delegate_send$Coord2 AddRectangle 41265>>>>> end_procedure 41266>>>>> procedure AddEllipse number x1# number y1# number x2# number y2# 41268>>>>> delegate_send$Coord2 AddEllipse 41278>>>>> end_procedure 41279>>>>> procedure AddRoundRect number x1# number y1# number x2# number y2# 41281>>>>> delegate_send$Coord2 AddRoundRect 41291>>>>> end_procedure 41292>>>>> procedure AddLine number x1# number y1# number x2# number y2# 41294>>>>> graph$showln ("Line: "+string(x1#)+","+string(y1#)+" to "+string(x2#)+","+string(y2#)) 41294>>>>> delegate_send$Coord2 AddLine 41304>>>>> end_procedure 41305>>>>> procedure AddLineMvTo number x1# number y1# 41307>>>>> delegate_send$Coord1 AddLineMvTo 41312>>>>> end_procedure 41313>>>>> procedure AddLineGoTo number x1# number y1# 41315>>>>> delegate_send$Coord1 AddLineGoTo 41320>>>>> end_procedure 41321>>>>> procedure AddDot number x1# number y1# 41323>>>>> delegate_send$Coord1 AddDot 41328>>>>> end_procedure 41329>>>>> procedure AddText string str# integer x1# integer y1# 41331>>>>> move x1# to gr$xConvValue 41332>>>>> move y1# to gr$yConvValue 41333>>>>> gosub vdfgraph$Convert 41334>>>>>> 41334>>>>> delegate send AddText str# gr$xConvValue gr$yConvValue 41336>>>>> end_procedure 41337>>>>> procedure AddPolyPoint integer x1# integer y1# 41339>>>>> delegate_send$Coord1 AddPolyPoint 41344>>>>> end_procedure 41345>>>>> function nxHighValue returns number 41347>>>>> function_return (pxSteps(self)*pxStepSize(self)+pxLowValue(self)) 41348>>>>> end_function 41349>>>>> function nyHighValue returns number 41351>>>>> function_return (pySteps(self)*pyStepSize(self)+pyLowValue(self)) 41352>>>>> end_function 41353>>>>> function nxRange returns number 41355>>>>> function_return (pxSteps(self)*pxStepSize(self)) 41356>>>>> end_function 41357>>>>> function nyRange returns number 41359>>>>> function_return (pySteps(self)*pyStepSize(self)) 41360>>>>> end_function 41361>>>>> 41361>>>>> procedure InitConversionGlobals // This represents a change of coordinate system 41363>>>>> move (pxLowValue(self)) to gr$xLowValue 41364>>>>> move (pyStepSize(self)*pySteps(self)+pyLowValue(self)) to gr$yHiValue 41365>>>>> move (pyAreaSiz(self)/(pxSteps(self)*pxStepSize(self))) to gr$xFactor 41366>>>>> move (pxAreaSiz(self)/(pySteps(self)*pyStepSize(self))) to gr$yFactor 41367>>>>> move (pxAreaLoc(self)) to gr$xCoordMin 41368>>>>> move (pyAreaLoc(self)) to gr$yCoordMin 41369>>>>> graph$showln (string(gr$xLowValue)) 41369>>>>> graph$showln (string(gr$yHiValue)) 41369>>>>> graph$showln (string(gr$xFactor)) 41369>>>>> graph$showln (string(gr$yFactor)) 41369>>>>> graph$showln (string(gr$xCoordMin)) 41369>>>>> graph$showln (string(gr$yCoordMin)) 41369>>>>> end_procedure 41370>>>>> 41370>>>>> procedure BroadcastNotifyAutoScale 41372>>>>> integer arr# itm# max# obj# 41372>>>>> move (xyObjects(self)) to arr# 41373>>>>> get item_count of arr# to max# 41374>>>>> for itm# from 0 to (max#-1) 41380>>>>>> 41380>>>>> send NotifyAutoScale to (value(arr#,itm#)) 41381>>>>> loop 41382>>>>>> 41382>>>>> end_procedure 41383>>>>> 41383>>>>> procedure AutoScale 41385>>>>> integer obj# 41385>>>>> send BroadcastNotifyAutoScale 41386>>>>> move (AutoScaler(self)) to obj# 41387>>>>> if (pxAutoScale(self)) begin 41389>>>>> set pMinValue of obj# to (pxMinValue(self)) 41390>>>>> set pMaxValue of obj# to (pxMaxValue(self)) 41391>>>>> set pZeroBased of obj# to (pxZeroBased(self)) 41392>>>>> set pAirPct of obj# to (pxAirPct(self)) 41393>>>>> set pMinSteps of obj# to (pxMinSteps(self)) 41394>>>>> set pMaxSteps of obj# to (pxMaxSteps(self)) 41395>>>>> send AutoScale to obj# 41396>>>>> set pxLowValue to (pLowValue(obj#)) 41397>>>>> set pxStepSize to (pStepSize(obj#)) 41398>>>>> set pxSteps to (pSteps(obj#)) 41399>>>>> set pxDecimals to (pDecimals(obj#)) 41400>>>>> end 41400>>>>>> 41400>>>>> if (pyAutoScale(self)) begin 41402>>>>> set pMinValue of obj# to (pyMinValue(self)) 41403>>>>> set pMaxValue of obj# to (pyMaxValue(self)) 41404>>>>> set pZeroBased of obj# to (pyZeroBased(self)) 41405>>>>> set pAirPct of obj# to (pyAirPct(self)) 41406>>>>> set pMinSteps of obj# to (pyMinSteps(self)) 41407>>>>> set pMaxSteps of obj# to (pyMaxSteps(self)) 41408>>>>> send AutoScale to obj# 41409>>>>> set pyLowValue to (pLowValue(obj#)) 41410>>>>> set pyStepSize to (pStepSize(obj#)) 41411>>>>> set pySteps to (pSteps(obj#)) 41412>>>>> set pyDecimals to (pDecimals(obj#)) 41413>>>>> end 41413>>>>>> 41413>>>>> end_procedure 41414>>>>> procedure DrawGridLines 41416>>>>> integer MajorStep# MinorStep# 41416>>>>> integer MajorStepMax# MinorStepMax# 41416>>>>> integer MajorSteps# MinorSteps# 41416>>>>> number MajorLowValue# MinorLowValue# 41416>>>>> number MajorStepSize# MinorStepSize# 41416>>>>> number MaxValue# MinValue# 41416>>>>> 41416>>>>> send SetPenWidth 1 41417>>>>> 41417>>>>> if (pColor(self)<>-1) begin 41419>>>>> send SetFillColor (pColor(self)) 41420>>>>> send SetPenColor (pColor(self)) 41421>>>>> delegate send AddRectangle (pxAreaLoc(self)) (pyAreaLoc(self)) (pxAreaLoc(self)+pxAreaSiz(self)) (pyAreaLoc(self)+pyAreaSiz(self)) 41423>>>>> end 41423>>>>>> 41423>>>>> 41423>>>>> send SetPenColor (pMinorScaleColor(self)) 41424>>>>> // If minor grids, they must be drawn first: 41424>>>>> if (pxMinorScale(self)<>GLS_None) begin 41426>>>>> send SetPenStyle (pxMinorScale(self)) 41427>>>>> get pxSteps to MajorStepMax# 41428>>>>> get pxLowValue to MajorLowValue# 41429>>>>> get pxStepSize to MajorStepSize# 41430>>>>> get pxMinorDiv to MinorStepMax# 41431>>>>> move (MajorStepSize#/MinorStepMax#) to MinorStepSize# 41432>>>>> get pyLowValue to MinValue# 41433>>>>> get nyHighValue to MaxValue# 41434>>>>> for MajorStep# from 0 to (MajorStepMax#-1) 41440>>>>>> 41440>>>>> move (MajorStep#*MajorStepSize#+MajorLowValue#) to MinorLowValue# 41441>>>>> for MinorStep# from 1 to (MinorStepMax#-1) 41447>>>>>> 41447>>>>> send AddLine (MinorStep#*MinorStepSize#+MinorLowValue#) MinValue# (MinorStep#*MinorStepSize#+MinorLowValue#) MaxValue# 41448>>>>> loop 41449>>>>>> 41449>>>>> loop 41450>>>>>> 41450>>>>> end 41450>>>>>> 41450>>>>> if (pyMinorScale(self)<>GLS_None) begin 41452>>>>> send SetPenStyle (pyMinorScale(self)) 41453>>>>> get pySteps to MajorStepMax# 41454>>>>> get pyLowValue to MajorLowValue# 41455>>>>> get pyStepSize to MajorStepSize# 41456>>>>> get pyMinorDiv to MinorStepMax# 41457>>>>> move (MajorStepSize#/MinorStepMax#) to MinorStepSize# 41458>>>>> get pxLowValue to MinValue# 41459>>>>> get nxHighValue to MaxValue# 41460>>>>> for MajorStep# from 0 to (MajorStepMax#-1) 41466>>>>>> 41466>>>>> move (MajorStep#*MajorStepSize#+MajorLowValue#) to MinorLowValue# 41467>>>>> for MinorStep# from 1 to (MinorStepMax#-1) 41473>>>>>> 41473>>>>> send AddLine MinValue# (MinorStep#*MinorStepSize#+MinorLowValue#) MaxValue# (MinorStep#*MinorStepSize#+MinorLowValue#) 41474>>>>> loop 41475>>>>>> 41475>>>>> loop 41476>>>>>> 41476>>>>> end 41476>>>>>> 41476>>>>> 41476>>>>> // Then we draw the major grid lines: 41476>>>>> send SetPenColor (pMajorScaleColor(self)) 41477>>>>> if (pxMajorScale(self)<>GLS_None) begin 41479>>>>> get pxSteps to MajorStepMax# 41480>>>>> get pxLowValue to MajorLowValue# 41481>>>>> get pxStepSize to MajorStepSize# 41482>>>>> get pyLowValue to MinValue# 41483>>>>> get nyHighValue to MaxValue# 41484>>>>> 41484>>>>> if (pxMajorScale(self)) eq GLS_Base begin 41486>>>>> send SetPenStyle PS_Solid 41487>>>>> move 0 to MajorStepMax# 41488>>>>> end 41488>>>>>> 41488>>>>> else send SetPenStyle (pxMajorScale(self)) 41490>>>>> 41490>>>>> for MajorStep# from 0 to MajorStepMax# 41496>>>>>> 41496>>>>> send AddLine (MajorStep#*MajorStepSize#+MajorLowValue#) MinValue# (MajorStep#*MajorStepSize#+MajorLowValue#) MaxValue# 41497>>>>> loop 41498>>>>>> 41498>>>>> end 41498>>>>>> 41498>>>>> if (pyMajorScale(self)<>GLS_None) begin 41500>>>>> get pySteps to MajorStepMax# 41501>>>>> get pyLowValue to MajorLowValue# 41502>>>>> get pyStepSize to MajorStepSize# 41503>>>>> get pxLowValue to MinValue# 41504>>>>> get nxHighValue to MaxValue# 41505>>>>> 41505>>>>> if (pyMajorScale(self)) eq GLS_Base begin 41507>>>>> send SetPenStyle PS_Solid 41508>>>>> move 0 to MajorStepMax# 41509>>>>> end 41509>>>>>> 41509>>>>> else send SetPenStyle (pyMajorScale(self)) 41511>>>>> 41511>>>>> for MajorStep# from 0 to MajorStepMax# 41517>>>>>> 41517>>>>> send AddLine MinValue# (MajorStep#*MajorStepSize#+MajorLowValue#) MaxValue# (MajorStep#*MajorStepSize#+MajorLowValue#) 41518>>>>> loop 41519>>>>>> 41519>>>>> end 41519>>>>>> 41519>>>>> end_procedure 41520>>>>> 41520>>>>> procedure DrawAxisTextX integer stp# string str# 41522>>>>> delegate send AddText str# (pxAreaLoc(self)+pxAreaSiz(self)+pxTextOffSet(self)) (stp#+if(pBarChartState(self),0.5,0.0)*pyAreaSiz(self)/pxSteps(self)+pyAreaLoc(self)) 41524>>>>> end_procedure 41525>>>>> procedure DrawAxisTextY integer stp# string str# 41527>>>>> delegate send AddText str# (-stp#*pxAreaSiz(self)/pySteps(self)+pxAreaLoc(self)+pxAreaSiz(self)) (pyAreaLoc(self)-pyTextOffSet(self)) 41529>>>>> end_procedure 41530>>>>> 41530>>>>> procedure DrawAxisTextsSetupX 41532>>>>> integer angle# 41532>>>>> send SetTextColor (pxTextColor(self)) 41533>>>>> if (pxTextStockFont(self)) begin 41535>>>>> send SetStockFont (pxTextStockFont(self)) 41536>>>>> move 0 to angle# 41537>>>>> end 41537>>>>>> 41537>>>>> else begin 41538>>>>> get pxTextTTFontAngle to angle# 41539>>>>> send SetTTFont (pxTextTTFontName(self)) (pxTextTTFontSize(self)) angle# (pxTextTTFontBold(self)) (pxTextTTFontItalic(self)) 0 41540>>>>> end 41540>>>>>> 41540>>>>> if angle# eq 0 send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_TOP) 41543>>>>> else begin 41544>>>>> if angle# ge 1800 send SetTextAlign (VDFGR_TA_LEFT +VDFGR_TA_BOTTOM) 41547>>>>> else begin 41548>>>>> if angle# gt 900 send SetTextAlign (VDFGR_TA_RIGHT +VDFGR_TA_BOTTOM) 41551>>>>> else send SetTextAlign (VDFGR_TA_RIGHT +VDFGR_TA_TOP) 41553>>>>> end 41553>>>>>> 41553>>>>> end 41553>>>>>> 41553>>>>> end_procedure 41554>>>>> procedure DrawAxisTextsSetupY 41556>>>>> integer angle# 41556>>>>> send SetTextColor (pyTextColor(self)) 41557>>>>> if (pyTextStockFont(self)) begin 41559>>>>> send SetStockFont (pyTextStockFont(self)) 41560>>>>> move 0 to angle# 41561>>>>> end 41561>>>>>> 41561>>>>> else begin 41562>>>>> get pyTextTTFontAngle to angle# 41563>>>>> send SetTTFont (pyTextTTFontName(self)) (pyTextTTFontSize(self)) angle# (pyTextTTFontBold(self)) (pyTextTTFontItalic(self)) 0 41564>>>>> end 41564>>>>>> 41564>>>>> if angle# eq 0 send SetTextAlign (VDFGR_TA_RIGHT+VDFGR_TA_VCENTER) 41567>>>>> else begin 41568>>>>> if angle# ge 1800 send SetTextAlign (VDFGR_TA_LEFT+VDFGR_TA_VCENTER) 41571>>>>> else send SetTextAlign (VDFGR_TA_RIGHT +VDFGR_TA_TOP) 41573>>>>> end 41573>>>>>> 41573>>>>> end_procedure 41574>>>>> 41574>>>>> procedure DrawAxisTexts 41576>>>>> integer decs# stp# self# 41576>>>>> number ssz# low# max# 41576>>>>> string title# 41576>>>>> if (pxAutoAxisText(self)<>AT_NONE) begin 41578>>>>> send DrawAxisTextsSetupX 41579>>>>> get pxDecimals to decs# 41580>>>>> get pxSteps to max# 41581>>>>> if (pBarChartState(self)) decrement max# 41584>>>>> get pxStepSize to ssz# 41585>>>>> get pxLowValue to low# 41586>>>>> if (pxAutoAxisText(self)=AT_AUTO) begin 41588>>>>> for stp# from 0 to max# 41594>>>>>> 41594>>>>> send DrawAxisTextX stp# (NumToStr(stp#*ssz#+low#,decs#)) 41595>>>>> loop 41596>>>>>> 41596>>>>> end 41596>>>>>> 41596>>>>> else begin // AT_TEXT 41597>>>>> for stp# from 0 to max# 41603>>>>>> 41603>>>>> send DrawAxisTextX stp# (AxisTextX(self,stp#)) 41604>>>>> loop 41605>>>>>> 41605>>>>> end 41605>>>>>> 41605>>>>> end 41605>>>>>> 41605>>>>> if (pyAutoAxisText(self)<>AT_NONE) begin 41607>>>>> send DrawAxisTextsSetupY 41608>>>>> get pyDecimals to decs# 41609>>>>> get pySteps to max# 41610>>>>> get pyStepSize to ssz# 41611>>>>> get pyLowValue to low# 41612>>>>> if (pyAutoAxisText(self)=AT_AUTO) begin 41614>>>>> for stp# from 0 to max# 41620>>>>>> 41620>>>>> send DrawAxisTextY stp# (NumToStr(stp#*ssz#+low#,decs#)) 41621>>>>> loop 41622>>>>>> 41622>>>>> end 41622>>>>>> 41622>>>>> else begin 41623>>>>> for stp# from 0 to max# 41629>>>>>> 41629>>>>> send DrawAxisTextY stp# (AxisTextY(self,stp#)) 41630>>>>> loop 41631>>>>>> 41631>>>>> end 41631>>>>>> 41631>>>>> end 41631>>>>>> 41631>>>>> get pTitleX to title# 41632>>>>> if title# ne "" begin 41634>>>>> move self to self# 41635>>>>> send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_TOP) 41636>>>>> send SetTextColor clBlack 41637>>>>> send SetStockFont ANSI_VAR_FONT 41638>>>>>// send AddText title# (nxRange(self#)*0.01+nxHighValue(self#)) (pyLowValue(self#)) 41638>>>>> send AddText title# (nxHighValue(self#)-(nxRange(self#)/2.0)) (pyLowValue(self#)-(nyRange(self#)/10.0)) 41639>>>>> end 41639>>>>>> 41639>>>>> get pTitleY to title# 41640>>>>> if title# ne "" begin 41642>>>>> move self to self# 41643>>>>> send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_BOTTOM) 41644>>>>> send SetTextColor clBlack 41645>>>>> send SetStockFont ANSI_VAR_FONT 41646>>>>> send AddText title# (pxLowValue(self#)) (nyRange(self#)*0.05+nyHighValue(self#)) 41647>>>>>// send AddText title# (pxLowValue(self#)) (nyRange(self#)*0.12+nyHighValue(self#)) 41647>>>>> end 41647>>>>>> 41647>>>>> end_procedure 41648>>>>> procedure DrawGraph 41650>>>>> integer arr# itm# max# obj# 41650>>>>> move (xyObjects(self)) to arr# 41651>>>>> get item_count of arr# to max# 41652>>>>> for itm# from 0 to (max#-1) 41658>>>>>> 41658>>>>> send Draw_Data to (value(arr#,itm#)) 41659>>>>> loop 41660>>>>>> 41660>>>>> end_procedure 41661>>>>> procedure Draw_Data // cCoordinateSystem 41663>>>>> send AutoScale 41664>>>>> send InitConversionGlobals 41665>>>>> send DrawGridLines 41666>>>>> send DrawAxisTexts 41667>>>>> send DrawGraph 41668>>>>> end_procedure 41669>>>>>end_class // cCoordinateSystem 41670>>>>> 41670>>>>>class cBoxSignatures is a cArray 41671>>>>> procedure construct_object 41673>>>>> forward send construct_object 41675>>>>> property integer pDeltaRow public 900 41676>>>>> property integer pDeltaCol public 2000 41677>>>>> property integer pLocRow public 1800 41678>>>>> property integer pLocCol public 500 41679>>>>> property integer pBoxSizeR public 800 41680>>>>> property integer pBoxSizeC public 400 41681>>>>> property integer pMaxRow public 5 41682>>>>> property integer pFrameCol public clWhite 41683>>>>> property integer pBackCol public -1 // Transparent 41684>>>>> end_procedure 41685>>>>> item_property_list 41685>>>>> item_property string psLabel.i 41685>>>>> item_property integer piFrameColor.i 41685>>>>> item_property integer piBackColor.i 41685>>>>> item_property integer piHatchStyle.i 41685>>>>> item_property integer piHatchColor.i 41685>>>>> end_item_property_list cBoxSignatures #REM 41726 DEFINE FUNCTION PIHATCHCOLOR.I INTEGER LIROW RETURNS INTEGER #REM 41730 DEFINE PROCEDURE SET PIHATCHCOLOR.I INTEGER LIROW INTEGER VALUE #REM 41734 DEFINE FUNCTION PIHATCHSTYLE.I INTEGER LIROW RETURNS INTEGER #REM 41738 DEFINE PROCEDURE SET PIHATCHSTYLE.I INTEGER LIROW INTEGER VALUE #REM 41742 DEFINE FUNCTION PIBACKCOLOR.I INTEGER LIROW RETURNS INTEGER #REM 41746 DEFINE PROCEDURE SET PIBACKCOLOR.I INTEGER LIROW INTEGER VALUE #REM 41750 DEFINE FUNCTION PIFRAMECOLOR.I INTEGER LIROW RETURNS INTEGER #REM 41754 DEFINE PROCEDURE SET PIFRAMECOLOR.I INTEGER LIROW INTEGER VALUE #REM 41758 DEFINE FUNCTION PSLABEL.I INTEGER LIROW RETURNS STRING #REM 41762 DEFINE PROCEDURE SET PSLABEL.I INTEGER LIROW STRING VALUE 41767>>>>> procedure add_signature string str# integer color_frame# integer color_back# integer hatch# integer color_hatch# 41769>>>>> integer row# 41769>>>>> get row_count to row# 41770>>>>> set psLabel.i item row# to str# 41771>>>>> set piFrameColor.i item row# to color_frame# 41772>>>>> set piBackColor.i item row# to color_back# 41773>>>>> set piHatchStyle.i item row# to hatch# 41774>>>>> set piHatchColor.i item row# to color_hatch# 41775>>>>> end_procedure 41776>>>>> procedure draw_frame 41778>>>>> integer itm# max# row_offset# col_offset# rows# columns# 41778>>>>> integer x1# y1# x2# y2# 41778>>>>> move (row_count(self)) to max# 41779>>>>> 41779>>>>> move (max#/pMaxRow(self)+1) to columns# 41780>>>>> move (pMaxRow(self) min max#) to rows# 41781>>>>> move (pLocRow(self)) to x1# 41782>>>>> move (pLocCol(self)) to y1# 41783>>>>> move (rows#*pDeltaRow(self)+x1#) to x2# 41784>>>>> move (columns#*pDeltaCol(self)+y1#) to y2# 41785>>>>> if (pBackCol(self)<>-1) begin 41787>>>>> send SetFillColor (pBackCol(self)) 41788>>>>> send SetPenColor (pFrameCol(self)) 41789>>>>> send AddRectangle x1# y1# x2# y2# 41790>>>>> end 41790>>>>>> 41790>>>>> end_procedure 41791>>>>> procedure Draw_Data // cBoxSignatures 41793>>>>> integer row# max# row_offset# col_offset# 41793>>>>> integer x1# y1# x2# y2# base# LocRow# LocCol# 41793>>>>> integer DeltaRow# DeltaCol# BoxSizeR# BoxSizeC# MaxRow# 41793>>>>> integer color_frame# color_back# hatch# color_hatch# 41793>>>>> string str# 41793>>>>> 41793>>>>> send draw_frame 41794>>>>> 41794>>>>> get pDeltaRow to DeltaRow# 41795>>>>> get pDeltaCol to DeltaCol# 41796>>>>> get pBoxSizeR to BoxSizeR# 41797>>>>> get pBoxSizeC to BoxSizeC# 41798>>>>> get pMaxRow to MaxRow# 41799>>>>> get pLocRow to LocRow# 41800>>>>> get pLocCol to LocCol# 41801>>>>> 41801>>>>> get row_count to max# 41802>>>>> move 0 to row_offset# 41803>>>>> move 0 to col_offset# 41804>>>>> for row# from 0 to (max#-1) 41810>>>>>> 41810>>>>> if row_offset# ge MaxRow# begin 41812>>>>> move 0 to row_offset# 41813>>>>> increment col_offset# 41814>>>>> end 41814>>>>>> 41814>>>>> move (row_offset#*DeltaRow#+LocRow#) to x1# 41815>>>>> move (col_offset#*DeltaCol#+LocCol#) to y1# 41816>>>>> move (x1#+BoxSizeR#) to x2# 41817>>>>> move (y1#+BoxSizeC#) to y2# 41818>>>>> 41818>>>>> get psLabel.i item row# to str# 41819>>>>> if (str#<>"") begin 41821>>>>> get piFrameColor.i item row# to color_frame# 41822>>>>> get piBackColor.i item row# to color_back# 41823>>>>> get piHatchStyle.i item row# to hatch# 41824>>>>> get piHatchColor.i item row# to color_hatch# 41825>>>>> 41825>>>>> send SetFillColor color_back# 41826>>>>> if (color_frame#>-1) begin 41828>>>>> send SetPenColor color_frame# 41829>>>>> send AddRectangle x1# y1# x2# y2# 41830>>>>> end 41830>>>>>> 41830>>>>> send SetTextAlign (VDFGR_TA_LEFT+VDFGR_TA_TOP) 41831>>>>> send SetTextColor clBlack 41832>>>>> send SetStockFont ANSI_VAR_FONT 41833>>>>> send AddText str# x1# (y1#+BoxSizeC#+100) 41834>>>>> end 41834>>>>>> 41834>>>>> 41834>>>>> increment row_offset# 41835>>>>> loop 41836>>>>>> 41836>>>>> end_procedure 41837>>>>>end_class // cBoxSignatures 41838>>>>> 41838>>>>> 41838>>>>>// This class is designed to hold the data for a bar chart. Data may by 41838>>>>>// stored, recalled and summed using these messages: 41838>>>>>// 41838>>>>>// Procedure Sto_Data 41838>>>>>// Function nRcl_Data.iii 41838>>>>>// Procedure Sum_Data 41838>>>>>// 41838>>>>>class cBarChartData is an array 41839>>>>> procedure construct_object 41841>>>>> forward send construct_object 41843>>>>> set delegation_mode to delegate_to_parent 41844>>>>> property integer pStacks public 1 41845>>>>> property integer pSeries public 1 41846>>>>> 41846>>>>> property integer pMinColumnUsed public 0 41847>>>>> property integer pMaxColumnUsed public -1 41848>>>>> 41848>>>>> property number pMinY public 0 41849>>>>> property number pMaxY public 0 41850>>>>> 41850>>>>> object oSignatures is an array 41852>>>>> end_object 41853>>>>> property integer pSignatures_Object public 0 41854>>>>> end_procedure 41855>>>>> 41855>>>>> Function iData_Index.iii integer column# integer serie# integer stack# returns integer 41857>>>>> function_return (column#*pSeries(self)+serie#*pStacks(self)+stack#) 41858>>>>> End_Function 41859>>>>> 41859>>>>> Procedure UpdateColumnsUsed integer column# 41861>>>>> if column# gt (pMaxColumnUsed(self)) set pMaxColumnUsed to column# 41864>>>>> if column# lt (pMinColumnUsed(self)) set pMinColumnUsed to column# 41867>>>>> End_Procedure 41868>>>>> 41868>>>>> Procedure Sto_Data number value# integer column# integer serie# integer stack# 41870>>>>> set value item (iData_Index.iii(self,column#,serie#,stack#)) to value# 41871>>>>> send UpdateColumnsUsed column# 41872>>>>> End_Procedure 41873>>>>> Function nRcl_Data.iii integer column# integer serie# integer stack# returns number 41875>>>>> integer idx# 41875>>>>> get iData_Index.iii column# serie# stack# to idx# 41876>>>>> function_return (number_value(self,idx#)) 41877>>>>> End_Function 41878>>>>> Procedure Sum_Data number value# integer column# integer serie# integer stack# 41880>>>>> integer idx# 41880>>>>> get iData_Index.iii column# serie# stack# to idx# 41881>>>>> set value item idx# to (value#+number_value(self,idx#)) 41882>>>>> send UpdateColumnsUsed column# 41883>>>>> End_Procedure 41884>>>>> 41884>>>>> Function iColumns returns integer 41886>>>>> number rval# 41886>>>>> move (1.0*item_count(self)/(pSeries(self)*pStacks(self))) to rval# 41887>>>>> if rval# ne (integer(rval#)) move (rval#+1) to rval# 41890>>>>> function_return rval# 41891>>>>> End_Function 41892>>>>> 41892>>>>> Function nColumnSum integer column# integer serie# integer code# returns number 41894>>>>> integer stack# 41894>>>>> number rval# tmp# 41894>>>>> move 0 to rval# 41895>>>>> for stack# from 0 to (pStacks(self)-1) 41901>>>>>> 41901>>>>> move (nRcl_Data.iii(self,column#,serie#,stack#)) to tmp# 41902>>>>> // top: 41902>>>>> if code# eq 0 if tmp# ge 0 move (rval#+tmp#) to rval# 41907>>>>> // bottom: 41907>>>>> if code# eq 1 if tmp# le 0 move (rval#+tmp#) to rval# 41912>>>>> // top reduced with negative bottom: 41912>>>>> if code# eq 2 move (rval#+tmp#) to rval# 41915>>>>> loop 41916>>>>>> 41916>>>>> function_return rval# 41917>>>>> End_Function 41918>>>>> 41918>>>>> Procedure CalculateRange 41920>>>>> integer column# stack# serie# 41920>>>>> integer max_column# max_stack# max_serie# 41920>>>>> number min# max# tmp_neg# tmp_pos# value# 41920>>>>> get pStacks to max_stack# 41921>>>>> get pSeries to max_serie# 41922>>>>> get iColumns to max_column# 41923>>>>> move 0 to min# 41924>>>>> move 0 to max# 41925>>>>> for column# from 0 to (max_column#-1) 41931>>>>>> 41931>>>>> for serie# from 0 to (max_serie#-1) 41937>>>>>> 41937>>>>> move 0 to tmp_neg# 41938>>>>> move 0 to tmp_pos# 41939>>>>> for stack# from 0 to (max_stack#-1) 41945>>>>>> 41945>>>>> get nRcl_Data.iii column# serie# stack# to value# 41946>>>>> if value# ge 0 move (tmp_pos#+value#) to tmp_pos# 41949>>>>> else move (tmp_neg#+value#) to tmp_neg# 41951>>>>> loop 41952>>>>>> 41952>>>>> if tmp_pos# gt max# move tmp_pos# to max# 41955>>>>> if tmp_neg# lt min# move tmp_neg# to min# 41958>>>>> loop 41959>>>>>> 41959>>>>> loop 41960>>>>>> 41960>>>>> set pMinY to min# 41961>>>>> set pMaxY to max# 41962>>>>> End_Procedure 41963>>>>> 41963>>>>> Procedure Reset_Data 41965>>>>> send delete_data 41966>>>>> set pMinColumnUsed to 0 41967>>>>> set pMaxColumnUsed to -1 41968>>>>> set pMinY to 0 41969>>>>> set pMaxY to 0 41970>>>>> End_Procedure 41971>>>>> 41971>>>>> procedure Add_Serie_Signature integer serie# string str# 41973>>>>> set value of (oSignatures(self)) item (serie#*2+0) to str# 41974>>>>> end_procedure 41975>>>>> procedure Add_Stack_Signature integer stack# string str# 41977>>>>> set value of (oSignatures(self)) item (stack#*2+1) to str# 41978>>>>> end_procedure 41979>>>>> procedure Reset_Signatures 41981>>>>> send delete_data to (oSignatures(self)) 41982>>>>> end_procedure 41983>>>>>end_class // cBarChartData 41984>>>>> 41984>>>>>class cGraphData is an array 41985>>>>> procedure construct_object 41987>>>>> forward send construct_object 41989>>>>> set delegation_mode to delegate_to_parent 41990>>>>> property integer pIndexedData_State public 0 41991>>>>> end_procedure 41992>>>>>end_class 41993>>>>> 41993>>>>>// Coloring strategy for bar charts. 41993>>>>>// --------------------------------- 41993>>>>>// If there are 4 or less stacks and 8 or less series then stacks will be 41993>>>>>// nuance coded. Otherwise ugly hatches are used 41993>>>>> 41993>>>>>// Bar Chart Coloring Strategies 41993>>>>> 41993>>>>>class cBarChart is a cBarChartData 41994>>>>> procedure construct_object 41996>>>>> forward send construct_object 41998>>>>> set delegation_mode to delegate_to_parent 41999>>>>> property integer pAir public 10 // Percent air between columns 42000>>>>> property integer pBarFrameColor public clBlack // -1 => no frame 42001>>>>> property integer pxAutoScale public 1 42002>>>>> property integer pyAutoScale public 1 42003>>>>> property integer pHatchState public BC_HATCH_ON_STACKS 42004>>>>> property integer pColorState public BC_COLOR_ON_SERIES 42005>>>>> property integer pSmartColor_State public true 42006>>>>> property integer private.pSmartColor public true 42007>>>>> end_procedure 42008>>>>> 42008>>>>> procedure end_construct_object 42010>>>>> integer self# 42010>>>>> move self to self# 42011>>>>> forward send end_construct_object 42013>>>>> delegate send register_xy_object self# 42015>>>>> end_procedure 42016>>>>> 42016>>>>> procedure Transfer_Signature 42018>>>>> integer max_stack# max_serie# stack# serie# obj# 42018>>>>> get pSignatures_Object to obj# 42019>>>>> if obj# begin 42021>>>>> get pStacks to max_stack# 42022>>>>> get pSeries to max_serie# 42023>>>>> if max_serie# gt 1 begin 42025>>>>> for serie# from 0 to (max_serie#-1) 42031>>>>>> 42031>>>>>// send add_signature to obj# string str# integer color_frame# integer color_back# integer hatch# integer color_hatch# 42031>>>>> loop 42032>>>>>> 42032>>>>> end 42032>>>>>> 42032>>>>> if max_stack# gt 1 begin 42034>>>>> for stack# from 0 to (max_stack#-1) 42040>>>>>> 42040>>>>> loop 42041>>>>>> 42041>>>>> end 42041>>>>>> 42041>>>>> end 42041>>>>>> 42041>>>>> end_procedure 42042>>>>>//procedure add_signature string str# integer color_frame# integer color_back# integer hatch# integer color_hatch# 42042>>>>> 42042>>>>> procedure NotifyAutoScale 42044>>>>> if (pxAutoScale(self)) begin 42046>>>>> delegate set pxAutoScale to false 42048>>>>> set pxLowValue to 0 42049>>>>> set pxSteps to (iColumns(self)) 42050>>>>> set pxStepSize to 10 42051>>>>> set pBarChartState to true 42052>>>>> end 42052>>>>>> 42052>>>>> if (pyAutoScale(self)) begin 42054>>>>> send CalculateRange 42055>>>>> set pyMinValue to (pMinY(self)) 42056>>>>> set pyMaxValue to (pMaxY(self)) 42057>>>>> end 42057>>>>>> 42057>>>>> end_procedure 42058>>>>> 42058>>>>> function iColor.iii integer column# integer serie# integer stack# returns integer 42060>>>>> integer ColorState# 42060>>>>> if (private.pSmartColor(self)) function_return (iColorNuance.iii(self,serie#,stack#,pStacks(self)-1)) 42063>>>>> get pColorState to ColorState# 42064>>>>> if ColorState# ge 0 function_return ColorState# // Constant color 42067>>>>> if ColorState# eq BC_COLOR_ON_SERIES function_return (iColor(self,serie#)) 42070>>>>> if ColorState# eq BC_COLOR_ON_STACKS function_return (iColor(self,stack#)) 42073>>>>> end_function 42074>>>>> function iHatch.iii integer column# integer serie# integer stack# returns integer 42076>>>>> integer HatchState# 42076>>>>> if (private.pSmartColor(self)) function_return HS_NONE 42079>>>>> get pHatchState to HatchState# 42080>>>>> if HatchState# ge -1 function_return HatchState# // Constant hatch 42083>>>>> if HatchState# eq BC_HATCH_ON_SERIES function_return (iHatch(self,serie#)) 42086>>>>> if HatchState# eq BC_HATCH_ON_STACKS function_return (iHatch(self,stack#)) 42089>>>>> end_function 42090>>>>> 42090>>>>> function nColumnWidth returns number 42092>>>>> integer liColumns 42092>>>>> number lnRange 42092>>>>> get nxRange to lnRange // This will delegate to an object of class cCoordinateSystem 42093>>>>> get iColumns to liColumns 42094>>>>> function_return (lnRange/liColumns) 42095>>>>> end_function 42096>>>>> function nBarWidth returns number 42098>>>>> integer liAir liSeries 42098>>>>> number lnColumnWidth 42098>>>>> get pAir to liAir 42099>>>>> get pSeries to liSeries 42100>>>>> get nColumnWidth to lnColumnWidth 42101>>>>> move (lnColumnWidth*(100-liAir)/100) to lnColumnWidth 42102>>>>> function_return (lnColumnWidth/liSeries) 42103>>>>> end_function 42104>>>>> function nColumnOffsetX integer column# returns number 42106>>>>> number lnColumnWidth 42106>>>>> get nColumnWidth to lnColumnWidth 42107>>>>> function_return (lnColumnWidth*column#+pxLowValue(self)) 42108>>>>> end_function 42109>>>>> function nBarOffsetX integer column# integer serie# returns number 42111>>>>> number lnColumnOffsetX lnBarWidth 42111>>>>> get nColumnOffsetX column# to lnColumnOffsetX 42112>>>>> get nBarWidth to lnBarWidth 42113>>>>> move (pAir(self)*nColumnWidth(self)/200+lnColumnOffsetX) to lnColumnOffsetX 42114>>>>> function_return (serie#*lnBarWidth+lnColumnOffsetX) 42115>>>>> end_function 42116>>>>> 42116>>>>> // liWhere: 0=left 1=mid 2=right 42116>>>>> function nBarCoordX integer column# integer serie# integer liWhere returns number 42118>>>>> number lnX 42118>>>>> get nBarOffsetX column# serie# to lnX 42119>>>>> if (liWhere=1) move (nBarWidth(self)/2.0+lnX) to lnX // Mid 42122>>>>> if (liWhere=2) move (nBarWidth(self)+lnX) to lnX // Right 42125>>>>> function_return lnX 42126>>>>> end_function 42127>>>>> 42127>>>>> // liWhere: 0=Buttom 1=Mid 2=Top, liStack -1:upper stack -2=lower stack 42127>>>>> function nBarCoordY integer liColumn integer liSerie integer liStack integer liWhere returns number 42129>>>>> number lnNegativeSum lnPositiveSum lnValue 42129>>>>> integer liMaxStack liTestStack 42129>>>>> 42129>>>>> get pStacks to liMaxStack 42130>>>>> move 0 to lnNegativeSum 42131>>>>> move 0 to lnPositiveSum 42132>>>>> decrement liMaxStack 42133>>>>> for liTestStack from 0 to liMaxStack 42139>>>>>> 42139>>>>> get nRcl_Data.iii liColumn liSerie liTestStack to lnValue 42140>>>>> if lnValue ne 0 begin // Only if there is something to draw# 42142>>>>> if lnValue ge 0 begin 42144>>>>> if (liTestStack=liStack) begin 42146>>>>> if (liWhere=0) function_return lnPositiveSum 42149>>>>> if (liWhere=1) function_return (lnValue/2+lnPositiveSum) 42152>>>>> if (liWhere=2) function_return (lnPositiveSum+lnValue) 42155>>>>> end 42155>>>>>> 42155>>>>> move (lnPositiveSum+lnValue) to lnPositiveSum 42156>>>>> end 42156>>>>>> 42156>>>>> else begin 42157>>>>> if (liTestStack=liStack) begin 42159>>>>> if (liWhere=2) function_return lnNegativeSum 42162>>>>> if (liWhere=1) function_return (lnValue/2+lnNegativeSum) 42165>>>>> if (liWhere=0) function_return (lnNegativeSum+lnValue) 42168>>>>> end 42168>>>>>> 42168>>>>> move (lnNegativeSum+lnValue) to lnNegativeSum 42169>>>>> end 42169>>>>>> 42169>>>>> end 42169>>>>>> 42169>>>>> loop // liStack 42170>>>>>> 42170>>>>> if (liStack=-1) function_return lnPositiveSum 42173>>>>> if (liStack=-2) function_return lnNegativeSum 42176>>>>> function_return 0 42177>>>>> end_function 42178>>>>> 42178>>>>> procedure draw_bar integer column# integer serie# integer stack# number from# number to# 42180>>>>> integer self# hatch# BarFrameColor# color# 42180>>>>> number width# OffsetX# 42180>>>>> get nBarWidth to width# 42181>>>>> get nBarOffsetX column# serie# to OffsetX# 42182>>>>> move self to self# 42183>>>>> get iHatch.iii column# serie# stack# to hatch# 42184>>>>> get iColor.iii column# serie# stack# to color# 42185>>>>> get pBarFrameColor to BarFrameColor# 42186>>>>> if BarFrameColor# eq -1 send SetPenColor Color# 42189>>>>> else send SetPenColor BarFrameColor# 42191>>>>> if hatch# ne HS_NONE begin 42193>>>>> send SetHatchStyle HS_NONE 42194>>>>> send SetFillColor clWhite 42195>>>>> send AddRectangle OffsetX# from# (OffsetX#+width#) to# 42196>>>>> end 42196>>>>>> 42196>>>>> send SetHatchStyle hatch# 42197>>>>> send SetFillColor color# 42198>>>>> send AddRectangle OffsetX# from# (OffsetX#+width#) to# 42199>>>>> end_procedure 42200>>>>> 42200>>>>> procedure SetupColorScheme 42202>>>>> if (pSmartColor_State(self) and pStacks(self)<5 and pSeries(self)<9) set private.pSmartColor to true 42205>>>>> else set private.pSmartColor to false 42207>>>>> end_procedure 42208>>>>> 42208>>>>> procedure Draw_Data // cBarChart 42210>>>>> integer column# stack# serie# 42210>>>>> integer max_column# max_stack# max_serie# 42210>>>>> number min# max# tmp_neg# tmp_pos# value# 42210>>>>> 42210>>>>> send SetupColorScheme 42211>>>>> 42211>>>>> get pStacks to max_stack# 42212>>>>> get pSeries to max_serie# 42213>>>>> get iColumns to max_column# 42214>>>>> for column# from 0 to (max_column#-1) 42220>>>>>> 42220>>>>> for serie# from 0 to (max_serie#-1) 42226>>>>>> 42226>>>>> move 0 to tmp_neg# 42227>>>>> move 0 to tmp_pos# 42228>>>>> for stack# from 0 to (max_stack#-1) 42234>>>>>> 42234>>>>> get nRcl_Data.iii column# serie# stack# to value# 42235>>>>> if value# ne 0 begin // Only if there is something to draw# 42237>>>>> if value# ge 0 begin 42239>>>>> send draw_bar column# serie# stack# tmp_pos# (tmp_pos#+value#) 42240>>>>> move (tmp_pos#+value#) to tmp_pos# 42241>>>>> end 42241>>>>>> 42241>>>>> else begin 42242>>>>> send draw_bar column# serie# stack# tmp_neg# (tmp_neg#+value#) 42243>>>>> move (tmp_neg#+value#) to tmp_neg# 42244>>>>> end 42244>>>>>> 42244>>>>> end 42244>>>>>> 42244>>>>> loop // stack 42245>>>>>> 42245>>>>> // send end_draw_serie 42245>>>>> loop 42246>>>>>> 42246>>>>> // send end_draw_column 42246>>>>> loop 42247>>>>>> 42247>>>>> end_procedure 42248>>>>> 42248>>>>>//function private.Replace_Column_Del string str# string del# returns string 42248>>>>>// function_return (replaces(del#,str#,"")) 42248>>>>>//end_function 42248>>>>>// 42248>>>>>//procedure Export_To_SpreadSheet string Column_Del# string DecPoint# 42248>>>>>// integer column# serie# stack# max_stack# max_serie# max_column# 42248>>>>>// number temp_value# 42248>>>>>// string tmp_str# 42248>>>>>// get pStacks to max_stack# 42248>>>>>// get pSeries to max_serie# 42248>>>>>// get iColumns to max_column# 42248>>>>>// 42248>>>>>// writeln '"' (private.Replace_Column_Del(self,pTitle(self),Column_Del#)) '"' 42248>>>>>// 42248>>>>>// writeln 42248>>>>>// writeln '"' (private.Replace_Column_Del(self,"X: "+pTitleX(self),Column_Del#)) '"' 42248>>>>>// writeln '"' (private.Replace_Column_Del(self,"Y: "+pTitleY(self),Column_Del#)) '"' 42248>>>>>// writeln 42248>>>>>// 42248>>>>>// for stack# from 0 to (max_stack#-1) 42248>>>>>// writeln '"' (trim(private.Replace_Column_Del(self,(Rcl_Hst_Sign_Stack(self,stack#)),Column_Del#))) '"' 42248>>>>>// 42248>>>>>// write Column_Del# // an empty field 42248>>>>>// // For every series, write name of series: 42248>>>>>// if (sgn_ser#(self)) begin 42248>>>>>// for serie# from 0 to (max_serie#-1) 42248>>>>>// write '"' (trim(Replace_Column_Del(self,(Rcl_Hst_Sign_Serie(self,serie#)),Column_Del#))) '"' 42248>>>>>// if serie# ne (max_serie#-1) write Column_Del# 42248>>>>>// loop 42248>>>>>// end 42248>>>>>// writeln // new line 42248>>>>>// 42248>>>>>// for column# from 0 to (pxSteps(self)-1) 42248>>>>>// 42248>>>>>// //write column name: 42248>>>>>// move (AxisTextX(self,column#)) to tmp_str# 42248>>>>>// move (trim(string_value(self,(column#*4+1)))) to tmp_str# 42248>>>>>// write '"' (trim(private.Replace_Column_Del(self,tmp_str#,Column_Del#))) '"' Column_Del# 42248>>>>>// 42248>>>>>// //write data: 42248>>>>>// for serie# from 0 to (max_serie#-1) 42248>>>>>// move (Rcl_Hst_Data(self,column#,serie#,stack#)) to temp_value# 42248>>>>>// move (NumToStr(temp_value#,(y_val_dec(self)+1))) to tmp_str# 42248>>>>>// replace "." in tmp_str# with decpoint# 42248>>>>>// replace "," in tmp_str# with decpoint# 42248>>>>>// write (Replace_Column_Del(self,tmp_str#,Column_Del#)) 42248>>>>>// ifnot serie# eq (max_serie#-1) write Column_Del# 42248>>>>>// loop 42248>>>>>// writeln "" 42248>>>>>// loop 42248>>>>>// loop 42248>>>>>//end_procedure 42248>>>>>end_class // cBarChart 42249>>>>> 42249>>>>> 42249>>>>> 42249>>>>> 42249>>>>>number gr$viewer.x gr$viewer.y gr$viewer.z // location of viewer's eye 42249>>>>>number gr$plane.a gr$plane.b gr$plane.c gr$plane.d // plane = {(x,y,z) | ax+by+cz+d=0} 42249>>>>>number gr$return.x gr$return.y // return values 42249>>>>>number gr$origo_2d.x gr$origo_2d.y gr$origo_2d.z // 2d origo in the 3d system 42249>>>>>number gr$xaxis_2d.x gr$xaxis_2d.y gr$xaxis_2d.z // vector embedded in 2d x-axis of length 1 42249>>>>>number gr$yaxis_2d.x gr$yaxis_2d.y gr$yaxis_2d.z // vector embedded in 2d y-axis of length 1 42249>>>>> 42249>>>>>class GraphicArea3D is a GraphicArea 42250>>>>> procedure construct_object 42252>>>>> forward send construct_object 42254>>>>> property number pViewer.x public 30000 42255>>>>> property number pViewer.y public 30000 42256>>>>> property number pViewer.z public 30000 42257>>>>> property number pPlane.a public 1 42258>>>>> property number pPlane.b public 1 42259>>>>> property number pPlane.c public 1 42260>>>>> property number pPlane.d public -20000 42261>>>>> property number pOrigo_2d.x public 2000 42262>>>>> property number pOrigo_2d.y public 2000 42263>>>>> property number pOrigo_2d.z public 16000 42264>>>>> property number pXaxis_2d.x public 0.707106781 42265>>>>> property number pXaxis_2d.y public 0 42266>>>>> property number pXaxis_2d.z public -0.707106781 42267>>>>> property number pYaxis_2d.x public -0.408248291 42268>>>>> property number pYaxis_2d.y public 0.816496581 42269>>>>> property number pYaxis_2d.z public -0.408248291 42270>>>>> end_procedure 42271>>>>> procedure BeginDraw 42273>>>>> get pViewer.x to gr$Viewer.x 42274>>>>> get pViewer.y to gr$Viewer.y 42275>>>>> get pViewer.z to gr$Viewer.z 42276>>>>> get pPlane.a to gr$Plane.a 42277>>>>> get pPlane.b to gr$Plane.b 42278>>>>> get pPlane.c to gr$Plane.c 42279>>>>> get pPlane.d to gr$Plane.d 42280>>>>> get pOrigo_2d.x to gr$Origo_2d.x 42281>>>>> get pOrigo_2d.y to gr$Origo_2d.y 42282>>>>> get pOrigo_2d.z to gr$Origo_2d.z 42283>>>>> get pXaxis_2d.x to gr$Xaxis_2d.x 42284>>>>> get pXaxis_2d.y to gr$Xaxis_2d.y 42285>>>>> get pXaxis_2d.z to gr$Xaxis_2d.z 42286>>>>> get pYaxis_2d.x to gr$Yaxis_2d.x 42287>>>>> get pYaxis_2d.y to gr$Yaxis_2d.y 42288>>>>> get pYaxis_2d.z to gr$Yaxis_2d.z 42289>>>>> forward send BeginDraw 42291>>>>> end_procedure 42292>>>>> procedure Convert3d_XYZ number px number py number pz 42294>>>>> number line.p line.q line.r line.t 42294>>>>> number intersec.x intersec.y intersec.z 42294>>>>> number q_minus_r0.x q_minus_r0.y q_minus_r0.z q_minus_r0.len 42294>>>>> number helpvar 42294>>>>> 42294>>>>> // line between point and eye: (x,y,z) = (px,py,pz) + t(p,q,r) 42294>>>>> 42294>>>>> move (gr$viewer.x-px) to line.p 42295>>>>> move (gr$viewer.y-py) to line.q 42296>>>>> move (gr$viewer.z-pz) to line.r 42297>>>>> 42297>>>>> move (-((gr$plane.a*px) + (gr$plane.b*py) + (gr$plane.c*pz) + gr$plane.d)) to line.t 42298>>>>> move (line.t/((gr$plane.a*line.p) + (gr$plane.b*line.q) + (gr$plane.c*line.r))) to line.t 42299>>>>> 42299>>>>> // Intersection: 42299>>>>> 42299>>>>> move (line.t*line.p+px) to intersec.x 42300>>>>> move (line.t*line.q+py) to intersec.y 42301>>>>> move (line.t*line.r+pz) to intersec.z 42302>>>>> 42302>>>>> // calculate distance gr$return.x to x-akse in the plane 42302>>>>> 42302>>>>> // As vector we use xaxis_2d 42302>>>>> // Vector q is (intersec.x,intersec.y,intersec.z) 42302>>>>> // As vector r0 (point on the line) we use origo_2d 42302>>>>> 42302>>>>> move (intersec.x-gr$origo_2d.x) to q_minus_r0.x 42303>>>>> move (intersec.y-gr$origo_2d.y) to q_minus_r0.y 42304>>>>> move (intersec.z-gr$origo_2d.z) to q_minus_r0.z 42305>>>>> move ((q_minus_r0.x*q_minus_r0.x)+(q_minus_r0.y*q_minus_r0.y)+(q_minus_r0.z*q_minus_r0.z)) to q_minus_r0.len 42306>>>>> //  Note: It is in fact the squared length we have calculated! 42306>>>>> move ((q_minus_r0.x*gr$xaxis_2d.x)+(q_minus_r0.y*gr$xaxis_2d.y)+(q_minus_r0.z*gr$xaxis_2d.z)) to helpvar 42307>>>>> move (((sqrt(q_minus_r0.len-(helpvar*helpvar)))/2.0)+0.5) to gr$return.x 42308>>>>> move ((q_minus_r0.x*gr$yaxis_2d.x)+(q_minus_r0.y*gr$yaxis_2d.y)+(q_minus_r0.z*gr$yaxis_2d.z)) to helpvar 42309>>>>> move (((sqrt(q_minus_r0.len-(helpvar*helpvar)))/2.0)+0.5) to gr$return.y 42310>>>>> end_procedure 42311>>>>> 42311>>>>> procedure Add3dLine ; integer x1# integer x2# integer x3# ; integer y1# integer y2# integer y3# 42313>>>>> send Convert3d_XYZ x1# x2# x3# 42314>>>>> send AddLineMvTo gr$return.x gr$return.y 42315>>>>> send Convert3d_XYZ y1# y2# y3# 42316>>>>> send AddLineGoTo gr$return.x gr$return.y 42317>>>>> end_procedure 42318>>>>> 42318>>>>> procedure Add3dPlane ; integer x1# integer y1# integer z1# ; integer x2# integer y2# integer z2# ; integer x3# integer y3# integer z3# ; integer x4# integer y4# integer z4# 42320>>>>> send Convert3d_XYZ x1# y1# z1# 42321>>>>> move gr$return.x to x1# 42322>>>>> move gr$return.y to y1# 42323>>>>> send Convert3d_XYZ x2# y2# z2# 42324>>>>> move gr$return.x to x2# 42325>>>>> move gr$return.y to y2# 42326>>>>> send Convert3d_XYZ x3# y3# z3# 42327>>>>> move gr$return.x to x3# 42328>>>>> move gr$return.y to y3# 42329>>>>> send Convert3d_XYZ x4# y4# z4# 42330>>>>> move gr$return.x to x4# 42331>>>>> move gr$return.y to y4# 42332>>>>> send Add4Angle x1# y1# x2# y2# x3# y3# x4# y4# 42333>>>>>// showln x1# "," y1# " " x2# "," y2# " " x3# "," y3# " " x4# "," y4# 42333>>>>> end_procedure 42334>>>>> 42334>>>>> procedure Add3dBox ; integer x1# integer y1# integer z1# ; integer x2# integer y2# integer z2# 42336>>>>> send Add3dPlane x1# y1# z2# x1# y2# z2# x2# y2# z2# x2# y1# z2# 42337>>>>> send Add3dPlane x2# y1# z2# x2# y2# z2# x2# y2# z1# x2# y1# z1# 42338>>>>> send Add3dPlane x1# y2# z1# x2# y2# z1# x2# y2# z2# x1# y2# z2# 42339>>>>> end_procedure 42340>>>>>end_class // GraphicArea3D 42341>>>>> 42341>>>Use AppInfo.utl // Setup application information Including file: appinfo.utl (C:\Apps\VDFQuery\AppSrc\appinfo.utl) 42341>>>>>// Use AppInfo.utl // Setup application information 42341>>>>> 42341>>>>>enumeration_list 42341>>>>> define AI_TITLE // Application title 42341>>>>> define AI_SUBTITLE // Application sub-title 42341>>>>> define AI_SUBTITLE2 // Application sub-title 2 42341>>>>> define AI_VERSION // Version 42341>>>>> define AI_REVISION // Revision 42341>>>>> define AI_AUTHOR // Author or Company 42341>>>>> define AI_WATERMARK // Set to "Beta" or "Demo" (May be used for splashes) 42341>>>>> define AI_RELEASEDATE // 42341>>>>> define AI_LOG_IMAGE // 42341>>>>> define AI_KNOWN_ISSUES // 42341>>>>> define TMP_GA_OBJECTID // Used internally by the packages to hold an object id 42341>>>>> define AI_CONTACT1 42341>>>>> define AI_CONTACT2 42341>>>>> define AI_CONTACT3 42341>>>>>end_enumeration_list 42341>>>>> 42341>>>>>object oApplicationInfo is an Array no_image 42343>>>>>end_object 42344>>>>>procedure set AppInfo global integer type# string value# 42346>>>>> set value of (oApplicationInfo(self)) item type# to value# 42347>>>>>end_procedure 42348>>>>>function AppInfo global integer type# returns string 42350>>>>> function_return (value(oApplicationInfo(self),type#)) 42351>>>>>end_function 42352>>>>> 42352>>> 42352>>>class cSplashGraphicArea is a GraphicArea 42353>>> procedure construct_object integer img# 42355>>> forward send construct_object img# 42357>>> set location to 0 0 42358>>> set size to 200 300 42359>>> end_procedure 42360>>> procedure Draw_AppInfo_Item integer itm# 42362>>> integer color# 42362>>> string str# 42362>>> get AppInfo itm# to str# 42363>>> if str# ne "" begin 42365>>> if itm# eq AI_TITLE begin 42367>>> send SetTTFont "Arial" 80 0 1 1 0 42368>>> send SetTextColor clBlack 42369>>> send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_VCENTER) 42370>>> send AddText str# 2500 5000 42371>>> end 42371>>>> 42371>>> if itm# eq AI_SUBTITLE begin 42373>>> send SetTTFont "Arial" 50 0 1 1 0 42374>>> send SetTextColor clBlack 42375>>> send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_VCENTER) 42376>>> send AddText "for" 5000 5000 42377>>> send AddText str# 7500 5000 42378>>> end 42378>>>> 42378>>> if itm# eq AI_SUBTITLE2 begin 42380>>> send SetTTFont "Arial" 12 0 1 0 0 42381>>> send SetTextColor clWhite 42382>>> send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_VCENTER) 42383>>> send AddText str# 8700 5000 42384>>> end 42384>>>> 42384>>> if itm# eq AI_VERSION begin 42386>>> send SetTTFont "Arial" 12 0 1 0 0 42387>>> send SetTextColor clWhite 42388>>> send SetTextAlign (VDFGR_TA_LEFT+VDFGR_TA_BOTTOM) 42389>>> send AddText ("Version "+str#) 9500 500 42390>>> end 42390>>>> 42390>>> if itm# eq AI_REVISION begin 42392>>> end 42392>>>> 42392>>> if itm# eq AI_AUTHOR begin 42394>>> send SetTextAlign (VDFGR_TA_RIGHT+VDFGR_TA_BOTTOM) 42395>>> send SetTextColor clWhite 42396>>> send AddText str# 9500 9500 42397>>> end 42397>>>> 42397>>> if itm# eq AI_WATERMARK begin 42399>>> get iWaterMarkColor to color# 42400>>> send SetTTFont "Arial" 180 0 1 1 0 42401>>> send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_VCENTER) 42402>>> send SetTextColor color# 42403>>> send AddText str# 5000 5000 42404>>> end 42404>>>> 42404>>> if itm# eq AI_RELEASEDATE begin 42406>>> end 42406>>>> 42406>>> end 42406>>>> 42406>>> end_procedure 42407>>> procedure Draw_BackGround.i integer color# 42409>>> integer count# 42409>>> send SetPenStyle PS_NULL 42410>>> send SetPenWidth 0 42411>>> for count# from 0 to 39 42417>>>> 42417>>> send SetFillColor color# 42418>>> send SetPenColor color# 42419>>> send AddRectangle (count#*250) 0 (count#+1*250+100) 10000 42420>>> move (RGB_Darken(color#,2)) to color# // Darken by 2 percent 42421>>> loop 42422>>>> 42422>>> end_procedure 42423>>> procedure Draw_Data 42425>>> integer color# 42425>>> forward send draw_data 42427>>> get iRandomBackColor to color# 42428>>> delegate send Draw_BackGround.i color# 42430>>> send Draw_AppInfo_Item AI_WATERMARK 42431>>> send Draw_AppInfo_Item AI_TITLE 42432>>> send Draw_AppInfo_Item AI_SUBTITLE 42433>>> send Draw_AppInfo_Item AI_SUBTITLE2 42434>>> send Draw_AppInfo_Item AI_VERSION 42435>>> send Draw_AppInfo_Item AI_REVISION 42436>>> send Draw_AppInfo_Item AI_AUTHOR 42437>>> send Draw_AppInfo_Item AI_RELEASEDATE 42438>>> end_procedure 42439>>> procedure end_construct_object 42441>>> integer ram# 42441>>> forward send end_construct_object 42443>>> get piProgram_RAM to ram# 42444>>> set AppInfo TMP_GA_OBJECTID to (piProgram_RAM(self)) 42445>>> end_procedure 42446>>>end_class // cSplashGraphicArea 42447>>> 42447>>>class cGraphicSplash is a ToolPanel 42448>>> procedure construct_object integer img# 42450>>> forward send construct_object img# 42452>>> set Size to 200 300 42453>>> set Caption_Bar to false 42454>>> set Border_Style to BORDER_DIALOG 42455>>> property integer piBackColor public 0 42456>>> object oGA is a cSplashGraphicArea 42458>>> set location to 0 0 42459>>> set size to 200 300 42460>>> end_object 42461>>> end_procedure 42462>>> procedure Draw_BackGround.i integer color# 42464>>> send Draw_BackGround.i to (oGA(self)) color# 42465>>> end_procedure 42466>>> function iRandomBackColor returns integer 42468>>> integer rval# 42468>>> sysdate rval# rval# rval# rval# 42472>>> move (mod(rval#,5)) to rval# 42473>>> if rval# eq 0 move clRed to rval# 42476>>> if rval# eq 1 move clGreen to rval# 42479>>> if rval# eq 2 move clBlue to rval# 42482>>> if rval# eq 3 move clYellow to rval# 42485>>> if rval# eq 4 move clWhite to rval# 42488>>> set piBackColor to rval# 42489>>> function_return rval# 42490>>> end_function 42491>>> function iWaterMarkColor returns integer 42493>>> function_return (RGB_Brighten(piBackColor(self),2)) 42494>>> end_function 42495>>> procedure activate 42497>>> send Draw_Data to (oGA(self)) 42498>>> forward send activate 42500>>> end_procedure 42501>>>end_class // cGraphicSplash 42502>>> 42502>>> 42502>>>//object oGraphicSplash is a ToolPanel 42502>>>// set size to 200 300 42502>>>// set caption_bar to false 42502>>>// set Border_Style to BORDER_DIALOG 42502>>>// object oGA is a GraphicArea 42502>>>// set location to 0 0 42502>>>// set size to 200 300 42502>>>// procedure draw_data 42502>>>// integer count# color# 42502>>>// integer watermark_color# 42502>>>// forward send draw_data 42502>>>// // This command will land the seconds in the color# variable: 42502>>>// sysdate color# color# color# color# 42502>>>// move (mod(color#,5)) to color# 42502>>>// if color# eq 0 move clRed to color# 42502>>>// if color# eq 1 move clGreen to color# 42502>>>// if color# eq 2 move clBlue to color# 42502>>>// if color# eq 3 move clYellow to color# 42502>>>// if color# eq 4 move clWhite to color# 42502>>>// move (RGB_Brighten(color#,2)) to watermark_color# 42502>>>// send SetPenStyle PS_NULL 42502>>>// send SetPenWidth 0 42502>>>// for count# from 0 to 39 42502>>>// send SetFillColor color# 42502>>>// send SetPenColor color# 42502>>>// send AddRectangle (count#*250) 0 (count#+1*250+100) 10000 42502>>>// move (RGB_Darken(color#,2)) to color# // Darken by 2 percent 42502>>>// loop 42502>>>// send SetTTFont "Courier New" 12 0 0 0 0 42502>>>// send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_VCENTER) 42502>>>// send SetTextColor watermark_color# 42502>>>// send AddText "8213 9921 9050 3853 0023 8127 8213 9921 9050 3853 4580 0893 0599" 500 5000 42502>>>// send AddText "7401 7049 2039 5072 0892 3823 7401 7049 2039 5072 3059 0293 2570" 1000 5000 42502>>>// send AddText "2798 1359 2159 5023 4050 2348 2798 1359 2159 5023 5324 8090 9313" 1500 5000 42502>>>// send AddText "9934 6897 7567 5712 4312 9593 9921 6897 7567 5712 0827 9862 4668" 2000 5000 42502>>>// send AddText "8230 0109 4197 0704 0912 0230 8230 0109 4197 0704 0214 9273 4901" 2500 5000 42502>>>// send AddText "3908 9028 2308 0928 3592 5097 3908 9028 2308 0928 0984 9820 8090" 3000 5000 42502>>>// send AddText "7401 7049 2039 5072 0892 3823 7401 7049 2039 5072 3059 0293 2570" 3500 5000 42502>>>// send AddText "2397 0197 4972 3975 7250 9273 2397 0197 4972 3975 7213 5970 9301" 4000 5000 42502>>>// send AddText "8490 8323 8509 8309 2350 7239 8490 8323 8509 8309 4098 0980 5983" 4500 5000 42502>>>// send AddText "3068 3040 0994 9740 0490 1290 3068 3040 0994 9740 0470 1409 7330" 5000 5000 42502>>>// send AddText "4568 7875 7657 2708 2095 3099 4568 7875 7657 2708 7398 2346 3178" 5500 5000 42502>>>// send AddText "2798 1359 2159 5023 4050 2348 2798 1359 2159 5023 5324 8090 9313" 6000 5000 42502>>>// send AddText "4568 7875 7657 2708 2095 3099 4568 7875 7657 2708 7398 2346 3178" 6500 5000 42502>>>// send AddText "3068 3040 0994 9740 0490 1290 3068 3040 0994 9740 0470 1409 7330" 7000 5000 42502>>>// send AddText "8490 8323 8509 8309 2350 7239 8490 8323 8509 8309 4098 0980 5983" 7500 5000 42502>>>// send AddText "2397 0197 4972 3975 7250 9273 2397 0197 4972 3975 7213 5970 9301" 8000 5000 42502>>>// send AddText "7401 7049 2039 5072 0892 3823 7401 7049 2039 5072 3059 0293 2570" 8500 5000 42502>>>// send AddText "3908 9028 2308 0928 3592 5097 3908 9028 2308 0928 0984 9820 8090" 9000 5000 42502>>>// send AddText "8230 0109 4197 0704 0912 0230 8230 0109 4197 0704 0214 9273 4901" 9500 5000 42502>>>// send AddText "9934 6897 7567 5712 4312 9593 9921 6897 7567 5712 0827 9862 4668" 10000 5000 42502>>>// 42502>>>// send SetTTFont "Arial" 180 0 1 1 0 42502>>>// send SetTextAlign (VDFGR_TA_CENTER+VDFGR_TA_VCENTER) 42502>>>// send SetTextColor watermark_color# 42502>>>// send AddText (AppInfo(AI_WATERMARK)) 5000 5000 42502>>>// send SetTTFont "Arial" 80 0 1 1 0 42502>>>// send SetTextColor clBlack 42502>>>// send AddText (AppInfo(AI_TITLE)) 2500 5000 42502>>>// send SetTTFont "Arial" 50 0 1 1 0 42502>>>// send AddText "for" 5000 5000 42502>>>// send AddText (AppInfo(AI_SUBTITLE)) 7500 5000 42502>>>// send SetTTFont "Arial" 12 0 1 0 0 42502>>>// send SetTextAlign (VDFGR_TA_LEFT+VDFGR_TA_BOTTOM) 42502>>>// send AddText (AppInfo(AI_VERSION)) 9500 500 42502>>>// send SetTextAlign (VDFGR_TA_RIGHT+VDFGR_TA_BOTTOM) 42502>>>// send SetTextColor clWhite 42502>>>// send AddText (AppInfo(AI_AUTHOR)) 9500 9500 42502>>>// end_procedure 42502>>>// end_object 42502>>>// procedure activate 42502>>>// send draw_data to (oGA(self)) 42502>>>// forward send activate 42502>>>// end_procedure 42502>>>//end_object 42502>>> 42502>>>// procedure Splash_On global 42502>>>// send activate to (oGraphicSplash(self)) 42502>>>// end_procedure 42502>>>// procedure Splash_Off global 42502>>>// send deactivate to (oGraphicSplash(self)) 42502>>>// end_procedure 42502>Use About.utl // About dialog Including file: about.utl (C:\Apps\VDFQuery\AppSrc\about.utl) 42502>>>// Use About.utl 42502>>> 42502>>>Use AppInfo.utl // Setup application information 42502>>>Use Buttons.utl // Button texts Including file: buttons.utl (C:\Apps\VDFQuery\AppSrc\buttons.utl) 42502>>>>>// Use Buttons.utl // Button texts 42502>>>>>Use Language Including file: language.pkg (C:\Apps\VDFQuery\AppSrc\language.pkg) 42502>>>>>>>// Use Language // Default language setup 42502>>>>>>>// Sets default languange 42502>>>>>>> 42502>>>>>>>Use LangSymb.pkg // Language symbols 42502>>>>>>> 42502>>>>>>> 42502>>>>>>> define _LANGUAGE_ for $ENGLISH$ 42502>>>>>>> #REM LANGUAGE SET BY LANGUAGE.PKG: $ENGLISH$ 42502>>>>>>> 42502>>>>>>> 42502>>>>>>>integer giLanguage 42502>>>>>>>move LNG_DEFAULT to giLanguage 42503>>>>>>> 42503>>>>>>>class cLanguageValues is an Array NO_IMAGE 42504>>>>>>> procedure set language_value integer liLanguage integer liConst string lsValue 42506>>>>>>> set value item (liLanguage*LNG_MAX+liConst) to lsValue 42507>>>>>>> end_procedure 42508>>>>>>> function language_value integer liConst returns string 42510>>>>>>> string lsValue 42510>>>>>>> get value item (giLanguage*LNG_MAX+liConst) to lsValue 42511>>>>>>> if (lsValue="") function_return (value(self,LNG_DEFAULT*LNG_MAX+liConst)) 42514>>>>>>> function_return lsValue 42515>>>>>>> end_function 42516>>>>>>> function language_coded_value integer liConst returns string 42518>>>>>>> function_return ("LV."+string(liConst)) 42519>>>>>>> end_function 42520>>>>>>> function language_decoded_value string lsValue returns string 42522>>>>>>> if (left(lsValue,3)="LV.") begin 42524>>>>>>> move (replace("LV.",lsValue,"")) to lsValue 42525>>>>>>> get language_value (integer(lsValue)) to lsValue 42526>>>>>>> end 42526>>>>>>>> 42526>>>>>>> function_return lsValue 42527>>>>>>> end_function 42528>>>>>>>end_class 42529>>>>> 42529>>>>> define t.btn.apply for "Apply" // LNG_ENGLISH 42529>>>>> define t.btn.help for "Help" // LNG_ENGLISH 42529>>>>> define t.btn.ok for "OK" // LNG_ENGLISH 42529>>>>> define t.btn.continue for "Continue" // LNG_ENGLISH 42529>>>>> define t.btn.cancel for "Cancel" // LNG_ENGLISH 42529>>>>> define t.btn.prompt for "Prompt" // LNG_ENGLISH 42529>>>>> define t.btn.create for "Create" // LNG_ENGLISH 42529>>>>> define t.btn.save for "Save" // LNG_ENGLISH 42529>>>>> define t.btn.delete for "Delete" // LNG_ENGLISH 42529>>>>> define t.btn.clear for "Clear" // LNG_ENGLISH 42529>>>>> define t.btn.exit for "Exit" // LNG_ENGLISH 42529>>>>> define t.btn.zoom for "Zoom" // LNG_ENGLISH 42529>>>>> define t.btn.close for "Close" // LNG_ENGLISH 42529>>>>> define t.btn.print for "Print" // LNG_ENGLISH 42529>>>>> define t.btn.reset for "Reset" // LNG_ENGLISH 42529>>>>> define t.btn.reset_all for "Reset all" // LNG_ENGLISH 42529>>>>> define t.btn.redraw for "Redraw" // LNG_ENGLISH 42529>>>>> define t.btn.remove for "Remove" // LNG_ENGLISH 42529>>>>> define t.btn.change for "Change" // LNG_ENGLISH 42529>>>>> define t.btn.insert for "Insert" // LNG_ENGLISH 42529>>>>> define t.btn.append for "Append" // LNG_ENGLISH 42529>>>>> define t.btn.restart for "Re-start" // LNG_ENGLISH 42529>>>>> define t.btn.display for "Display" // LNG_ENGLISH 42529>>>>> define t.btn.add for "Add" // LNG_ENGLISH 42529>>>>> define t.btn.edit for "Edit" // LNG_ENGLISH 42529>>>>> define t.btn.open for "Open" // LNG_ENGLISH 42529>>>>> define t.btn.properties for "Properties" // LNG_ENGLISH 42529>>>>> define t.btn.refresh for "Refresh" // LNG_ENGLISH 42529>>>>> define t.btn.select for "Select" // LNG_ENGLISH 42529>>>>> define t.btn.yes for "Yes" // LNG_ENGLISH 42529>>>>> define t.btn.no for "No" // LNG_ENGLISH 42529>>>>> define t.btn.move_up for "Move up" // LNG_ENGLISH 42529>>>>> define t.btn.move_down for "Move down" // LNG_ENGLISH 42529>>>>> define t.key.return for "Return" // LNG_ENGLISH 42529>>>>> define t.key.esc for "Esc" // LNG_ENGLISH 42529>>>>> 42529>>>Use Spec0007.utl // Display modal text (DoDisplayText) Including file: spec0007.utl (C:\Apps\VDFQuery\AppSrc\spec0007.utl) 42529>>>>>// Use Spec0007.utl // Display modal text (DoDisplayText) 42529>>>>> 42529>>>>>Use Strings.utl // String manipulation for VDF Including file: strings.utl (C:\Apps\VDFQuery\AppSrc\strings.utl) 42529>>>>>>>// Use Strings.utl // String manipulation for VDF 42529>>>>>>>// 42529>>>>>>>// NOTE that the bigger part of this package has been moved to STRINGS.NUI 42529>>>>>>>// 42529>>>>>>>Use Strings.nui // String manipulation for VDF (Non User Interface) 42529>>>>>>> 42529>>>>>>>function Text_EditObjectValue global integer lhEdit returns string 42531>>>>>>> integer liMax liItm liMargin liFormatSize lbActive 42531>>>>>>> string lsRval lsLine 42531>>>>>>> get active_state of lhEdit to lbActive // In windows Edit objects behave 42532>>>>>>> if lbActive begin // differently when they are 42534>>>>>>> get format_size of lhEdit to liFormatSize // active. If active we have to 42535>>>>>>> set format_size of lhEdit to 32000 32000 // do some mysterious stuff to 42536>>>>>>> set dynamic_update_state of lhEdit to true // get the correct value from it. 42537>>>>>>> end // Tsk tsk. 42537>>>>>>>> 42537>>>>>>> get line_count of lhEdit to liMax 42538>>>>>>> move "" to lsRval 42539>>>>>>> for liItm from 0 to (liMax-1) 42545>>>>>>>> 42545>>>>>>> get value of lhEdit item liItm to lsLine 42546>>>>>>> move (replaces(character(10),lsLine,"")) to lsLine 42547>>>>>>> move (replaces(character(13),lsLine,"")) to lsLine 42548>>>>>>> move (lsRval+lsLine) to lsRval 42549>>>>>>> if liItm ne (liMax-1) move (lsRval+character(10)) to lsRval 42552>>>>>>> loop 42553>>>>>>>> 42553>>>>>>> if lbActive begin // Tsk tsk... 42555>>>>>>> set format_size of lhEdit to (hi(liFormatSize)) (low(liFormatSize)) 42556>>>>>>> set dynamic_update_state of lhEdit to DFTRUE 42557>>>>>>> end 42557>>>>>>>> 42557>>>>>>> function_return lsRval 42558>>>>>>>end_function 42559>>>>>>> 42559>>>>>>>procedure Text_SetEditObjectValue global integer lhEdit string lsValue 42561>>>>>>> integer liLen liPos liMargin liItm 42561>>>>>>> string lsLine lsChar lsTen 42561>>>>>>> send delete_data to lhEdit 42562>>>>>>> move (character(10)) to lsTen 42563>>>>>>> move 0 to liItm 42564>>>>>>> move "" to lsLine 42565>>>>>>> move (length(lsValue)) to liLen 42566>>>>>>> for liPos from 1 to liLen 42572>>>>>>>> 42572>>>>>>> move (mid(lsValue,1,liPos)) to lsChar 42573>>>>>>> if lsChar eq lsTen begin 42575>>>>>>> set value of lhEdit item liItm to lsLine 42576>>>>>>> increment liItm 42577>>>>>>> move "" to lsLine 42578>>>>>>> end 42578>>>>>>>> 42578>>>>>>> else move (lsLine+lsChar) to lsLine 42580>>>>>>> loop 42581>>>>>>>> 42581>>>>>>> if lsLine ne "" set value of lhEdit item liItm to lsLine 42584>>>>>>>end_procedure 42585>>>>>>> 42585>>>>>>> 42585>>>>> 42585>>>>>Use APS // Auto Positioning and Sizing classes for VDF 42585>>>>>Use Buttons.utl // Button texts 42585>>>>>object oDisplayText is a aps.ModalPanel 42587>>>>> set locate_mode to CENTER_ON_SCREEN 42588>>>>> on_key kcancel send close_panel 42589>>>>> object oEdt is a aps.Edit 42591>>>>> set size to 170 250 42592>>>>> set TypeFace to "Courier New" 42593>>>>> //set FontWeight to 900 42593>>>>> set object_shadow_state to true 42594>>>>> set border_style to BORDER_NONE 42595>>>>> end_object 42596>>>>> object oBtn is a aps.Multi_Button 42598>>>>> on_item t.btn.close send close_panel 42599>>>>> end_object 42600>>>>> send aps_locate_multi_buttons 42601>>>>> set Border_Style to BORDER_THICK // Make panel resizeable 42602>>>>> set pMinimumSize to 0 75 42603>>>>> procedure aps_onResize integer delta_rw# integer delta_cl# 42606>>>>> send aps_resize (oEdt(self)) delta_rw# delta_cl# 42607>>>>> send aps_register_multi_button (oBtn(self)) 42608>>>>> send aps_locate_multi_buttons 42609>>>>> send aps_auto_size_container 42610>>>>> end_procedure 42611>>>>> procedure display.ss string title# string text# 42614>>>>> set label to title# 42615>>>>> send Text_SetEditObjectValue (oEdt(self)) text# 42616>>>>> send popup 42617>>>>> end_procedure 42618>>>>>end_object // oDisplayText 42619>>>>> 42619>>>>>object oDisplayTextAskQuestion is a aps.ModalPanel 42621>>>>> set locate_mode to CENTER_ON_SCREEN 42622>>>>> on_key kcancel send close_panel 42623>>>>> on_key kSave_Record send close_panel_ok 42624>>>>> property integer pbResult public 0 42626>>>>> procedure close_panel_ok 42629>>>>> set pbResult to DFTRUE 42630>>>>> send close_panel 42631>>>>> end_procedure 42632>>>>> object oEdt is a aps.Edit 42634>>>>> set size to 170 250 42635>>>>> set TypeFace to "Courier New" 42636>>>>> //set FontWeight to 900 42636>>>>> set object_shadow_state to true 42637>>>>> set border_style to BORDER_NONE 42638>>>>> end_object 42639>>>>> object oBtn1 is a aps.Multi_Button 42641>>>>> on_item t.btn.ok send close_panel_ok 42642>>>>> end_object 42643>>>>> object oBtn2 is a aps.Multi_Button 42645>>>>> on_item t.btn.cancel send close_panel 42646>>>>> end_object 42647>>>>> send aps_locate_multi_buttons 42648>>>>> set Border_Style to BORDER_THICK // Make panel resizeable 42649>>>>> set pMinimumSize to 0 75 42650>>>>> procedure aps_onResize integer delta_rw# integer delta_cl# 42653>>>>> send aps_resize (oEdt(self)) delta_rw# delta_cl# 42654>>>>> send aps_register_multi_button (oBtn1(self)) 42655>>>>> send aps_register_multi_button (oBtn2(self)) 42656>>>>> send aps_locate_multi_buttons 42657>>>>> send aps_auto_size_container 42658>>>>> end_procedure 42659>>>>> function iDisplay.ss string title# string text# returns integer 42662>>>>> set label to title# 42663>>>>> send Text_SetEditObjectValue (oEdt(self)) text# 42664>>>>> set pbResult to DFFALSE 42665>>>>> send popup 42666>>>>> function_return (pbResult(self)) 42667>>>>> end_function 42668>>>>>end_object // oDisplayTextAskQuestion 42669>>>>> 42669>>>>>procedure DoDisplayText global string title# string text# 42671>>>>> send display.ss to (oDisplayText(self)) title# text# 42672>>>>>end_procedure 42673>>>>> 42673>>>>>desktop_section 42678>>>>> object oDoDisplayTextLines is a cArray NO_IMAGE 42680>>>>> function sCombinedValue returns string 42683>>>>> integer liMax liItem 42683>>>>> string lsRval lsChar10 42683>>>>> move "" to lsRval 42684>>>>> move (character(10)) to lsChar10 42685>>>>> get item_count to liMax 42686>>>>> decrement liMax 42687>>>>> for liItem from 0 to liMax 42693>>>>>> 42693>>>>> move (lsRval+value(self,liItem)) to lsRval 42694>>>>> if (liItem<>liMax) move (lsRval+lsChar10) to lsRval 42697>>>>> loop 42698>>>>>> 42698>>>>> function_return lsRval 42699>>>>> end_function 42700>>>>> end_object 42701>>>>>end_desktop_section 42706>>>>> 42706>>>>>function DoDisplayTextConfirm global string title# string text# returns integer 42708>>>>> if (text#="") get sCombinedValue of (oDoDisplayTextLines(self)) to text# 42711>>>>> function_return (iDisplay.ss(oDisplayTextAskQuestion(self),title#,text#)) 42712>>>>>end_function 42713>>>>> 42713>>>>>procedure DoDisplayTextConfirm_Reset global 42715>>>>> send delete_data to (oDoDisplayTextLines(self)) 42716>>>>>end_procedure 42717>>>>>procedure DoDisplayTextConfirm_AddLine global string lsLine 42719>>>>> set value of (oDoDisplayTextLines(self)) item (item_count(oDoDisplayTextLines(self))) to lsLine 42720>>>>>end_procedure 42721>>>Use Spec0012.utl // Read image to string (sTextDfFromImage function) Including file: spec0012.utl (C:\Apps\VDFQuery\AppSrc\spec0012.utl) 42721>>>>>// Use Spec0012.utl // Read image to string (sTextDfFromImage function) 42721>>>>> 42721>>>>>Use Files.nui // Utilities for handling file related stuff Including file: files.nui (C:\Apps\VDFQuery\AppSrc\files.nui) 42721>>>>>>>// Use Files.nui // Utilities for handling file related stuff (No User Interface) 42721>>>>>>> 42721>>>>>>>// Sat 06-09-2003 - From 9.1 direct_input/direct_output and 42721>>>>>>>// append_output performs OEM to versions. 42721>>>>>>>// This is now reflected in the code (search _91_) 42721>>>>>>>// Wed 10-09-2003 - Added procedure SEQ_ReadRecordBufferToArray_LD 42721>>>>>>>// - Added function SEQ_InputChannelLineCount (and taken out again) 42721>>>>>>>// Mon 12-01-2004 - Function SEQ_CurrentFolder added 42721>>>>>>>// Thu 15-01-2004 - Procedure SEQ_CallBack_ItemsInDir no longer loads [.] and [..] items 42721>>>>>>>// - Function SEQ_NumberFiles now takes a parameter. 42721>>>>>>>// Sat 15-02-2004 - A long time Oem/ANSI issue with respect to filenames in DIRECT_INPUT/ 42721>>>>>>>// DIRECT_OUTPUT commands, that was apparently fixed in 9.1 beta, was 42721>>>>>>>// un-fixed in the final 9.1 release. Therefore the original fix to the 42721>>>>>>>// problem has been re-introduced (look for _91_) 42721>>>>>>>// Mon 01-03-2004 - Function SEQ_FindFileAlongPath has been fixed to let it handle 42721>>>>>>>// UNC pathing. 42721>>>>>>> 42721>>>>>>>// More exotic file functions may be found in the following packages: 42721>>>>>>>// 42721>>>>>>>// Use files01.nui // SEQ_DoChannelPositionsToLineCount - stuff 42721>>>>>>>// 42721>>>>>>> 42721>>>>>>>Use Seq_Chnl // Defines global sequential device management operations (DAW) 42721>>>>>>>Use Strings.nui // String manipulation for VDF 42721>>>>>>>Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes 42721>>>>>>>Use Dates.nui // Date routines Including file: dates.nui (C:\Apps\VDFQuery\AppSrc\dates.nui) 42721>>>>>>>>>// Use Dates.nui // Date routines (No User Interface) 42721>>>>>>>>> 42721>>>>>>>>>// The functions and procedures of this packages may be used with WebApp, VDF 7 or higher and DF3.2 or higher 42721>>>>>>>>> 42721>>>>>>>>>// Update: Tue 02-10-2001 - Fixed Module_Compile_Date function for VDF7 42721>>>>>>>>>// Mon 21-02-2002 - Error in 2 digit year datecompose fixed (Jan Morgils) 42721>>>>>>>>>// Fri 24-02-2002 - New function DateIsValid 42721>>>>>>>>>// Thu 14-11-2002 - Function DateDistance added 42721>>>>>>>>>// Fri 13-02-2004 - Procedure MilliSeconds_Wait added 42721>>>>>>>>>// Mon 01-08-2005 - Added #DN2 code to DateAsText function (Pieter van Dieren) 42721>>>>>>>>> 42721>>>>>>>>>Use ui 42721>>>>>>>>>Use Language // Set default languange if not set by compiler command line 42721>>>>>>>>>Use Seq_Chnl // Defines global sequential device management operations (DAW) 42721>>>>>>>>>Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface) 42721>>>>>>>>>Use Strings.nui // String manipulation for VDF (No User Interface) 42721>>>>>>>>>Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface) Including file: errorhnd.nui (C:\Apps\VDFQuery\AppSrc\errorhnd.nui) 42721>>>>>>>>>>>// Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface) 42721>>>>>>>>>>>Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes 42721>>>>>>>>>>> 42721>>>>>>>>>>>use dfError 42721>>>>>>>>>>>define ErrorHnd$NES for 1 // NES = New Error System 42721>>>>>>>>>>> 42721>>>>>>>>>>>use Version.nui 42721>>>>>>>>>>> 42721>>>>>>>>>>>class cErrorHandlerRedirector is a cArray 42722>>>>>>>>>>> procedure construct_object integer liImg 42724>>>>>>>>>>> forward send construct_object liImg 42726>>>>>>>>>>> property integer phPreviousErrorHandler public -1 42727>>>>>>>>>>> property integer error_processing_state public DFFALSE 42728>>>>>>>>>>> // These properties are used internally to enable forwarding of 42728>>>>>>>>>>> // errors to the previous error handler. 42728>>>>>>>>>>> property integer piError public 0 42729>>>>>>>>>>> property integer piErrorLine public 0 42730>>>>>>>>>>> property string psErrMsg public "" 42731>>>>>>>>>>> end_procedure 42732>>>>>>>>>>> 42732>>>>>>>>>>> item_property_list 42732>>>>>>>>>>> item_property integer piError.i 42732>>>>>>>>>>> item_property string psErrorText.i 42732>>>>>>>>>>> item_property integer piErrorLine.i 42732>>>>>>>>>>> end_item_property_list cErrorHandlerRedirector #REM 42767 DEFINE FUNCTION PIERRORLINE.I INTEGER LIROW RETURNS INTEGER #REM 42771 DEFINE PROCEDURE SET PIERRORLINE.I INTEGER LIROW INTEGER VALUE #REM 42775 DEFINE FUNCTION PSERRORTEXT.I INTEGER LIROW RETURNS STRING #REM 42779 DEFINE PROCEDURE SET PSERRORTEXT.I INTEGER LIROW STRING VALUE #REM 42783 DEFINE FUNCTION PIERROR.I INTEGER LIROW RETURNS INTEGER #REM 42787 DEFINE PROCEDURE SET PIERROR.I INTEGER LIROW INTEGER VALUE 42792>>>>>>>>>>> 42792>>>>>>>>>>> procedure Forward_Error_Report 42794>>>>>>>>>>> integer lhPreviousErrorHandler 42794>>>>>>>>>>> get phPreviousErrorHandler to lhPreviousErrorHandler 42795>>>>>>>>>>> if (lhPreviousErrorHandler<>-1) send error_report to lhPreviousErrorHandler (piError(self)) (piErrorLine(self)) (psErrMsg(self)) 42798>>>>>>>>>>> end_procedure 42799>>>>>>>>>>> 42799>>>>>>>>>>> procedure OnError integer liError string lsErrorText integer liErrorLine 42801>>>>>>>>>>> integer liRow 42801>>>>>>>>>>> get row_count to liRow 42802>>>>>>>>>>> set piError.i liRow to liError 42803>>>>>>>>>>> set psErrorText.i liRow to lsErrorText 42804>>>>>>>>>>> set piErrorLine.i liRow to liErrorLine 42805>>>>>>>>>>> end_procedure 42806>>>>>>>>>>> 42806>>>>>>>>>>> procedure DoReset 42808>>>>>>>>>>> send delete_data 42809>>>>>>>>>>> end_procedure 42810>>>>>>>>>>> 42810>>>>>>>>>>> procedure DoActivate 42812>>>>>>>>>>> send delete_data 42813>>>>>>>>>>> if (phPreviousErrorHandler(self)=-1) begin 42815>>>>>>>>>>> set phPreviousErrorHandler to Error_Object_Id 42816>>>>>>>>>>> move self to Error_Object_Id 42817>>>>>>>>>>> end 42817>>>>>>>>>>>> 42817>>>>>>>>>>> end_procedure 42818>>>>>>>>>>> procedure DoDeactivate 42820>>>>>>>>>>> if (phPreviousErrorHandler(self)<>-1) begin 42822>>>>>>>>>>> get phPreviousErrorHandler to Error_Object_Id 42823>>>>>>>>>>> set phPreviousErrorHandler to -1 42824>>>>>>>>>>> end 42824>>>>>>>>>>>> 42824>>>>>>>>>>> end_procedure 42825>>>>>>>>>>> //#IFDEF msg_Extended_Error_Message // New error system 42825>>>>>>>>>>> procedure Error_Report integer liError integer liErrorLine string lsErrMsg 42827>>>>>>>>>>> string lsErrorText 42827>>>>>>>>>>> integer lhObj 42827>>>>>>>>>>> if (error_processing_state(self)) procedure_return // this prevents recursion 42830>>>>>>>>>>> set error_processing_state to DFTRUE 42831>>>>>>>>>>> 42831>>>>>>>>>>> set piError to liError 42832>>>>>>>>>>> set piErrorLine to liErrorLine 42833>>>>>>>>>>> set psErrMsg to lsErrMsg 42834>>>>>>>>>>> 42834>>>>>>>>>>> get phPreviousErrorHandler to lhObj 42835>>>>>>>>>>> 42835>>>>>>>>>>> move (Error_Description(lhObj,liError,lsErrMsg)) to lsErrorText 42836>>>>>>>>>>> send OnError liError lsErrorText liErrorLine 42837>>>>>>>>>>> set error_processing_state to DFFALSE 42838>>>>>>>>>>> end_procedure 42839>>>>>>>>>>>end_class // cErrorHandlerRedirector 42840>>>>>>>>>>> 42840>>>>>>>>>>>desktop_section 42845>>>>>>>>>>> object oErrorHandlerQuiet is a cErrorHandlerRedirector NO_IMAGE 42847>>>>>>>>>>> end_object 42848>>>>>>>>>>>end_desktop_section 42853>>>>>>>>>>> 42853>>>>>>>>>>>procedure ErrorHnd_Quiet_Activate global 42855>>>>>>>>>>> send DoActivate to (oErrorHandlerQuiet(self)) 42856>>>>>>>>>>>end_procedure 42857>>>>>>>>>>>procedure ErrorHnd_Quiet_Deactivate global 42859>>>>>>>>>>> send DoDeactivate to (oErrorHandlerQuiet(self)) 42860>>>>>>>>>>>end_procedure 42861>>>>>>>>>>>function ErrorHnd_Quiet_ErrorCount global returns integer 42863>>>>>>>>>>> function_return (row_count(oErrorHandlerQuiet(self))) 42864>>>>>>>>>>>end_function 42865>>>>>>>>>>> 42865>>>>>>>>>>>// This commmand is only for use after "open"ing a table that 42865>>>>>>>>>>>// has all the listed fields as columns. Unfortunately, this 42865>>>>>>>>>>>// package does not include the means of making use of that. 42865>>>>>>>>>>> 42865>>>>>>>>> 42865>>>>>>>>>// Pske sndag: Forrsjvndgn -> Fuldmne -> Sndag 42865>>>>>>>>> 42865>>>>>>>>> define t.calendar.year for "Year" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.month for "Month" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.day for "Day" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.week for "Wk." // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.calendar_popup for "Calendar Popup" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Monday for "Monday" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Tuesday for "Tuesday" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Wednesday for "Wednesday" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Thursday for "Thursday" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Friday for "Friday" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Saturday for "Saturday" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Sunday for "Sunday" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.January for "January" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.February for "February" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.March for "March" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.April for "April" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.May for "May" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.June for "June" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.July for "July" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.August for "August" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.September for "September" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.October for "October" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.November for "November" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.December for "December" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.ok for "OK" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Cancel for "Cancel" // LNG_ENGLISH 42865>>>>>>>>> define t.calendar.Activate for "Activate popup calendar (Ctrl+D)" // LNG_ENGLISH 42865>>>>>>>>> 42865>>>>>>>>>define LargestPossibleDate for 913490 // December 31st 2500 42865>>>>>>>>>define Jan1st1900 for 693975 42865>>>>>>>>>define Jan1st2000 for 730500 42865>>>>>>>>>define Jan1st1930 for 704933 42865>>>>>>>>>define Jan1st1000 for 365250 42865>>>>>>>>>define Jan1st105 for 38352 42865>>>>>>>>>define Jan1st100 for 36525 42865>>>>>>>>> 42865>>>>>>>>>enumeration_list // Date Segments 42865>>>>>>>>> define DS_DAY 42865>>>>>>>>> define DS_WEEK 42865>>>>>>>>> define DS_MONTH 42865>>>>>>>>> define DS_YEAR 42865>>>>>>>>> define DS_QUARTER 42865>>>>>>>>>end_enumeration_list 42865>>>>>>>>> 42865>>>>>>>>>integer Dates$Year Dates$Month Dates$Day // internal use 42865>>>>>>>>> 42865>>>>>>>>>procedure DateDecompose global date ldDate //very internal!! 42867>>>>>>>>> integer liPos1 liPos2 liFormat 42867>>>>>>>>> string lsValue lsSep 42867>>>>>>>>> move (date(ldDate)) to ldDate 42868>>>>>>>>> get_attribute DF_DATE_FORMAT to liFormat 42871>>>>>>>>> get_attribute DF_DATE_SEPARATOR to liPos1 // overload 42874>>>>>>>>> character liPos1 to lsSep // end overload 42875>>>>>>>>>> 42875>>>>>>>>> move ldDate to lsValue 42876>>>>>>>>> replace lsSep in lsValue with "$" 42878>>>>>>>>> move strmark to liPos1 42879>>>>>>>>> if [found] begin 42881>>>>>>>>> replace lsSep in lsValue with "$" 42883>>>>>>>>> move strmark to liPos2 42884>>>>>>>>> end 42884>>>>>>>>>> 42884>>>>>>>>> else begin 42885>>>>>>>>> move 0 to Dates$Year 42886>>>>>>>>> move 0 to Dates$Month 42887>>>>>>>>> move 0 to Dates$Day 42888>>>>>>>>> end 42888>>>>>>>>>> 42888>>>>>>>>> [ found] begin 42890>>>>>>>>>> 42890>>>>>>>>> if liFormat eq DF_DATE_EUROPEAN ; left lsValue to Dates$Day (liPos1-1) 42894>>>>>>>>> if liFormat eq DF_DATE_USA begin 42896>>>>>>>>> mid lsValue to Dates$Day (liPos2-liPos1-1) (liPos1+1) 42899>>>>>>>>>> 42899>>>>>>>>> left lsValue to Dates$Month (liPos1-1) 42901>>>>>>>>>> 42901>>>>>>>>> end 42901>>>>>>>>>> 42901>>>>>>>>> else mid lsValue to Dates$Month (liPos2-liPos1-1) (liPos1+1) 42905>>>>>>>>> 42905>>>>>>>>> if liFormat eq DF_DATE_MILITARY begin 42907>>>>>>>>> mid lsValue to Dates$Day 2 (liPos2+1) 42910>>>>>>>>>> 42910>>>>>>>>> left lsValue to Dates$Year (liPos1-1) 42912>>>>>>>>>> 42912>>>>>>>>> end 42912>>>>>>>>>> 42912>>>>>>>>> else mid lsValue to Dates$Year 4 (liPos2+1) 42916>>>>>>>>> end 42916>>>>>>>>>> 42916>>>>>>>>> //showln "" 42916>>>>>>>>> //showln (string(date#)+": "+string(Dates$Day)+","+string(Dates$Month)+","+string(Dates$Year)) 42916>>>>>>>>>end_procedure 42917>>>>>>>>> 42917>>>>>>>>>function DateCompose global integer liDay integer liMonth integer liYear returns date 42919>>>>>>>>> integer liFormat 42919>>>>>>>>> date ldDate 42919>>>>>>>>> string lsSep 42919>>>>>>>>> ifnot (liDay*liMonth) function_return 0 42922>>>>>>>>>// ifnot (liDay*liMonth*liYear) function_return 0 42922>>>>>>>>> get_attribute DF_DATE_SEPARATOR to liFormat // overload 42925>>>>>>>>> character liFormat to lsSep // end overload 42926>>>>>>>>>> 42926>>>>>>>>> get_attribute DF_DATE_FORMAT to liFormat 42929>>>>>>>>> if liDay gt 28 begin 42931>>>>>>>>> if liFormat eq DF_DATE_EUROPEAN move (date(string(liDay)+lsSep+string(liMonth)+lsSep+string(liYear))) to ldDate // DMY 42934>>>>>>>>> if liFormat eq DF_DATE_USA move (date(string(liMonth)+lsSep+string(liDay)+lsSep+string(liYear))) to ldDate // MDY 42937>>>>>>>>> if liFormat eq DF_DATE_MILITARY move (date(string(liYear)+lsSep+string(liMonth)+lsSep+string(liDay))) to ldDate // YMD 42940>>>>>>>>> send DateDecompose ldDate 42941>>>>>>>>> if Dates$Month ne liMonth move (liDay-Dates$Day) to liDay 42944>>>>>>>>> end 42944>>>>>>>>>> 42944>>>>>>>>> if liFormat eq DF_DATE_EUROPEAN function_return (date(string(liDay)+lsSep+string(liMonth)+lsSep+string(liYear))) // DMY 42947>>>>>>>>> if liFormat eq DF_DATE_USA function_return (date(string(liMonth)+lsSep+string(liDay)+lsSep+string(liYear))) // MDY 42950>>>>>>>>> function_return (date(string(liYear)+lsSep+string(liMonth)+lsSep+string(liDay))) // YMD 42951>>>>>>>>>end_function 42952>>>>>>>>> 42952>>>>>>>>>function DateIsLegalComponents global integer liDay integer liMonth integer liYear returns integer 42954>>>>>>>>> date ldDate 42954>>>>>>>>> get Year2to4 liYear to liYear 42955>>>>>>>>> if liDay gt 31 function_return DFFALSE 42958>>>>>>>>> if liMonth gt 12 function_return DFFALSE 42961>>>>>>>>> get DateCompose liDay liMonth liYear to ldDate 42962>>>>>>>>> send DateDecompose ldDate 42963>>>>>>>>> function_return (Dates$Year=liYear and Dates$Month=liMonth and Dates$Day=liDay) 42964>>>>>>>>>end_function 42965>>>>>>>>> 42965>>>>>>>>>function DateFormatName global integer liFormat returns string 42967>>>>>>>>> if liFormat eq DF_DATE_EUROPEAN function_return "European" 42970>>>>>>>>> if liFormat eq DF_DATE_USA function_return "United States" 42973>>>>>>>>> if liFormat eq DF_DATE_MILITARY function_return "Military" 42976>>>>>>>>>end_function 42977>>>>>>>>> 42977>>>>>>>>>function DateCurrentSeparator global returns string 42979>>>>>>>>> integer liRval 42979>>>>>>>>> get_attribute DF_DATE_SEPARATOR to liRval 42982>>>>>>>>> function_return (character(liRval)) 42983>>>>>>>>>end_function 42984>>>>>>>>> 42984>>>>>>>>>function DateCurrentFormat global returns integer 42986>>>>>>>>> integer liRval 42986>>>>>>>>> get_attribute DF_DATE_FORMAT to liRval 42989>>>>>>>>> function_return liRval 42990>>>>>>>>>end_function 42991>>>>>>>>> 42991>>>>>>>>>function DateFormatAsString global integer liFormat integer lbLong string lsSep returns string 42993>>>>>>>>> string lsRval lsLetter 42993>>>>>>>>> if liFormat eq DF_DATE_EUROPEAN move "3342241111" to lsRval 42996>>>>>>>>> if liFormat eq DF_DATE_USA move "2243341111" to lsRval 42999>>>>>>>>> if liFormat eq DF_DATE_MILITARY move "1111422433" to lsRval 43002>>>>>>>>> left t.calendar.year to lsLetter 1 43004>>>>>>>>>> 43004>>>>>>>>> replace "1" in lsRval with lsLetter 43006>>>>>>>>> replace "1" in lsRval with lsLetter 43008>>>>>>>>> ifnot lbLong move "" to lsLetter 43011>>>>>>>>> move (replaces("1",lsRval,lsLetter)) to lsRval 43012>>>>>>>>> move (replaces("2",lsRval,left(t.calendar.month,1))) to lsRval 43013>>>>>>>>> move (replaces("3",lsRval,left(t.calendar.day,1))) to lsRval 43014>>>>>>>>> if lsSep eq "" begin 43016>>>>>>>>> get_attribute DF_DATE_SEPARATOR to liFormat 43019>>>>>>>>> character liFormat to lsSep 43020>>>>>>>>>> 43020>>>>>>>>> end 43020>>>>>>>>>> 43020>>>>>>>>> move (replaces("4",lsRval,lsSep)) to lsRval 43021>>>>>>>>> function_return lsRval 43022>>>>>>>>>end_function 43023>>>>>>>>> 43023>>>>>>>>>function StringToDate global string lsDate integer liFormat integer lbLong string lsSep returns date 43025>>>>>>>>> integer liSepLen liDay liMonth liYear 43025>>>>>>>>> move (length(lsSep)) to liSepLen 43026>>>>>>>>> if lbLong move 4 to lbLong // ugly overload 43029>>>>>>>>> else move 2 to lbLong 43031>>>>>>>>> if liFormat eq DF_DATE_EUROPEAN begin // DMY 43033>>>>>>>>> move (mid(lsDate,2,1)) to liDay 43034>>>>>>>>> move (mid(lsDate,2,3+liSepLen)) to liMonth 43035>>>>>>>>> move (mid(lsDate,lbLong,5+liSepLen+liSepLen)) to liYear 43036>>>>>>>>> end 43036>>>>>>>>>> 43036>>>>>>>>> if liFormat eq DF_DATE_USA begin // MDY 43038>>>>>>>>> move (mid(lsDate,2,1)) to liMonth 43039>>>>>>>>> move (mid(lsDate,2,3+liSepLen)) to liDay 43040>>>>>>>>> move (mid(lsDate,lbLong,5+liSepLen+liSepLen)) to liYear 43041>>>>>>>>> end 43041>>>>>>>>>> 43041>>>>>>>>> if liFormat eq DF_DATE_MILITARY begin // YMD 43043>>>>>>>>> move (mid(lsDate,lbLong,1)) to liYear 43044>>>>>>>>> move (mid(lsDate,2,1+lbLong+liSepLen)) to liMonth 43045>>>>>>>>> move (mid(lsDate,2,3+lbLong+liSepLen+liSepLen)) to liDay 43046>>>>>>>>> end 43046>>>>>>>>>> 43046>>>>>>>>> get Year2to4 liYear to liYear 43047>>>>>>>>> function_return (DateCompose(liDay,liMonth,liYear)) 43048>>>>>>>>>end_function 43049>>>>>>>>> 43049>>>>>>>>>function DateToString global date ldDate integer liFormat integer lbLong string lsSep returns string 43051>>>>>>>>> string lsRval lsDay lsMonth lsYear 43051>>>>>>>>> get Date2to4 ldDate to ldDate 43052>>>>>>>>> if (integer(ldDate)) begin 43054>>>>>>>>> send DateDecompose ldDate 43055>>>>>>>>> move Dates$Day to lsDay 43056>>>>>>>>> if Dates$Day lt 10 insert "0" in lsDay at 1 43060>>>>>>>>> move Dates$Month to lsMonth 43061>>>>>>>>> if Dates$Month lt 10 insert "0" in lsMonth at 1 43065>>>>>>>>> move Dates$Year to lsYear 43066>>>>>>>>> ifnot lbLong move (right(lsYear,2)) to lsYear 43069>>>>>>>>> if liFormat eq DF_DATE_EUROPEAN move (lsDay+lsSep+lsMonth+lsSep+lsYear) to lsRval // DMY 43072>>>>>>>>> if liFormat eq DF_DATE_USA move (lsMonth+lsSep+lsDay+lsSep+lsYear) to lsRval // MDY 43075>>>>>>>>> if liFormat eq DF_DATE_MILITARY move (lsYear+lsSep+lsMonth+lsSep+lsDay) to lsRval // YMD 43078>>>>>>>>> end 43078>>>>>>>>>> 43078>>>>>>>>> else move "" to lsRval 43080>>>>>>>>> function_return lsRval 43081>>>>>>>>>end_function 43082>>>>>>>>> 43082>>>>>>>>>//> The DateIsValid takes one string parameter and returns TRUE if its value 43082>>>>>>>>>//> constitutes a date. 43082>>>>>>>>>function DateIsValid global string lsValue returns integer 43084>>>>>>>>> date ldDate 43084>>>>>>>>> send ErrorHnd_Quiet_Activate // Deactivate error handler 43085>>>>>>>>> move lsValue to ldDate // Move the value to a date variable 43086>>>>>>>>> send ErrorHnd_Quiet_Deactivate // Re-activate the normal error handler 43087>>>>>>>>> ifnot (ErrorHnd_Quiet_ErrorCount()) function_return (integer(ldDate)) 43090>>>>>>>>> function_return DFFALSE 43091>>>>>>>>>end_function 43092>>>>>>>>> 43092>>>>>>>>>// Function DateAsString is only here for compatibility with earlier versions. 43092>>>>>>>>>// Use function DateToString instead. 43092>>>>>>>>>function DateAsString global date ldDate integer liFormat integer lbLong string lsSep returns string 43094>>>>>>>>> function_return (DateToString(ldDate,liFormat,lbLong,lsSep)) 43095>>>>>>>>>end_function 43096>>>>>>>>> 43096>>>>>>>>>//> Use DateIncrement to add or subtract a number of months, years, days or 43096>>>>>>>>>//> weeks from a given date. 43096>>>>>>>>>//> 43096>>>>>>>>>//> date ldDate is the date to which the time interval will be added or subtracted 43096>>>>>>>>>//> 43096>>>>>>>>>//> integer liSegment may be one of these constants: DS_YEAR, DS_MONTH, DS_DAY or DS_WEEK 43096>>>>>>>>>//> 43096>>>>>>>>>//> integer liAmount is the (positive or negative) amount of units (indicated by liSegment) to be added. 43096>>>>>>>>>function DateIncrement global date ldDate integer liSegment integer liAmount returns date 43098>>>>>>>>> if (ldDate=0) function_return 0 43101>>>>>>>>> if liSegment eq DS_QUARTER function_return (DateIncrement(ldDate,DS_MONTH,liAmount*3)) 43104>>>>>>>>> if liSegment eq DS_WEEK function_return (ldDate+(liAmount*7)) //weeks 43107>>>>>>>>> if (liSegment<>DS_DAY) begin // months or years 43109>>>>>>>>> send DateDecompose ldDate 43110>>>>>>>>> if liSegment eq DS_MONTH begin //months 43112>>>>>>>>> move (Dates$Month+liAmount) to Dates$Month 43113>>>>>>>>> if liAmount ge 0 function_return (DateCompose(Dates$Day,Dates$Month-(((Dates$Month-1)/12)*12),Dates$Year+((Dates$Month-1)/12))) 43116>>>>>>>>> function_return (DateCompose(Dates$Day,Dates$Month-(((Dates$Month-12)/12)*12),Dates$Year+((Dates$Month-12)/12))) 43117>>>>>>>>> end //years: 43117>>>>>>>>>> 43117>>>>>>>>> if liSegment eq DS_YEAR function_return (DateCompose(Dates$Day,Dates$Month,Dates$Year+liAmount)) 43120>>>>>>>>> end 43120>>>>>>>>>> 43120>>>>>>>>> else function_return (ldDate+liAmount) //days 43122>>>>>>>>>end_function 43123>>>>>>>>> 43123>>>>>>>>>function DateSegment global date ldDate integer liSegment returns integer 43125>>>>>>>>> send DateDecompose ldDate 43126>>>>>>>>> if liSegment eq DS_DAY function_return Dates$Day 43129>>>>>>>>> if liSegment eq DS_MONTH function_return Dates$Month 43132>>>>>>>>> if liSegment eq DS_YEAR function_return Dates$Year 43135>>>>>>>>> if liSegment eq DS_QUARTER function_return (Dates$Month+2/3) 43138>>>>>>>>>end_function 43139>>>>>>>>> 43139>>>>>>>>>function DateToInteger global date ldDate returns integer // 20011231 43141>>>>>>>>> send DateDecompose ldDate 43142>>>>>>>>> function_return (Dates$Year*100+Dates$Month*100+Dates$Day) 43143>>>>>>>>>end_function 43144>>>>>>>>> 43144>>>>>>>>>function FirstDayInMonth global date ldDate returns date 43146>>>>>>>>> integer liMonth liYear 43146>>>>>>>>> move (DateSegment(ldDate,DS_MONTH)) to liMonth 43147>>>>>>>>> move (DateSegment(ldDate,DS_YEAR)) to liYear 43148>>>>>>>>> function_return (DateCompose(1,liMonth,liYear)) 43149>>>>>>>>>end_function 43150>>>>>>>>> 43150>>>>>>>>>function LastDayInMonth global date ldDate returns date 43152>>>>>>>>> move (DateIncrement(ldDate,DS_MONTH,1)) to ldDate 43153>>>>>>>>> function_return (FirstDayInMonth(ldDate)-1) 43154>>>>>>>>>end_function 43155>>>>>>>>> 43155>>>>>>>>>function FirstDayInYear global date ldDate returns date 43157>>>>>>>>> integer liYear 43157>>>>>>>>> move (DateSegment(ldDate,DS_YEAR)) to liYear 43158>>>>>>>>> function_return (DateCompose(1,1,liYear)) 43159>>>>>>>>>end_function 43160>>>>>>>>> 43160>>>>>>>>>function LastDayInYear global date ldDate returns date 43162>>>>>>>>> move (DateIncrement(ldDate,DS_YEAR,1)) to ldDate 43163>>>>>>>>> function_return (FirstDayInYear(ldDate)-1) 43164>>>>>>>>>end_function 43165>>>>>>>>> 43165>>>>>>>>>function DateDistance global date ldDate1 date ldDate2 integer liSegment returns integer 43167>>>>>>>>> integer lbNegative liDistance liDay liYear1 liYear2 liMonth1 liMonth2 43167>>>>>>>>> date ldTemp 43167>>>>>>>>> if (ldDate1>ldDate2) begin 43169>>>>>>>>> move ldDate1 to ldTemp 43170>>>>>>>>> move ldDate2 to ldDate1 43171>>>>>>>>> move ldTemp to ldDate2 43172>>>>>>>>> move DFTRUE to lbNegative 43173>>>>>>>>> end 43173>>>>>>>>>> 43173>>>>>>>>> else move DFFALSE to lbNegative 43175>>>>>>>>> if (liSegment=DS_DAY) move (integer(ldDate2)-integer(ldDate1)) to liDistance 43178>>>>>>>>> if (liSegment=DS_WEEK) begin 43180>>>>>>>>> get DateDayNumber ldDate1 to liDay 43181>>>>>>>>> move (date(integer(ldDate1)-liDay+1)) to ldDate1 // Now a monday 43182>>>>>>>>> get DateDayNumber ldDate2 to liDay 43183>>>>>>>>> move (date(integer(ldDate2)-liDay+1)) to ldDate2 // Now a monday 43184>>>>>>>>> move (integer(ldDate2)-integer(ldDate1)) to liDistance 43185>>>>>>>>> move (liDistance/7) to liDistance 43186>>>>>>>>> end 43186>>>>>>>>>> 43186>>>>>>>>> if (liSegment=DS_MONTH) begin 43188>>>>>>>>> move (DateSegment(ldDate1,DS_MONTH)) to liMonth1 43189>>>>>>>>> move (DateSegment(ldDate1,DS_YEAR)) to liYear1 43190>>>>>>>>> move (DateSegment(ldDate2,DS_MONTH)) to liMonth2 43191>>>>>>>>> move (DateSegment(ldDate2,DS_YEAR)) to liYear2 43192>>>>>>>>> move (liYear2-liYear1*12+liMonth2-liMonth1) to liDistance 43193>>>>>>>>> end 43193>>>>>>>>>> 43193>>>>>>>>> if (liSegment=DS_QUARTER) begin 43195>>>>>>>>> move (DateSegment(ldDate1,DS_QUARTER)) to liMonth1 // Overload 43196>>>>>>>>> move (DateSegment(ldDate1,DS_YEAR)) to liYear1 43197>>>>>>>>> move (DateSegment(ldDate2,DS_QUARTER)) to liMonth2 // Overload 43198>>>>>>>>> move (DateSegment(ldDate2,DS_YEAR)) to liYear2 43199>>>>>>>>> move (liYear2-liYear1*4+liMonth2-liMonth1) to liDistance 43200>>>>>>>>> end 43200>>>>>>>>>> 43200>>>>>>>>> if (liSegment=DS_YEAR) begin 43202>>>>>>>>> move (DateSegment(ldDate1,DS_YEAR)) to liYear1 43203>>>>>>>>> move (DateSegment(ldDate2,DS_YEAR)) to liYear2 43204>>>>>>>>> move (liYear2-liYear1) to liDistance 43205>>>>>>>>> end 43205>>>>>>>>>> 43205>>>>>>>>> if lbNegative move (0-liDistance) to liDistance 43208>>>>>>>>> function_return liDistance 43209>>>>>>>>>end_function 43210>>>>>>>>> 43210>>>>>>>>>function DateWeekNumber global date ldDate returns integer 43212>>>>>>>>> integer liWeek liFirstWeekDay liDayOfYear liYear liWeekDay 43212>>>>>>>>> if (integer(ldDate)=0) function_return 0 43215>>>>>>>>> 43215>>>>>>>>> get Date2to4 ldDate to ldDate 43216>>>>>>>>> get DateDayNumber ldDate to liWeekDay 43217>>>>>>>>> move (DateSegment(ldDate-liWeekDay+1,DS_YEAR)) to liYear 43218>>>>>>>>> 43218>>>>>>>>> get DateDayNumber (FirstDayInYear(ldDate)) to liFirstWeekDay 43219>>>>>>>>> move (ldDate-FirstDayInYear(ldDate)) to liDayOfYear 43220>>>>>>>>> move (liDayOfYear-1-7+liFirstWeekDay) to liDayOfYear 43221>>>>>>>>> if (liDayOfYear/7.0) ge 0 move (liDayOfYear/7+1) to liWeek 43224>>>>>>>>> else move 0 to liWeek 43226>>>>>>>>> if liFirstWeekDay le 4 increment liWeek 43229>>>>>>>>> if liWeek gt 52 begin 43231>>>>>>>>> move 1 to liWeek 43232>>>>>>>>> if liFirstWeekDay eq 4 move 53 to liWeek 43235>>>>>>>>> if liFirstWeekDay eq 3 if ((liYear/4)*4) eq liYear ifnot ((liYear/100)*100) eq liYear move 53 to liWeek 43242>>>>>>>>> end 43242>>>>>>>>>> 43242>>>>>>>>> if liWeek eq 0 begin 43244>>>>>>>>> // Week 52 or 53 43244>>>>>>>>> get DateDayNumber (DateIncrement(FirstDayInYear(ldDate),DS_YEAR,-1)) to liFirstWeekDay 43245>>>>>>>>> move 52 to liWeek 43246>>>>>>>>> if liFirstWeekDay eq 4 move 53 to liWeek 43249>>>>>>>>> if liFirstWeekDay eq 3 if ((liYear/4)*4) eq liYear ifnot ((liYear/100)*100) eq liYear move 53 to liWeek 43256>>>>>>>>> end 43256>>>>>>>>>> 43256>>>>>>>>> function_return liWeek 43257>>>>>>>>>end_function 43258>>>>>>>>> 43258>>>>>>>>>function DayName global integer liWeekDay returns string 43260>>>>>>>>> if liWeekDay eq 1 function_return t.calendar.Monday 43263>>>>>>>>> if liWeekDay eq 2 function_return t.calendar.Tuesday 43266>>>>>>>>> if liWeekDay eq 3 function_return t.calendar.Wednesday 43269>>>>>>>>> if liWeekDay eq 4 function_return t.calendar.Thursday 43272>>>>>>>>> if liWeekDay eq 5 function_return t.calendar.Friday 43275>>>>>>>>> if liWeekDay eq 6 function_return t.calendar.Saturday 43278>>>>>>>>> if liWeekDay eq 7 function_return t.calendar.Sunday 43281>>>>>>>>> function_return "" 43282>>>>>>>>>end_function 43283>>>>>>>>> 43283>>>>>>>>>function DateDayNumber global date ldDate returns integer 43285>>>>>>>>> integer liRval // 1=Monday, ... , 7=Sunday 43285>>>>>>>>> get Date2to4 ldDate to ldDate 43286>>>>>>>>> move ldDate to liRval 43287>>>>>>>>> if liRval begin 43289>>>>>>>>> if liRval gt 693975 move (liRval-2) to liRval 43292>>>>>>>>> move (liRval-((liRval/7)*7)) to liRval 43293>>>>>>>>> if liRval eq 0 move 7 to liRval 43296>>>>>>>>> end 43296>>>>>>>>>> 43296>>>>>>>>> function_return liRval 43297>>>>>>>>>end_function 43298>>>>>>>>> 43298>>>>>>>>>function DateDayName global date ldDate returns string 43300>>>>>>>>> function_return (DayName(DateDayNumber(ldDate))) 43301>>>>>>>>>end_function 43302>>>>>>>>> 43302>>>>>>>>>function YearMaxWeek global integer liYear returns integer 43304>>>>>>>>> integer liWeek1 liWeek2 43304>>>>>>>>> get DateWeekNumber (DateCompose(31,12,liYear)) to liWeek1 43305>>>>>>>>> get DateWeekNumber (DateCompose(24,12,liYear)) to liWeek2 43306>>>>>>>>> function_return (liWeek1 max liWeek2) 43307>>>>>>>>>end_function 43308>>>>>>>>> 43308>>>>>>>>>function WeekToDate global integer liYear integer liWeek returns date 43310>>>>>>>>> date ldDate 43310>>>>>>>>> move (DateCompose(1,1,liYear)) to ldDate 43311>>>>>>>>> if (DateWeekNumber(ldDate)) ne 1 move (ldDate+7) to ldDate // week 52 or 53 43314>>>>>>>>> move (ldDate-DateDayNumber(ldDate)+1) to ldDate // Now it's a Monday 43315>>>>>>>>> function_return (liWeek-1*7+ldDate) 43316>>>>>>>>>end_function 43317>>>>>>>>> 43317>>>>>>>>>function MonthName global integer liMonth returns string 43319>>>>>>>>> if liMonth eq 1 function_return t.calendar.January 43322>>>>>>>>> if liMonth eq 2 function_return t.calendar.February 43325>>>>>>>>> if liMonth eq 3 function_return t.calendar.March 43328>>>>>>>>> if liMonth eq 4 function_return t.calendar.April 43331>>>>>>>>> if liMonth eq 5 function_return t.calendar.May 43334>>>>>>>>> if liMonth eq 6 function_return t.calendar.June 43337>>>>>>>>> if liMonth eq 7 function_return t.calendar.July 43340>>>>>>>>> if liMonth eq 8 function_return t.calendar.August 43343>>>>>>>>> if liMonth eq 9 function_return t.calendar.September 43346>>>>>>>>> if liMonth eq 10 function_return t.calendar.October 43349>>>>>>>>> if liMonth eq 11 function_return t.calendar.November 43352>>>>>>>>> if liMonth eq 12 function_return t.calendar.December 43355>>>>>>>>> function_return "" 43356>>>>>>>>>end_function 43357>>>>>>>>> 43357>>>>>>>>>function DateMonthName global date ldDate returns string 43359>>>>>>>>> function_return (MonthName(DateSegment(ldDate,DS_MONTH))) 43360>>>>>>>>>end_function 43361>>>>>>>>> 43361>>>>>>>>>// May be used like this: 43361>>>>>>>>>// get DateAsText 06/06/2006 "#D-#MN3-#Y4" to lsValue 43361>>>>>>>>>// => lsValue = 6-Jul-2006 43361>>>>>>>>>function DateAsText global date ldDate string lsFormat returns string 43363>>>>>>>>> integer liDay liMonth liYear liYearTmp 43363>>>>>>>>> if ldDate eq 0 function_return "" 43366>>>>>>>>> move (replace("#DN3",lsFormat,left(DateDayName(ldDate),3))) to lsFormat 43367>>>>>>>>> move (replace("#DN2",lsFormat,left(DateDayName(ldDate),2))) to lsFormat // Dutch request. 01/08/2005 43368>>>>>>>>> move (replace("#MN3",lsFormat,left(DateMonthName(ldDate),3))) to lsFormat 43369>>>>>>>>> move (replace("#DN", lsFormat,DateDayName(ldDate))) to lsFormat 43370>>>>>>>>> move (replace("#MN", lsFormat,DateMonthName(ldDate))) to lsFormat 43371>>>>>>>>> move (replace("#WN", lsFormat,DateWeekNumber(ldDate))) to lsFormat 43372>>>>>>>>> move (DateSegment(ldDate,DS_DAY)) to liDay 43373>>>>>>>>> move (DateSegment(ldDate,DS_MONTH)) to liMonth 43374>>>>>>>>> move (DateSegment(ldDate,DS_YEAR)) to liYear 43375>>>>>>>>> move (replace("#D2", lsFormat,if(liDay<10,"0"+string(liDay),string(liDay)))) to lsFormat 43376>>>>>>>>> move (replace("#D", lsFormat,string(liDay))) to lsFormat 43377>>>>>>>>> 43377>>>>>>>>> get Year4to2 liYear to liYearTmp 43378>>>>>>>>> move (replace("#Y2", lsFormat,if(liYearTmp<10,"0"+string(liYearTmp),string(liYearTmp)))) to lsFormat 43379>>>>>>>>> 43379>>>>>>>>> get Year2to4 liYear to liYearTmp 43380>>>>>>>>> move (replace("#Y4", lsFormat,string(liYearTmp))) to lsFormat 43381>>>>>>>>> 43381>>>>>>>>> move (replace("#M2", lsFormat,if(liMonth<10,"0"+string(liMonth),string(liMonth)))) to lsFormat 43382>>>>>>>>> move (replace("#M", lsFormat,string(liMonth))) to lsFormat 43383>>>>>>>>> function_return lsFormat 43384>>>>>>>>>end_function 43385>>>>>>>>> 43385>>>>>>>>>function Year2to4 global integer liYear returns integer 43387>>>>>>>>> integer liEpochValue 43387>>>>>>>>> get_date_attribute EPOCH_VALUE to liEpochValue 43388>>>>>>>>> if liYear lt 100 begin 43390>>>>>>>>> if liYear gt liEpochValue function_return (liYear+1900) 43393>>>>>>>>> function_return (liYear+2000) 43394>>>>>>>>> end 43394>>>>>>>>>> 43394>>>>>>>>> function_return liYear // No conversion done! 43395>>>>>>>>>end_function 43396>>>>>>>>> 43396>>>>>>>>>function Year4to2 global integer liYear returns integer 43398>>>>>>>>> function_return (right(string(liYear),2)) 43399>>>>>>>>>end_function 43400>>>>>>>>> 43400>>>>>>>>>function Date2to4 global date ldDate returns date 43402>>>>>>>>> integer liEpochValue 43402>>>>>>>>> move (date(ldDate)) to ldDate 43403>>>>>>>>> get_date_attribute EPOCH_VALUE to liEpochValue 43404>>>>>>>>> if ldDate gt 0 begin // Only if there is a date to convert 43406>>>>>>>>> if (DateSegment(ldDate,DS_YEAR)) lt 105 begin 43408>>>>>>>>> if Dates$Year gt liEpochValue function_return (DateIncrement(ldDate,DS_YEAR,1900)) 43411>>>>>>>>> function_return (DateIncrement(ldDate,DS_YEAR,2000)) 43412>>>>>>>>> end 43412>>>>>>>>>> 43412>>>>>>>>> function_return ldDate // No conversion done! 43413>>>>>>>>> end 43413>>>>>>>>>> 43413>>>>>>>>>end_function 43414>>>>>>>>> 43414>>>>>>>>>function Date4to2 global date ldDate returns date 43416>>>>>>>>> integer liEpochValue liYear 43416>>>>>>>>> get_date_attribute EPOCH_VALUE to liEpochValue 43417>>>>>>>>> if ldDate gt 0 begin // Only if there is a date to convert 43419>>>>>>>>> move (DateSegment(ldDate,DS_YEAR)) to liYear 43420>>>>>>>>> if liYear ge 100 begin // Only then conversion is needed! 43422>>>>>>>>> if (liYear>=(1900+liEpochValue) and liYear<(2000+liEpochValue)) begin 43424>>>>>>>>> if liYear lt 2000 function_return (DateIncrement(ldDate,DS_YEAR,-1900)) 43427>>>>>>>>> else function_return (DateIncrement(ldDate,DS_YEAR,-2000)) 43429>>>>>>>>> end 43429>>>>>>>>>> 43429>>>>>>>>> else error 301 "Date is out of epoch range" 43431>>>>>>>>> end 43431>>>>>>>>>> 43431>>>>>>>>> end 43431>>>>>>>>>> 43431>>>>>>>>> function_return ldDate // No conversion done! 43432>>>>>>>>>end_function 43433>>>>>>>>> 43433>>>>>>>>>function dSysDate global returns date 43435>>>>>>>>> date ldDate 43435>>>>>>>>> sysdate4 ldDate 43436>>>>>>>>> function_return ldDate 43437>>>>>>>>>end_function 43438>>>>>>>>> 43438>>>>>>>>>function iSysYear global returns integer 43440>>>>>>>>> date ldDate 43440>>>>>>>>> sysdate4 ldDate 43441>>>>>>>>> function_return (DateSegment(ldDate,DS_YEAR)) 43442>>>>>>>>>end_function 43443>>>>>>>>> 43443>>>>>>>>> procedure FieldSysdate for DataDictionary integer liField 43445>>>>>>>>> date ldDate 43445>>>>>>>>> get field_current_value liField to ldDate 43446>>>>>>>>> if ldDate eq 0 begin 43448>>>>>>>>> sysdate4 ldDate 43449>>>>>>>>> set field_changed_value liField to ldDate 43450>>>>>>>>> end 43450>>>>>>>>>> 43450>>>>>>>>> end_procedure 43451>>>>>>>>> 43451>>>>>>>>> procedure FieldDate2to4 for DataDictionary integer liField 43453>>>>>>>>> integer liYear 43453>>>>>>>>> date ldDate ldNewDate 43453>>>>>>>>> get field_current_value liField to ldDate 43454>>>>>>>>> 43454>>>>>>>>> move (DateSegment(ldDate,DS_YEAR)) to liYear 43455>>>>>>>>> if (liYear=0 and ldDate<>0) move (DateIncrement(ldDate,3,iSysYear())) to ldNewDate 43458>>>>>>>>> else move ldDate to ldNewDate 43460>>>>>>>>> 43460>>>>>>>>> move (Date2to4(ldNewDate)) to ldNewDate 43461>>>>>>>>> move (DateSegment(ldNewDate,3)) to liYear 43462>>>>>>>>> if (liYear>99 and liYear <=999) begin 43464>>>>>>>>> error 15 // Illegal entry in this window 43465>>>>>>>>>> 43465>>>>>>>>> procedure_return 1 43466>>>>>>>>> end 43466>>>>>>>>>> 43466>>>>>>>>> if ldNewDate ne ldDate set field_changed_value liField to ldNewDate 43469>>>>>>>>> end_procedure 43470>>>>>>>>> 43470>>>>>>>>> procedure FieldYear2to4 for DataDictionary integer liField 43472>>>>>>>>> integer liYear liNewYear lbChanged 43472>>>>>>>>> get field_current_value liField to liYear 43473>>>>>>>>> get field_changed_state liField to lbChanged 43474>>>>>>>>> if lbChanged begin 43476>>>>>>>>> if (liYear>99 and liYear<1000) begin 43478>>>>>>>>> error 15 // Illegal entry in this window 43479>>>>>>>>>> 43479>>>>>>>>> procedure_return 1 43480>>>>>>>>> end 43480>>>>>>>>>> 43480>>>>>>>>> move (Year2to4(liYear)) to liNewYear 43481>>>>>>>>> if liNewYear ne liYear set field_changed_value liField to liNewYear 43484>>>>>>>>> end 43484>>>>>>>>>> 43484>>>>>>>>> end_procedure 43485>>>>>>>>> 43485>>>>>>>>> function SysDate global returns date 43487>>>>>>>>> function_return (dSysDate()) 43488>>>>>>>>> end_function 43489>>>>>>>>> 43489>>>>>>>>>function sSysTime global returns string 43491>>>>>>>>> integer h# m# s# 43491>>>>>>>>> sysdate4 h# h# m# s# 43495>>>>>>>>> function_return (if(h#<10,"0","")+string(h#)+":"+if(m#<10,"0","")+string(m#)+":"+if(s#<10,"0","")+string(s#)) 43496>>>>>>>>>end_function 43497>>>>>>>>> 43497>>>>>>>>>function TS_SysTime global returns number 43499>>>>>>>>> integer liDate liHour liMinute liSecond 43499>>>>>>>>> sysdate4 liDate liHour liMinute liSecond 43503>>>>>>>>> function_return (liDate*24.0+liHour*60+liMinute*60+liSecond) 43504>>>>>>>>>end_function 43505>>>>>>>>> 43505>>>>>>>>>//> This function returns a TS value composed from the date and time 43505>>>>>>>>>//> passed to it. Note that the time variable must be of the format 43505>>>>>>>>>//> "hh:mm:ss". 43505>>>>>>>>>function TS_Compose global date ldDate string lsTime returns number 43507>>>>>>>>> integer liHour liMinute liSecond 43507>>>>>>>>> left lsTime to liHour 2 43509>>>>>>>>>> 43509>>>>>>>>> mid lsTime to liMinute 2 4 43512>>>>>>>>>> 43512>>>>>>>>> mid lsTime to liSecond 2 7 43515>>>>>>>>>> 43515>>>>>>>>> function_return (integer(ldDate)*24.0+liHour*60+liMinute*60+liSecond) 43516>>>>>>>>>end_function 43517>>>>>>>>> 43517>>>>>>>>>function TS_Compose2 global date ldDate integer liHour integer liMinute integer liSecond returns number 43519>>>>>>>>> function_return (integer(ldDate)*24.0+liHour*60+liMinute*60+liSecond) 43520>>>>>>>>>end_function 43521>>>>>>>>> 43521>>>>>>>>>function TS_ExtractDate global number lnTime returns date 43523>>>>>>>>> function_return (lnTime/86400) // 86400=24*60*60 43524>>>>>>>>>end_function 43525>>>>>>>>> 43525>>>>>>>>>function TS_ExtractTime global number lnTime returns string 43527>>>>>>>>> integer liHour liMinute liSecond 43527>>>>>>>>> move (lnTime-(86400.0*integer(TS_ExtractDate(lnTime)))) to liSecond 43528>>>>>>>>> move (liSecond/3600) to liHour 43529>>>>>>>>> move (liSecond-(liHour*3600)) to liSecond 43530>>>>>>>>> move (liSecond/60) to liMinute 43531>>>>>>>>> move (liSecond-(liMinute*60)) to liSecond 43532>>>>>>>>> function_return (if(liHour<10,"0","")+string(liHour)+":"+if(liMinute<10,"0","")+string(liMinute)+":"+if(liSecond<10,"0","")+string(liSecond)) 43533>>>>>>>>>end_function 43534>>>>>>>>> 43534>>>>>>>>>function TS_ConvertToString global number lnTime returns string 43536>>>>>>>>> date ldDate 43536>>>>>>>>> if (lnTime=0) function_return "" 43539>>>>>>>>> move (TS_ExtractDate(lnTime)) to ldDate 43540>>>>>>>>> if (integer(ldDate)) function_return (string(ldDate)+" "+TS_ExtractTime(lnTime)) 43543>>>>>>>>> else function_return (TS_ExtractTime(lnTime)) 43545>>>>>>>>>end_function 43546>>>>>>>>> 43546>>>>>>>>>function TS_ConvertStringToTS global string lsValue returns number 43548>>>>>>>>> string lsDate lsTime 43548>>>>>>>>> move (ExtractWord(lsValue," ",1)) to lsDate 43549>>>>>>>>> move (ExtractWord(lsValue," ",2)) to lsTime 43550>>>>>>>>> function_return (TS_Compose(lsDate,lsTime)) 43551>>>>>>>>>end_function 43552>>>>>>>>> 43552>>>>>>>>>function TS_ConvertToStringNoDate global number lnTS returns string 43554>>>>>>>>> integer liHour liMinute 43554>>>>>>>>> if (lnTS=0) function_return "" 43557>>>>>>>>> move (lnTS/3600) to liHour 43558>>>>>>>>> move (lnTS-(liHour*3600)) to lnTS 43559>>>>>>>>> move (lnTS/60) to liMinute 43560>>>>>>>>> move (lnTS-(liMinute*60)) to lnTS 43561>>>>>>>>> function_return (if(liHour<10,"0","")+string(liHour)+":"+if(liMinute<10,"0","")+string(liMinute)+":"+if(lnTS<10,"0","")+string(lnTS)) 43562>>>>>>>>>end_function 43563>>>>>>>>> 43563>>>>>>>>>// This procedure is used when a TS-variable must be displayed on screen. 43563>>>>>>>>>procedure TS_UI_Update global number lnTS integer lhObj1 integer liItm1 integer lhTmpObj2 integer liTmpItm2 43565>>>>>>>>> integer lhObj2 liItm2 43565>>>>>>>>> if num_arguments gt 3 begin 43567>>>>>>>>> move lhTmpObj2 to lhObj2 43568>>>>>>>>> move liTmpItm2 to liItm2 43569>>>>>>>>> end 43569>>>>>>>>>> 43569>>>>>>>>> else begin 43570>>>>>>>>> move lhObj1 to lhObj2 43571>>>>>>>>> move (liItm1+1) to liItm2 43572>>>>>>>>> end 43572>>>>>>>>>> 43572>>>>>>>>> set value of lhObj1 item liItm1 to (TS_ExtractDate(lnTS)) 43573>>>>>>>>> set value of lhObj2 item liItm2 to (TS_ExtractTime(lnTS)) 43574>>>>>>>>>end_procedure 43575>>>>>>>>> 43575>>>>>>>>>class TS_TimeEstimator is an array 43576>>>>>>>>> procedure construct_object 43578>>>>>>>>> forward send construct_object 43580>>>>>>>>> set delegation_mode to delegate_to_parent 43581>>>>>>>>> property number pnTotal public 0 // Seconds needed to run the loop. 43582>>>>>>>>> property number pnElapsed public 0 // Seconds elapsed so far. 43583>>>>>>>>> property number pnLeft public 0 // Number of seconds left 43584>>>>>>>>> property number pnStart public 0 43585>>>>>>>>> property number pnPause public 0 43586>>>>>>>>> property number pnPercent public 0 43587>>>>>>>>> property integer piMin public 0 43588>>>>>>>>> property integer piMax public 0 43589>>>>>>>>> end_procedure 43590>>>>>>>>> 43590>>>>>>>>> procedure TS_Start integer liMin integer liMax 43592>>>>>>>>> set piMin to liMin 43593>>>>>>>>> set piMax to liMax 43594>>>>>>>>> set pnStart to (TS_SysTime()) 43595>>>>>>>>> set pnElapsed to 0 43596>>>>>>>>> set pnPercent to 0 43597>>>>>>>>> end_procedure 43598>>>>>>>>> 43598>>>>>>>>> procedure TS_Calculate integer liPos 43600>>>>>>>>> integer liMin liMax 43600>>>>>>>>> get piMin to liMin 43601>>>>>>>>> get piMax to liMax 43602>>>>>>>>> set pnElapsed to (TS_SysTime()-pnStart(self)) 43603>>>>>>>>> set pnTotal to (pnElapsed(self)*(liMax-liMin)/number(liPos-liMin)) 43604>>>>>>>>> set pnLeft to (pnTotal(self)-pnElapsed(self)) 43605>>>>>>>>> set pnPercent to (100.0*(liPos-liMin)/(liMax-liMin)) 43606>>>>>>>>> end_procedure 43607>>>>>>>>> 43607>>>>>>>>> procedure TS_Pause 43609>>>>>>>>> set pnPause to (TS_SysTime()) 43610>>>>>>>>> end_procedure 43611>>>>>>>>> 43611>>>>>>>>> procedure TS_Continue 43613>>>>>>>>> set pnStart to (pnStart(self)+TS_SysTime()-pnPause(self)) 43614>>>>>>>>> end_procedure 43615>>>>>>>>>end_class 43616>>>>>>>>> 43616>>>>>>>>>function TS_Module_Compile_Time global string lsPath returns number 43618>>>>>>>>> date ldDate 43618>>>>>>>>> integer liHour liMin liSec 43618>>>>>>>>> string lsAppName 43618>>>>>>>>> move (ToOem(SysConf(SYSCONF_RUNTIME_NAME))) to lsAppName 43619>>>>>>>>> get_file_mod_time (ToOem(lsAppName)) to ldDate liHour liMin liSec 43623>>>>>>>>> function_return (TS_Compose2(ldDate,liHour,liMin,liSec)) 43624>>>>>>>>>end_function 43625>>>>>>>>> 43625>>>>>>>>>string Dates$Module_Compile_Time 43625>>>>>>>>>move "" to Dates$Module_Compile_Time 43626>>>>>>>>> 43626>>>>>>>>>function Module_Compile_Date global returns date 43628>>>>>>>>> number lnTS 43628>>>>>>>>> string lsValue 43628>>>>>>>>> get module_name to lsValue // 'module_name' is most likely the name of the .flx file. 43629>>>>>>>>> get TS_Module_Compile_Time lsValue to lnTS 43630>>>>>>>>> move (TS_ExtractTime(lnTS)) to Dates$Module_Compile_Time 43631>>>>>>>>> function_return (TS_ExtractDate(lnTS)) 43632>>>>>>>>>end_function 43633>>>>>>>>> 43633>>>>>>>>>function Module_Compile_Time global returns string 43635>>>>>>>>> date ldGarbage 43635>>>>>>>>> // Module_Compile_Date must be called before this one! 43635>>>>>>>>> if Dates$Module_Compile_Time eq "" move (Module_Compile_Date()) to ldGarbage 43638>>>>>>>>> function_return Dates$Module_Compile_Time 43639>>>>>>>>>end_function 43640>>>>>>>>> 43640>>>>>>>>>date Dates$ModuleStartDate 43640>>>>>>>>>string Dates$ModuleStartTime 8 43640>>>>>>>>>move (dSysDate()) to Dates$ModuleStartDate 43641>>>>>>>>>move (sSysTime()) to Dates$ModuleStartTime 43642>>>>>>>>> 43642>>>>>>>>>function Module_Start_Date global returns date 43644>>>>>>>>> function_return Dates$ModuleStartDate 43645>>>>>>>>>end_function 43646>>>>>>>>> 43646>>>>>>>>>function Module_Start_Time global returns string 43648>>>>>>>>> function_return Dates$ModuleStartTime 43649>>>>>>>>>end_function 43650>>>>>>>>> 43650>>>>>>>>> 43650>>>>>>>>>// The necessary information to do the following comes from Oliver Nelson 43650>>>>>>>>> 43650>>>>>>>>>Type Dates$SystemTime 43650>>>>>>>>> field Dates$SystemTime.iYear As Word 43650>>>>>>>>> field Dates$SystemTime.iMonth As Word 43650>>>>>>>>> field Dates$SystemTime.iDayOfWeek As Word 43650>>>>>>>>> field Dates$SystemTime.iDay As Word 43650>>>>>>>>> field Dates$SystemTime.iHour As Word 43650>>>>>>>>> field Dates$SystemTime.iMinute As Word 43650>>>>>>>>> field Dates$SystemTime.iSecond As Word 43650>>>>>>>>> field Dates$SystemTime.iMilliseconds As Word 43650>>>>>>>>>End_Type 43650>>>>>>>>>external_function Dates.GetSystemTime "GetSystemTime" kernel32.dll Pointer lpGST Returns VOID_TYPE 43651>>>>>>>>> 43651>>>>>>>>>function MilliSeconds_Systime global returns string 43653>>>>>>>>> integer liGrb 43653>>>>>>>>> string lsTimeData 43653>>>>>>>>> pointer lpST 43653>>>>>>>>> ZeroType Dates$SystemTime to lsTimeData 43654>>>>>>>>> getAddress of lsTimeData to lpST 43655>>>>>>>>> move (Dates.GetSystemTime(lpST)) to liGrb 43656>>>>>>>>> function_return lsTimeData 43657>>>>>>>>> //getbuff from TimeData as SystemTime.IVAL to var 43657>>>>>>>>>end_function 43658>>>>>>>>> 43658>>>>>>>>>function MilliSeconds_Elapsed global string lsStart string lsStop returns integer 43660>>>>>>>>> integer liYear1 liMonth1 liDay1 liHour1 liMinute1 liSecond1 liMilli1 43660>>>>>>>>> integer liYear2 liMonth2 liDay2 liHour2 liMinute2 liSecond2 liMilli2 43660>>>>>>>>> date ldDate1 ldDate2 43660>>>>>>>>> 43660>>>>>>>>> getbuff from lsStart at Dates$SystemTime.iYear to liYear1 43661>>>>>>>>> getbuff from lsStart at Dates$SystemTime.iMonth to liMonth1 43662>>>>>>>>> getbuff from lsStart at Dates$SystemTime.iDay to liDay1 43663>>>>>>>>> getbuff from lsStart at Dates$SystemTime.iHour to liHour1 43664>>>>>>>>> getbuff from lsStart at Dates$SystemTime.iMinute to liMinute1 43665>>>>>>>>> getbuff from lsStart at Dates$SystemTime.iSecond to liSecond1 43666>>>>>>>>> getbuff from lsStart at Dates$SystemTime.iMilliseconds to liMilli1 43667>>>>>>>>> getbuff from lsStop at Dates$SystemTime.iYear to liYear2 43668>>>>>>>>> getbuff from lsStop at Dates$SystemTime.iMonth to liMonth2 43669>>>>>>>>> getbuff from lsStop at Dates$SystemTime.iDay to liDay2 43670>>>>>>>>> getbuff from lsStop at Dates$SystemTime.iHour to liHour2 43671>>>>>>>>> getbuff from lsStop at Dates$SystemTime.iMinute to liMinute2 43672>>>>>>>>> getbuff from lsStop at Dates$SystemTime.iSecond to liSecond2 43673>>>>>>>>> getbuff from lsStop at Dates$SystemTime.iMilliseconds to liMilli2 43674>>>>>>>>> get DateCompose liDay1 liMonth1 liYear1 to ldDate1 43675>>>>>>>>> get DateCompose liDay2 liMonth2 liYear2 to ldDate2 43676>>>>>>>>> 43676>>>>>>>>> move (ldDate2 -ldDate1 ) to liDay1 43677>>>>>>>>> move (liHour2 -liHour1 ) to liHour1 43678>>>>>>>>> move (liMinute2-liMinute1) to liMinute1 43679>>>>>>>>> move (liSecond2-liSecond1) to liSecond1 43680>>>>>>>>> move (liMilli2 -liMilli1 ) to liMilli1 43681>>>>>>>>> 43681>>>>>>>>> function_return (liDay1*24+liHour1*60+liMinute1*60+liSecond1*1000+liMilli1) 43682>>>>>>>>>end_function 43683>>>>>>>>> 43683>>>>>>>>>procedure MilliSeconds_Wait global integer liMS 43685>>>>>>>>> string lsSys lsNow 43685>>>>>>>>> get MilliSeconds_Systime to lsSys 43686>>>>>>>>> repeat 43686>>>>>>>>>> 43686>>>>>>>>> get MilliSeconds_Systime to lsNow 43687>>>>>>>>> until (MilliSeconds_Elapsed(lsSys,lsNow)>=liMS) 43689>>>>>>>>>end_procedure 43690>>>>>>>>> 43690>>>>>>>Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object 43690>>>>>>>Use Version.nui 43690>>>>>>> 43690>>>>>>>use WinFolder.nui // WinFolder_ReadFolder message Including file: winfolder.nui (C:\Apps\VDFQuery\AppSrc\winfolder.nui) 43690>>>>>>>>>// use WinFolder.nui // WinFolder_ReadFolder message 43690>>>>>>>>> 43690>>>>>>>>>Use Base.nui // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface) 43690>>>>>>>>>Use Files.nui // Utilities for handling file related stuff (No User Interface) 43690>>>>>>>>>Use Dates.nui // Date routines (No User Interface) 43690>>>>>>>>>Use vWin32fh.pkg // Win API functions by Wil van Antwerpen of VDF-GuiDance Including file: vWin32fh.pkg (C:\Apps\VDFQuery\AppSrc\vWin32fh.pkg) 43690>>>>>>>>>>>// This code is part of VDF GUIdance 43690>>>>>>>>>>>// Visit us @ http://www.vdf-guidance.com 43690>>>>>>>>>>>// e-Mail us @ info@vdf-guidance.com 43690>>>>>>>>>>>// VDF GUIdance is a mutual project of 43690>>>>>>>>>>>// Frank Vandervelpen - Vandervelpen Systems and 43690>>>>>>>>>>>// Wil van Antwerpen - Antwise Solutions 43690>>>>>>>>>>>// All software source code should be used <> without any warranty. 43690>>>>>>>>>>>// 43690>>>>>>>>>>>// 43690>>>>>>>>>>>// *** Windows 32 bit file handling wrapper class *** 43690>>>>>>>>>>>// 43690>>>>>>>>>>> 43690>>>>>>>>>>>// 05-09-2000 **WvA: Changed namingconvention of all classes and methods to new standard 43690>>>>>>>>>>>// This may be painfull for some of you, but it was really needed as it was 43690>>>>>>>>>>>// getting messy. The "vs" -prefix we used before was confusing and could 43690>>>>>>>>>>>// unintentionally have been interpreted as "Vdf-GUIdance String". 43690>>>>>>>>>>>// 43690>>>>>>>>>>>// The used naming-convention is: 43690>>>>>>>>>>>// - a prefix of "vWin32_" for every external function declaration 43690>>>>>>>>>>>// - a prefix of the letter "v" for the full API name for the vdf-wrapper function. 43690>>>>>>>>>>>// 43690>>>>>>>>>>>// By using this we are guarding ourselves for conflicts with variable declarations 43690>>>>>>>>>>>// of DataAccess in the future. 43690>>>>>>>>>>>// 43690>>>>>>>>>>>// mm-dd-yyyy Author Description 43690>>>>>>>>>>>// 43690>>>>>>>>>>>// vSHGetFolderPath added to retrieve the new shell folders 43690>>>>>>>>>>>// vGetWindowsDirectory 43690>>>>>>>>>>>// 43690>>>>>>>>>>>// vGetTempFileName 43690>>>>>>>>>>>// vGetTempPath 43690>>>>>>>>>>>// 11-17-2001 **WvA: Removed User Interface Error popups such as Error handling. 43690>>>>>>>>>>>// This is an absolute need for WebApp. We expect you to handle the 43690>>>>>>>>>>>// error in your application anyways. Changed this for: 43690>>>>>>>>>>>// vDeleteFile, vCopyFile, vMoveFile and vRenameFile 43690>>>>>>>>>>>// 03-02-2002 **WvA: vRemoveDirectory added 43690>>>>>>>>>>>// 03-11-2002 **WvA: The parameter lpdword in the external function declaration for 43690>>>>>>>>>>>// vWin32_SHBrowsForFolder can cause compiler errors. 43690>>>>>>>>>>>// It is renamed too avoid this. 43690>>>>>>>>>>>// 11-11-2002 **WvA: Codecleanup, vcSelectFile_Dialog is now cvSelectFile_Dialog, its 43690>>>>>>>>>>>// function vSelectedFileName is now just SelectedFileName 43690>>>>>>>>>>>// Removed the local keyword in the variable declarations 43690>>>>>>>>>>>// 02-12-2004 **WvA: Allan Ankerstjeme pointed me into a bug for the vCreateTempFileInPath 43690>>>>>>>>>>>// in that it didn't exactly return the correct filename of the file created. 43690>>>>>>>>>>>// This has now been taken care of. 43690>>>>>>>>>>>// ??-??-???? Also fixed are a number of other errors, like a memoryleak for the openfolders dialog and an addition of a missing 43690>>>>>>>>>>>// parameter when handling DDE errors. 43690>>>>>>>>>>> 43690>>>>>>>>>>>Use Case.mac 43690>>>>>>>>>>>Use File_Dlg.pkg // Contains OpenDialog class definition 43690>>>>>>>>>>>Use Seq_chnl.pkg 43690>>>>>>>>>>> 43690>>>>>>>>>>>Use windows 43690>>>>>>>>>>>Use Dferror 43690>>>>>>>>>>>Use Dll 43690>>>>>>>>>>> 43690>>>>>>>>>>>Define vMax_Path For |CI260 43690>>>>>>>>>>>Define vMinChar For |CI$80 43690>>>>>>>>>>>Define vMaxChar For |CI$7F 43690>>>>>>>>>>>Define vMinShort For |CI$8000 43690>>>>>>>>>>>Define vMaxShort For |CI$7FFF 43690>>>>>>>>>>>Define vMinLong For |CI$80000000 43690>>>>>>>>>>>Define vMaxLong For |CI$7FFFFFFF 43690>>>>>>>>>>>Define vMaxByte For |CI$FF 43690>>>>>>>>>>>Define vMaxWord For |CI$FFFF 43690>>>>>>>>>>>Define vMaxDword For |CI$FFFFFFFF 43690>>>>>>>>>>> 43690>>>>>>>>>>> 43690>>>>>>>>>>> 43690>>>>>>>>>>>// For FindFirstFile 43690>>>>>>>>>>>Define vINVALID_HANDLE_VALUE For |CI-1 43690>>>>>>>>>>>Define vINVALID_FILE_SIZE For |CI$FFFFFFFF 43690>>>>>>>>>>>Define vERROR_NO_MORE_FILES For |CI18 43690>>>>>>>>>>> 43690>>>>>>>>>>>// The defines below can be used to find out what kind of error has occured if 43690>>>>>>>>>>>// the API-call ShellExecute is used. 43690>>>>>>>>>>>Define vERROR_FILE_NOT_FOUND For |CI0002 43690>>>>>>>>>>>Define vERROR_PATH_NOT_FOUND For |CI0003 43690>>>>>>>>>>>Define vERROR_BAD_FORMAT For |CI0011 43690>>>>>>>>>>>Define vSE_ERR_ACCESSDENIED For |CI0005 43690>>>>>>>>>>>Define vSE_ERR_ASSOCINCOMPLETE For |CI0027 43690>>>>>>>>>>>Define vSE_ERR_DDEBUSY For |CI0030 43690>>>>>>>>>>>Define vSE_ERR_DDEFAIL For |CI0029 43690>>>>>>>>>>>Define vSE_ERR_DDETIMEOUT For |CI0028 43690>>>>>>>>>>>Define vSE_ERR_DLLNOTFOUND For |CI0032 43690>>>>>>>>>>>Define vSE_ERR_FNF For |CI0002 43690>>>>>>>>>>>Define vSE_ERR_NOASSOC For |CI0031 43690>>>>>>>>>>>Define vSE_ERR_OOM For |CI0008 43690>>>>>>>>>>>Define vSE_ERR_PNF For |CI0003 43690>>>>>>>>>>>Define vSE_ERR_SHARE For |CI0026 43690>>>>>>>>>>> 43690>>>>>>>>>>> 43690>>>>>>>>>>> 43690>>>>>>>>>>> 43690>>>>>>>>>>>// *WvA: 13-01-1999 Created 43690>>>>>>>>>>>// The Class cSelectFile_Dialog is created to support the function Select_File 43690>>>>>>>>>>>// This function opens the Windows standard file open dialog and returns the selected 43690>>>>>>>>>>>// file_name. 43690>>>>>>>>>>>Class cvSelectFile_Dialog Is An OpenDialog 43691>>>>>>>>>>> 43691>>>>>>>>>>> Procedure Construct_Object Integer iImage_Id 43693>>>>>>>>>>> Forward Send Construct_Object iImage_Id 43695>>>>>>>>>>> Set HideReadOnly_State To True 43696>>>>>>>>>>> End_Procedure // Construct_Object 43697>>>>>>>>>>> 43697>>>>>>>>>>> Function SelectedFileName Returns String 43699>>>>>>>>>>> String sFileName 43699>>>>>>>>>>> Move "" To sFileName 43700>>>>>>>>>>> If (Show_Dialog(Self)) Begin 43702>>>>>>>>>>> Move (RTrim(File_Name(Self))) To sFileName 43703>>>>>>>>>>> End 43703>>>>>>>>>>>> 43703>>>>>>>>>>> Function_Return sFileName 43704>>>>>>>>>>> End_Function // SelectedFileName 43705>>>>>>>>>>>End_Class // cvSelectFile_Dialog 43706>>>>>>>>>>> 43706>>>>>>>>>>>// *WvA: 13-01-1999 Created 43706>>>>>>>>>>>// This function opens the Windows standard file open dialog and returns the selected 43706>>>>>>>>>>>// file_name. Returns '' if the user didn't make a selection. 43706>>>>>>>>>>>// **WvA: 17-10-2003 Cleaned up and added code to destroy the dynamically created 43706>>>>>>>>>>>// file-open dialog 43706>>>>>>>>>>>Function vSelect_File Global String sSupportedFileTypes String sCaptionText ; String sInitialFolder Returns String 43708>>>>>>>>>>> String sSelectedFile 43708>>>>>>>>>>> Integer hoOpenFileDialog 43708>>>>>>>>>>> 43708>>>>>>>>>>> Object oOpenFileDialog Is A cvSelectFile_Dialog 43710>>>>>>>>>>> Set Dialog_Caption To sCaptionText 43711>>>>>>>>>>> Set Filter_String To sSupportedFileTypes 43712>>>>>>>>>>> Set Initial_Folder To sInitialFolder 43713>>>>>>>>>>> 43713>>>>>>>>>>> Move Self To hoOpenFileDialog 43714>>>>>>>>>>> End_Object // oOpenFileDialog 43715>>>>>>>>>>> 43715>>>>>>>>>>> Get SelectedFileName Of hoOpenFileDialog To sSelectedFile 43716>>>>>>>>>>> Send Destroy_Object To hoOpenFileDialog 43717>>>>>>>>>>> Function_Return sSelectedFile 43718>>>>>>>>>>>End_Function // vSelect_File 43719>>>>>>>>>>> 43719>>>>>>>>>>>// These functions will only work if you include the packages of vdfquery 43719>>>>>>>>>>>// 43719>>>>>>>>>>>//// Pre: sFileName contains the complete path of the file. 43719>>>>>>>>>>>//// Post: returns the complete path of the file. 43719>>>>>>>>>>>//// This function is inspired on function SEQ_ExtractPathFromFileName of Sture Andersen. 43719>>>>>>>>>>>//Function ParseFolderName Global String sFileName Returns String 43719>>>>>>>>>>>// String sFolderName 43719>>>>>>>>>>>// String sDirSeperator // this is "\" for windows, or "/" for unix 43719>>>>>>>>>>>// Move (sysconf(SYSCONF_DIR_SEPARATOR)) to sDirSeperator 43719>>>>>>>>>>>// If sDirSeperator in sFileName function_return (StripFromLastOccurance(sFileName,sDirSeperator)) 43719>>>>>>>>>>>// if ":" in sFileName function_return (StripFromLastOccurance(sFileName,":")) 43719>>>>>>>>>>>// Function_Return sFolderName 43719>>>>>>>>>>>//End_Function // ParseFolderName 43719>>>>>>>>>>> 43719>>>>>>>>>>> 43719>>>>>>>>>>>//// Pre: sFileName contains the complete path of the file. 43719>>>>>>>>>>>//// post: The returned filename will have a extension 43719>>>>>>>>>>>//Function ParseFileName Global String sFileName Returns String 43719>>>>>>>>>>>// String sFolderName 43719>>>>>>>>>>>// String sDirSeperator // this is "\" for windows, or "/" for unix 43719>>>>>>>>>>>// Move (sysconf(SYSCONF_DIR_SEPARATOR)) to sDirSeperator 43719>>>>>>>>>>>// Get ParseFolderName sFileName To sFolderName 43719>>>>>>>>>>>// If (sFolderName NE "") replace sFolderName in sFileName with "" 43719>>>>>>>>>>>// replace sDirSeperator in sFileName with "" 43719>>>>>>>>>>>// Function_Return sFilename 43719>>>>>>>>>>>//End_Function // ParseFileName 43719>>>>>>>>>>> 43719>>>>>>>>>>> 43719>>>>>>>>>>>// Pre: sFileName may contain the complete path of the file. 43719>>>>>>>>>>>// or contain multiple dots in the filename, so temp.gif.bak will 43719>>>>>>>>>>>// return "bak" as the extension and not "gif" 43719>>>>>>>>>>>// Post: returns the extension only, this extension can be a valid unixlike extension 43719>>>>>>>>>>>// such as "html" or "java" 43719>>>>>>>>>>>Function ParseFileExtension Global String sFileName Returns String 43721>>>>>>>>>>> String sFileExtension 43721>>>>>>>>>>> String sChar 43721>>>>>>>>>>> Integer iLength 43721>>>>>>>>>>> Integer iPos 43721>>>>>>>>>>> Boolean bIsDot 43721>>>>>>>>>>> Move "" To sFileExtension 43722>>>>>>>>>>> Move (Length(sFileName)) To iLength 43723>>>>>>>>>>> If ((iLength>0) And (Pos(".",sFileName) <> 0)) Begin 43725>>>>>>>>>>> Move iLength To iPos 43726>>>>>>>>>>> Move (False) To bIsDot 43727>>>>>>>>>>> While Not bIsDot 43731>>>>>>>>>>> Move (Mid(sFileName,1,iPos)) To sChar 43732>>>>>>>>>>> Decrement iPos 43733>>>>>>>>>>> If ((sChar=".") Or (iPos<1)) Begin 43735>>>>>>>>>>> Move (True) To bIsDot 43736>>>>>>>>>>> End 43736>>>>>>>>>>>> 43736>>>>>>>>>>> Else Begin 43737>>>>>>>>>>> Move (sChar+sFileExtension) To sFileExtension 43738>>>>>>>>>>> End 43738>>>>>>>>>>>> 43738>>>>>>>>>>> Loop 43739>>>>>>>>>>>> 43739>>>>>>>>>>> End 43739>>>>>>>>>>>> 43739>>>>>>>>>>> Function_Return sFileExtension 43740>>>>>>>>>>>End_Function // ParseFileExtension 43741>>>>>>>>>>> 43741>>>>>>>>>>> 43741>>>>>>>>>>> 43741>>>>>>>>>>>Function DDE_Error_To_String Integer iErrorID Returns String #REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE) 43743>>>>>>>>>>> String sMessage 43743>>>>>>>>>>> Case begin 43743>>>>>>>>>>> Case (iErrorID = vERROR_FILE_NOT_FOUND) 43745>>>>>>>>>>> Append sMessage "The specified file was not found.\n" 43746>>>>>>>>>>> Case Break 43747>>>>>>>>>>> Case (iErrorID = vERROR_PATH_NOT_FOUND) 43750>>>>>>>>>>> Append sMessage "The specified path was not found.\n" 43751>>>>>>>>>>> Case Break 43752>>>>>>>>>>> Case (iErrorID = vERROR_BAD_FORMAT) 43755>>>>>>>>>>> Append sMessage "The .EXE file is invalid.\n" 43756>>>>>>>>>>> Case Break 43757>>>>>>>>>>> Case (iErrorID = vSE_ERR_ACCESSDENIED) 43760>>>>>>>>>>> Append sMessage "The operating system denied access to the specified file.\n" 43761>>>>>>>>>>> Case Break 43762>>>>>>>>>>> Case (iErrorID = vSE_ERR_ASSOCINCOMPLETE) 43765>>>>>>>>>>> Append sMessage "The filename association is incomplete or invalid.\n" 43766>>>>>>>>>>> Case Break 43767>>>>>>>>>>> Case (iErrorID = vSE_ERR_DDEBUSY) 43770>>>>>>>>>>> Append sMessage "The DDE transaction could not be completed because other DDE\n" 43771>>>>>>>>>>> Append sMessage "transactions were being processed.\n" 43772>>>>>>>>>>> Case Break 43773>>>>>>>>>>> Case (iErrorID = vSE_ERR_DDEFAIL) 43776>>>>>>>>>>> Append sMessage "The DDE transaction failed.\n" 43777>>>>>>>>>>> Case Break 43778>>>>>>>>>>> Case (iErrorID = vSE_ERR_DDETIMEOUT) 43781>>>>>>>>>>> Append sMessage "The DDE transaction could not be completed,\n" 43782>>>>>>>>>>> Append sMessage "because the request timed out.\n" 43783>>>>>>>>>>> Case Break 43784>>>>>>>>>>> Case (iErrorID = vSE_ERR_DLLNOTFOUND) 43787>>>>>>>>>>> Append sMessage "The specified dynamic-link library was not found.\n" 43788>>>>>>>>>>> Case Break 43789>>>>>>>>>>> Case (iErrorID = vSE_ERR_NOASSOC) 43792>>>>>>>>>>> Append sMessage "There is no application associated with the given filename extension.\n" 43793>>>>>>>>>>> Case Break 43794>>>>>>>>>>> Case ((iErrorID = vSE_ERR_OOM) OR (iErrorID = 0)) 43797>>>>>>>>>>> Append sMessage "There is not enough free memory available to complete the operation.\n" 43798>>>>>>>>>>> Case Break 43799>>>>>>>>>>> Case (iErrorID = vSE_ERR_PNF) 43802>>>>>>>>>>> Append sMessage "The specified path was not found.\n" 43803>>>>>>>>>>> Case Break 43804>>>>>>>>>>> Case (iErrorID = vSE_ERR_SHARE) 43807>>>>>>>>>>> Append sMessage "A sharing violation occurred.\n" 43808>>>>>>>>>>> Case Break 43809>>>>>>>>>>> Case Else 43809>>>>>>>>>>> Append sMessage "Unknown DDE-error occurred.\n" 43810>>>>>>>>>>> Append sMessage ("Errornumber"*trim(iErrorID)*".\n") 43811>>>>>>>>>>> Case Break 43812>>>>>>>>>>> Case end 43812>>>>>>>>>>> Function_Return sMessage 43813>>>>>>>>>>>End_Function // DDE_Error_To_String 43814>>>>>>>>>>> 43814>>>>>>>>>>> 43814>>>>>>>>>>>Procedure vDDE_Error_Handler Integer iErrorID #REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE) 43816>>>>>>>>>>> String sMessage 43816>>>>>>>>>>> Get DDE_Error_To_String iErrorID To sMessage 43817>>>>>>>>>>> Append sMessage "\nPress a key to continue...\n\n" 43818>>>>>>>>>>> Send Stop_Box sMessage "a DDE-error occured" 43819>>>>>>>>>>>End_Procedure // vDDE_Error_Handler hInstance 43820>>>>>>>>>>> 43820>>>>>>>>>>> 43820>>>>>>>>>>>// Does the directory exist? - No = 0, Yes = 1 43820>>>>>>>>>>>// This also works with UNC path encoding and wildcards 43820>>>>>>>>>>>Function vFolderExists Global String sFolderName returns Integer 43822>>>>>>>>>>> String sFolder sTmp 43822>>>>>>>>>>> Integer bFolderExists iCh 43822>>>>>>>>>>> 43822>>>>>>>>>>> Move dfTrue to bFolderExists 43823>>>>>>>>>>> Move "dir:" to sFolder 43824>>>>>>>>>>> Append sFolder sFolderName 43825>>>>>>>>>>> Get Seq_New_Channel to iCh // get free channel for input 43826>>>>>>>>>>> Direct_input channel iCh sFolder 43828>>>>>>>>>>> Repeat 43828>>>>>>>>>>>> 43828>>>>>>>>>>> Readln channel iCh sTmp 43830>>>>>>>>>>> If (trim(sTmp)="") Move dfFalse to bFolderExists 43833>>>>>>>>>>> Else Begin 43834>>>>>>>>>>> Move dfTrue to bFolderExists 43835>>>>>>>>>>> indicate seqeof True // end loop 43836>>>>>>>>>>> End 43836>>>>>>>>>>>> 43836>>>>>>>>>>> Until (seqeof) 43838>>>>>>>>>>> Close_input channel iCh 43840>>>>>>>>>>> Send Seq_Release_Channel iCh 43841>>>>>>>>>>> Function_Return bFolderExists 43842>>>>>>>>>>>End_Function // vFolderExists 43843>>>>>>>>>>> 43843>>>>>>>>>>> 43843>>>>>>>>>>> 43843>>>>>>>>>>>// C-Structure 43843>>>>>>>>>>>//typedef struct _browseinfo { 43843>>>>>>>>>>>// HWND hwndOwner; 43843>>>>>>>>>>>// LPCITEMIDLIST pidlRoot; 43843>>>>>>>>>>>// LPSTR pszDisplayName; 43843>>>>>>>>>>>// LPCSTR lpszTitle; 43843>>>>>>>>>>>// UINT ulFlags; 43843>>>>>>>>>>>// BFFCALLBACK lpfn; 43843>>>>>>>>>>>// LPARAM lParam; 43843>>>>>>>>>>>// int iImage; 43843>>>>>>>>>>>//} BROWSEINFO, *PBROWSEINFO, *LPBROWSEINFO; 43843>>>>>>>>>>> 43843>>>>>>>>>>>//declare C structure struct_browseinfo 43843>>>>>>>>>>>//as documented in MSDN under Windows Shell API 43843>>>>>>>>>>>Type vtBrowseInfo 43843>>>>>>>>>>> Field vtBrowseInfo.hWndOwner as handle 43843>>>>>>>>>>> Field vtBrowseInfo.pIDLRoot as Pointer 43843>>>>>>>>>>> Field vtBrowseInfo.pszDisplayName as Pointer 43843>>>>>>>>>>> Field vtBrowseInfo.lpszTitle as Pointer 43843>>>>>>>>>>> Field vtBrowseInfo.ulFlags as dWord 43843>>>>>>>>>>> Field vtBrowseInfo.lpfnCallback as Pointer 43843>>>>>>>>>>> Field vtBrowseInfo.lParam as dWord 43843>>>>>>>>>>> Field vtBrowseInfo.iImage as dWord 43843>>>>>>>>>>>End_Type // tBrowseInfo 43843>>>>>>>>>>> 43843>>>>>>>>>>>// Browsing for directory. 43843>>>>>>>>>>>Define vBIF_RETURNONLYFSDIRS For |CI$0001 // For finding a folder to start document searching 43843>>>>>>>>>>>Define vBIF_DONTGOBELOWDOMAIN For |CI$0002 // For starting the Find Computer 43843>>>>>>>>>>>Define vBIF_STATUSTEXT For |CI$0004 // Includes a status area in the dialog box. 43843>>>>>>>>>>> // The callback function can set the status text by 43843>>>>>>>>>>> // sending messages to the dialog box. 43843>>>>>>>>>>>Define vBIF_RETURNFSANCESTORS For |CI$0008 // Only returns file system ancestors. 43843>>>>>>>>>>> 43843>>>>>>>>>>>Define vBIF_BROWSEFORCOMPUTER For |CI$1000 // Browsing for Computers. 43843>>>>>>>>>>>Define vBIF_BROWSEFORPRINTER For |CI$2000 // Browsing for Printers 43843>>>>>>>>>>> 43843>>>>>>>>>>>// message from browser 43843>>>>>>>>>>>//Define BFFM_INITIALIZED 1 43843>>>>>>>>>>>//Define BFFM_SELCHANGED 2 43843>>>>>>>>>>> 43843>>>>>>>>>>>// messages to browser 43843>>>>>>>>>>>//Define BFFM_SETSTATUSTEXT (WM_USER + 100) 43843>>>>>>>>>>>//Define BFFM_ENABLEOK (WM_USER + 101) 43843>>>>>>>>>>>//Define BFFM_SETSELECTION (WM_USER + 102) 43843>>>>>>>>>>> 43843>>>>>>>>>>> 43843>>>>>>>>>>>External_Function vWin32_SHBrowseForFolder "SHBrowseForFolder" shell32.dll ; pointer lpsBrowseInfo returns dWord 43844>>>>>>>>>>> 43844>>>>>>>>>>>External_Function vWin32_SHGetPathFromIDList "SHGetPathFromIDList" shell32.dll ; pointer pidList pointer lpBuffer returns dWord 43845>>>>>>>>>>> 43845>>>>>>>>>>>External_Function vWin32_CoTaskMemFree "CoTaskMemFree" ole32.dll pointer pV returns Integer 43846>>>>>>>>>>> 43846>>>>>>>>>>>// returns folder name if a folder was selected, otherwise returns "" 43846>>>>>>>>>>>Function vSHBrowseForFolder Global String sDialogTitle returns String 43848>>>>>>>>>>> string sFolder sBrowseInfo sTitle 43848>>>>>>>>>>> pointer lpItemIdList lpsFolder lpsBrowseInfo lpsTitle 43848>>>>>>>>>>> integer iFolderSelected iRetval 43848>>>>>>>>>>> 43848>>>>>>>>>>> // fill string variable with null characters 43848>>>>>>>>>>> ZeroType vtBrowseInfo to sBrowseInfo 43849>>>>>>>>>>> 43849>>>>>>>>>>> If (sDialogTitle<>"") Begin 43851>>>>>>>>>>> Move sDialogTitle to sTitle 43852>>>>>>>>>>> // Torben Lund suggested converting the string with toansi. Doing it like that 43852>>>>>>>>>>> // disables showing some commonly used ascii characters like ascii 137 () 43852>>>>>>>>>>> // These chars are correctly shown if no toansi is used. 43852>>>>>>>>>>> // I can imagine that he wanted to path to be ANSI, but as long as it isa just 43852>>>>>>>>>>> // selected it will always be valid. 43852>>>>>>>>>>> GetAddress of sTitle to lpsTitle 43853>>>>>>>>>>> Put lpsTitle to sBrowseInfo at vtBrowseInfo.lpszTitle 43854>>>>>>>>>>> End 43854>>>>>>>>>>>> 43854>>>>>>>>>>> 43854>>>>>>>>>>> Put vBIF_RETURNONLYFSDIRS to sBrowseInfo at vtBrowseInfo.ulFlags 43855>>>>>>>>>>> 43855>>>>>>>>>>> // Torben Lund added line below. Move handle of focus object to structure before 43855>>>>>>>>>>> // calling function. Otherwise, the folderdialog will be started as a seperate task. 43855>>>>>>>>>>> Put (window_handle(focus(desktop))) to sBrowseInfo at vtBrowseInfo.hWndOwner 43856>>>>>>>>>>> 43856>>>>>>>>>>> GetAddress of sBrowseInfo to lpsBrowseInfo 43857>>>>>>>>>>> 43857>>>>>>>>>>> // null 128 chars into var (make space) 43857>>>>>>>>>>> move (repeat(character(0), vMAX_PATH)) to sFolder 43858>>>>>>>>>>> GetAddress of sFolder to lpsFolder 43859>>>>>>>>>>> 43859>>>>>>>>>>> // select folder 43859>>>>>>>>>>> move (vWin32_SHBrowseForFolder(lpsBrowseInfo)) to lpItemIdList 43860>>>>>>>>>>> // get selected folder name 43860>>>>>>>>>>> move (vWin32_SHGetPathFromIDList(lpItemIdList, lpsFolder)) to iFolderSelected 43861>>>>>>>>>>> 43861>>>>>>>>>>> // release memory resources that are used by the ItemIdList 43861>>>>>>>>>>> move (vWin32_CoTaskMemFree(lpItemIdList)) to iRetval 43862>>>>>>>>>>> 43862>>>>>>>>>>> If (iFolderSelected<>0) function_return (CString(sFolder)) 43865>>>>>>>>>>> Else Function_Return "" 43867>>>>>>>>>>>End_Function // vSHBrowseForFolder 43868>>>>>>>>>>> 43868>>>>>>>>>>> 43868>>>>>>>>>>> 43868>>>>>>>>>>>Type vtSecurity_attributes 43868>>>>>>>>>>> Field vtSecurity_attributes.nLength as dWord 43868>>>>>>>>>>> Field vtSecurity_attributes.lpDescriptor as Pointer 43868>>>>>>>>>>> Field vtSecurity_attributes.bInheritHandle as Integer 43868>>>>>>>>>>>End_Type // vtSecurity_attributes 43868>>>>>>>>>>> 43868>>>>>>>>>>>//nLength: 43868>>>>>>>>>>>// Specifies the size, in bytes, of this structure. Set this value to the size of the 43868>>>>>>>>>>>// SECURITY_ATTRIBUTES structure. 43868>>>>>>>>>>>// Windows NT: Some functions that use the SECURITY_ATTRIBUTES structure do not verify the 43868>>>>>>>>>>>// value of the nLength member. However, an application should still set it properly. 43868>>>>>>>>>>>// That ensures current, future, and cross-platform compatibility. 43868>>>>>>>>>>>// 43868>>>>>>>>>>>//lpSecurityDescriptor: 43868>>>>>>>>>>>// Points to a security descriptor for the object that controls the sharing of it. 43868>>>>>>>>>>>// If NULL is specified for this member, the object may be assigned the default security 43868>>>>>>>>>>>// descriptor of the calling process. 43868>>>>>>>>>>>// 43868>>>>>>>>>>>//bInheritHandle: 43868>>>>>>>>>>>// Specifies whether the returned handle is inherited when a new process is created. 43868>>>>>>>>>>>// If this member is TRUE, the new process inherits the handle. 43868>>>>>>>>>>> 43868>>>>>>>>>>> 43868>>>>>>>>>>>// BOOL CreateDirectory( 43868>>>>>>>>>>>// LPCTSTR lpPathName, 43868>>>>>>>>>>>// LPSECURITY_ATTRIBUTES lpSecurityAttributes // pointer to a security descriptor 43868>>>>>>>>>>>// ); 43868>>>>>>>>>>>// 43868>>>>>>>>>>>// lpPathName 43868>>>>>>>>>>>// Points to a null-terminated string that specifies the path of the directory 43868>>>>>>>>>>>// to be created. 43868>>>>>>>>>>>// There is a default string size limit for paths of MAX_PATH characters. 43868>>>>>>>>>>>// This limit is related to how the CreateDirectory function parses paths. 43868>>>>>>>>>>>// lpSecurityAttributes 43868>>>>>>>>>>>// Pointer to a SECURITY_ATTRIBUTES structure als called a security descriptor that 43868>>>>>>>>>>>// determines whether the returned handle can be inherited by child processes. 43868>>>>>>>>>>>// If lpSecurityAttributes is NULL, the handle cannot be inherited. 43868>>>>>>>>>>>// Returns: 43868>>>>>>>>>>>// If the function succeeds, the return value is nonzero. 43868>>>>>>>>>>>// If the function fails, the return value is zero. To get extended error information, call GetLastError. 43868>>>>>>>>>>>External_Function vWin32_CreateDirectory "CreateDirectoryA" kernel32.dll ; Pointer lpPathName Pointer lpSecurity_Attributes returns Integer 43869>>>>>>>>>>> 43869>>>>>>>>>>> 43869>>>>>>>>>>>// lpPathName 43869>>>>>>>>>>>// Points to a null-terminated string that specifies the path of the directory 43869>>>>>>>>>>>// to be removed. 43869>>>>>>>>>>>// There is a default string size limit for paths of MAX_PATH characters. 43869>>>>>>>>>>>// Returns: 43869>>>>>>>>>>>// If the function succeeds, the return value is nonzero. 43869>>>>>>>>>>>// If the function fails, the return value is zero. To get extended error information, call GetLastError. 43869>>>>>>>>>>>External_Function vWin32_RemoveDirectory "RemoveDirectoryA" kernel32.dll ; Pointer lpPathName returns Integer 43870>>>>>>>>>>> 43870>>>>>>>>>>> 43870>>>>>>>>>>>// returns 0 if the folder is created. 43870>>>>>>>>>>>// 1 if the API-call returned an error. 43870>>>>>>>>>>>Function vCreateDirectory Global String sNewFolder Returns Integer 43872>>>>>>>>>>> String sFolder sSA 43872>>>>>>>>>>> Pointer lpsFolder lpsSecurity_Attributes lpDescriptor 43872>>>>>>>>>>> Integer iRetval bFolderCreated bInheritHandle 43872>>>>>>>>>>> 43872>>>>>>>>>>> Move (False) To bFolderCreated 43873>>>>>>>>>>> // fill string variable with null characters 43873>>>>>>>>>>> ZeroType vtSecurity_attributes To sSA 43874>>>>>>>>>>> 43874>>>>>>>>>>> // null MAX_PATH chars into var (make space) 43874>>>>>>>>>>> Move (repeat(character(0), vMAX_PATH)) To sFolder 43875>>>>>>>>>>> 43875>>>>>>>>>>> If (sNewFolder <> "") Begin 43877>>>>>>>>>>> 43877>>>>>>>>>>> Move dfTrue To bInheritHandle 43878>>>>>>>>>>> // Setting this to NULL is already done by the zerotype command 43878>>>>>>>>>>> // Move NULL To lpDescriptor 43878>>>>>>>>>>> Put (length(sSA)) To sSA at vtSecurity_attributes.nLength 43879>>>>>>>>>>> //Put lpDescriptor To sSA at vtSecurity_attributes.lpDescriptor 43879>>>>>>>>>>> Put bInheritHandle To sSA at vtSecurity_attributes.bInheritHandle 43880>>>>>>>>>>> 43880>>>>>>>>>>> GetAddress Of sSA To lpsSecurity_Attributes 43881>>>>>>>>>>> 43881>>>>>>>>>>> // 43881>>>>>>>>>>> Move sNewFolder to sFolder 43882>>>>>>>>>>> GetAddress of sFolder to lpsFolder 43883>>>>>>>>>>> Move (vWin32_CreateDirectory(lpsFolder, lpsSecurity_Attributes)) to bFolderCreated 43884>>>>>>>>>>> End 43884>>>>>>>>>>>> 43884>>>>>>>>>>> 43884>>>>>>>>>>> IfNot bFolderCreated Move 1 To iRetVal 43887>>>>>>>>>>> Function_Return iRetVal 43888>>>>>>>>>>>End_Function // vCreateDirectory 43889>>>>>>>>>>> 43889>>>>>>>>>>> 43889>>>>>>>>>>>// **WvA: 03-02-2002 Function created. 43889>>>>>>>>>>>// With this function one can remove a directory. 43889>>>>>>>>>>>// returns 0 if the folder is removed. 43889>>>>>>>>>>>// 1 if the API-call returned an error (Use GetLastError API to get the details) 43889>>>>>>>>>>>// 2 if the folder did not exist 43889>>>>>>>>>>>// 3 if the sFolder parameter passed is equal to "" 43889>>>>>>>>>>>Function vRemoveDirectory Global String sFolder Returns Integer 43891>>>>>>>>>>> String sPath 43891>>>>>>>>>>> Pointer lpsPath 43891>>>>>>>>>>> Integer iRetval bRemoved bExists 43891>>>>>>>>>>> 43891>>>>>>>>>>> Move (False) To bRemoved 43892>>>>>>>>>>> Move 0 To iRetVal 43893>>>>>>>>>>> Move (Trim(sFolder)) To sFolder 43894>>>>>>>>>>> If (sFolder="") Begin 43896>>>>>>>>>>> Move 3 To iRetVal 43897>>>>>>>>>>> End 43897>>>>>>>>>>>> 43897>>>>>>>>>>> If (vFolderExists(sFolder)=False) Begin 43899>>>>>>>>>>> Move 2 To iRetVal 43900>>>>>>>>>>> End 43900>>>>>>>>>>>> 43900>>>>>>>>>>> If (iRetVal=0) Begin 43902>>>>>>>>>>> // null MAX_PATH chars into var (make space) 43902>>>>>>>>>>> Move (repeat(character(0), vMAX_PATH)) To sPath 43903>>>>>>>>>>> // 43903>>>>>>>>>>> Move (Insert(sFolder,sPath,1)) To sPath 43904>>>>>>>>>>> GetAddress of sPath to lpsPath 43905>>>>>>>>>>> Move (vWin32_RemoveDirectory(lpsPath)) to bRemoved 43906>>>>>>>>>>> End 43906>>>>>>>>>>>> 43906>>>>>>>>>>> 43906>>>>>>>>>>> If ((iRetVal=0) And (bRemoved=False)) Begin 43908>>>>>>>>>>> Move 1 To iRetVal 43909>>>>>>>>>>> End 43909>>>>>>>>>>>> 43909>>>>>>>>>>> Function_Return iRetVal 43910>>>>>>>>>>>End_Function // vRemoveDirectory 43911>>>>>>>>>>> 43911>>>>>>>>>>> 43911>>>>>>>>>>> 43911>>>>>>>>>>>// This function informs the user that he entered a yet unknown folder and 43911>>>>>>>>>>>// asks if he/she wants to create the folder (Yes/No) 43911>>>>>>>>>>>// Choice: "Yes" - this creates the folder 43911>>>>>>>>>>>// if successful, the function returns false 43911>>>>>>>>>>>// else it will be true. 43911>>>>>>>>>>>// Choice: "No" - returns TRUE, This allows the programmer to take action 43911>>>>>>>>>>>// For example: to stop a save 43911>>>>>>>>>>>// Precondition: A foldername must be entered. We do not check for empty paths 43911>>>>>>>>>>>// This function returns a non-zero value if the folder isn't created afterwards 43911>>>>>>>>>>>Function vVerifyNewFolder Global String sFolderName Returns Integer 43913>>>>>>>>>>> Integer bIsNotValid 43913>>>>>>>>>>> Integer iUsers_Choice 43913>>>>>>>>>>> String sMessage 43913>>>>>>>>>>> 43913>>>>>>>>>>> If (vFolderExists(sFolderName) EQ 0) Begin 43915>>>>>>>>>>> Move "The folder '" To sMessage 43916>>>>>>>>>>> Append sMessage sFolderName 43917>>>>>>>>>>> Append sMessage "' does not yet exist,\n" 43918>>>>>>>>>>> Append sMessage "Do you want to create it now?" 43919>>>>>>>>>>> Get YesNo_Box sMessage "Confirm" MB_DefButton1 To iUsers_Choice 43920>>>>>>>>>>> Case Begin 43920>>>>>>>>>>> Case (iUsers_Choice = MBR_Yes) 43922>>>>>>>>>>> Move (vCreateDirectory(sFolderName)) to bIsNotValid 43923>>>>>>>>>>> If bIsNotValid Begin 43925>>>>>>>>>>> Move "An error occurred while trying to create folder '" To sMessage 43926>>>>>>>>>>> Append sMessage sFolderName "'.\n\n" 43928>>>>>>>>>>> Send Info_Box sMessage "Info" 43929>>>>>>>>>>> End 43929>>>>>>>>>>>> 43929>>>>>>>>>>> Case Break 43930>>>>>>>>>>> Case (iUsers_Choice = MBR_No) 43933>>>>>>>>>>> Move dfTrue To bIsNotValid // Cancel the save 43934>>>>>>>>>>> Case Break 43935>>>>>>>>>>> Case End 43935>>>>>>>>>>> End 43935>>>>>>>>>>>> 43935>>>>>>>>>>> Function_return bIsNotValid 43936>>>>>>>>>>>End_Function // vVerifyNewFolder 43937>>>>>>>>>>> 43937>>>>>>>>>>> 43937>>>>>>>>>>>// The ShellExecute function opens or prints a specified file. The file can be an 43937>>>>>>>>>>>// executable file or a document file. 43937>>>>>>>>>>>// 43937>>>>>>>>>>>// Operation can be one of the following: 43937>>>>>>>>>>>// "OPEN" The function opens the file specified by lpFile. 43937>>>>>>>>>>>// The file can be an executable file or a document file. 43937>>>>>>>>>>>// The file can be a folder to open. 43937>>>>>>>>>>>// "PRINT" The function prints the file specified by lpFile. 43937>>>>>>>>>>>// The file should be a document file. If the file is an executable file, 43937>>>>>>>>>>>// the function opens the file, as if open had been specified. 43937>>>>>>>>>>>// "EXPLORE" The function explores the folder specified by lpFile. 43937>>>>>>>>>>>// 43937>>>>>>>>>>>// Return Values: 43937>>>>>>>>>>>// 43937>>>>>>>>>>>// If the function succeeds, the return value is the instance handle of the application that 43937>>>>>>>>>>>// was run, or the handle of a dynamic data exchange (DDE) server application. 43937>>>>>>>>>>>// If the function fails, the return value is an error value that is less than or equal to 32. 43937>>>>>>>>>>>// 43937>>>>>>>>>>>// The following table lists these error values: 43937>>>>>>>>>>>// Public Const ERROR_FILE_NOT_FOUND = 2& 43937>>>>>>>>>>>// Public Const ERROR_PATH_NOT_FOUND = 3& 43937>>>>>>>>>>>// Public Const ERROR_BAD_FORMAT = 11& 43937>>>>>>>>>>>// Public Const SE_ERR_ACCESSDENIED = 5 43937>>>>>>>>>>>// Public Const SE_ERR_ASSOCINCOMPLETE = 27 43937>>>>>>>>>>>// Public Const SE_ERR_DDEBUSY = 30 43937>>>>>>>>>>>// Public Const SE_ERR_DDEFAIL = 29 43937>>>>>>>>>>>// Public Const SE_ERR_DDETIMEOUT = 28 43937>>>>>>>>>>>// Public Const SE_ERR_DLLNOTFOUND = 32 43937>>>>>>>>>>>// Public Const SE_ERR_FNF = 2 43937>>>>>>>>>>>// Public Const SE_ERR_NOASSOC = 31 43937>>>>>>>>>>>// Public Const SE_ERR_OOM = 8 43937>>>>>>>>>>>// Public Const SE_ERR_PNF = 3 43937>>>>>>>>>>>// Public Const SE_ERR_SHARE = 26 43937>>>>>>>>>>> 43937>>>>>>>>>>> 43937>>>>>>>>>>> 43937>>>>>>>>>>>// Code to open the program that is associated with the selected file. 43937>>>>>>>>>>>// 43937>>>>>>>>>>>// External function call used in Procedure DoStartDocument 43937>>>>>>>>>>>External_Function vWin32_ShellExecute "ShellExecuteA" shell32.dll ; Handle hWnd ; Pointer lpOperation ; Pointer lpFile ; Pointer lpParameters ; Pointer lpDirectory ; Dword iShowCmd Returns Handle 43938>>>>>>>>>>> 43938>>>>>>>>>>> 43938>>>>>>>>>>>// This will perform an operation on a file (e.g. open) with the application 43938>>>>>>>>>>>// registered in the Windows Registry to open that type of file (via its extension) 43938>>>>>>>>>>>// sOperation would be "OPEN" (it could also be "PRINT" etc). 43938>>>>>>>>>>>Procedure vShellExecute global String sOperation String sDocument String sParameters String sPath 43940>>>>>>>>>>> Handle hInstance hWnd 43940>>>>>>>>>>> Pointer lpsOperation 43940>>>>>>>>>>> Pointer lpsDocument 43940>>>>>>>>>>> Pointer lpsParameters 43940>>>>>>>>>>> Pointer lpsPath 43940>>>>>>>>>>> // remove any leading/trailing spaces in the string 43940>>>>>>>>>>> Move (Trim(sDocument)) To sDocument 43941>>>>>>>>>>> Move (Trim(sPath)) To sPath 43942>>>>>>>>>>> // Make the strings readable for windows API, by converting them to null-terminated 43942>>>>>>>>>>> Append sOperation (Character(0)) 43943>>>>>>>>>>> Append sDocument (Character(0)) 43944>>>>>>>>>>> Append sParameters (Character(0)) 43945>>>>>>>>>>> Append sPath (Character(0)) 43946>>>>>>>>>>> // Connect the corresponding pointers to the strings 43946>>>>>>>>>>> GetAddress Of sOperation to lpsOperation 43947>>>>>>>>>>> GetAddress Of sDocument to lpsDocument 43948>>>>>>>>>>> GetAddress Of sParameters to lpsParameters 43949>>>>>>>>>>> GetAddress Of sPath to lpsPath 43950>>>>>>>>>>> 43950>>>>>>>>>>> Get Window_Handle To hWnd 43951>>>>>>>>>>> Move (vWin32_ShellExecute (hWnd, lpsOperation, lpsDocument, lpsParameters, lpsPath, 1)) To hInstance 43952>>>>>>>>>>> If (hInstance <= 32) Begin 43954>>>>>>>>>>> Send vDDE_Error_Handler hInstance 43955>>>>>>>>>>> End 43955>>>>>>>>>>>> 43955>>>>>>>>>>>End_Procedure // vShellExecute 43956>>>>>>>>>>> 43956>>>>>>>>>>> 43956>>>>>>>>>>> 43956>>>>>>>>>>> 43956>>>>>>>>>>> // Must be freed using SHFreeNameMappings 43956>>>>>>>>>>> 43956>>>>>>>>>>>Type vtShFileOpStruct 43956>>>>>>>>>>> Field vtShFileOpStruct.hWnd as Handle 43956>>>>>>>>>>> Field vtShFileOpStruct.wFunc as Integer 43956>>>>>>>>>>> Field vtShFileOpStruct.pFrom as Pointer 43956>>>>>>>>>>> Field vtShFileOpStruct.pTo as Pointer 43956>>>>>>>>>>> Field vtShFileOpStruct.fFlags as Short 43956>>>>>>>>>>> Field vtShFileOpStruct.fAnyOperationsAborted as Short 43956>>>>>>>>>>> Field vtShFileOpStruct.hNameMappings as Pointer 43956>>>>>>>>>>> Field vtShFileOpStruct.lpszProgressTitle as Pointer // only used if FOF_SIMPLEPROGRESS 43956>>>>>>>>>>>End_Type // tShFileOpStruct 43956>>>>>>>>>>> 43956>>>>>>>>>>>// hwnd 43956>>>>>>>>>>>// Handle of the dialog box to use to display information about the status of the operation. 43956>>>>>>>>>>> 43956>>>>>>>>>>>// wFunc 43956>>>>>>>>>>>// Operation to perform. This member can be one of the following values: 43956>>>>>>>>>>>// FO_COPY Copies the files specified by pFrom to the location specified by pTo. 43956>>>>>>>>>>>// FO_DELETE Deletes the files specified by pFrom (pTo is ignored). 43956>>>>>>>>>>>// FO_MOVE Moves the files specified by pFrom to the location specified by pTo. 43956>>>>>>>>>>>// FO_RENAME Renames the files specified by pFrom. 43956>>>>>>>>>>> 43956>>>>>>>>>>>// pFrom 43956>>>>>>>>>>>// Pointer to a buffer that specifies one or more source file names. Multiple names must 43956>>>>>>>>>>>// be null-separated. The list of names must be double null-terminated. 43956>>>>>>>>>>> 43956>>>>>>>>>>>// pTo 43956>>>>>>>>>>>// Pointer to a buffer that contains the name of the destination file or directory. The 43956>>>>>>>>>>>// buffer can contain mutiple destination file names if the fFlags member specifies 43956>>>>>>>>>>>// FOF_MULTIDESTFILES. Multiple names must be null-separated. The list of names must be 43956>>>>>>>>>>>// double null-terminated. 43956>>>>>>>>>>> 43956>>>>>>>>>>>// fAnyOperationsAborted 43956>>>>>>>>>>>// Value that receives TRUE if the user aborted any file operations before they 43956>>>>>>>>>>>// were completed or FALSE otherwise. 43956>>>>>>>>>>> 43956>>>>>>>>>>> 43956>>>>>>>>>>>// Performs a copy, move, rename, or delete operation on a file system object. 43956>>>>>>>>>>>// This can be a file or a folder. 43956>>>>>>>>>>>// With thanks to Andrew S Kaplan 43956>>>>>>>>>>>External_Function vWin32_SHFileOperation "SHFileOperationA" Shell32.dll ; pointer lpFileOp returns integer 43957>>>>>>>>>>> 43957>>>>>>>>>>> 43957>>>>>>>>>>> 43957>>>>>>>>>>>Function vDeleteFile Global String sFileName Returns Integer 43959>>>>>>>>>>> String sShFileOp 43959>>>>>>>>>>> Pointer lpShFileOp 43959>>>>>>>>>>> Pointer lpsFileName 43959>>>>>>>>>>> Integer iFlags 43959>>>>>>>>>>> Integer iRetVal 43959>>>>>>>>>>> Integer bUserAbort 43959>>>>>>>>>>> 43959>>>>>>>>>>> ZeroType vtShFileOpStruct To sShFileOp 43960>>>>>>>>>>> Append sFileName (Character(0)) (Character(0)) 43962>>>>>>>>>>> GetAddress of sFileName to lpsFileName 43963>>>>>>>>>>> Move (vFOF_SILENT iOr vFOF_NOCONFIRMATION iOr vFOF_ALLOWUNDO) To iFlags 43964>>>>>>>>>>> 43964>>>>>>>>>>> Put vFO_DELETE To sShFileOp at vtShFileOpStruct.wFunc 43965>>>>>>>>>>> Put lpsFileName To sShFileOp at vtShFileOpStruct.pFrom 43966>>>>>>>>>>> Put iFlags To sShFileOp at vtShFileOpStruct.fFlags 43967>>>>>>>>>>> GetAddress of sShFileOp To lpShFileOp 43968>>>>>>>>>>> 43968>>>>>>>>>>> Move (vWin32_SHFileOperation(lpShFileOp)) To iRetVal 43969>>>>>>>>>>> GetBuff from sShFileOp At vtShFileOpStruct.fAnyOperationsAborted To bUserAbort 43970>>>>>>>>>>> If (bUserAbort <> 0) Begin 43972>>>>>>>>>>> Move 80 To iRetVal // Deletefile Operation Aborted by USER 43973>>>>>>>>>>> End 43973>>>>>>>>>>>> 43973>>>>>>>>>>> Function_return iRetVal 43974>>>>>>>>>>>End_Function // vDeleteFile 43975>>>>>>>>>>> 43975>>>>>>>>>>> 43975>>>>>>>>>>>Function vCopyFile Global String sSource String sDestination returns Integer 43977>>>>>>>>>>> String sShFileOp 43977>>>>>>>>>>> Pointer lpShFileOp 43977>>>>>>>>>>> Pointer lpsSource 43977>>>>>>>>>>> Pointer lpsDestination 43977>>>>>>>>>>> Integer iFlags 43977>>>>>>>>>>> Integer iRetVal 43977>>>>>>>>>>> Integer bUserAbort 43977>>>>>>>>>>> 43977>>>>>>>>>>> ZeroType vtShFileOpStruct To sShFileOp 43978>>>>>>>>>>> Append sSource (Character(0)) (Character(0)) 43980>>>>>>>>>>> Append sDestination (Character(0)) (Character(0)) 43982>>>>>>>>>>> GetAddress of sSource To lpsSource 43983>>>>>>>>>>> GetAddress of sDestination To lpsDestination 43984>>>>>>>>>>> Move (vFOF_SILENT iOr vFOF_NOCONFIRMATION iOr vFOF_ALLOWUNDO) To iFlags 43985>>>>>>>>>>> 43985>>>>>>>>>>> Put vFO_COPY To sShFileOp at vtShFileOpStruct.wFunc 43986>>>>>>>>>>> Put lpsSource To sShFileOp at vtShFileOpStruct.pFrom 43987>>>>>>>>>>> Put lpsDestination To sShFileOp at vtShFileOpStruct.pTo 43988>>>>>>>>>>> Put iFlags To sShFileOp at vtShFileOpStruct.fFlags 43989>>>>>>>>>>> 43989>>>>>>>>>>> GetAddress of sShFileOp To lpShFileOp 43990>>>>>>>>>>> 43990>>>>>>>>>>> Move (vWin32_SHFileOperation(lpShFileOp)) To iRetVal 43991>>>>>>>>>>> GetBuff from sShFileOp At vtShFileOpStruct.fAnyOperationsAborted To bUserAbort 43992>>>>>>>>>>> If (bUserAbort <> 0) Begin 43994>>>>>>>>>>> Move 80 To iRetVal // Copyfile Operation Aborted by USER 43995>>>>>>>>>>> End 43995>>>>>>>>>>>> 43995>>>>>>>>>>> Function_return (iRetVal) 43996>>>>>>>>>>>End_Function // vCopyFile 43997>>>>>>>>>>> 43997>>>>>>>>>>> 43997>>>>>>>>>>>Function vMoveFile Global String sSource String sDestination returns Integer 43999>>>>>>>>>>> String sShFileOp 43999>>>>>>>>>>> Pointer lpShFileOp 43999>>>>>>>>>>> Pointer lpsSource 43999>>>>>>>>>>> Pointer lpsDestination 43999>>>>>>>>>>> Integer iFlags 43999>>>>>>>>>>> Integer iRetVal 43999>>>>>>>>>>> Integer bUserAbort 43999>>>>>>>>>>> 43999>>>>>>>>>>> ZeroType vtShFileOpStruct To sShFileOp 44000>>>>>>>>>>> Append sSource (Character(0)) (Character(0)) 44002>>>>>>>>>>> Append sDestination (Character(0)) (Character(0)) 44004>>>>>>>>>>> GetAddress of sSource To lpsSource 44005>>>>>>>>>>> GetAddress of sDestination To lpsDestination 44006>>>>>>>>>>> Move (vFOF_SILENT iOr vFOF_NOCONFIRMATION iOr vFOF_ALLOWUNDO) To iFlags 44007>>>>>>>>>>> 44007>>>>>>>>>>> Put vFO_MOVE To sShFileOp at vtShFileOpStruct.wFunc 44008>>>>>>>>>>> Put lpsSource To sShFileOp at vtShFileOpStruct.pFrom 44009>>>>>>>>>>> Put lpsDestination To sShFileOp at vtShFileOpStruct.pTo 44010>>>>>>>>>>> Put iFlags To sShFileOp at vtShFileOpStruct.fFlags 44011>>>>>>>>>>> 44011>>>>>>>>>>> GetAddress of sShFileOp To lpShFileOp 44012>>>>>>>>>>> 44012>>>>>>>>>>> Move (vWin32_SHFileOperation(lpShFileOp)) To iRetVal 44013>>>>>>>>>>> GetBuff from sShFileOp At vtShFileOpStruct.fAnyOperationsAborted To bUserAbort 44014>>>>>>>>>>> If (bUserAbort <> 0) Begin 44016>>>>>>>>>>> Move 80 To iRetVal // Movefile Operation Aborted by USER 44017>>>>>>>>>>> End 44017>>>>>>>>>>>> 44017>>>>>>>>>>> Function_return (iRetVal) 44018>>>>>>>>>>>End_Function // vMoveFile 44019>>>>>>>>>>> 44019>>>>>>>>>>>// Rename a file or folder 44019>>>>>>>>>>>// Returns a nonzero value if the operation failed. 44019>>>>>>>>>>>Function vRenameFile Global String sSource String sDestination returns Integer 44021>>>>>>>>>>> String sShFileOp 44021>>>>>>>>>>> Pointer lpShFileOp 44021>>>>>>>>>>> Pointer lpsSource 44021>>>>>>>>>>> Pointer lpsDestination 44021>>>>>>>>>>> Integer iFlags 44021>>>>>>>>>>> Integer iRetVal 44021>>>>>>>>>>> Integer bUserAbort 44021>>>>>>>>>>> 44021>>>>>>>>>>> ZeroType vtShFileOpStruct To sShFileOp 44022>>>>>>>>>>> Append sSource (Character(0)) (Character(0)) 44024>>>>>>>>>>> Append sDestination (Character(0)) (Character(0)) 44026>>>>>>>>>>> GetAddress of sSource To lpsSource 44027>>>>>>>>>>> GetAddress of sDestination To lpsDestination 44028>>>>>>>>>>> Move (vFOF_SILENT iOr vFOF_NOCONFIRMATION iOr vFOF_ALLOWUNDO) To iFlags 44029>>>>>>>>>>> 44029>>>>>>>>>>> Put vFO_RENAME To sShFileOp at vtShFileOpStruct.wFunc 44030>>>>>>>>>>> Put lpsSource To sShFileOp at vtShFileOpStruct.pFrom 44031>>>>>>>>>>> Put lpsDestination To sShFileOp at vtShFileOpStruct.pTo 44032>>>>>>>>>>> Put iFlags To sShFileOp at vtShFileOpStruct.fFlags 44033>>>>>>>>>>> 44033>>>>>>>>>>> GetAddress of sShFileOp To lpShFileOp 44034>>>>>>>>>>> 44034>>>>>>>>>>> Move (vWin32_SHFileOperation(lpShFileOp)) To iRetVal 44035>>>>>>>>>>> GetBuff from sShFileOp At vtShFileOpStruct.fAnyOperationsAborted To bUserAbort 44036>>>>>>>>>>> If (bUserAbort <> 0) Begin 44038>>>>>>>>>>> Move 80 To iRetVal // Renamefile Operation Aborted by USER 44039>>>>>>>>>>> End 44039>>>>>>>>>>>> 44039>>>>>>>>>>> Function_return (iRetVal) 44040>>>>>>>>>>>End_Function // vRenameFile 44041>>>>>>>>>>> 44041>>>>>>>>>>> 44041>>>>>>>>>>>// Thanks To Oliver Nelson for posting this code on the newsgroups 44041>>>>>>>>>>>External_function vWin32_GetWindowsDirectory "GetWindowsDirectoryA" kernel32.dll ; Pointer lpBuffer Integer nSize returns integer 44042>>>>>>>>>>> 44042>>>>>>>>>>> 44042>>>>>>>>>>>Function vGetWindowsDirectory Returns String #REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE) 44044>>>>>>>>>>> String sDirectory 44044>>>>>>>>>>> Pointer lpDirectory 44044>>>>>>>>>>> Integer iVoid 44044>>>>>>>>>>> 44044>>>>>>>>>>> ZeroString vMAX_PATH to sDirectory 44045>>>>>>>>>>> GetAddress of sDirectory to lpDirectory 44046>>>>>>>>>>> 44046>>>>>>>>>>> Move (vWin32_GetWindowsDirectory(lpDirectory, vMAX_PATH)) to iVoid 44047>>>>>>>>>>> Function_Return (CString(sDirectory)) // **WvA: Changed to CString() 44048>>>>>>>>>>>End_Function // vGetWindowsDirectory 44049>>>>>>>>>>> 44049>>>>>>>>>>> 44049>>>>>>>>>>> 44049>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44049>>>>>>>>>>>//External_Function vWin32_GetTempFileName "GetTempFileNameA" Kernel32.Dll ; 44049>>>>>>>>>>>// Pointer lpPathName ; 44049>>>>>>>>>>>// Pointer lpPrefixString ; 44049>>>>>>>>>>>// Integer uUnique ; 44049>>>>>>>>>>>// Pointer lpTempFileName ; 44049>>>>>>>>>>>// Returns Integer 44049>>>>>>>>>>> 44049>>>>>>>>>>>External_Function vWin32_GetTempFileName "GetTempFileNameA" kernel32.dll String sPath ; String sPrefix Integer iUnique Pointer pLoad Returns Integer 44050>>>>>>>>>>> 44050>>>>>>>>>>>External_Function vWin32_GetTempPath "GetTempPathA" Kernel32.Dll ; Dword nBufferLength ; Pointer lpBuffer ; Returns Integer 44051>>>>>>>>>>> 44051>>>>>>>>>>>External_Function vWin32_DeleteFile "DeleteFileA" Kernel32.Dll ; Pointer lpFileName ; Returns Integer 44052>>>>>>>>>>> 44052>>>>>>>>>>>// Courtesy of Marco Kuipers 44052>>>>>>>>>>>Function vMakeTempFile Returns String #REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE) 44054>>>>>>>>>>> Integer iRetval 44054>>>>>>>>>>> String sTempPath sTempFileName sPrefixString 44054>>>>>>>>>>> Pointer lpTempPath lpTempFileName lpPrefixString 44054>>>>>>>>>>> 44054>>>>>>>>>>> Move (Repeat (Character (0), 255)) To sTempPath 44055>>>>>>>>>>> GetAddress Of sTempPath To lpTempPath 44056>>>>>>>>>>> Move (vWin32_GetTempPath (255, lpTempPath)) To iRetVal 44057>>>>>>>>>>> 44057>>>>>>>>>>> If (sTempPath = "") Begin 44059>>>>>>>>>>> Get_Current_Directory To sTempPath 44060>>>>>>>>>>> End 44060>>>>>>>>>>>> 44060>>>>>>>>>>> 44060>>>>>>>>>>> Move (Repeat (Character (0), 255)) To sTempFileName 44061>>>>>>>>>>> GetAddress Of sTempFileName To lpTempFileName 44062>>>>>>>>>>> Move "tmp" To sPrefixString // TMP 44063>>>>>>>>>>> GetAddress Of sPrefixString To lpPrefixString 44064>>>>>>>>>>> GetAddress Of sTempPath To lpTempPath 44065>>>>>>>>>>> Move (vWin32_GetTempFileName (lpTempPath, lpPrefixString, 0, lpTempFileName)) To iRetval 44066>>>>>>>>>>> If (iRetval <> 0) Begin 44068>>>>>>>>>>> Move "" To sTempFileName 44069>>>>>>>>>>> End 44069>>>>>>>>>>>> 44069>>>>>>>>>>> 44069>>>>>>>>>>> Function_Return sTempFileName 44070>>>>>>>>>>>End_Function // vMakeTempFile 44071>>>>>>>>>>> 44071>>>>>>>>>>>// This function creates a uniquely named temporary file in folder sPath 44071>>>>>>>>>>>// The file created will have a prefix based on the first 3 characters in sPrefix 44071>>>>>>>>>>>// Note that you will have to cleanup the tempfile yourself as the function 44071>>>>>>>>>>>// does not take care of that. 44071>>>>>>>>>>>Function vCreateTempFileInPath String sPath String sPrefix Returns String #REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE) 44073>>>>>>>>>>> String sTempFileName 44073>>>>>>>>>>> Integer iCnt iRetVal 44073>>>>>>>>>>> Pointer lpTempFileName 44073>>>>>>>>>>> 44073>>>>>>>>>>> Move (ToAnsi(sPath)+Character(0)) To sPath 44074>>>>>>>>>>> Move (ToAnsi(sPrefix)+Character(0)) To sPrefix 44075>>>>>>>>>>> Move (pad("", vMAX_PATH)) To sTempFileName 44076>>>>>>>>>>> GetAddress Of sTempFileName To lpTempFileName 44077>>>>>>>>>>> 44077>>>>>>>>>>> Move (vWin32_GetTempFileName(sPath, sPrefix, 0, lpTempFileName)) To iRetVal 44078>>>>>>>>>>> Move (Trim(Cstring(sTempFileName))) To sTempFileName 44079>>>>>>>>>>> Function_Return sTempFileName 44080>>>>>>>>>>>End_Function // vCreateTempFileInPath 44081>>>>>>>>>>> 44081>>>>>>>>>>> 44081>>>>>>>>>>>Define vCSIDL_DESKTOP For |CI$00 44081>>>>>>>>>>>Define vCSIDL_PROGRAMS For |CI$02 44081>>>>>>>>>>>Define vCSIDL_CONTROLS For |CI$03 44081>>>>>>>>>>>Define vCSIDL_PRINTERS For |CI$04 44081>>>>>>>>>>>Define vCSIDL_PERSONAL For |CI$05 // (Documents folder) 44081>>>>>>>>>>>Define vCSIDL_FAVORITES For |CI$06 44081>>>>>>>>>>>Define vCSIDL_STARTUP For |CI$07 44081>>>>>>>>>>>Define vCSIDL_RECENT For |CI$08 // (Recent folder) 44081>>>>>>>>>>>Define vCSIDL_SENDTO For |CI$09 44081>>>>>>>>>>>Define vCSIDL_BITBUCKET For |CI$0A 44081>>>>>>>>>>>Define vCSIDL_STARTMENU For |CI$0B 44081>>>>>>>>>>>Define vCSIDL_DESKTOPDIRECTORY For |CI$10 44081>>>>>>>>>>>Define vCSIDL_DRIVES For |CI$11 44081>>>>>>>>>>>Define vCSIDL_NETWORK For |CI$12 44081>>>>>>>>>>>Define vCSIDL_NETHOOD For |CI$13 44081>>>>>>>>>>>Define vCSIDL_FONTS For |CI$14 44081>>>>>>>>>>>Define vCSIDL_TEMPLATES For |CI$15 // (ShellNew folder) 44081>>>>>>>>>>> 44081>>>>>>>>>>> 44081>>>>>>>>>>>//HRESULT SHGetFolderPath( 44081>>>>>>>>>>>// HWND hwndOwner, 44081>>>>>>>>>>>// int nFolder, 44081>>>>>>>>>>>// HANDLE hToken, 44081>>>>>>>>>>>// DWORD dwFlags, 44081>>>>>>>>>>>// LPTSTR pszPath 44081>>>>>>>>>>>//); 44081>>>>>>>>>>>// This function is a superset of SHGetSpecialFolderPath, included with earlier versions of 44081>>>>>>>>>>>// the shell. It is implemented in a redistributable DLL, SHFolder.dll, that also simulates 44081>>>>>>>>>>>// many of the new shell folders on older platforms such as Windows 95, Windows 98, and 44081>>>>>>>>>>>// Windows NT 4.0. This DLL always calls the current platform's version of this function. 44081>>>>>>>>>>>// If that fails, it will try to simulate the appropriate behavior. 44081>>>>>>>>>>>// 44081>>>>>>>>>>>External_Function vWin32_SHGetFolderPath "SHGetFolderPathA" SHFolder.Dll ; Pointer hWnd ; Integer nFolder ; Pointer hToken ; DWord dwFlags ; Pointer lpszPath ; Returns Integer 44082>>>>>>>>>>> 44082>>>>>>>>>>>Function vSHGetFolderPath Integer nFolder Returns String #REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE) 44084>>>>>>>>>>> String sFolder 44084>>>>>>>>>>> Integer iVoid 44084>>>>>>>>>>> Pointer lpsFolder 44084>>>>>>>>>>> Handle hWnd 44084>>>>>>>>>>> Move (Window_Handle(focus(desktop))) to hWnd 44085>>>>>>>>>>> 44085>>>>>>>>>>> move (repeat(character(0), vMAX_PATH)) to sFolder 44086>>>>>>>>>>> GetAddress of sFolder to lpsFolder 44087>>>>>>>>>>> 44087>>>>>>>>>>> Move (vWin32_SHGetFolderPath(hWnd,nFolder, 0, 0,lpsFolder)) To iVoid 44088>>>>>>>>>>> Function_Return (CString(sFolder)) 44089>>>>>>>>>>>End_Function // vSHGetFolderPAth 44090>>>>>>>>>>> 44090>>>>>>>>>>> 44090>>>>>>>>>>> 44090>>>>>>>>>>> 44090>>>>>>>>>>>Type vWin32_Find_Data 44090>>>>>>>>>>> Field vWin32_Find_Data.dwFileAttributes As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.ftCreationLowDateTime As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.ftCreationHighDateTime As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.ftLastAccessLowDateTime As dword 44090>>>>>>>>>>> Field vWin32_Find_Data.ftLastAccessHighDateTime As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.ftLastWriteLowDateTime As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.ftLastWriteHighDateTime As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.nFileSizeHigh As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.nFileSizeLow As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.dwReserved0 As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.dwReserved1 As Dword 44090>>>>>>>>>>> Field vWin32_Find_Data.cFileName As Char vMax_Path 44090>>>>>>>>>>> Field vWin32_Find_Data.cAlternateFileName As Char 14 44090>>>>>>>>>>>End_Type // vWin32_Find_Data 44090>>>>>>>>>>> 44090>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44090>>>>>>>>>>>// lpFileName : address of name of file to search for 44090>>>>>>>>>>>// lpFindFileData : address of returned information 44090>>>>>>>>>>>External_Function vWin32_FindFirstFile "FindFirstFileA" Kernel32.dll Pointer lpFileName ; Pointer lpFindFileData Returns Handle 44091>>>>>>>>>>> 44091>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44091>>>>>>>>>>>// hFindFile : handle of search 44091>>>>>>>>>>>// lpFindFileData : address of structure for data on found file 44091>>>>>>>>>>>External_Function vWin32_FindNextFile "FindNextFileA" Kernel32.dll Handle hFindFile ; Pointer lpFindFileData Returns Integer 44092>>>>>>>>>>> 44092>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44092>>>>>>>>>>>// hFindFile : file search handle 44092>>>>>>>>>>>External_Function vWin32_FindClose "FindClose" Kernel32.dll Handle hFindFile Returns Integer 44093>>>>>>>>>>> 44093>>>>>>>>>>> 44093>>>>>>>>>>> 44093>>>>>>>>>>>Type vFileTime 44093>>>>>>>>>>> Field vFileTime.dwLowDateTime As Dword 44093>>>>>>>>>>> FIeld vFileTime.dwHighDateTime As Dword 44093>>>>>>>>>>>End_Type // vFileTime 44093>>>>>>>>>>> 44093>>>>>>>>>>> 44093>>>>>>>>>>>Type vSystemTime 44093>>>>>>>>>>> Field vSystemTime.wYear As Word 44093>>>>>>>>>>> Field vSystemTime.wMonth As Word 44093>>>>>>>>>>> Field vSystemTime.wDayOfWeek As Word 44093>>>>>>>>>>> Field vSystemTime.wDay As Word 44093>>>>>>>>>>> Field vSystemTime.wHour As Word 44093>>>>>>>>>>> Field vSystemTime.wMinute As Word 44093>>>>>>>>>>> Field vSystemTime.wSecond As Word 44093>>>>>>>>>>> Field vSystemTime.wMilliSeconds As Word 44093>>>>>>>>>>>End_Type // vSystemTime 44093>>>>>>>>>>> 44093>>>>>>>>>>> 44093>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44093>>>>>>>>>>>// lpFileTime : pointer to file time to convert 44093>>>>>>>>>>>// lpSystemTime : pointer to structure to receive system time 44093>>>>>>>>>>>External_Function vWin32_FileTimeToSystemTime "FileTimeToSystemTime" Kernel32.Dll ; Pointer lpFileTime Pointer lpsystemTime Returns Integer 44094>>>>>>>>>>> 44094>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44094>>>>>>>>>>>// This function formats the time in a picture-string passed 44094>>>>>>>>>>>// 44094>>>>>>>>>>>// Picture Meaning 44094>>>>>>>>>>>// h Hours with no leading zero for single-digit hours; 12-hour clock 44094>>>>>>>>>>>// hh Hours with leading zero for single-digit hours; 12-hour clock 44094>>>>>>>>>>>// H Hours with no leading zero for single-digit hours; 24-hour clock 44094>>>>>>>>>>>// HH Hours with leading zero for single-digit hours; 24-hour clock 44094>>>>>>>>>>>// m Minutes with no leading zero for single-digit minutes 44094>>>>>>>>>>>// mm Minutes with leading zero for single-digit minutes 44094>>>>>>>>>>>// s Seconds with no leading zero for single-digit seconds 44094>>>>>>>>>>>// ss Seconds with leading zero for single-digit seconds 44094>>>>>>>>>>>// t One character time marker string, such as A or P 44094>>>>>>>>>>>// tt Multicharacter time marker string, such as AM or PM 44094>>>>>>>>>>>// 44094>>>>>>>>>>>// For example, to get the time string "11:29:40 PM" 44094>>>>>>>>>>>// use the following picture string: "hh" : "mm" : "ss tt" 44094>>>>>>>>>>> 44094>>>>>>>>>>>External_Function vWin32_GetTimeFormat "GetTimeFormatA" Kernel32.Dll ; Dword LCID Dword dwFlags Pointer lpsSystemTime Pointer lpFormat Pointer lpTimeStr ; Integer cchTime Returns Integer 44095>>>>>>>>>>> 44095>>>>>>>>>>> 44095>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44095>>>>>>>>>>>// This function formats the date in a picture-string passed 44095>>>>>>>>>>>// 44095>>>>>>>>>>>// Picture Meaning 44095>>>>>>>>>>>// d Day of month as digits with no leading zero for single-digit days. 44095>>>>>>>>>>>// dd Day of month as digits with leading zero for single-digit days. 44095>>>>>>>>>>>// ddd Day of week as a three-letter abbreviation. The function uses the 44095>>>>>>>>>>>// LOCALE_SABBREVOAYMAME value associated with the specified locale. 44095>>>>>>>>>>>// dddd Day of week as its full name. The function uses the LOCALE_SDAYNAME 44095>>>>>>>>>>>// value associated with the specified locale. 44095>>>>>>>>>>>// M Month as digits with no leading zero for single-digit months. 44095>>>>>>>>>>>// MM Month as digits with leading zero for single-digit months. 44095>>>>>>>>>>>// MMM Month as a three-letter abbreviation. The function uses the 44095>>>>>>>>>>>// LOCALE_SABBREVMONTHNAME value associated with the specified locale. 44095>>>>>>>>>>>// MMMM Month as its full name. The function uses the LOCALE_SMONTHNAME value 44095>>>>>>>>>>>// associated with the specified locale. 44095>>>>>>>>>>>// y Year as last two digits, but with no leading zero for years less than 10. 44095>>>>>>>>>>>// yy Year as last two digits, but with leading zero for years less than 10. 44095>>>>>>>>>>>// yyyy Year represented hy full four digits. 44095>>>>>>>>>>>// gg Period/era string. The function uses the CAL_SERASTRING value associated 44095>>>>>>>>>>>// with the specified locale. This element is ignored if the date to be formatted 44095>>>>>>>>>>>// does not have an associated era or period string. 44095>>>>>>>>>>>// For example, to get the date string "Wed, Aug 31 94" 44095>>>>>>>>>>>// use the following picture string: "ddd","MMM dd yy" 44095>>>>>>>>>>> 44095>>>>>>>>>>>External_Function vWin32_GetDateFormat "GetDateFormatA" Kernel32.Dll ; Dword LCID Dword dwFlags Pointer lpsSystemTime Pointer lpFormat Pointer lpDateStr ; Integer cchDate Returns Integer 44096>>>>>>>>>>> 44096>>>>>>>>>>>Define LOCALE_NOUSEROVERRIDE For |CI$80000000 // do not use user overrides 44096>>>>>>>>>>>Define TIME_NOMIHUTESORSECONDS For |CI$0000000l // do not use minutes or seconds 44096>>>>>>>>>>>Define TIME_NOSECONDS For |CI$00000002 // do not use seconds 44096>>>>>>>>>>>Define TIME_NOTIMEMARKER For |CI$00000004 // do not use time marker 44096>>>>>>>>>>>Define TIME_FORCE24HOURFORMAT For |CI$00000008 // always use 24 hour format 44096>>>>>>>>>>> 44096>>>>>>>>>>>// Date Flags for GetDateFormatW. 44096>>>>>>>>>>>// 44096>>>>>>>>>>>Define DATE_SHORTDATE For |CI$0000000l // use short date picture 44096>>>>>>>>>>>Define DATE_LONGDATE For |CI$00000002 // use long date picture 44096>>>>>>>>>>>Define DATE_USE_ALT_CALENDAR For |CI$00000004 // use alternate calendar (if any) 44096>>>>>>>>>>> 44096>>>>>>>>>>> 44096>>>>>>>>>>>// Courtesy Of Vincent Oorsprong 44096>>>>>>>>>>>Function vConvertFileDateTime Global Dword dwLowDateTime Dword dwHighDateTime Returns String 44098>>>>>>>>>>> String sftTime sSystemTime sFormattedTime sFormattedDate 44098>>>>>>>>>>> Pointer lpsftTime lpsSystemTime lpsFormattedTime lpsFormattedDate 44098>>>>>>>>>>> Integer iSuccess iLenCcTime iDataLength iLenCcDate 44098>>>>>>>>>>> 44098>>>>>>>>>>> ZeroType vFileTime To sftTime 44099>>>>>>>>>>> Put dwLowDateTime To sftTime At vFileTime.dwLowDateTime 44100>>>>>>>>>>> Put dwHighDateTime To sftTime At vFileTime.dwHighDateTime 44101>>>>>>>>>>> GetAddress Of sftTime To lpsftTime 44102>>>>>>>>>>> 44102>>>>>>>>>>> ZeroType vSystemTime To sSystemTime 44103>>>>>>>>>>> GetAddress Of sSystemTime To lpsSystemTime 44104>>>>>>>>>>> 44104>>>>>>>>>>> Moveint (vWin32_FileTimeToSystemTime (lpsftTime, lpsSystemTime)) To iSuccess 44105>>>>>>>>>>>> 44105>>>>>>>>>>> If iSuccess Eq DfTrue Begin 44107>>>>>>>>>>> ZeroString 255 To sFormattedTime 44108>>>>>>>>>>> GetAddress Of sFormattedTime To lpsFormattedTime 44109>>>>>>>>>>> Length sFormattedTime To iLenCcTime 44110>>>>>>>>>>>> 44110>>>>>>>>>>> Moveint (vWin32_GetTimeFormat (LOCALE_USER_DEFAULT, 0, lpsSystemTime, 0, ; lpsFormattedTime, iLenCcTime)) To iDataLength 44111>>>>>>>>>>>> 44111>>>>>>>>>>> ZeroString 255 To sFormattedDate 44112>>>>>>>>>>> GetAddress Of sFormattedDate To lpsFormattedDate 44113>>>>>>>>>>> Length sFormattedDate To iLenCcDate 44114>>>>>>>>>>>> 44114>>>>>>>>>>> Moveint (vWin32_GetDateFormat (LOCALE_USER_DEFAULT, 0, lpsSystemTime, 0, ; lpsFormattedDate, iLenCcDate)) To iDataLength 44115>>>>>>>>>>>> 44115>>>>>>>>>>> Function_Return (Cstring (sFormattedDate) * Cstring (sFormattedTime)) 44116>>>>>>>>>>> End // iSuccess 44116>>>>>>>>>>>> 44116>>>>>>>>>>>End_Function // vConvertFileDateTime 44117>>>>>>>>>>> 44117>>>>>>>>>>> 44117>>>>>>>>>>>// **WvA Removed, See the cFileSet class for an alternative 44117>>>>>>>>>>>//Procedure DoBrowseDir String sFilePath 44117>>>>>>>>>>>//End_Procedure // DoBrowseDir 44117>>>>>>>>>>> 44117>>>>>>>>>>>External_Function vWin32_SetLastError "SetLastError" Kernel32.Dll Dword dwLastError Returns integer 44118>>>>>>>>>>> 44118>>>>>>>>>>>// **WvA: 44118>>>>>>>>>>>// A windows replacement for the standard function FileExists. 44118>>>>>>>>>>>// This version will also return (true) for a file when it is open by an application. 44118>>>>>>>>>>>// Note that you can apply normal windows mask-signs in the filename such as * and ? 44118>>>>>>>>>>>// Example: Get vFilePathExists "C:\config.sy?" 44118>>>>>>>>>>>// This will return true if you have a file matching these conditions. (aka config.sys) 44118>>>>>>>>>>>Function vFilePathExists String sFilePathMask Returns Integer #REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE) 44120>>>>>>>>>>> String sWin32FindData 44120>>>>>>>>>>> String sLongFileName 44120>>>>>>>>>>> Pointer lpsFilePathMask lpsWin32FindData 44120>>>>>>>>>>> Handle hFindFile 44120>>>>>>>>>>> Integer iVoid iRetval bFound 44120>>>>>>>>>>> 44120>>>>>>>>>>> GetAddress Of sFilePathMask To lpsFilePathMask 44121>>>>>>>>>>> Zerotype vWin32_Find_Data To sWin32FindData 44122>>>>>>>>>>> GetAddress Of sWin32FindData To lpswin32FindData 44123>>>>>>>>>>> Move (vWin32_FindFirstFile (lpsFilePathMask, lpsWin32FindData)) To hFindFile 44124>>>>>>>>>>> Move (vWin32_FindClose (hFindFile)) To iVoid 44125>>>>>>>>>>> Function_Return (hFindFile <> vINVALID_HANDLE_VALUE) 44126>>>>>>>>>>>End_Function // vFilePathExists 44127>>>>>>>>>>> 44127>>>>>>>>>>>// **WvA 44127>>>>>>>>>>>// Formats a foldername by first trimming it and after that by sticking a 44127>>>>>>>>>>>// directory separator (/\) to the end if it doesn't have one there already. 44127>>>>>>>>>>>// The folder may contain a drive letter or UNC encoding. 44127>>>>>>>>>>>Function vFolderFormat Global String sFolderName Returns String 44129>>>>>>>>>>> String sDirSep 44129>>>>>>>>>>> Move (sysconf(SYSCONF_DIR_SEPARATOR)) To sDirSep // normally \ (backslash) 44130>>>>>>>>>>> Move (Trim(sFolderName)) To sFolderName 44131>>>>>>>>>>> If (Right(sFolderName,1)<>sDirSep) Begin 44133>>>>>>>>>>> Move (sFolderName+sDirSep) To sFolderName 44134>>>>>>>>>>> End 44134>>>>>>>>>>>> 44134>>>>>>>>>>> Function_Return sFolderName 44135>>>>>>>>>>>End_Function // vFolderFormat 44136>>>>>>>>> 44136>>>>>>>>> Define FILE_ATTRIBUTE_READONLY for |CI$00000001 44136>>>>>>>>> Define FILE_ATTRIBUTE_HIDDEN for |CI$00000002 44136>>>>>>>>> Define FILE_ATTRIBUTE_SYSTEM for |CI$00000004 44136>>>>>>>>> Define FILE_ATTRIBUTE_DIRECTORY for |CI$00000010 44136>>>>>>>>> Define FILE_ATTRIBUTE_ARCHIVE for |CI$00000020 44136>>>>>>>>> Define FILE_ATTRIBUTE_ENCRYPTED for |CI$00000040 44136>>>>>>>>> Define FILE_ATTRIBUTE_NORMAL for |CI$00000080 44136>>>>>>>>> Define FILE_ATTRIBUTE_TEMPORARY for |CI$00000100 44136>>>>>>>>> Define FILE_ATTRIBUTE_SPARSEFILE for |CI$00000200 44136>>>>>>>>> Define FILE_ATTRIBUTE_REPARSEPOINT for |CI$00000400 44136>>>>>>>>> Define FILE_ATTRIBUTE_COMPRESSED for |CI$00000800 44136>>>>>>>>> Define FILE_ATTRIBUTE_OFFLINE for |CI$00001000 44136>>>>>>>>> 44136>>>>>>>>>desktop_section 44141>>>>>>>>>object oWinFolderEntries is a cArray 44143>>>>>>>>> property integer piFileCount 44145>>>>>>>>> property integer piFolderCount 44147>>>>>>>>> property string psFolder 44149>>>>>>>>> item_property_list 44149>>>>>>>>> item_property integer pbFolder.i 44149>>>>>>>>> item_property string psFileName.i 44149>>>>>>>>> item_property string psAlternateFileName.i 44149>>>>>>>>> item_property number pnFileSz.i 44149>>>>>>>>> item_property number pnCreated.i 44149>>>>>>>>> item_property number pnLastWrite.i 44149>>>>>>>>> item_property number pnLastAccessed.i 44149>>>>>>>>> item_property integer piAttributes.i 44149>>>>>>>>> end_item_property_list #REM 44204 DEFINE FUNCTION PIATTRIBUTES.I INTEGER LIROW RETURNS INTEGER #REM 44209 DEFINE PROCEDURE SET PIATTRIBUTES.I INTEGER LIROW INTEGER VALUE #REM 44214 DEFINE FUNCTION PNLASTACCESSED.I INTEGER LIROW RETURNS NUMBER #REM 44219 DEFINE PROCEDURE SET PNLASTACCESSED.I INTEGER LIROW NUMBER VALUE #REM 44224 DEFINE FUNCTION PNLASTWRITE.I INTEGER LIROW RETURNS NUMBER #REM 44229 DEFINE PROCEDURE SET PNLASTWRITE.I INTEGER LIROW NUMBER VALUE #REM 44234 DEFINE FUNCTION PNCREATED.I INTEGER LIROW RETURNS NUMBER #REM 44239 DEFINE PROCEDURE SET PNCREATED.I INTEGER LIROW NUMBER VALUE #REM 44244 DEFINE FUNCTION PNFILESZ.I INTEGER LIROW RETURNS NUMBER #REM 44249 DEFINE PROCEDURE SET PNFILESZ.I INTEGER LIROW NUMBER VALUE #REM 44254 DEFINE FUNCTION PSALTERNATEFILENAME.I INTEGER LIROW RETURNS STRING #REM 44259 DEFINE PROCEDURE SET PSALTERNATEFILENAME.I INTEGER LIROW STRING VALUE #REM 44264 DEFINE FUNCTION PSFILENAME.I INTEGER LIROW RETURNS STRING #REM 44269 DEFINE PROCEDURE SET PSFILENAME.I INTEGER LIROW STRING VALUE #REM 44274 DEFINE FUNCTION PBFOLDER.I INTEGER LIROW RETURNS INTEGER #REM 44279 DEFINE PROCEDURE SET PBFOLDER.I INTEGER LIROW INTEGER VALUE 44285>>>>>>>>> 44285>>>>>>>>> function nFileTimeTS dword ldwHi dword ldwLo returns number 44288>>>>>>>>> integer liYear liMonth liDay liHour liMinute liSecond 44288>>>>>>>>> integer lbSuccess 44288>>>>>>>>> pointer lpsftTime lpsSystemTime 44288>>>>>>>>> date ldDate 44288>>>>>>>>> string lsftTime lsSystemTime 44288>>>>>>>>> number lnRval 44288>>>>>>>>> 44288>>>>>>>>> ZeroType vFileTime to lsftTime 44289>>>>>>>>> Put ldwLo to lsftTime at vFileTime.dwLowDateTime 44290>>>>>>>>> Put ldwHi to lsftTime at vFileTime.dwHighDateTime 44291>>>>>>>>> GetAddress of lsftTime to lpsftTime 44292>>>>>>>>> 44292>>>>>>>>> ZeroType vSystemTime to lsSystemTime 44293>>>>>>>>> GetAddress of lsSystemTime to lpsSystemTime 44294>>>>>>>>> 44294>>>>>>>>> move (vWin32_FileTimeToSystemTime(lpsftTime,lpsSystemTime)) to lbSuccess 44295>>>>>>>>> if lbSuccess begin 44297>>>>>>>>> GetBuff from lsSystemTime at vSystemTime.wYear to liYear 44298>>>>>>>>> GetBuff from lsSystemTime at vSystemTime.wMonth to liMonth 44299>>>>>>>>> GetBuff from lsSystemTime at vSystemTime.wDay to liDay 44300>>>>>>>>> GetBuff from lsSystemTime at vSystemTime.wHour to liHour 44301>>>>>>>>> GetBuff from lsSystemTime at vSystemTime.wMinute to liMinute 44302>>>>>>>>> GetBuff from lsSystemTime at vSystemTime.wSecond to liSecond 44303>>>>>>>>> 44303>>>>>>>>> get DateCompose liDay liMonth liYear to ldDate 44304>>>>>>>>> get TS_Compose2 ldDate liHour liMinute liSecond to lnRval 44305>>>>>>>>> function_return lnRval 44306>>>>>>>>> end 44306>>>>>>>>>> 44306>>>>>>>>> function_return 0 44307>>>>>>>>> end_function 44308>>>>>>>>> 44308>>>>>>>>> procedure DoLoad string lsFolderPath 44311>>>>>>>>> handle lhImportFile 44311>>>>>>>>> pointer lpsPath lps32Data 44311>>>>>>>>> dword ldwFileAtt ldwHi ldwLo 44311>>>>>>>>> integer liVoid liRow liFileCount liFolderCount 44311>>>>>>>>> boolean lbRetval lbFolder 44311>>>>>>>>> number lnTS 44311>>>>>>>>> string lsWin32FindData lsFileName 44311>>>>>>>>> 44311>>>>>>>>> move 0 to liFileCount 44312>>>>>>>>> move 0 to liFolderCount 44313>>>>>>>>> set psFolder to lsFolderPath 44314>>>>>>>>> 44314>>>>>>>>> send delete_data 44315>>>>>>>>> 44315>>>>>>>>> ifnot (pos("*",lsFolderPath) or pos("?",lsFolderPath)) ; get Files_AppendPath lsFolderPath "*" to lsFolderPath 44318>>>>>>>>> 44318>>>>>>>>> move (ToAnsi(lsFolderPath)) to lsFolderPath 44319>>>>>>>>> 44319>>>>>>>>> GetAddress of lsFolderPath to lpsPath 44320>>>>>>>>> ZeroType vWin32_Find_Data to lsWin32FindData 44321>>>>>>>>> GetAddress of lsWin32FindData to lps32Data 44322>>>>>>>>> move (vWin32_FindFirstFile(lpsPath,lps32Data)) to lhImportFile 44323>>>>>>>>> if (lhImportFile <> INVALID_HANDLE_VALUE) begin 44325>>>>>>>>> repeat 44325>>>>>>>>>> 44325>>>>>>>>> get row_count to liRow 44326>>>>>>>>> 44326>>>>>>>>> GetBuff_String From lsWin32FindData at vWin32_Find_Data.cFileName to lsFileName 44327>>>>>>>>> 44327>>>>>>>>> if (lsFileName<>"." and lsFileName<>"..") begin 44329>>>>>>>>> set psFileName.i liRow to (ToOem(lsFileName)) 44330>>>>>>>>> 44330>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.dwFileAttributes to ldwFileAtt 44331>>>>>>>>> set piAttributes.i liRow to ldwFileAtt 44332>>>>>>>>> 44332>>>>>>>>> move (ldwFileAtt iand FILE_ATTRIBUTE_DIRECTORY) to lbFolder 44333>>>>>>>>> set pbFolder.i liRow to lbFolder 44334>>>>>>>>> 44334>>>>>>>>> if lbFolder increment liFolderCount 44337>>>>>>>>> else increment liFileCount 44339>>>>>>>>> 44339>>>>>>>>> GetBuff_String From lsWin32FindData at vWin32_Find_Data.cAlternateFileName to lsFileName // get attribute 44340>>>>>>>>> set psAlternateFileName.i liRow to lsFileName 44341>>>>>>>>> 44341>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.nFileSizeHigh to ldwHi 44342>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.nFileSizeLow to ldwLo 44343>>>>>>>>> set pnFileSz.i liRow to (ldwHi*4294967296+ldwLo) 44344>>>>>>>>> 44344>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.ftCreationHighDateTime to ldwHi 44345>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.ftCreationLowDateTime to ldwLo 44346>>>>>>>>> get nFileTimeTS ldwHi ldwLo to lnTS 44347>>>>>>>>> set pnCreated.i liRow to lnTS 44348>>>>>>>>> 44348>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.ftLastWriteHighDateTime to ldwHi 44349>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.ftLastWriteLowDateTime to ldwLo 44350>>>>>>>>> get nFileTimeTS ldwHi ldwLo to lnTS 44351>>>>>>>>> set pnLastWrite.i liRow to lnTS 44352>>>>>>>>> 44352>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.ftLastAccessHighDateTime to ldwHi 44353>>>>>>>>> GetBuff From lsWin32FindData at vWin32_Find_Data.ftLastAccessLowDateTime to ldwLo 44354>>>>>>>>> get nFileTimeTS ldwHi ldwLo to lnTS 44355>>>>>>>>> set pnLastAccessed.i liRow to lnTS 44356>>>>>>>>> end 44356>>>>>>>>>> 44356>>>>>>>>> Move (vWin32_FindNextFile(lhImportFile,lps32Data)) to lbRetval // get next file in directory 44357>>>>>>>>> Until (lbRetval = False) 44359>>>>>>>>> Move (vWin32_FindClose(lhImportFile)) to liVoid // 44360>>>>>>>>> end 44360>>>>>>>>>> 44360>>>>>>>>> set piFileCount to liFileCount 44361>>>>>>>>> set piFolderCount to liFolderCount 44362>>>>>>>>> end_procedure 44363>>>>>>>>>end_object // oWinFolderEntries 44364>>>>>>>>>end_desktop_section 44369>>>>>>>>> 44369>>>>>>>>>procedure WinFolder_ReadFolder global string lsFolder 44371>>>>>>>>> send DoLoad of oWinFolderEntries lsFolder 44372>>>>>>>>>end_procedure 44373>>>>>>> 44373>>>>>>>string giSeq$Temp 250 44373>>>>>>> 44373>>>>>>>function SEQ_UniqueFileName global string lsPreFix returns string 44375>>>>>>> integer count# unique# loop# ch# 44375>>>>>>> move (left(trim(lsPreFix),4)) to lsPreFix 44376>>>>>>> move 12 to count# // max number of retries 44377>>>>>>> move 1 to loop# 44378>>>>>>> get Seq_New_Channel to ch# // This method and Seq_Release_Channel are 44379>>>>>>> if ch# lt 0 function_return "" // located in seq_chnl.pkg 44382>>>>>>> send Seq_Release_Channel ch# // We only need it for a second 44383>>>>>>> repeat 44383>>>>>>>> 44383>>>>>>> move (random(9999)) to unique# 44384>>>>>>> direct_input channel ch# (lsPreFix+string(unique#)+".tmp") 44386>>>>>>> move (count#-1) to count# 44387>>>>>>> [seqeof] move 0 to loop# 44388>>>>>>> if loop# if count# le 0 move 0 to loop# 44393>>>>>>> close_input channel ch# 44395>>>>>>> until (not(loop#)) 44397>>>>>>> if count# le 0 function_return "" // failure 44400>>>>>>> function_return (lsPreFix+string(unique#)+".tmp") 44401>>>>>>>end_function 44402>>>>>>> 44402>>>>>>>string SEQ_UniqueFileNamePath$ext 5 44402>>>>>>>move "tmp" to SEQ_UniqueFileNamePath$ext 44403>>>>>>> 44403>>>>>>>function SEQ_UniqueFileNamePath global string lsPath string lsPreFix returns string 44405>>>>>>> integer count# unique# loop# ch# 44405>>>>>>> string lsFileName 44405>>>>>>> if (lsPath="." or lsPath="") get SEQ_CurrentFolder to lsPath 44408>>>>>>> move (left(trim(lsPreFix),4)) to lsPreFix 44409>>>>>>> move 12 to count# // max number of retries 44410>>>>>>> move 1 to loop# 44411>>>>>>> get Seq_New_Channel to ch# // This method and Seq_Release_Channel are 44412>>>>>>> if ch# lt 0 function_return "" // located in seq_chnl.pkg 44415>>>>>>> send Seq_Release_Channel ch# // We only need it for a second 44416>>>>>>> repeat 44416>>>>>>>> 44416>>>>>>> move (random(9999)) to unique# 44417>>>>>>> get SEQ_ComposeAbsoluteFileName lsPath (lsPreFix+string(unique#)+"."+SEQ_UniqueFileNamePath$ext) to lsFileName 44418>>>>>>> direct_input channel ch# lsFileName 44420>>>>>>> move (count#-1) to count# 44421>>>>>>> [seqeof] move 0 to loop# 44422>>>>>>> if loop# if count# le 0 move 0 to loop# 44427>>>>>>> close_input channel ch# 44429>>>>>>> until (not(loop#)) 44431>>>>>>> if count# le 0 function_return "" // failure 44434>>>>>>> function_return lsFileName 44435>>>>>>>end_function 44436>>>>>>> 44436>>>>>>>function SEQ_UniqueFileNamePathAndExt global string lsPath string lsPreFix string lsExt returns string 44438>>>>>>> string lsRval 44438>>>>>>> move lsExt to SEQ_UniqueFileNamePath$ext 44439>>>>>>> get SEQ_UniqueFileNamePath lsPath lsPreFix to lsRval 44440>>>>>>> move "tmp" to SEQ_UniqueFileNamePath$ext 44441>>>>>>> function_return lsRval 44442>>>>>>>end_function 44443>>>>>>> 44443>>>>>>>define FS_KILOBYTE for 1024 44443>>>>>>>define FS_MEGABYTE for 1048576 44443>>>>>>>define FS_GIGABYTE for 1073741824 44443>>>>>>> 44443>>>>>>>define SEQ_FileExists$Test for 0 44443>>>>>>> 44443>>>>>>> 44443>>>>>>>define SEQIT_NONE for 0 44443>>>>>>>define SEQIT_FILE for 1 44443>>>>>>>define SEQIT_DIRECTORY for 2 44443>>>>>>> 44443>>>>>>> function SEQ_FileExists global string lsFile returns integer 44445>>>>>>> integer liRval liChannel 44445>>>>>>> string lsStr 44445>>>>>>> if lsFile eq "" function_return SEQIT_NONE 44448>>>>>>> get Seq_New_Channel to liChannel // This method and Seq_Release_Channel are 44449>>>>>>> if liChannel lt 0 function_return 1 // located in seq_chnl.pkg 44452>>>>>>> 44452>>>>>>> SEQ_FileExists$Test$ShowLn "1 SEQ_FileExists:" (">"+lsFile+"<") "on channel " liChannel 44452>>>>>>> 44452>>>>>>> direct_input channel liChannel ("DIR:"+StringOemToAnsi(lsFile)) 44454>>>>>>> move (not(seqeof)) to liRval 44455>>>>>>> 44455>>>>>>> SEQ_FileExists$Test$ShowLn "2 (liRval): " liRval 44455>>>>>>> 44455>>>>>>> ifnot liRval begin 44457>>>>>>> get SEQ_ExtractPathFromFileName lsFile to lsStr 44458>>>>>>> SEQ_FileExists$Test$ShowLn "3 (lsStr): " lsStr 44458>>>>>>> if lsStr eq "" begin // There's no path in the file name 44460>>>>>>> get SEQ_FindFileAlongDFPath lsFile to lsStr 44461>>>>>>> SEQ_FileExists$Test$ShowLn "4 (lsStr): " lsStr 44461>>>>>>> if lsStr ne "" begin 44463>>>>>>> get SEQ_ComposeAbsoluteFileName lsStr lsFile to lsFile 44464>>>>>>> SEQ_FileExists$Test$ShowLn "5 (lsFile): " lsFile 44464>>>>>>> close_input channel liChannel 44466>>>>>>> send Seq_Release_Channel liChannel // We only need it for a second 44467>>>>>>> function_return (SEQ_FileExists(lsFile)) 44468>>>>>>> end 44468>>>>>>>> 44468>>>>>>> end 44468>>>>>>>> 44468>>>>>>> end 44468>>>>>>>> 44468>>>>>>> SEQ_FileExists$Test$ShowLn "7 (liRval): " liRval 44468>>>>>>> if liRval begin // Item exists! Is it a directory? 44470>>>>>>> move SEQIT_FILE to liRval 44471>>>>>>> readln channel liChannel lsStr 44473>>>>>>> if (left(lsStr,1)="[") move SEQIT_DIRECTORY to liRval 44476>>>>>>> SEQ_FileExists$Test$ShowLn "8 (liRval): " liRval 44476>>>>>>> SEQ_FileExists$Test$ShowLn "9 (lsStr): " lsStr 44476>>>>>>> end 44476>>>>>>>> 44476>>>>>>> close_input channel liChannel 44478>>>>>>> send Seq_Release_Channel liChannel // We only need it for a second 44479>>>>>>> function_return liRval 44480>>>>>>> end_function 44481>>>>>>> 44481>>>>>>>function SEQ_FileSize global string fn# returns number 44483>>>>>>> // This function returns the size of file in bytes. 44483>>>>>>> integer ch# 44483>>>>>>> number rval# 44483>>>>>>> ifnot (SEQ_FileExists(fn#)=SEQIT_FILE) function_return 0 44486>>>>>>> get Seq_New_Channel to ch# 44487>>>>>>> send Seq_Release_Channel ch# 44488>>>>>>> move (StringOemToAnsi(fn#)) to fn# 44489>>>>>>> append_output channel ch# fn# 44491>>>>>>> get_channel_position ch# to rval# 44492>>>>>>>> 44492>>>>>>> close_output channel ch# 44494>>>>>>> function_return rval# 44495>>>>>>>end_function 44496>>>>>>> 44496>>>>>>>function SEQ_SizeToStringHelp global number XB# returns string 44498>>>>>>> if XB# ge 1000 function_return (NumToStr(XB#,0)) 44501>>>>>>> if XB# ge 100 function_return (NumToStr(XB#,1)) 44504>>>>>>> if XB# ge 10 function_return (NumToStr(XB#,2)) 44507>>>>>>> function_return (NumToStr(XB#,3)) 44508>>>>>>>end_function 44509>>>>>>> 44509>>>>>>>function SEQ_FileSizeToString global number bytes# returns string 44511>>>>>>> if bytes# ge FS_GIGABYTE function_return (SEQ_SizeToStringHelp(bytes#/FS_GIGABYTE)+" GB") 44514>>>>>>> else if bytes# ge FS_MEGABYTE function_return (SEQ_SizeToStringHelp(bytes#/FS_MEGABYTE)+" MB") 44518>>>>>>> else if bytes# ge FS_KILOBYTE function_return (SEQ_SizeToStringHelp(bytes#/FS_KILOBYTE)+" KB") 44522>>>>>>> function_return bytes# 44523>>>>>>>end_function 44524>>>>>>> 44524>>>>>>>function SEQ_FileLineCount global string fn# returns integer 44526>>>>>>> //> This function returns the number of lines in (ascii-) file . 44526>>>>>>> //> Note that this function will read through the entire file (use with 44526>>>>>>> //> caution!). 44526>>>>>>> integer rval# ch# 44526>>>>>>> string str# 44526>>>>>>> get Seq_New_Channel to ch# 44527>>>>>>> send Seq_Release_Channel ch# 44528>>>>>>> move (StringOemToAnsi(fn#)) to fn# 44529>>>>>>> direct_input channel ch# fn# 44531>>>>>>> move 0 to rval# 44532>>>>>>> ifnot [seqeof] begin 44534>>>>>>> repeat 44534>>>>>>>> 44534>>>>>>> readln str# 44535>>>>>>> [~seqeof] increment rval# 44536>>>>>>> [~seqeof] loop 44537>>>>>>>> 44537>>>>>>> end 44537>>>>>>>> 44537>>>>>>> close_input channel ch# 44539>>>>>>> function_return rval# 44540>>>>>>>end_function 44541>>>>>>> 44541>>>>>>>function SEQ_DirectInput global string fn# returns integer 44543>>>>>>> //> The function attempts to open the file fn# for sequential reading. 44543>>>>>>> //> If it succeeds a channel number will be returned, if it fails -1 44543>>>>>>> //> will be returned. If the function succseeds it is the responsability 44543>>>>>>> //> of the caller to release the channel (Seq_Release_Channel) when 44543>>>>>>> //> done. 44543>>>>>>> integer ch# 44543>>>>>>> get Seq_New_Channel to ch# 44544>>>>>>> move (StringOemToAnsi(fn#)) to fn# 44545>>>>>>> direct_input channel ch# fn# 44547>>>>>>> if (seqeof) begin 44549>>>>>>> send Seq_Release_Channel ch# 44550>>>>>>> move -1 to ch# 44551>>>>>>> end 44551>>>>>>>> 44551>>>>>>> function_return ch# 44552>>>>>>>end_function 44553>>>>>>> 44553>>>>>>>procedure SEQ_CloseInput global integer ch# 44555>>>>>>> close_input channel ch# 44557>>>>>>> send Seq_Release_Channel ch# 44558>>>>>>>end_procedure 44559>>>>>>> 44559>>>>>>>function SEQ_DirectOutput global string fn# returns integer 44561>>>>>>> integer ch# 44561>>>>>>> get Seq_New_Channel to ch# 44562>>>>>>> send ErrorHnd_Quiet_Activate 44563>>>>>>> move (StringOemToAnsi(fn#)) to fn# 44564>>>>>>> direct_output channel ch# fn# 44566>>>>>>> send ErrorHnd_Quiet_Deactivate 44567>>>>>>> if (ErrorHnd_Quiet_ErrorCount()) begin 44569>>>>>>> send SEQ_CloseOutput ch# 44570>>>>>>> move -1 to ch# 44571>>>>>>> end 44571>>>>>>>> 44571>>>>>>> function_return ch# 44572>>>>>>>end_function 44573>>>>>>> 44573>>>>>>>function SEQ_AppendOutput global string fn# returns integer 44575>>>>>>> integer ch# 44575>>>>>>> get Seq_New_Channel to ch# 44576>>>>>>> move (StringOemToAnsi(fn#)) to fn# 44577>>>>>>> append_output channel ch# fn# 44579>>>>>>> function_return ch# 44580>>>>>>>end_function 44581>>>>>>> 44581>>>>>>>function SEQ_DirectInputDBMS global integer liFile integer liField returns integer 44583>>>>>>> function_return (SEQ_DirectInput("DBMS:"+string(liFile)+","+string(liField))) 44584>>>>>>>end_function 44585>>>>>>>function SEQ_DirectOutputDBMS global integer liFile integer liField returns integer 44587>>>>>>> function_return (SEQ_DirectOutput("DBMS:"+string(liFile)+","+string(liField))) 44588>>>>>>>end_function 44589>>>>>>> 44589>>>>>>>procedure SEQ_CloseOutput global integer ch# 44591>>>>>>> close_output channel ch# 44593>>>>>>> send Seq_Release_Channel ch# 44594>>>>>>>end_procedure 44595>>>>>>> 44595>>>>>>>//> Just a small function for convenience. Sometimes it's nice not to have 44595>>>>>>>//> to declare a variable just to read a line in a file. Global indicator 44595>>>>>>>//> SeqEof will be false after calling this function if an EOF has been 44595>>>>>>>//> reached. 44595>>>>>>>function SEQ_ReadLn global integer ch# returns string 44597>>>>>>> string rval# 44597>>>>>>> readln channel ch# rval# 44599>>>>>>> function_return rval# 44600>>>>>>>end_function 44601>>>>>>> 44601>>>>>>>//> Reads sequential channel liChannel until the value lsValue is found. 44601>>>>>>>//> Return value 1: OK, 0: Value not found 44601>>>>>>>function SEQ_ReadLnUntilValue global integer liChannel string lsValue returns integer 44603>>>>>>> string lsLine 44603>>>>>>> repeat 44603>>>>>>>> 44603>>>>>>> readln channel liChannel lsLine 44605>>>>>>> if (SeqEof) function_return 0 44608>>>>>>> if (lsLine=lsValue) function_return 1 44611>>>>>>> loop 44612>>>>>>>> 44612>>>>>>>end_function 44613>>>>>>> 44613>>>>>>>//> Function SEQ_ReadLnProbe reads a line from input channel ch# without 44613>>>>>>>//> affecting the current channel position of that channel. The return 44613>>>>>>>//> value is of type string and will be the line read. The function sets 44613>>>>>>>//> indicator [seqeof] as a sideeffect 44613>>>>>>>function SEQ_ReadLnProbe global integer liChannel returns string 44615>>>>>>> integer liPos lbSeqEof lbSneakMode 44615>>>>>>> string lsRval lsValue 44615>>>>>>> get_channel_position liChannel to liPos 44616>>>>>>>> 44616>>>>>>> readln channel liChannel lsRval 44618>>>>>>> move (seqeof) to lbSeqEof 44619>>>>>>> move (liPos>0) to lbSneakMode 44620>>>>>>> if lbSneakMode decrement liPos 44623>>>>>>> set_channel_position liChannel to liPos 44624>>>>>>>> 44624>>>>>>> if lbSneakMode read_block channel liChannel lsValue 1 44628>>>>>>> indicate seqeof as lbSeqEof ne 0 44629>>>>>>> function_return lsRval 44630>>>>>>>end_function 44631>>>>>>> 44631>>>>>>>//> Read entire file into one string and return it. 44631>>>>>>>function SEQ_ReadFileAsOneString global string lsFileName returns string 44633>>>>>>> integer liChannel liArgSz 44633>>>>>>> number lnSize 44633>>>>>>> string lsValue 44633>>>>>>> get SEQ_FileSize lsFileName to lnSize 44634>>>>>>> if (lnSize>0) begin 44636>>>>>>> get_argument_size To liArgSz 44637>>>>>>> if (liArgSz>>>>>> 44640>>>>>>> get SEQ_DirectInput lsFileName to liChannel 44641>>>>>>> if (liChannel>=0) begin 44643>>>>>>> read_block channel liChannel lsValue lnSize 44645>>>>>>> send SEQ_CloseInput liChannel 44646>>>>>>> end 44646>>>>>>>> 44646>>>>>>> end 44646>>>>>>>> 44646>>>>>>> else move "" to lsValue 44648>>>>>>> function_return lsValue 44649>>>>>>>end_function 44650>>>>>>> 44650>>>>>>>procedure SEQ_AppendLineClose global string lsFileName string lsLine 44652>>>>>>> integer liChannel 44652>>>>>>> get SEQ_AppendOutput lsFileName to liChannel 44653>>>>>>> writeln channel liChannel lsLine 44656>>>>>>> send SEQ_CloseOutput liChannel 44657>>>>>>>end_procedure 44658>>>>>>> 44658>>>>>>>procedure SEQ_AppendOutputImageClose global string lsFileName integer liImg 44660>>>>>>> integer liChannel liAuxChannel liSeqEof 44660>>>>>>> string lsLine 44660>>>>>>> get SEQ_DirectInput ("image: "+string(liImg)) to liAuxChannel 44661>>>>>>> if liAuxChannel ge 0 begin 44663>>>>>>> get SEQ_AppendOutput lsFileName to liChannel 44664>>>>>>> 44664>>>>>>> repeat 44664>>>>>>>> 44664>>>>>>> readln channel liAuxChannel lsLine 44666>>>>>>> move (SeqEof) to liSeqEof 44667>>>>>>> ifnot liSeqEof writeln channel liChannel (rtrim(lsLine)) 44672>>>>>>> until liSeqEof 44674>>>>>>> 44674>>>>>>> send SEQ_CloseInput liAuxChannel 44675>>>>>>> send SEQ_CloseOutput liChannel 44676>>>>>>> end 44676>>>>>>>> 44676>>>>>>>end_procedure 44677>>>>>>> 44677>>>>>>>procedure SEQ_WriteImage global integer liChannel integer liImage 44679>>>>>>> integer liAuxChannel liSeqEof 44679>>>>>>> string lsLine 44679>>>>>>> get SEQ_DirectInput ("image: "+string(liImage)) to liAuxChannel 44680>>>>>>> if liAuxChannel ge 0 begin 44682>>>>>>> repeat 44682>>>>>>>> 44682>>>>>>> readln channel liAuxChannel lsLine 44684>>>>>>> move (trim(lsLine)) to lsLine 44685>>>>>>> move (SeqEof) to liSeqEof 44686>>>>>>> ifnot liSeqEof writeln channel liChannel lsLine 44691>>>>>>> until liSeqEof 44693>>>>>>> send SEQ_CloseInput liAuxChannel 44694>>>>>>> end 44694>>>>>>>> 44694>>>>>>>end_procedure 44695>>>>>>> 44695>>>>>>>procedure SEQ_WriteFile global integer liChannel string lsFile 44697>>>>>>> integer liChannelIn liSize liIterations liRest liCount 44697>>>>>>> get SEQ_FileSize lsFile to liSize 44698>>>>>>> if liSize begin 44700>>>>>>> get SEQ_DirectInput ("binary:"+lsFile) to liChannelIn 44701>>>>>>> if liChannelIn ge 0 begin 44703>>>>>>> move (liSize/250) to liIterations 44704>>>>>>> move (liSize-(liIterations*250)) to liRest 44705>>>>>>> for liCount from 1 to liIterations 44711>>>>>>>> 44711>>>>>>> read_block channel liChannelIn giSeq$Temp 250 44713>>>>>>> write channel liChannel giSeq$Temp 44715>>>>>>> loop 44716>>>>>>>> 44716>>>>>>> read_block channel liChannelIn giSeq$Temp liRest 44718>>>>>>> write channel liChannel giSeq$Temp 44720>>>>>>> send SEQ_CloseInput liChannelIn 44721>>>>>>> end 44721>>>>>>>> 44721>>>>>>> end 44721>>>>>>>> 44721>>>>>>>end_procedure 44722>>>>>>> 44722>>>>>>>function SEQ_FindFileAlongPath global string path# string fn# returns string 44724>>>>>>> //> Returns the directory along path# in which the file fn# is found. 44724>>>>>>> integer ch# eof# 44724>>>>>>> string str# tmp# dir_sep# path_sep# cur_dir# 44724>>>>>>> 44724>>>>>>> get Seq_New_Channel to ch# 44725>>>>>>> send Seq_Release_Channel ch# 44726>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to dir_sep# // \ 44727>>>>>>> move (sysconf(SYSCONF_PATH_SEPARATOR)) to path_sep# // ; 44728>>>>>>> move (replaces(dir_sep#,fn#,"")) to fn# 44729>>>>>>> while path# ne "" 44733>>>>>>> if path_sep# in path# begin 44735>>>>>>> move (left(path#,pos(path_sep#,path#)-1)) to str# 44736>>>>>>> replace (str#+path_sep#) in path# with "" 44738>>>>>>> end 44738>>>>>>>> 44738>>>>>>> else begin 44739>>>>>>> move path# to str# 44740>>>>>>> move "" to path# 44741>>>>>>> end 44741>>>>>>>> 44741>>>>>>> 44741>>>>>>> get Files_AppendPath str# fn# to tmp# 44742>>>>>>>// move (str#+dir_sep#+fn#) to tmp# 44742>>>>>>>// move (replaces(dir_sep#+dir_sep#,tmp#,dir_sep#)) to tmp# 44742>>>>>>> 44742>>>>>>> direct_input channel ch# ("DIR:"+StringOemToAnsi(tmp#)) 44744>>>>>>> move (seqeof) to eof# 44745>>>>>>> close_input channel ch# 44747>>>>>>> ifnot eof# begin 44749>>>>>>> if (StringBeginsWith(str#,"."+dir_sep#)) begin 44751>>>>>>> get_current_directory to cur_dir# 44752>>>>>>> replace "." in str# with cur_dir# 44754>>>>>>> end 44754>>>>>>>> 44754>>>>>>> function_return str# 44755>>>>>>> end 44755>>>>>>>> 44755>>>>>>> end 44756>>>>>>>> 44756>>>>>>> function_return "" // file not found! 44757>>>>>>>end_function 44758>>>>>>> 44758>>>>>>>function SEQ_DfPath global returns string 44760>>>>>>> string path# 44760>>>>>>> get_attribute DF_OPEN_PATH to path# // Oem fixed! 44763>>>>>>> move (ToOem(path#)) to path# 44764>>>>>>> function_return path# 44765>>>>>>>end_function 44766>>>>>>> 44766>>>>>>>function SEQ_FirstDirInDfPath global returns string 44768>>>>>>> string lsDir lsPathSep 44768>>>>>>> get SEQ_DfPath to lsDir 44769>>>>>>> move (SysConf(SYSCONF_PATH_SEPARATOR)) to lsPathSep 44770>>>>>>> get ExtractItem lsDir lsPathSep 1 to lsDir 44771>>>>>>> function_return (ToOem(lsDir)) 44772>>>>>>>end_function 44773>>>>>>> 44773>>>>>>>function SEQ_FindFileAlongDFPath global string fn# returns string 44775>>>>>>> function_return (SEQ_FindFileAlongPath(SEQ_DfPath(),fn#)) 44776>>>>>>>end_function 44777>>>>>>> 44777>>>>>>>//> Function SEQ_ExtractPathFromFileName expects a file name or a file 44777>>>>>>>//> mask as an argument. Only then will it return the path of that file. 44777>>>>>>>//> Otherwise it will simply strip the last directory from the path. 44777>>>>>>>function SEQ_ExtractPathFromFileName global string lsFile returns string 44779>>>>>>> string lsDirSep 44779>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to lsDirSep 44780>>>>>>> if (right(lsFile,1)=lsDirSep) move (StringLeftBut(lsFile,1)) to lsFile 44783>>>>>>> if lsDirSep in lsFile function_return (StripFromLastOccurance(lsFile,lsDirSep)) 44786>>>>>>> if ":" in lsFile function_return (StripFromLastOccurance(lsFile,":")) 44789>>>>>>> function_return "" 44790>>>>>>>end_function 44791>>>>>>> 44791>>>>>>>//> Function SEQ_ExtractExtensionFromFileName expects a file name or a file 44791>>>>>>>//> mask as an argument. Only then will it return the type of that file. 44791>>>>>>>function SEQ_ExtractExtensionFromFileName global string fn# returns string 44793>>>>>>> string dir_sep# 44793>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to dir_sep# 44794>>>>>>> if dir_sep# in fn# move (GetFromLastOccurance(fn#,dir_sep#)) to fn# 44797>>>>>>> if "." in fn# function_return (replace(".",GetFromLastOccurance(fn#,"."),"")) 44800>>>>>>> function_return "" 44801>>>>>>>end_function 44802>>>>>>> 44802>>>>>>>//> Function SEQ_ExtractRootNameFromFileName expects a file name or a file !!!! 44802>>>>>>>//> mask as an argument. Only then will it return the rootname of that file. 44802>>>>>>>function SEQ_ExtractRootNameFromFileName global string fn# returns string 44804>>>>>>> string dir_sep# 44804>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to dir_sep# 44805>>>>>>> if dir_sep# in fn# move (GetFromLastOccurance(fn#,dir_sep#)) to fn# 44808>>>>>>> if ":" in fn# move (GetFromLastOccurance(fn#,":")) to fn# 44811>>>>>>> if "." in fn# function_return (replace(".",StripFromLastOccurance(fn#,"."),"")) 44814>>>>>>> function_return fn# 44815>>>>>>>end_function 44816>>>>>>> 44816>>>>>>>function SEQ_RemovePathFromFileName global string fn# returns string 44818>>>>>>> string dir_sep# 44818>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to dir_sep# 44819>>>>>>> if dir_sep# in fn# begin 44821>>>>>>> move (GetFromLastOccurance(fn#,dir_sep#)) to fn# 44822>>>>>>> function_return (StringRightBut(fn#,1)) 44823>>>>>>> end 44823>>>>>>>> 44823>>>>>>> if ":" in fn# begin 44825>>>>>>> move (GetFromLastOccurance(fn#,dir_sep#)) to fn# 44826>>>>>>> move (GetFromLastOccurance(fn#,":")) to fn# 44827>>>>>>> end 44827>>>>>>>> 44827>>>>>>> function_return fn# 44828>>>>>>>end_function 44829>>>>>>> 44829>>>>>>>function SEQ_TranslatePathToAbsolute global string lsPath returns string 44831>>>>>>> string lsRval lsDirSep lsCurDir 44831>>>>>>> if lsPath eq "" move "." to lsPath 44834>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to lsDirSep // "/" or "\" 44835>>>>>>> get_current_directory to lsCurDir 44836>>>>>>> if (StringBeginsWith(lsPath,"."+lsDirSep)) replace "." in lsPath with lsCurDir 44840>>>>>>> if lsPath eq "." move lsCurDir to lsPath 44843>>>>>>> if (right(lsPath,1)=lsDirSep and right(lsPath,2)<>(":"+lsDirSep)) move (StringLeftBut(lsPath,1)) to lsPath 44846>>>>>>> function_return lsPath 44847>>>>>>>end_function 44848>>>>>>> 44848>>>>>>>// The SEQ_ComposeAbsoluteFileName function takes a path (without filename) 44848>>>>>>>// and a file name (without a path) and returns a file name including path. 44848>>>>>>>// It's purpose is to insert a path delimiter if necessary. 44848>>>>>>>function SEQ_ComposeAbsoluteFileName global string sDir string fn# returns string 44850>>>>>>> string dir_sep# 44850>>>>>>> move (replace(SEQ_ExtractPathFromFileName(fn#),fn#,"")) to fn# // Remove path if present anyway! 44851>>>>>>> //move (SEQ_ExtractPathFromFileName(sDir)) to sDir 44851>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to dir_sep# 44852>>>>>>> if sDir eq "" get_current_directory to sDir 44855>>>>>>> if (right(sDir,1)<>dir_sep#) move (sDir+dir_sep#) to sDir 44858>>>>>>> function_return (sDir+fn#) 44859>>>>>>>end_function 44860>>>>>>> 44860>>>>>>>//> This function pretty much does the same as SEQ_ComposeAbsoluteFileName. Only 44860>>>>>>>//> the code is less tricky and it's got a nicer name. 44860>>>>>>>function Files_AppendPath global string lsPath1 string lsPath2 returns string 44862>>>>>>> string lsSep 44862>>>>>>> move (trim(lsPath1)) to lsPath1 44863>>>>>>> move (trim(lsPath2)) to lsPath2 44864>>>>>>> move (sysconf(SYSCONF_DIR_SEPARATOR)) to lsSep 44865>>>>>>> if (right(lsPath1,1)=lsSep and left(lsPath2,1)=lsSep) move (replace(lsSep,lsPath2,"")) to lsPath2 44868>>>>>>> if (lsPath1<>"" and lsPath2<>"" and right(lsPath1,1)<>lsSep and left(lsPath2,1)<>lsSep) move (lsSep+lsPath2) to lsPath2 44871>>>>>>> function_return (append(lsPath1,lsPath2)) 44872>>>>>>>end_function 44873>>>>>>> 44873>>>>>>>// This function does the same as Files_AppendPath except here you also 44873>>>>>>>// pass the dir separator to the function. 44873>>>>>>>function Files_AppendPath_Sep global string lsPath1 string lsSep string lsPath2 returns string 44875>>>>>>> move (trim(lsPath1)) to lsPath1 44876>>>>>>> move (trim(lsPath2)) to lsPath2 44877>>>>>>> if (right(lsPath1,1)=lsSep and left(lsPath2,1)=lsSep) move (replace(lsSep,lsPath2,"")) to lsPath2 44880>>>>>>> if (lsPath1<>"" and lsPath2<>"" and right(lsPath1,1)<>lsSep and left(lsPath2,1)<>lsSep) move (lsSep+lsPath2) to lsPath2 44883>>>>>>> function_return (append(lsPath1,lsPath2)) 44884>>>>>>>end_function 44885>>>>>>> 44885>>>>>>>function SEQ_ConvertToAbsoluteFileName global string sFileName returns string 44887>>>>>>> string sDir 44887>>>>>>>// showln "SEQ_ConvertToAbsoluteFileName " sFileName 44887>>>>>>> if (SEQ_FileExists(sFileName)) ne SEQIT_NONE begin 44889>>>>>>>// showln "Does exists" 44889>>>>>>> get SEQ_ExtractPathFromFileName sFileName to sDir 44890>>>>>>> if sDir eq "" begin 44892>>>>>>> get SEQ_FindFileAlongDFPath sFileName to sDir 44893>>>>>>> get SEQ_ComposeAbsoluteFileName sDir sFileName to sFileName 44894>>>>>>> end 44894>>>>>>>> 44894>>>>>>> get SEQ_TranslatePathToAbsolute sFileName to sFileName 44895>>>>>>> end 44895>>>>>>>> 44895>>>>>>> else move "" to sFileName 44897>>>>>>> function_return sFileName 44898>>>>>>>end_function 44899>>>>>>> 44899>>>>>>>//> This function really makes an effert to return the full path 44899>>>>>>>//> if the data file. If it cannot be determined, the empty string 44899>>>>>>>//> is returned. 44899>>>>>>>function SEQ_FindDataFileFromRootName global string lsRoot returns string 44901>>>>>>> string lsExt lsPath 44901>>>>>>> // This procedure 44901>>>>>>> move (lowercase(right(lsRoot,4))) to lsExt 44902>>>>>>> ifnot (lsExt=".dat" or lsExt=".int") move (lsRoot+".DAT") to lsRoot 44905>>>>>>> 44905>>>>>>> if (SEQ_ExtractPathFromFileName(lsRoot)) eq "" begin 44907>>>>>>> move (SEQ_FindFileAlongDFPath(lsRoot)) to lsPath 44908>>>>>>> move (SEQ_ComposeAbsoluteFileName(lsPath,lsRoot)) to lsRoot 44909>>>>>>> end 44909>>>>>>>> 44909>>>>>>> 44909>>>>>>> get SEQ_ConvertToAbsoluteFileName lsRoot to lsRoot 44910>>>>>>> function_return lsRoot 44911>>>>>>>end_function 44912>>>>>>> 44912>>>>>>>[found ~found] begin // Sneaky way of skipping code 44914>>>>>>>> 44914>>>>>>> files.no$err: // This serves as an empty low-level error handler routine 44914>>>>>>> return 44915>>>>>>>end 44915>>>>>>>> 44915>>>>>>> 44915>>>>>>>//> Function SEQ_FileModTime returns the last modified stamp of a file 44915>>>>>>>//> in TS format (see DATES.NUI). NOTE! File specification MUST include 44915>>>>>>>//> full path. 44915>>>>>>>function SEQ_FileModTime global string fn# returns number 44917>>>>>>> integer h# m# s# err_label# 44917>>>>>>> date date# 44917>>>>>>> number rval# 44917>>>>>>> move (StringOemToAnsi(fn#)) to fn# 44918>>>>>>> ifnot (SEQ_FileExists(fn#)) function_return 0 44921>>>>>>> move |VI31 to err_label# //copy ON ERROR label 44922>>>>>>> on error gosub files.no$err // If file is open get_file_mod_time 44923>>>>>>> indicate err false // command will fail. 44924>>>>>>> get_file_mod_time fn# to date# h# m# s# // VDF6: 4358 DFRUNCON(31e): 4630 44928>>>>>>>// showln "get_file_mod_time " date# " " h# " " m# " " s# 44928>>>>>>> indicate err false 44929>>>>>>> move err_label# to |VI31 //restore original ON ERROR label 44930>>>>>>> indicate err false 44931>>>>>>> move (Date2to4(date#)) to date# 44932>>>>>>> move (TS_Compose2(date#,h#,m#,s#)) to rval# 44933>>>>>>> function_return rval# 44934>>>>>>>end_function // SEQ_FileModTime 44935>>>>>>> 44935>>>>>>>procedure set SEQ_FileModTime global string lsFile number lnTime 44937>>>>>>> integer h# m# s# err_label# liDateFormat 44937>>>>>>> date date# 44937>>>>>>> number rval# 44937>>>>>>> string lsTime 44937>>>>>>> ifnot (SEQ_FileExists(lsFile)) procedure_return 44940>>>>>>> move |VI31 to err_label# //copy ON ERROR label 44941>>>>>>> on error gosub files.no$err 44942>>>>>>> indicate err false 44943>>>>>>> get TS_ExtractDate lnTime to date# 44944>>>>>>> get TS_ExtractTime lnTime to lsTime 44945>>>>>>> move (mid(lsTime,2,1)) to h# 44946>>>>>>> move (mid(lsTime,2,4)) to m# 44947>>>>>>> move (mid(lsTime,2,7)) to s# 44948>>>>>>>// showln "set_file_mod_time " date# " " h# " " m# " " s# 44948>>>>>>> get_attribute DF_DATE_FORMAT to liDateFormat // set_file_mod_time only works when dateformat is DF_DATE_USA 44951>>>>>>> set_attribute DF_DATE_FORMAT to DF_DATE_USA 44954>>>>>>> move (StringOemToAnsi(lsFile)) to lsFile 44955>>>>>>> set_file_mod_time lsFile to date# h# m# s# // Faulty Faulty Faulty 44960>>>>>>> set_attribute DF_DATE_FORMAT to liDateFormat 44963>>>>>>> indicate err false 44964>>>>>>> move err_label# to |VI31 //restore original ON ERROR label 44965>>>>>>> indicate err false 44966>>>>>>>end_procedure // set SEQ_FileModTime 44967>>>>>>> 44967>>>>>>>procedure SEQ_CallBack_DirsInPath global string path# integer msg# integer obj# 44969>>>>>>> integer pos# len# 44969>>>>>>> string sep# dir# char# 44969>>>>>>> move (sysconf(SYSCONF_PATH_SEPARATOR)) to sep# 44970>>>>>>> move (length(path#)) to len# 44971>>>>>>> move "" to dir# 44972>>>>>>> for pos# from 1 to len# 44978>>>>>>>> 44978>>>>>>> move (mid(path#,1,pos#)) to char# 44979>>>>>>> if char# eq sep# begin 44981>>>>>>> if dir# ne "" send msg# to obj# dir# 44984>>>>>>> move "" to dir# 44985>>>>>>> end 44985>>>>>>>> 44985>>>>>>> else move (dir#+char#) to dir# 44987>>>>>>> loop 44988>>>>>>>> 44988>>>>>>> if dir# ne "" send msg# to obj# dir# 44991>>>>>>>end_procedure 44992>>>>>>> 44992>>>>>>>function SEQ_RemoveRedundantDirs global string path# returns string 44994>>>>>>> integer pos# len# 44994>>>>>>> string sep# dir# char# rval# 44994>>>>>>> move (sysconf(SYSCONF_PATH_SEPARATOR)) to sep# 44995>>>>>>> move (length(path#)) to len# 44996>>>>>>> move "" to dir# 44997>>>>>>> move "|" to rval# 44998>>>>>>> for pos# from 1 to len# 45004>>>>>>>> 45004>>>>>>> move (mid(path#,1,pos#)) to char# 45005>>>>>>> if char# eq sep# begin 45007>>>>>>> if dir# ne "" begin 45009>>>>>>> move (SEQ_TranslatePathToAbsolute(dir#)) to dir# 45010>>>>>>> ifnot ("|"+lowercase(dir#)+"|") in (lowercase(rval#)) move (rval#+dir#+"|") to rval# 45013>>>>>>> move "" to dir# 45014>>>>>>> end 45014>>>>>>>> 45014>>>>>>> end 45014>>>>>>>> 45014>>>>>>> else move (dir#+char#) to dir# 45016>>>>>>> loop 45017>>>>>>>> 45017>>>>>>> if dir# ne "" begin 45019>>>>>>> move (SEQ_TranslatePathToAbsolute(dir#)) to dir# 45020>>>>>>> ifnot ("|"+lowercase(dir#)+"|") in (lowercase(rval#)) move (rval#+dir#+"|") to rval# 45023>>>>>>> end 45023>>>>>>>> 45023>>>>>>> replace "|" in rval# with "" 45025>>>>>>> move (replaces("|",rval#,sep#)) to rval# 45026>>>>>>> function_return rval# 45027>>>>>>>end_function 45028>>>>>>> 45028>>>>>>>enumeration_list 45028>>>>>>> define SEQCB_FILES_ONLY 45028>>>>>>> define SEQCB_DIRS_ONLY 45028>>>>>>> define SEQCB_FILESANDDIRS 45028>>>>>>>end_enumeration_list 45028>>>>>>> 45028>>>>>>>desktop_section 45033>>>>>>> object oSEQ_CallBack_ItemsInDir is an cArray NO_IMAGE 45035>>>>>>> property string psPath public "" 45037>>>>>>> procedure add_item string str# 45040>>>>>>> set value item (item_count(self)) to str# 45041>>>>>>> end_procedure 45042>>>>>>> function iNumberOfItems integer lhMode returns integer 45045>>>>>>> integer liMax liItm liCount 45045>>>>>>> get item_count to liMax 45046>>>>>>> decrement liMax 45047>>>>>>> move 0 to liCount 45048>>>>>>> if (lhMode=SEQCB_FILES_ONLY) begin 45050>>>>>>> for liItm from 0 to liMax 45056>>>>>>>> 45056>>>>>>> ifnot (left(value(self,liItm),1)="[") increment liCount 45059>>>>>>> loop 45060>>>>>>>> 45060>>>>>>> function_return liCount 45061>>>>>>> end 45061>>>>>>>> 45061>>>>>>> if (lhMode=SEQCB_DIRS_ONLY) begin 45063>>>>>>> for liItm from 0 to liMax 45069>>>>>>>> 45069>>>>>>> if (left(value(self,liItm),1)="[") increment liCount 45072>>>>>>> loop 45073>>>>>>>> 45073>>>>>>> function_return liCount 45074>>>>>>> end 45074>>>>>>>> 45074>>>>>>> if (lhMode=SEQCB_FILESANDDIRS) function_return (item_count(self)) 45077>>>>>>> end_function 45078>>>>>>> end_object 45079>>>>>>>end_desktop_section 45084>>>>>>> 45084>>>>>>>procedure SEQ_Load_ItemsInDir global string path# 45086>>>>>>> send WinFolder_ReadFolder path# 45087>>>>>>>end_procedure 45088>>>>>>>function SEQ_NumberFiles global integer liMode returns integer 45090>>>>>>> integer lhObj 45090>>>>>>> move (oWinFolderEntries(self)) to lhObj 45091>>>>>>> if (liMode=SEQCB_FILES_ONLY ) function_return (piFileCount(lhObj)) 45094>>>>>>> if (liMode=SEQCB_DIRS_ONLY ) function_return (piFolderCount(lhObj)) 45097>>>>>>> if (liMode=SEQCB_FILESANDDIRS) function_return (piFileCount(lhObj)+piFolderCount(lhObj)) 45100>>>>>>>end_function 45101>>>>>>>procedure SEQ_CallBack_ItemsInDir global integer liMode integer lhMsg integer lhObj 45103>>>>>>> integer lhFolder liMax liRow lbFolder 45103>>>>>>> string lsName lsPath 45103>>>>>>> move (oWinFolderEntries(self)) to lhFolder 45104>>>>>>> get psFolder of lhFolder to lsPath 45105>>>>>>> get row_count of lhFolder to liMax 45106>>>>>>> decrement liMax 45107>>>>>>> for liRow from 0 to liMax 45113>>>>>>>> 45113>>>>>>> get pbFolder.i of lhFolder liRow to lbFolder 45114>>>>>>> get psFileName.i of lhFolder liRow to lsName 45115>>>>>>> 45115>>>>>>> if lbFolder begin 45117>>>>>>> if (liMode<>SEQCB_FILES_ONLY) send lhMsg to lhObj ("["+lsName+"]") lsPath (pnFileSz.i(lhFolder,liRow)) (pnLastWrite.i(lhFolder,liRow)) 45120>>>>>>> end 45120>>>>>>>> 45120>>>>>>> else begin 45121>>>>>>> if (liMode<>SEQCB_DIRS_ONLY) send lhMsg to lhObj lsName lsPath (pnFileSz.i(lhFolder,liRow)) (pnLastWrite.i(lhFolder,liRow)) 45124>>>>>>> end 45124>>>>>>>> 45124>>>>>>> loop 45125>>>>>>>> 45125>>>>>>>end_procedure 45126>>>>>>> 45126>>>>>>>desktop_section 45131>>>>>>> object oFileInPath is an cArray NO_IMAGE 45133>>>>>>> property string psFileToCheck public "" 45135>>>>>>> property integer piMessage public 0 45137>>>>>>> property integer piObject public 0 45139>>>>>>> procedure CallBack_FileInPath_Help string dir# 45142>>>>>>> integer msg# obj# 45142>>>>>>> string fn# 45142>>>>>>> get piMessage to msg# 45143>>>>>>> get piObject to obj# 45144>>>>>>> move (SEQ_ComposeAbsoluteFileName(dir#,psFileToCheck(self))) to fn# 45145>>>>>>> if (SEQ_FileExists(fn#)) send msg# to obj# fn# 45148>>>>>>> end_procedure 45149>>>>>>> procedure CallBack_FileInPath string file# string path# integer msg# integer obj# 45152>>>>>>> send delete_data 45153>>>>>>> set psFileToCheck to file# 45154>>>>>>> set piMessage to msg# 45155>>>>>>> set piObject to obj# 45156>>>>>>> send SEQ_CallBack_DirsInPath path# msg_CallBack_FileInPath_help self 45157>>>>>>> send delete_data 45158>>>>>>> end_procedure 45159>>>>>>> end_object 45160>>>>>>>end_desktop_section 45165>>>>>>> 45165>>>>>>>procedure SEQ_CallBack_FileInPath global string file# string path# integer msg# integer obj# 45167>>>>>>> send CallBack_FileInPath to (oFileInPath(self)) file# path# msg# obj# 45168>>>>>>>end_procedure 45169>>>>>>> 45169>>>>>>>// Procedure SEQ_WriteArrayItems writes the contents of an array (obj#) to 45169>>>>>>>// sequential channel ch#. The procedure will only produce a meaningful 45169>>>>>>>// result if the items of the array does not contain strings with binary data 45169>>>>>>>// or CR/FL characters. 45169>>>>>>>procedure SEQ_WriteArrayItems global integer ch# integer obj# 45171>>>>>>> integer itm# max# 45171>>>>>>> get item_count of obj# to max# 45172>>>>>>> writeln channel ch# max# 45175>>>>>>> for itm# from 0 to (max#-1) 45181>>>>>>>> 45181>>>>>>> writeln (value(obj#,itm#)) 45183>>>>>>> loop 45184>>>>>>>> 45184>>>>>>>end_procedure 45185>>>>>>> 45185>>>>>>>// Procedure SEQ_ReadArrayItems will fill the array (obj#) with data 45185>>>>>>>// read from sequential channel ch#. These data must have been written 45185>>>>>>>// using the SEQ_WriteArrayItems procedure. 45185>>>>>>>procedure SEQ_ReadArrayItems global integer ch# integer obj# 45187>>>>>>> integer itm# max# 45187>>>>>>> string str# 45187>>>>>>> send delete_data to obj# 45188>>>>>>> get item_count of obj# to max# 45189>>>>>>> readln channel ch# max# 45191>>>>>>> for itm# from 0 to (max#-1) 45197>>>>>>>> 45197>>>>>>> readln str# 45198>>>>>>> set value of obj# item itm# to str# 45199>>>>>>> loop 45200>>>>>>>> 45200>>>>>>>end_procedure 45201>>>>>>> 45201>>>>>>>// Calling procedure SEQ_WriteRecordBuffer_LD will write the current 45201>>>>>>>// contents of the record buffer of file file# through channel ch#. 45201>>>>>>>// The post-fix "LD" means line delimited. 45201>>>>>>>procedure SEQ_WriteRecordBuffer_LD global integer ch# integer file# 45203>>>>>>> integer max# field# fieldindex# filenumber# len# type# 45203>>>>>>> move fieldindex to fieldindex# 45204>>>>>>> move filenumber to filenumber# 45205>>>>>>> get_attribute DF_FILE_NUMBER_FIELDS of file# to max# 45208>>>>>>> move file# to filenumber 45209>>>>>>> write channel ch# // Set channel 45210>>>>>>> for fieldindex from 1 to max# 45216>>>>>>>> 45216>>>>>>> get_attribute DF_FIELD_TYPE of file# fieldindex to type# 45219>>>>>>> if type# ne DF_OVERLAP begin // Do not write overlap fields 45221>>>>>>> if (type#=DF_BINARY or type#=DF_TEXT) begin // If TEXT or BINARY we 45223>>>>>>> move (length(indirect_file.recnum)) to len# // write(ln) the length 45224>>>>>>> writeln len# // of the field before 45226>>>>>>> write indirect_file.recnum // its contents. 45227>>>>>>> end 45227>>>>>>>> 45227>>>>>>> else writeln indirect_file.recnum 45230>>>>>>> end 45230>>>>>>>> 45230>>>>>>> loop 45231>>>>>>>> 45231>>>>>>> move fieldindex# to fieldindex 45232>>>>>>> move filenumber# to filenumber 45233>>>>>>>end_procedure 45234>>>>>>> 45234>>>>>>>// Read a record from channel ch# as written by the SEQ_WriteRecordBuffer_LD 45234>>>>>>>// procedure. 45234>>>>>>>procedure SEQ_ReadRecordBuffer_LD global integer ch# integer file# 45236>>>>>>> integer max# fieldindex# filenumber# len# type# 45236>>>>>>> move fieldindex to fieldindex# 45237>>>>>>> move filenumber to filenumber# 45238>>>>>>> get_attribute DF_FILE_NUMBER_FIELDS of file# to max# 45241>>>>>>> move file# to filenumber 45242>>>>>>> read channel ch# // Set channel 45243>>>>>>> for fieldindex from 1 to max# 45249>>>>>>>> 45249>>>>>>> get_attribute DF_FIELD_TYPE of file# fieldindex to type# 45252>>>>>>> if type# ne DF_OVERLAP begin 45254>>>>>>> if (type#=DF_BINARY or type#=DF_TEXT) begin 45256>>>>>>> readln len# 45257>>>>>>> read_block indirect_file.recnum len# 45258>>>>>>> end 45258>>>>>>>> 45258>>>>>>> else readln indirect_file.recnum 45260>>>>>>> end 45260>>>>>>>> 45260>>>>>>> loop 45261>>>>>>>> 45261>>>>>>> move fieldindex# to fieldindex 45262>>>>>>> move filenumber# to filenumber 45263>>>>>>>end_procedure 45264>>>>>>> 45264>>>>>>>// Reads a record like the SEQ_ReadRecordBuffer_LD procedure but places the 45264>>>>>>>// result in the array passed in the lhArray instead of directly in the 45264>>>>>>>// record buffer. 45264>>>>>>>procedure SEQ_ReadRecordBufferToArray_LD global integer liChannel integer liFile integer lhArray 45266>>>>>>> integer liMax liField liLen liType 45266>>>>>>> string lsValue 45266>>>>>>> send delete_data to lhArray 45267>>>>>>> get_attribute DF_FILE_NUMBER_FIELDS of liFile to liMax 45270>>>>>>> read channel liChannel // Set channel 45271>>>>>>> for liField from 1 to liMax 45277>>>>>>>> 45277>>>>>>> get_attribute DF_FIELD_TYPE of liFile liField to liType 45280>>>>>>> if liType ne DF_OVERLAP begin 45282>>>>>>> if (liType=DF_BINARY or liType=DF_TEXT) begin 45284>>>>>>> readln liLen 45285>>>>>>> read_block lsValue liLen 45286>>>>>>> end 45286>>>>>>>> 45286>>>>>>> else readln lsValue 45288>>>>>>> end 45288>>>>>>>> 45288>>>>>>> set value of lhArray item liField to lsValue 45289>>>>>>> loop 45290>>>>>>>> 45290>>>>>>>end_procedure 45291>>>>>>> 45291>>>>>>>// Returns true if delete was successful 45291>>>>>>>function SEQ_EraseFile global string lsFile returns integer 45293>>>>>>> if (SEQ_FileExists(lsFile)) eq SEQIT_DIRECTORY function_return 0 45296>>>>>>> erasefile (StringOemToAnsi(lsFile)) 45297>>>>>>>> 45297>>>>>>> if (SEQ_FileExists(lsFile)) eq SEQIT_NONE function_return 1 45300>>>>>>> // function_return 0 45300>>>>>>>end_function 45301>>>>>>> 45301>>>>>>>Use wvaW32fh.pkg // Package by Wil van Antwerpen from www.vdf-guidance.com Including file: wvaw32fh.pkg (C:\Apps\VDFQuery\AppSrc\wvaw32fh.pkg) 45301>>>>>>>>>// this package serves as a buffer between VDFQuery packages and 45301>>>>>>>>>// the Win32 file handling of Wil v. Antwherpen. 45301>>>>>>>>> 45301>>>>>>>>>use wvasymb.pkg Including file: wvasymb.pkg (C:\Apps\VDFQuery\AppSrc\wvasymb.pkg) 45301>>>>>>>>>>> 45301>>>>>>>>>>>enumeration_list 45301>>>>>>>>>>> define WVA$FILE_HANDLING_1999 45301>>>>>>>>>>> define WVA$FILE_HANDLING_2002 45301>>>>>>>>>>>end_enumeration_list 45301>>>>>>>>> 45301>>>>>>>>> // define wva_default for WVA$FILE_HANDLING_1999 45301>>>>>>>>> define wva_default for WVA$FILE_HANDLING_2002 45301>>>>>>>>> 45301>>>>>>>>>//#IF wva_default=WVA$FILE_HANDLING_1999 45301>>>>>>>>> //use vsWin32fh.pkg 45301>>>>>>>>> //Function wvaSelect_File Global String sSupportedFileTypes String sCaptionText String sInitial_Folder Returns String 45301>>>>>>>>> //function_return (vsSelect_File(sSupportedFileTypes,sCaptionText,sInitial_Folder)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaFolderExists Global String sFolderName returns Integer 45301>>>>>>>>> //function_return (vsFolderExists(sFolderName)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaWin32_SHBrowseForFolder Global String sDialogTitle returns String 45301>>>>>>>>> //function_return (vsWin32_SHBrowseForFolder(sDialogTitle)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaWin32_CreateDirectory Global String sNewFolder Returns Integer 45301>>>>>>>>> //function_return (vsWin32_CreateDirectory(sNewFolder)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaVerifyNewFolder Global String sFolderName Returns Integer 45301>>>>>>>>> //function_return (vsVerifyNewFolder(sFolderName)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaWin32_ShDeleteFile Global String sFileName Returns Integer 45301>>>>>>>>> //function_return (vsWin32_ShDeleteFile(sFileName)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaWin32_ShCopyFile Global String sSource String sDestination returns Integer 45301>>>>>>>>> //function_return (vsWin32_ShCopyFile(sSource,sDestination)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaWin32_ShMoveFile Global String sSource String sDestination returns Integer 45301>>>>>>>>> //function_return (vsWin32_ShMoveFile(sSource,sDestination)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Function wvaWin32_ShRenameFile Global String sSource String sDestination returns Integer 45301>>>>>>>>> //function_return (vsWin32_ShRenameFile(sSource,sDestination)) 45301>>>>>>>>> //End_Function 45301>>>>>>>>> //Procedure wvaWin32_ShellExecute global String sOperation String sDocument String sParameters String sPath 45301>>>>>>>>> //send vsWin32_ShellExecute sOperation sDocument sParameters sPath 45301>>>>>>>>> //end_procedure 45301>>>>>>>>>//#ENDIF 45301>>>>>>>>> use vWin32fh.pkg 45301>>>>>>>>> Function wvaSelect_File Global String sSupportedFileTypes String sCaptionText String sInitial_Folder Returns String 45303>>>>>>>>> function_return (vSelect_File(sSupportedFileTypes,sCaptionText,sInitial_Folder)) 45304>>>>>>>>> End_Function 45305>>>>>>>>> Function wvaFolderExists Global String sFolderName returns Integer 45307>>>>>>>>> function_return (vFolderExists(sFolderName)) 45308>>>>>>>>> End_Function 45309>>>>>>>>> Function wvaWin32_SHBrowseForFolder Global String sDialogTitle returns String 45311>>>>>>>>> function_return (vSHBrowseForFolder(sDialogTitle)) 45312>>>>>>>>> End_Function 45313>>>>>>>>> Function wvaWin32_CreateDirectory Global String sNewFolder Returns Integer 45315>>>>>>>>> function_return (vCreateDirectory(sNewFolder)) 45316>>>>>>>>> End_Function 45317>>>>>>>>> Function wvaVerifyNewFolder Global String sFolderName Returns Integer 45319>>>>>>>>> function_return (vVerifyNewFolder(sFolderName)) 45320>>>>>>>>> End_Function 45321>>>>>>>>> Function wvaWin32_ShDeleteFile Global String sFileName Returns Integer 45323>>>>>>>>> function_return (vDeleteFile(sFileName)) 45324>>>>>>>>> End_Function 45325>>>>>>>>> Function wvaWin32_ShCopyFile Global String sSource String sDestination returns Integer 45327>>>>>>>>> function_return (vCopyFile(sSource,sDestination)) 45328>>>>>>>>> End_Function 45329>>>>>>>>> Function wvaWin32_ShMoveFile Global String sSource String sDestination returns Integer 45331>>>>>>>>> function_return (vMoveFile(sSource,sDestination)) 45332>>>>>>>>> End_Function 45333>>>>>>>>> Function wvaWin32_ShRenameFile Global String sSource String sDestination returns Integer 45335>>>>>>>>> function_return (vRenameFile(sSource,sDestination)) 45336>>>>>>>>> End_Function 45337>>>>>>>>> Procedure wvaWin32_ShellExecute global String sOperation String sDocument String sParameters String sPath 45339>>>>>>>>> send vShellExecute sOperation sDocument sParameters sPath 45340>>>>>>>>> end_procedure 45341>>>>>>>function SEQ_CopyFile global string lsSourceFile string lsTargetFile returns integer 45343>>>>>>> integer liRval 45343>>>>>>> move (StringOemToAnsi(lsSourceFile)) to lsSourceFile 45344>>>>>>> move (StringOemToAnsi(lsTargetFile)) to lsTargetFile 45345>>>>>>> get wvaWin32_ShCopyFile lsSourceFile lsTargetFile to liRval 45346>>>>>>> move (not(liRval)) to liRval 45347>>>>>>> function_return liRval 45348>>>>>>>end_function 45349>>>>>>>// Returns true if delete was successful 45349>>>>>>>function SEQ_MoveFile global string lsSourceFile string lsTargetFile returns integer 45351>>>>>>> integer liRval 45351>>>>>>> get SEQ_CopyFile lsSourceFile lsTargetFile to liRval 45352>>>>>>> if liRval get SEQ_EraseFile lsSourceFile to liRval 45355>>>>>>> function_return liRval 45356>>>>>>>end_function 45357>>>>>>> 45357>>>>>>>function SEQ_ValidDrives global returns string 45359>>>>>>> integer liLen liPos lbError 45359>>>>>>> string lsDrives lsDrive lsRval 45359>>>>>>> send delete_data 45360>>>>>>> move "ABCDEFGHIJKLMNOPQRSTUVWXYZ" to lsDrives 45361>>>>>>> move (length(lsDrives)) to liLen 45362>>>>>>> move "" to lsRval 45363>>>>>>> for liPos from 1 to liLen 45369>>>>>>>> 45369>>>>>>> move (mid(lsDrives,1,liPos)) to lsDrive 45370>>>>>>> valid_drive lsDrive lbError 45371>>>>>>> ifnot lbError move (lsRval+lsDrive) to lsRval 45374>>>>>>> loop 45375>>>>>>>> 45375>>>>>>> function_return lsRval 45376>>>>>>>end_function 45377>>>>>>> 45377>>>>>>>function SEQ_AppendFiles global string lsFile1 string lsFile2 returns integer 45379>>>>>>> integer liRval liChannelOut liChannelIn liSize liIterations liRest liCount 45379>>>>>>> move (lowercase(lsFile1)) to lsFile1 45380>>>>>>> move (lowercase(lsFile2)) to lsFile2 45381>>>>>>> move 0 to liRval // Failure 45382>>>>>>> if lsFile1 ne lsFile2 begin 45384>>>>>>> // Both files exists? 45384>>>>>>> get SEQ_AppendOutput lsFile1 to liChannelOut 45385>>>>>>> if liChannelOut ge 0 begin 45387>>>>>>> send SEQ_WriteFile liChannelOut lsFile2 45388>>>>>>> move 1 to liRval // Let's just hope it's ok 45389>>>>>>> //get SEQ_FileSize lsFile2 to liSize 45389>>>>>>> //if liSize begin 45389>>>>>>> // get SEQ_DirectInput ("binary:"+lsFile2) to liChannelIn 45389>>>>>>> // if liChannelIn ge 0 begin 45389>>>>>>> // move (liSize/250) to liIterations 45389>>>>>>> // move (liSize-(liIterations*250)) to liRest 45389>>>>>>> // for liCount from 1 to liIterations 45389>>>>>>> // read_block channel liChannelIn giSeq$Temp 250 45389>>>>>>> // write channel liChannelOut giSeq$Temp 45389>>>>>>> // loop 45389>>>>>>> // read_block channel liChannelIn giSeq$Temp liRest 45389>>>>>>> // write channel liChannelOut giSeq$Temp 45389>>>>>>> // move 1 to liRval 45389>>>>>>> // send SEQ_CloseInput liChannelIn 45389>>>>>>> // end 45389>>>>>>> //end 45389>>>>>>> send SEQ_CloseOutput liChannelOut 45390>>>>>>> end 45390>>>>>>>> 45390>>>>>>> end 45390>>>>>>>> 45390>>>>>>> function_return liRval 45391>>>>>>>end_function 45392>>>>>>> 45392>>>>>>>// procedure SEQ_WriteHexByteStream global integer liChannel string lsHexBytes 45392>>>>>>>// integer liBytes liPos liByte liByteValue 45392>>>>>>>// string lsHexByte 45392>>>>>>>// move (length(lsHexBytes)/2) to liBytes 45392>>>>>>>// showln "Start SEQ_WriteHexByteStream" 45392>>>>>>>// decrement liBytes 45392>>>>>>>// for liByte from 0 to liBytes 45392>>>>>>>// move (liByte*2+1) to liPos 45392>>>>>>>// move (mid(lsHexBytes,2,liPos)) to lsHexByte 45392>>>>>>>// move (pos(left(lsHexByte,1),"0123456789ABCDEF")-1*16+pos(right(lsHexByte,1),"0123456789ABCDEF")-1) to liByteValue 45392>>>>>>>// character liByteValue to giSeq$Temp 45392>>>>>>>// write channel liChannel giSeq$Temp 45392>>>>>>>// loop 45392>>>>>>>// showln "End SEQ_WriteHexByteStream" 45392>>>>>>>// end_procedure 45392>>>>>>> 45392>>>>>>>procedure SEQ_WriteHexByteStream global integer liChannel string lsHexBytes 45394>>>>>>> integer liBytes liPos liByte liByteValue liByteCount 45394>>>>>>> string lsHexByte 45394>>>>>>> move (length(lsHexBytes)/2) to liBytes 45395>>>>>>> decrement liBytes 45396>>>>>>> move 0 to liByteCount 45397>>>>>>> move "" to giSeq$Temp 45398>>>>>>> for liByte from 0 to liBytes 45404>>>>>>>> 45404>>>>>>> move (liByte*2+1) to liPos 45405>>>>>>> move (mid(lsHexBytes,2,liPos)) to lsHexByte 45406>>>>>>> move (pos(left(lsHexByte,1),"0123456789ABCDEF")-1*16+pos(right(lsHexByte,1),"0123456789ABCDEF")-1) to liByteValue 45407>>>>>>> append giSeq$Temp (character(liByteValue)) 45408>>>>>>> increment liByteCount 45409>>>>>>> if liByteCount eq 250 begin 45411>>>>>>> write channel liChannel giSeq$Temp 45413>>>>>>> move 0 to liByteCount 45414>>>>>>> move "" to giSeq$Temp 45415>>>>>>> end 45415>>>>>>>> 45415>>>>>>> loop 45416>>>>>>>> 45416>>>>>>> if liByteCount write channel liChannel giSeq$Temp 45420>>>>>>>end_procedure 45421>>>>>>> 45421>>>>>>>function SEQ_FileListDirectory global returns string 45423>>>>>>> 45423>>>>>>>end_function 45424>>>>>>> 45424>>>>>>>//> The cChannelAdmin class was deviced to help administrate one sequential 45424>>>>>>>//> channel when it is used for more than one task at the same time. 45424>>>>>>>//> It may be used to temporarily suspend its current connection, do 45424>>>>>>>//> something else and then resume where it left off. 45424>>>>>>>class cChannelAdmin is an cArray // in/out device ch_pos 45425>>>>>>> procedure construct_object integer liImg 45427>>>>>>> forward send construct_object liImg 45429>>>>>>> property integer pChannel public 0 // channel number to administrate 45430>>>>>>> property integer pPointer public 0 // stack pointer 45431>>>>>>> end_procedure 45432>>>>>>> 45432>>>>>>> procedure reset 45434>>>>>>> send delete_data 45435>>>>>>> set pPointer to 0 45436>>>>>>> end_procedure 45437>>>>>>> 45437>>>>>>> procedure close_help 45439>>>>>>> integer liPointer liCh liPosition lbInput 45439>>>>>>> string lsDev 45439>>>>>>> get pPointer to liPointer 45440>>>>>>> decrement liPointer 45441>>>>>>> get pChannel to liCh 45442>>>>>>> get_channel_position liCh to liPosition 45443>>>>>>>> 45443>>>>>>> get integer_value item (liPointer*3) to lbInput 45444>>>>>>> if lbInput close_input channel liCh 45448>>>>>>> else close_output channel liCh 45451>>>>>>> set value item (liPointer*3+2) to liPosition 45452>>>>>>> get value item (liPointer*3+1) to lsDev 45453>>>>>>> //send obs ("closing current activity ("+if(lbInput,"input","output")+") "+lsDev+" at position "+string(liPosition)) 45453>>>>>>> end_procedure 45454>>>>>>> 45454>>>>>>> procedure close_current_activity 45456>>>>>>> send close_help 45457>>>>>>> end_procedure 45458>>>>>>> 45458>>>>>>> procedure restore_activity 45460>>>>>>> integer liPointer lbInput liPosition liCh 45460>>>>>>> string lsDev lsValue 45460>>>>>>> get pPointer to liPointer 45461>>>>>>> decrement liPointer 45462>>>>>>> get pChannel to liCh 45463>>>>>>> get value item (liPointer*3) to lbInput 45464>>>>>>> get value item (liPointer*3+1) to lsDev 45465>>>>>>> get value item (liPointer*3+2) to liPosition 45466>>>>>>> if lbInput begin 45468>>>>>>> direct_input channel liCh lsDev 45470>>>>>>> if liPosition gt 0 decrement liPosition 45473>>>>>>> set_channel_position liCh to liPosition 45474>>>>>>>> 45474>>>>>>> if liPosition gt 0 read_block channel liCh lsValue 1 45478>>>>>>> end 45478>>>>>>>> 45478>>>>>>> else append_output channel liCh (StringOemToAnsi(lsDev)) 45481>>>>>>> //send obs ("restoring current activity ("+if(lbInput,"input","output")+") "+lsDev+" at position "+string(liPosition)) 45481>>>>>>> end_procedure 45482>>>>>>> 45482>>>>>>> function sReadln returns string 45484>>>>>>> string lsRval 45484>>>>>>> readln channel (pChannel(self)) lsRval 45486>>>>>>> function_return lsRval 45487>>>>>>> end_function 45488>>>>>>> 45488>>>>>>> //> Use this procedure to initiate a new sequential file operation. 45488>>>>>>> procedure direct_xput integer lbInput string lsDev 45490>>>>>>> integer liPointer liChannel 45490>>>>>>> //send obs ("direct_xput ("+if(lbInput,"input","output")+") "+lsDev) 45490>>>>>>> get pPointer to liPointer 45491>>>>>>> get pChannel to liChannel 45492>>>>>>> if liPointer send close_current_activity 45495>>>>>>> 45495>>>>>>> if lbInput direct_input channel liChannel (StringOemToAnsi(lsDev)) 45499>>>>>>> else direct_output channel liChannel (StringOemToAnsi(lsDev)) 45502>>>>>>> set array_value item (liPointer*3) to lbInput 45503>>>>>>> set array_value item (liPointer*3+1) to lsDev 45504>>>>>>> set pPointer to (liPointer+1) 45505>>>>>>> end_procedure 45506>>>>>>> 45506>>>>>>> //> Use procedure Close_Xput to terminate the current sequential file 45506>>>>>>> //> operation and restore the previous, if any. 45506>>>>>>> procedure close_xput 45508>>>>>>> integer liPointer 45508>>>>>>> get pPointer to liPointer 45509>>>>>>> send close_help 45510>>>>>>> decrement liPointer 45511>>>>>>> set pPointer to liPointer 45512>>>>>>> if liPointer send restore_activity 45515>>>>>>> end_procedure 45516>>>>>>>end_class // cChannelAdmin 45517>>>>>>> 45517>>>>>>>// Returns something like 
2003-08-23_175515.
45517>>>>>>>function SEQ_SysTimeFileName global string lsPre string lsExt returns string
45519>>>>>>>  string lsRval
45519>>>>>>>  move (lsPre+DateToString(dSysDate(),DF_DATE_MILITARY,1,"-")+"_"+replaces(":",sSysTime(),"")) to lsRval
45520>>>>>>>  if (lsExt<>"") move (lsRval+"."+lsExt) to lsRval
45523>>>>>>>  function_return lsRval
45524>>>>>>>end_function
45525>>>>>>>
45525>>>>>>>
45525>>>>>>>function SEQ_InputChannelLineCount global integer liChannel returns integer
45527>>>>>>>  string lsThrowAway
45527>>>>>>>  get SEQ_ReadLnProbe liChannel to lsThrowAway
45528>>>>>>>  function_return LineCount
45529>>>>>>>end_function
45530>>>>>>>
45530>>>>>>>function SEQ_ChannelPosToLineCount global integer liChannel integer liPos returns integer
45532>>>>>>>  integer liPushPos lbSeqEof lbSneakMode liTestPos liCount
45532>>>>>>>  string lsRval lsValue liLineCount
45532>>>>>>>  get_channel_position liChannel to liPushPos
45533>>>>>>>>
45533>>>>>>>
45533>>>>>>>  move 0 to liCount
45534>>>>>>>  set_channel_position liChannel to 0
45535>>>>>>>>
45535>>>>>>>  repeat
45535>>>>>>>>
45535>>>>>>>    readln channel liChannel lsValue
45537>>>>>>>    increment liCount
45538>>>>>>>    move (seqeof) to lbSeqEof
45539>>>>>>>    get_channel_position liChannel to liTestPos
45540>>>>>>>>
45540>>>>>>>  until (liTestPos>=liPos or lbSeqEof<>0)
45542>>>>>>>  if (liPos>liTestPos) move -1 to liCount // Signal that the position doesn't exist at all
45545>>>>>>>
45545>>>>>>>  // Restore the state of the channel:
45545>>>>>>>  move (liPushPos>0) to lbSneakMode
45546>>>>>>>  if lbSneakMode decrement liPushPos
45549>>>>>>>  set_channel_position liChannel to liPushPos
45550>>>>>>>>
45550>>>>>>>  if lbSneakMode read_block channel liChannel lsValue 1
45554>>>>>>>  indicate seqeof as lbSeqEof ne 0
45555>>>>>>>  function_return liCount
45556>>>>>>>end_function
45557>>>>>>>
45557>>>>>>>function SEQ_CurrentFolder global returns string
45559>>>>>>>  string lsValue
45559>>>>>>>  GET_CURRENT_DIRECTORY to lsValue
45560>>>>>>>  function_return lsValue
45561>>>>>>>end_function
45562>>>>>>>
45562>>>>>>>function SEQ_TextFromSeqInput global string sDevice returns string
45564>>>>>>>  integer liChannel lbSeqEof
45564>>>>>>>  string sRval sLine sChar10
45564>>>>>>>  move "" to sRval
45565>>>>>>>  move (character(10)) to sChar10
45566>>>>>>>  get SEQ_DirectInput sDevice to liChannel
45567>>>>>>>  if liChannel ge 0 begin
45569>>>>>>>    repeat
45569>>>>>>>>
45569>>>>>>>      readln sLine
45570>>>>>>>      move (seqeof) to lbSeqEof
45571>>>>>>>      ifnot lbSeqEof move (sRval+sLine+sChar10) to sRval
45574>>>>>>>    until lbSeqEof
45576>>>>>>>  end
45576>>>>>>>>
45576>>>>>>>  send SEQ_CloseInput liChannel
45577>>>>>>>  function_return sRval
45578>>>>>>>end_function
45579>>>>>>>
45579>>>>>>>function SEQ_TextFromDfImage global integer iImg returns string
45581>>>>>>>  function_return (SEQ_TextFromSeqInput("image:"+string(iImg)))
45582>>>>>>>end_function
45583>>>>>>>function SEQ_TextFromFile global string sFile returns string
45585>>>>>>>  function_return (SEQ_TextFromSeqInput(sFile))
45586>>>>>>>end_function
45587>>>>>>>function SEQ_TextFromDfField global integer iFile integer iField returns string
45589>>>>>>>  // I have no idea whether this will work
45589>>>>>>>  function_return (SEQ_TextFromSeqInput("dbms:"+string(iFile)+" "+string(iField)))
45590>>>>>>>end_function
45591>>>>>>>
45591>>>>>
45591>>>>>function sTextFromDfImage global integer iImg returns string
45593>>>>>  function_return (SEQ_TextFromSeqInput("image:"+string(iImg)))
45594>>>>>end_function
45595>>>>>function sTextFromFile global string sFile returns string
45597>>>>>  function_return (SEQ_TextFromSeqInput(sFile))
45598>>>>>end_function
45599>>>>>function sTextFromDfField global integer iFile integer iField returns string
45601>>>>>  // I have no idea whether this will work
45601>>>>>  function_return (SEQ_TextFromSeqInput("dbms:"+string(iFile)+" "+string(iField)))
45602>>>>>end_function
45603>>>>>
45603>>>
45603>>>procedure DoDisplayLog global
45605>>>  integer liLogImage
45605>>>  string lsLog
45605>>>  get AppInfo AI_LOG_IMAGE to liLogImage
45606>>>  get sTextFromDfImage liLogImage to lsLog
45607>>>  send DoDisplayText "Program log" lsLog
45608>>>end_procedure
45609>>>procedure DoDisplayKnownIssues global
45611>>>  integer liLogImage
45611>>>  string lsLog
45611>>>  get AppInfo AI_KNOWN_ISSUES to liLogImage
45612>>>  get sTextFromDfImage liLogImage to lsLog
45613>>>  send DoDisplayText "Known Issues" lsLog
45614>>>end_procedure
45615>>>
45615>>>object oAboutPanel is a aps.ModalPanel label ("About "+AppInfo(AI_TITLE))
45618>>>  set locate_mode to CENTER_ON_SCREEN
45619>>>  on_key kcancel send close_panel
45620>>>  object oGraph is a GraphicArea
45622>>>    set size to 200 300
45623>>>    send aps_auto_locate_control self
45624>>>  end_object
45625>>>  object oBtn1 is a aps.multi_button
45627>>>    on_item "Log" send DoDisplayLog
45628>>>  end_object
45629>>>  object oBtn2 is a aps.multi_button
45631>>>    on_item "Known issues" send DoDisplayKnownIssues
45632>>>  end_object
45633>>>  object oBtn3 is a aps.multi_button
45635>>>    on_item t.btn.close send close_panel
45636>>>  end_object
45637>>>  procedure popup
45640>>>    integer liLogImage
45640>>>    get AppInfo AI_LOG_IMAGE to liLogImage
45641>>>    set object_shadow_state of (oBtn1(self)) to (not(liLogImage))
45642>>>    get AppInfo AI_KNOWN_ISSUES to liLogImage
45643>>>    set object_shadow_state of (oBtn2(self)) to (not(liLogImage))
45644>>>    set piProgram_RAM of (oGraph(self)) to (AppInfo(TMP_GA_OBJECTID))
45645>>>    forward send popup
45647>>>  end_procedure
45648>>>  send aps_locate_multi_buttons
45649>>>end_object
45650>>>
45650>>>procedure DoAbout global
45652>>>  send popup to (oAboutPanel(self))
45653>>>end_procedure
45654>
/DFMATRIX.LOG
Image 2, DFMATRIX.LOG
DFMatrix for Windows
--- Version 12 ---
--- Version 11 ---
--- Version 10 ---
27-03-04 Added "Explore folder sizes"
--- Version 9.1 ---
16-02-04 Create Empty Tables function has
         been fixed.
         The Compare All Table Definitions
         function is now able to handle
         alias files.
--- Version 2.9 ---
07-09-03 New load/dump utility
25-08-03 Now able to open by filelist.
--- Version 2.6+ ---
22-01-02 Generate field name changed
         files (*.fdn) and take them into
         account when generating restruc-
         ture programs.
--- Version 2.6 ---
18-11-01 If field type changed then also
         field length is set (regardless
         if it is the same)
11-11-01 Made compliant with VDF 8 (RC1)
16-10-01 'Compare table definitions' now
         refuses to compare if one of the
         sides are 'empty'.
17-09-01 Table selector now sorts table
         numbers lager than 999 correctly.
       - Check definitions no longer checks
         presence of HDR and VLD files if
         driver is not "DATAFLEX"
--- Version 2.5 ---
22-08-01 4095 tables support
--- Version 2.492 ---
06-08-01 Added 'Open current definitions'
         to the 'Select workspace' function.
15-07-01 Import text file feature.
--- Version 2.3 ---
11-07-01 DAW utilities pulldown added
27-06-01 ODBC viewer added
07-05-01 Search for stray index files re-
         vitalized.
06-05-01 Compare synchro fixed again!!!
--- Version 2.2 ---
01-05-01 Compare synchro fixed.
       - No more complaints about setting
         'main index' to 0.
28-04-01 Transaction type and lock type
         added to 'Change parameters for
         selected tables'.
23-04-01 Escape now works in all 'views'.
--- Version 2.1 ---
12-04-01 Filter in 'Compare directories'.
11-04-01 Auto copy directory name in
         'Compare directories'.
       - 'Copy files' feature in 'Find file,
         result' view.
09-04-01 Trace view taken out of main menu.
02-04-01 'Find file' rewritten from scratch.
28-03-01 MakePath in File Find fixed.
26-03-01 Ctrl+W in 'Check definitions'
25-03-01 Sorting on directory comp. grid.
24-03-01 Copy files on Ctrl+C in file grids.
       - Tolerance on timestamps when
         comparing files.
21-03-01 Absolute path on temp.txt file.
20-03-01 Ctrl+W moves grid data to editor.
/DFMatrix.About
Image 3, DFMATRIX.ABOUT
DFMatrix was programmed by:
  Sture Andersen
  e-mail: sture.aps@mail.tele.dk
/*
45654>
45654>set AppInfo AI_TITLE     to "DFMatrix"
45655>set AppInfo AI_SUBTITLE  to "Windows"
45656>Set AppInfo AI_VERSION   to "12.0"
45657>set AppInfo AI_REVISION  to ""
45658>set AppInfo AI_AUTHOR    to "Sture ApS"
45659>set AppInfo AI_WATERMARK to "2006"
45660>
45660>set AppInfo AI_LOG_IMAGE to DFMatrix.Log.N
45661>
45661>object oSplash is a cGraphicSplash
45663>  procedure Draw_BackGround.i integer liColor
45666>    integer lhGA
45666>    forward send Draw_BackGround.i liColor
45668>    move (oGA(self)) to lhGA
45669>    send SetTTFont to lhGA "Courier New" 12 0 0 0 0
45670>    send SetTextAlign to lhGA (VDFGR_TA_CENTER+VDFGR_TA_VCENTER)
45671>    send SetTextColor to lhGA liColor
45672>    send AddText to lhGA "NUM  FIELD NAME       TYPE SIZE  OFFST IX   RELATES TO FILE.FIELD            "   500 5000
45673>    send AddText to lhGA "---  ---------------  ---- ----- ----- --   ---------------------------------"  1000 5000
45674>    send AddText to lhGA "  1  TYPE             ASC      2     1  1   TYPES.FIELD_1 (10,1)             "  1500 5000
45675>    send AddText to lhGA "  2  SIZE             ASC      2     3      SIZES.FIELD_1 (11,1)             "  2000 5000
45676>    send AddText to lhGA "  3  ORIGIN           ASC      3     5      LOCATIONS.FIELD_1 (12,1)         "  2500 5000
45677>    send AddText to lhGA "  4  YEAR             NUM    2.0     8  1   DRIVER NAME                      "  3000 5000
45678>    send AddText to lhGA "  5  VINTNER          ASC     30     9  1   FILE ROOT NAME                   "  3500 5000
45679>    send AddText to lhGA "  6  COST             NUM    4.2    39      USER DISPLAY NAME                "  4000 5000
45680>    send AddText to lhGA "  7  PURCHASE_PLACE   ASC     25    42      DATAFLEX FILE NAME               "  4500 5000
45681>    send AddText to lhGA "  8  PURCHASE_DATE    DAT      3    67      -------------------------        "  5000 5000
45682>    send AddText to lhGA "  9  OPEN_DATE        DAT      3    70      RECORD LENGTH                    "  5500 5000
45683>    send AddText to lhGA " 10  TASTING_NOTES    TEX   2048    73      MAX NUMBER OF RECORDS            "  6000 5000
45684>    send AddText to lhGA " 11  SHORT_NAME       ASC     48  2121      FILE COMPRESSION                 "  6500 5000
45685>    send AddText to lhGA " 12  RESERVE          ASC      1  2169      RE-USE DELETED SPACE             "  7000 5000
45686>    send AddText to lhGA " 13  COMMENTS         TEX   1024  2170      LOCKING TYPE                     "  7500 5000
45687>    send AddText to lhGA " 14  SUGAR_CONTENT    NUM    2.2  3194      HEADER INTEGRITY CHECKING        "  8000 5000
45688>    send AddText to lhGA " 15  ALCOHOL_CONTENT  NUM    2.2  3196      TRANSACTION TYPE                 "  8500 5000
45689>    send AddText to lhGA " 16  WHO_DRANK        ASC     50  3198      RECORD IDENTITY INDEX            "  9000 5000
45690>    send AddText to lhGA " 17  BIN              ASC     10  3248  3   FILE LOGIN PARAMETER             "  9500 5000
45691>    send AddText to lhGA " 18  WINE_SPEC_RATE   NUM    2.0  3258      SYSTEM FILE                      " 10000 5000
45692>  end_procedure
45693>end_object
45694>send activate to (oSplash(self))
45695>
45695>//Use Output.utl   // Basic sequential output service
45695>Use FDX.nui      // cFDX class
Including file: fdx.nui    (C:\Apps\VDFQuery\AppSrc\fdx.nui)
45695>>>//**********************************************************************
45695>>>// Use FDX.nui      // cFDX class
45695>>>//
45695>>>// By Sture Andersen
45695>>>//
45695>>>// Create: Mon  13-12-1999
45695>>>// Update: Sun  16-01-2000
45695>>>//         Tue  08-02-2000 - cFdxFileRelations class added
45695>>>//         Sat  18-03-2000 - Added function iNextFileThatCanOpen
45695>>>//         Wed  28-02-2001 - Added function sAliasFiles.i
45695>>>//
45695>>>//**********************************************************************
45695>>>
45695>>>Use API_Attr.nui // Database API attribute characteristics
Including file: api_attr.nui    (C:\Apps\VDFQuery\AppSrc\api_attr.nui)
45695>>>>>// Use API_Attr.nui // Functions for querying API attributes (No User Interface)
45695>>>>>// Part of VDFQuery by Sture ApS
45695>>>>>//
45695>>>>>// Create: Mon  25-10-1999
45695>>>>>// Update: Fri  10-11-1999 - Changed
45695>>>>>//         Sat  15-01-2000 - Sysconf atributes added
45695>>>>>//         Tue  16-02-2000 - OA_DFPATH taken out. Made superfluous by DF_OPEN_PATH
45695>>>>>//         Wed  22-03-2000 - Internal workings simplified
45695>>>>>//         Wed  27-06-2001 - OA_COLLATE_PATH, OA_COLLATE_SIZE and
45695>>>>>//                           OA_COLLATE_TIME changed
45695>>>>>//         Tue  07-08-2001 - OA_CURRENT_USER_COUNT added
45695>>>>>//         Mon  13-08-2001 - DF_FILE_REVISION changed from DF_BCD to DF_ASCII
45695>>>>>//         Sat  11-09-2004 - OA_LOCK_COUNT added
45695>>>>>
45695>>>>>//> pkgdoc.begin
45695>>>>>//> This package defines a number of functions designed to replace
45695>>>>>//> the GET_ATTRIBUTE command. Now, the GET_ATTRIBUTE is very very (very)
45695>>>>>//> flexible in that it allows you to query any attribute whether it is
45695>>>>>//> file-, field- or index related.
45695>>>>>//>
45695>>>>>//> However, the attributes are so different in nature that it is useful
45695>>>>>//> to group them into categories. Actually, the attribute names that are
45695>>>>>//> used as first parameter to the GET_ATTRIBUTE command in any case,
45695>>>>>//> indicates a grouping of the attributes:
45695>>>>>//>
45695>>>>>//> Example of file related attributes:
45695>>>>>//> 
45695>>>>>//> DF_FILE_MAX_RECORDS
45695>>>>>//> DF_FILE_LOCK_TYPE
45695>>>>>//> 
45695>>>>>//>
45695>>>>>//> and field related dittos:
45695>>>>>//> 
45695>>>>>//> DF_FIELD_NAME
45695>>>>>//> DF_FIELD_TYPE
45695>>>>>//> 
45695>>>>>//>
45695>>>>>//> and global attributes (for the entire application):
45695>>>>>//> 
45695>>>>>//> DF_DECIMAL_SEPARATOR
45695>>>>>//> DF_OPEN_PATH
45695>>>>>//> 
45695>>>>>//>
45695>>>>>//> As you can see, the first part of the name indicates which group Data
45695>>>>>//> Access considers it belongs to.
45695>>>>>//>
45695>>>>>//> But, their grouping is not strong enough (for my purpose anyway). Consider
45695>>>>>//> these attributes:
45695>>>>>//>
45695>>>>>//> 
45695>>>>>//> 1: DF_FILE_RECORD_LENGTH
45695>>>>>//> 2: DF_FILE_DISPLAY_NAME
45695>>>>>//> 3: DF_FILE_NEXT_EMPTY
45695>>>>>//> 
45695>>>>>//>
45695>>>>>//> According to their names they all belong in the group of file related
45695>>>>>//> attributes. But in reality only the DF_FILE_RECORD_LENGTH returns
45695>>>>>//> an attribute of the file definition itself. The DF_FILE_DISPLAY_NAME
45695>>>>>//> attribute (together with DF_FILE_LOGICAL_NAME and DF_FILE_ROOT_NAME)
45695>>>>>//> returns an attribute of FILELIST.CFG. The same could be said about
45695>>>>>//> DF_FILE_NEXT_EMPTY but again it differs from the two others in that
45695>>>>>//> it returns the next entry (relative to its parameter) in FILELIST.CFG
45695>>>>>//> that is currently not used (empty root name).
45695>>>>>//>
45695>>>>>//> Therefore this package divides the attributes into the following groups:
45695>>>>>//>
45695>>>>>//> 
45695>>>>>//> ATTRTYPE_GLOBAL    Attributes not related to tables or drivers
45695>>>>>//> ATTRTYPE_FILELIST  Filelist attributes (root name, display name and
45695>>>>>//>                    logical name)
45695>>>>>//> ATTRTYPE_FILE      Table attributes
45695>>>>>//> ATTRTYPE_FIELD     Field attributes
45695>>>>>//> ATTRTYPE_INDEX     Index attributes
45695>>>>>//> ATTRTYPE_IDXSEG    Index segment attributes
45695>>>>>//> ATTRTYPE_DRIVER    Driver attributes
45695>>>>>//> ATTRTYPE_DRVSRV    Server attributes
45695>>>>>//> ATTRTYPE_SPECIAL1  Used to figure out whether 2 fields overlap each
45695>>>>>//>                    other
45695>>>>>//> ATTRTYPE_FLSTNAV   Filelist.cfg navigation (next empty, next used,
45695>>>>>//>                    next open)
45695>>>>>//> 
45695>>>>>//>
45695>>>>>//> If you want to retrieve an attribute value using one of the functions in
45695>>>>>//> this package, you have to know which type of attribute you are querying
45695>>>>>//> in order to use the correct function:
45695>>>>>//>
45695>>>>>//> 
45695>>>>>//> Type               Function
45695>>>>>//> ------------------ -----------------------
45695>>>>>//> ATTRTYPE_GLOBAL    API_AttrValue_GLOBAL
45695>>>>>//> ATTRTYPE_FILELIST  API_AttrValue_FILELIST
45695>>>>>//> ATTRTYPE_FILE      API_AttrValue_FILE
45695>>>>>//> ATTRTYPE_FIELD     API_AttrValue_FIELD
45695>>>>>//> ATTRTYPE_INDEX     API_AttrValue_INDEX
45695>>>>>//> ATTRTYPE_IDXSEG    API_AttrValue_IDXSEG
45695>>>>>//> ATTRTYPE_DRIVER    API_AttrValue_DRIVER
45695>>>>>//> ATTRTYPE_DRVSRV    API_AttrValue_DRVSRV
45695>>>>>//> ATTRTYPE_SPECIAL1  API_AttrValue_SPECIAL1
45695>>>>>//> ATTRTYPE_FLSTNAV   API_AttrValue_FLSTNAV
45695>>>>>//> 
45695>>>>>//>
45695>>>>>//> These functions are defined like this:
45695>>>>>//>
45695>>>>>//> 
45695>>>>>//> FUNCTION API_AttrValue_GLOBAL global INTEGER attr# RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_FILELIST global INTEGER attr# integer file# ;
45695>>>>>//>                                                            RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_FILE global INTEGER attr# INTEGER file# ;
45695>>>>>//>                                                            RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_FIELD global INTEGER attr# INTEGER file# ;
45695>>>>>//>                                           INTEGER field# RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_INDEX global INTEGER attr# INTEGER file# ;
45695>>>>>//>                                            INTEGER index# RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_IDXSEG global INTEGER attr# INTEGER file# ;
45695>>>>>//>                             INTEGER index# INTEGER segment# RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_DRIVER global INTEGER attr# INTEGER driver# ;
45695>>>>>//>                                                             RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_DRVSRV global INTEGER attr# INTEGER driver# ;
45695>>>>>//>                                             INTEGER server# RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_SPECIAL1 global INTEGER attr# INTEGER file# ;
45695>>>>>//>                              INTEGER field1# INTEGER field2# RETURNS string
45695>>>>>//>
45695>>>>>//> FUNCTION API_AttrValue_FLSTNAV global INTEGER attr# INTEGER file# ;
45695>>>>>//>                                                           RETURNS string
45695>>>>>//> 
45695>>>>>//>
45695>>>>>//> Take a moment to convince yourself that each function takes a reasonable
45695>>>>>//> number of parameters. Note that even if these functions most often will
45695>>>>>//> return an integer (some indeed always return integers) their return type
45695>>>>>//> is string. This was done for reasons of simplicity.
45695>>>>>//> pkgdoc.end
45695>>>>>
45695>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
45695>>>>>Use Files.nui    // Utilities for handling file related stuff
45695>>>>>Use DBMS.nui     // Basic DBMS functions
Including file: dbms.nui    (C:\Apps\VDFQuery\AppSrc\dbms.nui)
45695>>>>>>>//**********************************************************************
45695>>>>>>>// Use DBMS.nui     // Basic DBMS functions (No User Interface)
45695>>>>>>>//
45695>>>>>>>// By Sture Andersen
45695>>>>>>>//
45695>>>>>>>// Create: Mon  10-11-1997
45695>>>>>>>// Update: Wed  10-12-1997 - Added DBMS_OpenFileAs, DBMS_OpenFileBrowse
45695>>>>>>>//                           and DBMS_IsOpen functions
45695>>>>>>>//         Thu  18-12-1997 - Function DBMS_IsOpenedAsFile added
45695>>>>>>>//         Wed  03-02-1999 - Functions DBMS_Driver_UserName and
45695>>>>>>>//                           DBMS_DriverNameToType added
45695>>>>>>>//         Sat  29-05-1999 - DBMS_Callback_FilelistEntries added
45695>>>>>>>//         Thu  16-09-1999 - ON ERROR error fixed
45695>>>>>>>//         Thu  04-11-1999 - Procedure DBMS_CallBack_FileFields added
45695>>>>>>>//         Tue  04-01-2000 - Function DBMS_NextNotOpen added
45695>>>>>>>//         Wed  19-04-2000 - Function DBMS_StripPathAndDriver added
45695>>>>>>>//         Wed  02-04-2003 - Function DBMS_TablePath added
45695>>>>>>>//         Sun  21-12-2003 - DBMS_Callback_FilelistEntries enhanced.
45695>>>>>>>//                         - Function DBMS_EraseDfFile added
45695>>>>>>>//         Mon  17-01-2005 - Procedures DBMS_SetFieldValueMax and
45695>>>>>>>//                           DBMS_SetFieldValueMin added
45695>>>>>>>//         Fri  21-01-2005 - Procedure DBMS_FindByRecnum added
45695>>>>>>>//**********************************************************************
45695>>>>>>>// Useful pastry:
45695>>>>>>>//
45695>>>>>>>// Set_Attribute DF_FILE_ALIAS Customer2.File_number to DF_FILE_IS_ALIAS
45695>>>>>>>// Set_Attribute DF_FILE_ALIAS Customer.File_number  to DF_FILE_IS_MASTER
45695>>>>>>>Use Strings.nui  // String manipulation for VDF
45695>>>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
45695>>>>>>>Use Dates.nui    // Date routines (No User Interface)
45695>>>>>>>
45695>>>>>>>define DBMS_MaxFileListEntry for 4095 // 255
45695>>>>>>>
45695>>>>>>>enumeration_list // Driver ID's
45695>>>>>>>  define DBMS_DRIVER_ERROR
45695>>>>>>>  define DBMS_DRIVER_UNKNOWN
45695>>>>>>>  define DBMS_DRIVER_DATAFLEX
45695>>>>>>>  define DBMS_DRIVER_PERVASIVE
45695>>>>>>>  define DBMS_DRIVER_ORACLE
45695>>>>>>>  define DBMS_DRIVER_MS_SQL
45695>>>>>>>  define DBMS_DRIVER_DB2
45695>>>>>>>  define DBMS_DRIVER_ODBC
45695>>>>>>>  define DBMS_DRIVER_PERVASIVE_MODRT
45695>>>>>>>  define DBMS_DRIVER_MS_SQL_DAW
45695>>>>>>>  define DBMS_DRIVER_MAX             // Points to the highest known driver ID
45695>>>>>>>end_enumeration_list
45695>>>>>>>
45695>>>>>>>function DBMS_Driver_UserName global integer liType returns string
45697>>>>>>>  if liType eq DBMS_DRIVER_ERROR      function_return "Unknown (Error)"
45700>>>>>>>  if liType eq DBMS_DRIVER_UNKNOWN    function_return "Unknown"
45703>>>>>>>  if liType eq DBMS_DRIVER_DATAFLEX   function_return "DataFlex"
45706>>>>>>>  if liType eq DBMS_DRIVER_PERVASIVE  function_return "Pervasive"
45709>>>>>>>  if liType eq DBMS_DRIVER_ORACLE     function_return "Oracle"
45712>>>>>>>  if liType eq DBMS_DRIVER_MS_SQL     function_return "MS SQL (MT)"
45715>>>>>>>  if liType eq DBMS_DRIVER_DB2        function_return "DB/2"
45718>>>>>>>  if liType eq DBMS_DRIVER_MS_SQL_DAW function_return "MS SQL (DAW)"
45721>>>>>>>  if liType eq DBMS_DRIVER_ODBC       function_return "ODBC Connectivity"
45724>>>>>>>  if liType eq DBMS_DRIVER_PERVASIVE_MODRT function_return "Pervasive (mod/rt)"
45727>>>>>>>end_function
45728>>>>>>>
45728>>>>>>>function DBMS_DriverNameToType global string lsDriver returns integer
45730>>>>>>>  uppercase lsDriver
45731>>>>>>>>
45731>>>>>>>  if lsDriver eq "DATAFLEX" function_return DBMS_DRIVER_DATAFLEX
45734>>>>>>>  if lsDriver eq "ORA_DRV"  function_return DBMS_DRIVER_ORACLE
45737>>>>>>>  if lsDriver eq "SQL_DRV"  function_return DBMS_DRIVER_MS_SQL
45740>>>>>>>  if lsDriver eq "DFBTRDRV" function_return DBMS_DRIVER_PERVASIVE
45743>>>>>>>  if lsDriver eq "MSSQLDRV" function_return DBMS_DRIVER_MS_SQL_DAW
45746>>>>>>>  if lsDriver eq "ODBC_DRV" function_return DBMS_DRIVER_ODBC
45749>>>>>>>  function_return DBMS_DRIVER_UNKNOWN // is not zero!
45750>>>>>>>end_function
45751>>>>>>>
45751>>>>>>>function DBMS_TypeToDriverName global integer liType returns string
45753>>>>>>>  if liType eq DBMS_DRIVER_DATAFLEX   function_return "DATAFLEX"
45756>>>>>>>  if liType eq DBMS_DRIVER_ORACLE     function_return "ORA_DRV"
45759>>>>>>>  if liType eq DBMS_DRIVER_MS_SQL     function_return "SQL_DRV"
45762>>>>>>>  if liType eq DBMS_DRIVER_MS_SQL_DAW function_return "MSSQLDRV"
45765>>>>>>>  if liType eq DBMS_DRIVER_PERVASIVE  function_return "DFBTRDRV"
45768>>>>>>>  if liType eq DBMS_DRIVER_ODBC       function_return "ODBC_DRV"
45771>>>>>>>  function_return "Unknown" // Must return this value!
45772>>>>>>>end_function
45773>>>>>>>
45773>>>>>>>function DBMS_FileDriverType global integer liFile returns integer
45775>>>>>>>  string lsDriver
45775>>>>>>>  get_attribute DF_FILE_DRIVER of liFile to lsDriver
45778>>>>>>>  function_return (DBMS_DriverNameToType(lsDriver))
45779>>>>>>>end_function
45780>>>>>>>
45780>>>>>>>if dfFalse begin
45782>>>>>>>  DBMS_OpenError: move DBMS_DRIVER_ERROR to windowindex // DBMS_DRIVER_ERROR is 0
45783>>>>>>>  return
45784>>>>>>>end
45784>>>>>>>>
45784>>>>>>>
45784>>>>>>>//> This function is used to find out if a file is currently open. If not
45784>>>>>>>//> it will return 0 (false)  and if it is opened a driver ID like
45784>>>>>>>//> DBMS_DRIVER_DATAFLEX or DBMS_DRIVER_ORACLE will be returned.
45784>>>>>>>function DBMS_IsOpenFile global integer liFile returns integer
45786>>>>>>>  integer liRval liHandleType
45786>>>>>>>  string lsDriver
45786>>>>>>>  get_attribute DF_FILE_HANDLE_TYPE of liFile to liHandleType
45789>>>>>>>  if (liHandleType=DF_FILE_HANDLE_EXISTING_RESTRUCTURE or liHandleType=DF_FILE_HANDLE_NEW_RESTRUCTURE) function_return 1
45792>>>>>>>  get_attribute DF_FILE_OPENED of liFile to liRval
45795>>>>>>>  if liRval begin
45797>>>>>>>    get_attribute DF_FILE_DRIVER of liFile to lsDriver
45800>>>>>>>    get DBMS_DriverNameToType lsDriver to liRval
45801>>>>>>>  end
45801>>>>>>>>
45801>>>>>>>  function_return liRval
45802>>>>>>>end_function
45803>>>>>>>
45803>>>>>>>function DBMS_IsOpenedAsFile global integer liFile returns integer
45805>>>>>>>  integer lbOpen
45805>>>>>>>  string lsPhysName lsRootName
45805>>>>>>>  get_attribute DF_FILE_OPENED of liFile to lbOpen
45808>>>>>>>  if lbOpen begin
45810>>>>>>>    get_attribute DF_FILE_PHYSICAL_NAME of liFile to lsPhysName
45813>>>>>>>    get_attribute DF_FILE_ROOT_NAME of liFile to lsRootName
45816>>>>>>>    if (uppercase(lsPhysName)) ne (uppercase(lsRootName)) function_return 1
45819>>>>>>>  end
45819>>>>>>>>
45819>>>>>>>  function_return 0
45820>>>>>>>end_function
45821>>>>>>>
45821>>>>>>>function DBMS_RootNameWhichDriver global string lsRootName returns integer
45823>>>>>>>  // This function analyses the rootname and determines which driver should
45823>>>>>>>  // be used to open it.
45823>>>>>>>  integer liRval
45823>>>>>>>  string lsDriver
45823>>>>>>>  if ".INT" in (uppercase(lsRootName)) move DBMS_DRIVER_UNKNOWN to liRval
45826>>>>>>>  else if ":" in lsRootName begin
45829>>>>>>>    move (uppercase(ExtractWord(lsRootName,":",1))) to lsDriver
45830>>>>>>>    if (length(trim(lsDriver))) eq 1 move DBMS_DRIVER_DATAFLEX to liRval
45833>>>>>>>    else get DBMS_DriverNameToType lsDriver to liRval
45835>>>>>>>  end
45835>>>>>>>>
45835>>>>>>>  else move DBMS_DRIVER_DATAFLEX to liRval
45837>>>>>>>  function_return liRval
45838>>>>>>>end_function
45839>>>>>>>
45839>>>>>>>function DBMS_AutoLoadDriver global string lsRootName returns integer
45841>>>>>>>  // This function returns the ID for the driver loaded, if successful.
45841>>>>>>>  integer liDriver liRval
45841>>>>>>>  get DBMS_RootNameWhichDriver lsRootName to liDriver
45842>>>>>>>  if (liDriver<>DBMS_DRIVER_DATAFLEX and ;      liDriver<>DBMS_DRIVER_ERROR and ;      liDriver<>DBMS_DRIVER_UNKNOWN) begin
45844>>>>>>>
45844>>>>>>>  end
45844>>>>>>>>
45844>>>>>>>  else move 0 to liRval
45846>>>>>>>//  send obs (DBMS_Driver_UserName(lsDriver))
45846>>>>>>>end_function
45847>>>>>>>
45847>>>>>>>// The function returns the driver ID for that DB if the table could be
45847>>>>>>>// opened. If the table could not be opened 0 is returned.
45847>>>>>>>function DBMS_OpenFile global integer liFile integer liMode integer liBufIndex returns integer
45849>>>>>>>  integer liRval liWindowIndex
45849>>>>>>>  string lsDriver lsRoot
45849>>>>>>>//  send obs "OpenFile" (string(liFile)) (string(liMode)) (string(liBufIndex))
45849>>>>>>>  move windowindex to liWindowIndex
45850>>>>>>>  move |VI31 to |VI32 //copy ON ERROR label
45851>>>>>>>  on error gosub DBMS_OpenError
45852>>>>>>>  indicate err false
45853>>>>>>>  move DBMS_DRIVER_UNKNOWN to windowindex
45854>>>>>>>  if liBufIndex open liFile mode liMode liBufIndex
45858>>>>>>>  else          open liFile mode liMode
45861>>>>>>>  move |VI32 to |VI31 //restore original ON ERROR label
45862>>>>>>>  move windowindex to liRval // If an error was triggered the
45863>>>>>>>  indicate err false        // subroutine will have changed windowindex
45864>>>>>>>  move liWindowIndex to windowindex
45865>>>>>>>  if liRval begin
45867>>>>>>>    get_attribute DF_FILE_DRIVER of liFile to lsDriver
45870>>>>>>>    get DBMS_DriverNameToType lsDriver to liRval
45871>>>>>>>  end
45871>>>>>>>>
45871>>>>>>>//  if DBMS_DRIVER_UNKNOWN eq liRval send obs ("UNKNOWN DRIVER: "+string(liRval)+" "+string(liFile))
45871>>>>>>>  ifnot liRval begin
45873>>>>>>>    if liFile begin
45875>>>>>>>      get_attribute DF_FILE_ROOT_NAME of liFile to lsRoot
45878>>>>>>>      //get DBMS_AutoLoadDriver lsRoot to liRval
45878>>>>>>>    end
45878>>>>>>>>
45878>>>>>>>  end
45878>>>>>>>>
45878>>>>>>>  function_return liRval
45879>>>>>>>end_function
45880>>>>>>>
45880>>>>>>>function DBMS_OpenFileAs global string lsFileName integer liFile integer liMode integer liBufIndex returns integer
45882>>>>>>>  integer liRval liWindowIndex
45882>>>>>>>  string lsDriver
45882>>>>>>>  if (DBMS_IsOpenFile(liFile)) close liFile
45885>>>>>>>  move (ToAnsi(lsFileName)) to lsFileName
45886>>>>>>>  if lsFileName eq "" function_return DBMS_DRIVER_ERROR
45889>>>>>>>  move windowindex to liWindowIndex
45890>>>>>>>  move |VI31 to |VI32 //copy ON ERROR label
45891>>>>>>>  on error gosub DBMS_OpenError
45892>>>>>>>  indicate err false
45893>>>>>>>  move DBMS_DRIVER_UNKNOWN to windowindex
45894>>>>>>>  if liBufIndex open lsFileName as liFile mode liMode liBufIndex
45898>>>>>>>  else          open lsFileName as liFile mode liMode
45901>>>>>>>  move |VI32 to |VI31 //restore original ON ERROR label
45902>>>>>>>  move windowindex to liRval // If an error was triggered the
45903>>>>>>>  indicate err false        // subroutine will have changed windowindex
45904>>>>>>>  move liWindowIndex to windowindex
45905>>>>>>>  if liRval begin
45907>>>>>>>    get_attribute DF_FILE_DRIVER of liFile to lsDriver
45910>>>>>>>    get DBMS_DriverNameToType lsDriver to liRval
45911>>>>>>>  end
45911>>>>>>>>
45911>>>>>>>  function_return liRval
45912>>>>>>>end_function
45913>>>>>>>
45913>>>>>>>procedure DBMS_CloseFile global integer liFile
45915>>>>>>>  integer lbOpen
45915>>>>>>>  if liFile begin
45917>>>>>>>    get_attribute DF_FILE_OPENED of liFile to lbOpen
45920>>>>>>>    if lbOpen close liFile
45923>>>>>>>  end
45923>>>>>>>>
45923>>>>>>>end_procedure
45924>>>>>>>
45924>>>>>>>function DBMS_StripPathAndDriver global string lsRoot returns string
45926>>>>>>>  integer liPos
45926>>>>>>>  string lsChar
45926>>>>>>>  move (sysconf(SYSCONF_DIR_SEPARATOR)) to lsChar
45927>>>>>>>  if lsChar in lsRoot begin
45929>>>>>>>    move (pos(lsChar,lsRoot)) to liPos
45930>>>>>>>    move (StringRightBut(lsRoot,liPos)) to lsRoot
45931>>>>>>>  end
45931>>>>>>>>
45931>>>>>>>  move ":" to lsChar
45932>>>>>>>  if lsChar in lsRoot begin
45934>>>>>>>    move (pos(lsChar,lsRoot)) to liPos
45935>>>>>>>    move (StringRightBut(lsRoot,liPos)) to lsRoot
45936>>>>>>>  end
45936>>>>>>>>
45936>>>>>>>  if "." in lsRoot get StripFromLastOccurance lsRoot "." to lsRoot
45939>>>>>>>  function_return lsRoot
45940>>>>>>>end_function
45941>>>>>>>
45941>>>>>>>function DBMS_TablePath global integer liFile returns string
45943>>>>>>>  integer lbIsOpenedAs liType
45943>>>>>>>  string lsDriver lsRval lsCurrentDir lsDirSep lsPath
45943>>>>>>>
45943>>>>>>>  move (sysconf(SYSCONF_DIR_SEPARATOR)) to lsDirSep // "/" or "\"
45944>>>>>>>
45944>>>>>>>  get_attribute DF_FILE_DRIVER of liFile to lsDriver
45947>>>>>>>  get DBMS_DriverNameToType lsDriver to liType
45948>>>>>>>
45948>>>>>>>  get DBMS_IsOpenedAsFile liFile to lbIsOpenedAs
45949>>>>>>>
45949>>>>>>>  if lbIsOpenedAs get_attribute DF_FILE_PHYSICAL_NAME of liFile to lsRval
45954>>>>>>>  else get_attribute DF_FILE_ROOT_NAME of liFile to lsRval
45958>>>>>>>
45958>>>>>>>  if liType eq DBMS_DRIVER_DATAFLEX move (lsRval+".dat") to lsRval
45961>>>>>>>  else begin
45962>>>>>>>    replace (lsDriver+":") in lsRval with ""
45964>>>>>>>    ifnot ".INT" in (uppercase(lsRval)) move (lsRval+".int") to lsRval
45967>>>>>>>  end
45967>>>>>>>>
45967>>>>>>>  ifnot (lsRval contains lsDirSep) get_file_path lsRval to lsRval
45970>>>>>>>  if (left(lsRval,2)=("."+lsDirSep)) begin
45972>>>>>>>    get_current_directory to lsCurrentDir
45973>>>>>>>    replace "." in lsRval with lsCurrentDir
45975>>>>>>>  end
45975>>>>>>>>
45975>>>>>>>  function_return lsRval
45976>>>>>>>end_function
45977>>>>>>>
45977>>>>>>>Use WinBase
45977>>>>>>>// This one probably requires the file to open?
45977>>>>>>>function DBMS_Rootname_Path global integer liFile returns string
45979>>>>>>>  integer liType
45979>>>>>>>  string lsStr lsCurDir lsDriver
45979>>>>>>>  get_current_directory to lsCurDir
45980>>>>>>>  get_attribute DF_FILE_DRIVER of liFile to lsDriver
45983>>>>>>>  get DBMS_DriverNameToType lsDriver to liType
45984>>>>>>>
45984>>>>>>>  get_attribute DF_FILE_ROOT_NAME of liFile to lsStr
45987>>>>>>>  if liType eq DBMS_DRIVER_DATAFLEX move (lsStr+".dat") to lsStr
45990>>>>>>>  else begin
45991>>>>>>>    replace (lsDriver+":") in lsStr with ""
45993>>>>>>>    ifnot ".INT" in (uppercase(lsStr)) move (lsStr+".int") to lsStr
45996>>>>>>>  end
45996>>>>>>>>
45996>>>>>>>  ifnot "\" in lsStr get_file_path lsStr to lsStr
45999>>>>>>>  if (left(lsStr,2)) eq ".\" replace "." in lsStr with lsCurDir
46003>>>>>>>  function_return (uppercase(lsStr))
46004>>>>>>>end_function
46005>>>>>>>
46005>>>>>>>function DBMS_Rootname global integer liFile returns string
46007>>>>>>>  string lsRval
46007>>>>>>>  get_attribute DF_FILE_ROOT_NAME of liFile to lsRval
46010>>>>>>>  function_return lsRval
46011>>>>>>>end_function
46012>>>>>>>function DBMS_DFName global integer liFile returns string
46014>>>>>>>  string lsRval
46014>>>>>>>  get_attribute DF_FILE_LOGICAL_NAME of liFile to lsRval
46017>>>>>>>  function_return lsRval
46018>>>>>>>end_function
46019>>>>>>>function DBMS_DisplayName global integer liFile returns string
46021>>>>>>>  string lsRval
46021>>>>>>>  get_attribute DF_FILE_DISPLAY_NAME of liFile to lsRval
46024>>>>>>>  function_return (rtrim(lsRval))
46025>>>>>>>end_function
46026>>>>>>>function DBMS_FieldValue global integer liFile integer liField returns string
46028>>>>>>>  string lsRval
46028>>>>>>>  get_field_value liFile liField to lsRval
46031>>>>>>>  function_return lsRval
46032>>>>>>>end_function
46033>>>>>>>function DBMS_FieldName global integer liFile integer liField returns string
46035>>>>>>>  integer lbOpen lbWasOpen
46035>>>>>>>  string lsRval
46035>>>>>>>  move (DBMS_IsOpenFile(liFile)) to lbWasOpen
46036>>>>>>>  ifnot lbWasOpen move (DBMS_OpenFile(liFile,DF_SHARE,0)) to lbOpen
46039>>>>>>>  if (lbWasOpen or lbOpen) get_attribute DF_FIELD_NAME of liFile liField to lsRval
46044>>>>>>>  else move ("FILE"+string(liFile)+"."+string(liField)+" N/A") to lsRval
46046>>>>>>>  if (lbOpen and not(lbWasOpen)) close liFile
46049>>>>>>>  function_return lsRval
46050>>>>>>>end_function
46051>>>>>>>
46051>>>>>>>// OBS! Functions DBMS_FieldInfo and DBMS_FileInfo will go away some day
46051>>>>>>>
46051>>>>>>>                                              // 0=field type Ŀ
46051>>>>>>>                                              // 1=field length Ĵ
46051>>>>>>>                                              // 2=#dec points Ĵ
46051>>>>>>>                                              // 3=relating file Ĵ
46051>>>>>>>                                              // 4=relating fieldĴ
46051>>>>>>>                                              // 5=main index
46051>>>>>>>function DBMS_FieldInfo global integer liFile integer liField integer liItem returns integer
46053>>>>>>>  integer liRval
46053>>>>>>>  if liItem eq 0 get_attribute DF_FIELD_TYPE          of liFile liField to liRval // DF_ASCII DF_BCD DF_DATE DF_OVERLAP DF_TEXT DF_BINARY
46058>>>>>>>  if liItem eq 1 get_attribute DF_FIELD_LENGTH        of liFile liField to liRval
46063>>>>>>>  if liItem eq 2 get_attribute DF_FIELD_PRECISION     of liFile liField to liRval
46068>>>>>>>  if liItem eq 3 get_attribute DF_FIELD_RELATED_FILE  of liFile liField to liRval
46073>>>>>>>  if liItem eq 4 get_attribute DF_FIELD_RELATED_FIELD of liFile liField to liRval
46078>>>>>>>  if liItem eq 5 get_attribute DF_FIELD_INDEX         of liFile liField to liRval
46083>>>>>>>  function_return liRval
46084>>>>>>>end_function                    // 0=max records Ŀ
46085>>>>>>>                                // 1=current recs Ĵ
46085>>>>>>>                                // 2=rec length Ĵ
46085>>>>>>>                                // 3=rec length used
46085>>>>>>>                                // 4=number of flds
46085>>>>>>>function DBMS_FileInfo global integer liFile integer liItem returns integer
46087>>>>>>>  integer liRval
46087>>>>>>>  if liItem eq 0 get_attribute DF_FILE_MAX_RECORDS        of liFile to liRval
46092>>>>>>>  if liItem eq 1 get_attribute DF_FILE_RECORDS_USED       of liFile to liRval
46097>>>>>>>  if liItem eq 2 get_attribute DF_FILE_RECORD_LENGTH      of liFile to liRval
46102>>>>>>>  if liItem eq 3 get_attribute DF_FILE_RECORD_LENGTH_USED of liFile to liRval
46107>>>>>>>  if liItem eq 4 get_attribute DF_FILE_NUMBER_FIELDS      of liFile to liRval
46112>>>>>>>  function_return liRval
46113>>>>>>>end_function
46114>>>>>>>
46114>>>>>>>// Function DBMS_Relating_Field returns the number of the field in liFile
46114>>>>>>>// that relates to liRelFile. The search for the field is started at field
46114>>>>>>>// number liStartField plus one. If no such field is found 0 is returned.
46114>>>>>>>function DBMS_Relating_Field global integer liFile integer liRelFile integer liStartField returns integer
46116>>>>>>>  integer liRval liField liMax lbFin lbTmp
46116>>>>>>>  move liStartField to liField
46117>>>>>>>  move 0 to lbFin
46118>>>>>>>  move 0 to liRval
46119>>>>>>>  get_attribute DF_FILE_NUMBER_FIELDS of liFile to liMax
46122>>>>>>>  repeat
46122>>>>>>>>
46122>>>>>>>    increment liField
46123>>>>>>>    if liField gt liMax move 1 to lbFin
46126>>>>>>>    ifnot lbFin begin
46128>>>>>>>      get_attribute DF_FIELD_RELATED_FILE of liFile liField to lbTmp
46131>>>>>>>      if lbTmp eq liRelFile begin
46133>>>>>>>        move liField to liRval
46134>>>>>>>        move 1 to lbFin
46135>>>>>>>      end
46135>>>>>>>>
46135>>>>>>>    end
46135>>>>>>>>
46135>>>>>>>  until lbFin
46137>>>>>>>  function_return liRval
46138>>>>>>>end_function
46139>>>>>>>
46139>>>>>>>function DBMS_CanOpenFile global integer liFile returns integer
46141>>>>>>>  integer lbOpen liRval
46141>>>>>>>  string lsDriver
46141>>>>>>>  move 0 to liRval
46142>>>>>>>  get_attribute DF_FILE_OPENED of liFile to lbOpen
46145>>>>>>>  if lbOpen begin
46147>>>>>>>    ifnot (DBMS_IsOpenedAsFile(liFile)) begin // Return false if file is opened AS
46149>>>>>>>      get_attribute DF_FILE_DRIVER of liFile to lsDriver
46152>>>>>>>      get DBMS_DriverNameToType lsDriver to liRval
46153>>>>>>>      //send obs "DBMS_CanOpenFile" liFile lsDriver liRval
46153>>>>>>>    end
46153>>>>>>>>
46153>>>>>>>  end
46153>>>>>>>>
46153>>>>>>>  else move (DBMS_OpenFile(liFile,DF_SHARE,0)) to liRval
46155>>>>>>>  if (liRval and not(lbOpen)) close liFile
46158>>>>>>>  function_return liRval
46159>>>>>>>end_function
46160>>>>>>>
46160>>>>>>>function DBMS_CanOpenFileAs global string lsFileName integer liFile returns integer
46162>>>>>>>  integer lbOpen liRval
46162>>>>>>>  string lsDriver
46162>>>>>>>  move 0 to liRval
46163>>>>>>>  get_attribute DF_FILE_OPENED of liFile to lbOpen
46166>>>>>>>  if lbOpen begin
46168>>>>>>>    get_attribute DF_FILE_DRIVER of liFile to lsDriver
46171>>>>>>>    get DBMS_DriverNameToType lsDriver to liRval
46172>>>>>>>  end
46172>>>>>>>>
46172>>>>>>>  else move (DBMS_OpenFileAs(lsFileName,liFile,DF_SHARE,0)) to liRval
46174>>>>>>>  if (liRval and not(lbOpen)) close liFile
46177>>>>>>>  function_return liRval
46178>>>>>>>end_function
46179>>>>>>>
46179>>>>>>>function DBMS_NextNotOpen global integer liFile returns integer
46181>>>>>>>  integer liRval
46181>>>>>>>  move 0 to liRval
46182>>>>>>>  increment liFile
46183>>>>>>>  while (liFile<=DBMS_MaxFileListEntry and liRval=0)
46187>>>>>>>    ifnot (DBMS_IsOpenFile(liFile)) move liFile to liRval
46190>>>>>>>    increment liFile
46191>>>>>>>  end
46192>>>>>>>>
46192>>>>>>>  function_return liRval
46193>>>>>>>end_function
46194>>>>>>>
46194>>>>>>>// Filelist Entry Classes
46194>>>>>>>define FLEC_ALL            for 1
46194>>>>>>>define FLEC_NOT_BAD        for 2
46194>>>>>>>define FLEC_BAD            for 4
46194>>>>>>>define FLEC_NO_ALIAS       for 8
46194>>>>>>>define FLEC_EMPTY          for 10
46194>>>>>>>define FLEC_EMPTY_NOT_OPEN for 11
46194>>>>>>>
46194>>>>>>>procedure DBMS_Callback_FilelistEntries global integer liFlec integer liMsg integer lhObj
46196>>>>>>>  integer liFile lbOk
46196>>>>>>>  string lsRoot lsRootNames
46196>>>>>>>  if (liFlec=FLEC_EMPTY or liFlec=FLEC_EMPTY_NOT_OPEN) begin
46198>>>>>>>    repeat
46198>>>>>>>>
46198>>>>>>>      get_attribute DF_FILE_NEXT_EMPTY of liFile to liFile
46201>>>>>>>      if liFile begin
46203>>>>>>>        if (liFlec=FLEC_EMPTY_NOT_OPEN) begin
46205>>>>>>>          get_attribute DF_FILE_OPENED of liFile to lbOK
46208>>>>>>>          move (not(lbOK)) to lbOK
46209>>>>>>>        end
46209>>>>>>>>
46209>>>>>>>        else move 1 to lbOK
46211>>>>>>>        if lbOk send liMsg to lhObj liFile
46214>>>>>>>      end
46214>>>>>>>>
46214>>>>>>>    until liFile eq 0
46216>>>>>>>  end
46216>>>>>>>>
46216>>>>>>>  else begin
46217>>>>>>>    move " " to lsRootNames
46218>>>>>>>    move 0 to liFile
46219>>>>>>>    repeat
46219>>>>>>>>
46219>>>>>>>      get_attribute DF_FILE_NEXT_USED of liFile to liFile
46222>>>>>>>      if liFile begin
46224>>>>>>>        move 1 to lbOk
46225>>>>>>>        ifnot (liFlec iand FLEC_ALL) begin
46227>>>>>>>          ifnot (liFlec iand FLEC_BAD    ) move (DBMS_CanOpenFile(liFile)) to lbOk
46230>>>>>>>          ifnot (liFlec iand FLEC_NOT_BAD) move (not(DBMS_CanOpenFile(liFile))) to lbOk
46233>>>>>>>        end
46233>>>>>>>>
46233>>>>>>>        if lbOk begin
46235>>>>>>>          if (liFlec iand FLEC_NO_ALIAS) begin
46237>>>>>>>            get_attribute DF_FILE_ROOT_NAME of liFile to lsRoot
46240>>>>>>>            move (lowercase(lsRoot)) to lsRoot
46241>>>>>>>            if (" "+lsRoot+" ") in lsRootNames move 0 to lbOk
46244>>>>>>>            else move (lsRootNames+lsRoot+" ") to lsRootNames
46246>>>>>>>          end
46246>>>>>>>>
46246>>>>>>>          if lbOk send liMsg to lhObj liFile
46249>>>>>>>        end
46249>>>>>>>>
46249>>>>>>>      end
46249>>>>>>>>
46249>>>>>>>    until liFile eq 0
46251>>>>>>>  end
46251>>>>>>>>
46251>>>>>>>end_procedure
46252>>>>>>>
46252>>>>>>>procedure DBMS_CallBack_FileFields global integer liFile integer liMsg integer lhObj
46254>>>>>>>  integer liType liLen liDec liRelFile liRelField liOffset liField liMax liIdx
46254>>>>>>>  string lsName
46254>>>>>>>  get_attribute DF_FILE_NUMBER_FIELDS of liFile to liMax
46257>>>>>>>  for liField from 1 to liMax
46263>>>>>>>>
46263>>>>>>>    get_attribute DF_FIELD_NAME          of liFile liField to lsName
46266>>>>>>>    get_attribute DF_FIELD_TYPE          of liFile liField to liType
46269>>>>>>>    get_attribute DF_FIELD_LENGTH        of liFile liField to liLen
46272>>>>>>>    get_attribute DF_FIELD_PRECISION     of liFile liField to liDec
46275>>>>>>>    get_attribute DF_FIELD_INDEX         of liFile liField to liIdx
46278>>>>>>>    get_attribute DF_FIELD_RELATED_FILE  of liFile liField to liRelFile
46281>>>>>>>    get_attribute DF_FIELD_RELATED_FIELD of liFile liField to liRelField
46284>>>>>>>    get_attribute DF_FIELD_OFFSET        of liFile liField to liOffset
46287>>>>>>>    send liMsg to lhObj liFile liField lsName liType liLen liDec liIdx liRelFile liRelField liOffset
46288>>>>>>>  loop
46289>>>>>>>>
46289>>>>>>>end_procedure
46290>>>>>>>
46290>>>>>>>function DBMS_GetFieldNumber global integer liFile integer liField returns integer
46292>>>>>>>  function_return liField
46293>>>>>>>end_function
46294>>>>>>>
46294>>>>>>>function DBMS_EraseDfFile global integer liFile string lsRoot returns integer
46296>>>>>>>  integer liRval
46296>>>>>>>  string lsDatFile lsPath
46296>>>>>>>  if liFile get_attribute DF_FILE_ROOT_NAME of liFile to lsRoot
46301>>>>>>>  move (lowercase(lsRoot)) to lsRoot
46302>>>>>>>  move (lsRoot+".dat") to lsDatFile
46303>>>>>>>  move (SEQ_FindFileAlongDFPath(lsDatFile)) to lsPath
46304>>>>>>>  get Files_AppendPath lsPath lsRoot to lsRoot
46305>>>>>>>
46305>>>>>>>  get SEQ_EraseFile (lsRoot+".dat") to liRval
46306>>>>>>>  get SEQ_EraseFile (lsRoot+".tag") to liRval
46307>>>>>>>  get SEQ_EraseFile (lsRoot+".vld") to liRval
46308>>>>>>>  get SEQ_EraseFile (lsRoot+".hdr") to liRval
46309>>>>>>>  get SEQ_EraseFile (lsRoot+".k1")  to liRval
46310>>>>>>>  get SEQ_EraseFile (lsRoot+".k2")  to liRval
46311>>>>>>>  get SEQ_EraseFile (lsRoot+".k3")  to liRval
46312>>>>>>>  get SEQ_EraseFile (lsRoot+".k4")  to liRval
46313>>>>>>>  get SEQ_EraseFile (lsRoot+".k5")  to liRval
46314>>>>>>>  get SEQ_EraseFile (lsRoot+".k6")  to liRval
46315>>>>>>>  get SEQ_EraseFile (lsRoot+".k7")  to liRval
46316>>>>>>>  get SEQ_EraseFile (lsRoot+".k8")  to liRval
46317>>>>>>>  get SEQ_EraseFile (lsRoot+".k9")  to liRval
46318>>>>>>>  get SEQ_EraseFile (lsRoot+".k10") to liRval
46319>>>>>>>  get SEQ_EraseFile (lsRoot+".k11") to liRval
46320>>>>>>>  get SEQ_EraseFile (lsRoot+".k12") to liRval
46321>>>>>>>  get SEQ_EraseFile (lsRoot+".k13") to liRval
46322>>>>>>>  get SEQ_EraseFile (lsRoot+".k14") to liRval
46323>>>>>>>  get SEQ_EraseFile (lsRoot+".k15") to liRval
46324>>>>>>>  get SEQ_EraseFile (lsRoot+".def") to liRval
46325>>>>>>>  get SEQ_EraseFile (lsRoot+".fd")  to liRval
46326>>>>>>>  function_return 1
46327>>>>>>>end_function
46328>>>>>>>
46328>>>>>>>//> Sets a field to its highest possible value
46328>>>>>>>procedure DBMS_SetFieldValueMax global integer liFile integer liField
46330>>>>>>>  integer liType liLen liDecs
46330>>>>>>>  number lnValue
46330>>>>>>>  string lsChar lsValue
46330>>>>>>>  get_attribute DF_FIELD_TYPE of liFile liField to liType
46333>>>>>>>  if (liType=DF_DATE) set_field_value liFile liField to LargestPossibleDate
46338>>>>>>>  else begin
46339>>>>>>>    get_attribute DF_FIELD_LENGTH of liFile liField to liLen
46342>>>>>>>    if (liType=DF_ASCII) begin
46344>>>>>>>      move (left(trim(gs$CollateString),1)) to lsChar // Highest possible collating value
46345>>>>>>>      set_field_value liFile liField to (repeat(lsChar,liLen))
46348>>>>>>>    end
46348>>>>>>>>
46348>>>>>>>    if (liType=DF_BCD) begin
46350>>>>>>>      get_attribute DF_FIELD_PRECISION of liFile liField to liDecs
46353>>>>>>>      move (liLen-liDecs) to liLen
46354>>>>>>>      if liDecs move (repeat("9",liLen)+CurrentDecimalSeparator()+repeat("9",liDecs)) to lsValue
46357>>>>>>>      else      move (repeat("9",liLen)) to lsValue
46359>>>>>>>      move lsValue to lnValue
46360>>>>>>>      set_field_value liFile liField to lnValue
46363>>>>>>>    end
46363>>>>>>>>
46363>>>>>>>  end
46363>>>>>>>>
46363>>>>>>>end_procedure
46364>>>>>>>
46364>>>>>>>//> Sets a field to its lowest possible value
46364>>>>>>>procedure DBMS_SetFieldValueMin global integer liFile integer liField
46366>>>>>>>  integer liType liLen liDecs
46366>>>>>>>  number lnValue
46366>>>>>>>  string lsChar lsValue
46366>>>>>>>  get_attribute DF_FIELD_TYPE of liFile liField to liType
46369>>>>>>>  if (liType=DF_DATE) set_field_value liFile liField to 0
46374>>>>>>>  else begin
46375>>>>>>>    get_attribute DF_FIELD_LENGTH of liFile liField to liLen
46378>>>>>>>    if (liType=DF_ASCII) begin
46380>>>>>>>      set_field_value liFile liField to (repeat(" ",liLen))
46383>>>>>>>    end
46383>>>>>>>>
46383>>>>>>>    if (liType=DF_BCD) begin
46385>>>>>>>      if liField begin // Not RECNUM
46387>>>>>>>        get_attribute DF_FIELD_PRECISION of liFile liField to liDecs
46390>>>>>>>        move (liLen-liDecs) to liLen
46391>>>>>>>        decrement liLen
46392>>>>>>>        if liDecs move ("-"+repeat("9",liLen)+CurrentDecimalSeparator()+repeat("9",liDecs)) to lsValue
46395>>>>>>>        else      move ("-"+repeat("9",liLen)) to lsValue
46397>>>>>>>        move lsValue to lnValue
46398>>>>>>>        set_field_value liFile liField to lnValue
46401>>>>>>>      end
46401>>>>>>>>
46401>>>>>>>      else set_field_value liFile liField to 0 // If RECNUM field
46405>>>>>>>    end
46405>>>>>>>>
46405>>>>>>>  end
46405>>>>>>>>
46405>>>>>>>end_procedure
46406>>>>>>>
46406>>>>>>>procedure DBMS_FindByRecnum global integer liFile integer liRecnum
46408>>>>>>>  clear liFile
46409>>>>>>>  if liRecnum begin
46411>>>>>>>    set_field_value liFile 0 to liRecnum
46414>>>>>>>    vfind liFile 0 EQ
46416>>>>>>>  end
46416>>>>>>>>
46416>>>>>>>end_procedure
46417>>>>>>>
46417>>>>>>>
46417>>>>>Use AppFolders.nui // Function AppFolder returns the absolute folder name of strategic folders
Including file: AppFolders.nui    (C:\Apps\VDFQuery\AppSrc\AppFolders.nui)
46417>>>>>>>// Use AppFolders.nui // Function AppFolder returns the absolute folder name of strategic folders
46417>>>>>>>//
46417>>>>>>>// Not very sophisticated! Everything is based on the location of filelist.cfg. Should really
46417>>>>>>>// examine the -ws file. Well, let's see how VDF 12 works before exhausting ourselves.
46417>>>>>>>
46417>>>>>>>use files.nui
46417>>>>>>>
46417>>>>>>>enumeration_list
46417>>>>>>>  define APPFOLDER_HTML
46417>>>>>>>  define APPFOLDER_FILELIST
46417>>>>>>>  define APPFOLDER_PROGRAM
46417>>>>>>>  define APPFOLDER_VDF_ROOT
46417>>>>>>>  define APPFOLDER_MAX
46417>>>>>>>end_enumeration_list
46417>>>>>>>
46417>>>>>>>
46417>>>>>>>function AppFolder global integer liWhich returns string
46419>>>>>>>  string lsValue
46419>>>>>>>  if (liWhich=APPFOLDER_VDF_ROOT) begin // VDF Root dir
46421>>>>>>>    get_profile_string "Defaults" "VdfRootDir" To lsValue
46424>>>>>>>  end
46424>>>>>>>>
46424>>>>>>>  if (liWhich=APPFOLDER_FILELIST) begin // Filelist.cfg
46426>>>>>>>    get SEQ_FindFileAlongDFPath "filelist.cfg" to lsValue
46427>>>>>>>  end
46427>>>>>>>>
46427>>>>>>>  if (liWhich=APPFOLDER_PROGRAM) begin // Filelist.cfg
46429>>>>>>>    get appfolder APPFOLDER_FILELIST to lsValue
46430>>>>>>>    get SEQ_ExtractPathFromFileName lsValue to lsValue
46431>>>>>>>    get Files_AppendPath lsValue "Programs" to lsValue
46432>>>>>>>  end
46432>>>>>>>>
46432>>>>>>>  if (liWhich=APPFOLDER_HTML) begin // Filelist.cfg
46434>>>>>>>    get appfolder APPFOLDER_FILELIST to lsValue
46435>>>>>>>    get SEQ_ExtractPathFromFileName lsValue to lsValue
46436>>>>>>>    get Files_AppendPath lsValue "AppHtml" to lsValue
46437>>>>>>>  end
46437>>>>>>>>
46437>>>>>>>  function_return lsValue
46438>>>>>>>end_function
46439>>>>>>>
46439>>>>>>>function AppSubFolder global integer liWhich string lsSubFolder returns string
46441>>>>>>>  string lsValue
46441>>>>>>>  get AppFolder liWhich to lsValue
46442>>>>>>>  get Files_AppendPath lsValue lsSubFolder to lsValue
46443>>>>>>>  function_return lsValue
46444>>>>>>>end_function
46445>>>>>>>
46445>>>>>>>// Translate absolute disk folder (or file) into relative HTML folder (or file).
46445>>>>>>>function AppFolder_DiskToHtml global string lsDiskFolder returns string
46447>>>>>>>  string lsHtmlRootFolder lsRelativeFolder
46447>>>>>>>  get AppFolder APPFOLDER_HTML to lsHtmlRootFolder
46448>>>>>>>  move (lowercase(lsDiskFolder)) to lsDiskFolder
46449>>>>>>>  move (lowercase(lsHtmlRootFolder)) to lsHtmlRootFolder
46450>>>>>>>  move (replace(lsHtmlRootFolder,lsDiskFolder,"")) to lsRelativeFolder
46451>>>>>>>
46451>>>>>>>  if (left(lsRelativeFolder,1)="\") move (replace("\",lsRelativeFolder,"")) to lsRelativeFolder
46454>>>>>>>  move (replaces("\",lsRelativeFolder,"/")) to lsRelativeFolder
46455>>>>>>>  function_return lsRelativeFolder
46456>>>>>>>end_function
46457>>>>>enumeration_list // Global read only attributes from sysconf and other (OA = Other Attributes)
46457>>>>>  define OA_REG_NAME
46457>>>>>  define OA_SERIAL_NUMBER
46457>>>>>  define OA_MAX_USERS
46457>>>>>  define OA_DATAFLEX_REV
46457>>>>>  define OA_OS_SHORT_NAME
46457>>>>>  define OA_OS_MAJOR_REV
46457>>>>>  define OA_OS_MINOR_REV
46457>>>>>  define OA_OS_NAME
46457>>>>>  define OA_MACHINE_NAME
46457>>>>>  define OA_WORKDIR
46457>>>>>  define OA_PATH
46457>>>>>  define OA_DIR_SEPARATOR // "/" or "\"
46457>>>>>  define OA_FILE_MASK
46457>>>>>  define OA_SYSTEM_NAME
46457>>>>>  define OA_PATH_SEPARATOR // ":" or ";"
46457>>>>>  define OA_DATE4_STATE
46457>>>>>  define OA_SYSDATE4_STATE
46457>>>>>  define OA_EPOCH_VALUE
46457>>>>>  define OA_TIMER_RESOLUTION
46457>>>>>  define OA_COLLATE_PATH     // Path to COLLATE.CFG (excluding the file name itself)
46457>>>>>  define OA_COLLATE_SIZE     // Size of COLLATE.CFG in bytes
46457>>>>>  define OA_COLLATE_TIME     // Time stamp of COLLATE.CFG in TS-number format (see DATES.UTL)
46457>>>>>  define OA_RUNTIME_NAME     // SYSCONF_RUNTIME_NAME
46457>>>>>  define OA_UTC_TIME_OFFSET  // SYSCONF_UTC_TIME_OFFSET
46457>>>>>  define OA_MAX_ARGUMENT_SIZE
46457>>>>>  define OA_CURRENT_USER_COUNT
46457>>>>>  define OA_DFPRINTER
46457>>>>>  define OA_LOCK_COUNT
46457>>>>>
46457>>>>>  define OA_FOLDER_VDF_ROOT
46457>>>>>  define OA_FOLDER_FILELIST
46457>>>>>  define OA_FOLDER_HTML
46457>>>>>  define OA_FOLDER_PROGRAM
46457>>>>>
46457>>>>>  define OA_MAX // Pointer to highest OA index+1 (formerly OA_PATH_MAX)
46457>>>>>end_enumeration_list
46457>>>>>
46457>>>>>enumeration_list // Enumerate attribute types
46457>>>>>  define ATTRTYPE_NONE      // Not an attribute type
46457>>>>>  define ATTRTYPE_GLOBAL    // No parameters
46457>>>>>  define ATTRTYPE_DRIVER    // 1: Driver number
46457>>>>>  define ATTRTYPE_DRVSRV    // 1: Driver number  2: Server number
46457>>>>>  define ATTRTYPE_FILELIST  // 1: File  (No changes to structure, filelist only)
46457>>>>>  define ATTRTYPE_FILE      // 1: File
46457>>>>>  define ATTRTYPE_FIELD     // 1: File   2: Field
46457>>>>>  define ATTRTYPE_INDEX     // 1: File   2: Index
46457>>>>>  define ATTRTYPE_IDXSEG    // 1: File   2: Index   3: Segment
46457>>>>>  define ATTRTYPE_SPECIAL1  // 1: File 2/3: Field/Field  (overlap check)
46457>>>>>  define ATTRTYPE_FLSTNAV   // 1: File (for navigating filelist)
46457>>>>>end_enumeration_list
46457>>>>>
46457>>>>>desktop_section // Compile as if on desktop
46462>>>>>  object oAPI_AttributeTypes is a cArray no_image
46464>>>>>    item_property_list
46464>>>>>      item_property string  psName.i
46464>>>>>      item_property integer piParams.i // Number of parameters (DFScript feature)
46464>>>>>    end_item_property_list
#REM 46501 DEFINE FUNCTION PIPARAMS.I INTEGER LIROW RETURNS INTEGER
#REM 46506 DEFINE PROCEDURE SET PIPARAMS.I INTEGER LIROW INTEGER VALUE
#REM 46511 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 46516 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
46522>>>>>    procedure DefAttrType integer type# string name# integer params#
46525>>>>>      set psName.i type# to name#
46526>>>>>      set piParams.i type# to params#
46527>>>>>    end_procedure                   // Number of parameters
46528>>>>>    send DefAttrType ATTRTYPE_GLOBAL   "Global"              0
46529>>>>>    send DefAttrType ATTRTYPE_DRIVER   "Driver"              1
46530>>>>>    send DefAttrType ATTRTYPE_DRVSRV   "Server"              2
46531>>>>>    send DefAttrType ATTRTYPE_FILELIST "Filelist"            1
46532>>>>>    send DefAttrType ATTRTYPE_FILE     "File"                1
46533>>>>>    send DefAttrType ATTRTYPE_FIELD    "Field"               2
46534>>>>>    send DefAttrType ATTRTYPE_INDEX    "Index"               2
46535>>>>>    send DefAttrType ATTRTYPE_IDXSEG   "Index segment"       3
46536>>>>>    send DefAttrType ATTRTYPE_SPECIAL1 "Special1"            3
46537>>>>>    send DefAttrType ATTRTYPE_FLSTNAV  "Filelist navigation" 1
46538>>>>>  end_object
46539>>>>>  class cAPI_AttrValueArray is a cArray
46540>>>>>    item_property_list
46540>>>>>      item_property integer piValue.i        // Actual value
46540>>>>>      item_property string  psCodeName.i     // Value as written in code
46540>>>>>      item_property string  psDisplayName.i  // Value as presented to an unknowing user
46540>>>>>    end_item_property_list cAPI_AttrValueArray
#REM 46575 DEFINE FUNCTION PSDISPLAYNAME.I INTEGER LIROW RETURNS STRING
#REM 46579 DEFINE PROCEDURE SET PSDISPLAYNAME.I INTEGER LIROW STRING VALUE
#REM 46583 DEFINE FUNCTION PSCODENAME.I INTEGER LIROW RETURNS STRING
#REM 46587 DEFINE PROCEDURE SET PSCODENAME.I INTEGER LIROW STRING VALUE
#REM 46591 DEFINE FUNCTION PIVALUE.I INTEGER LIROW RETURNS INTEGER
#REM 46595 DEFINE PROCEDURE SET PIVALUE.I INTEGER LIROW INTEGER VALUE
46600>>>>>    procedure add_value integer value# string codename# string displayname#
46602>>>>>      integer row#
46602>>>>>      get row_count to row#
46603>>>>>      set piValue.i       row# to value#
46604>>>>>      set psCodeName.i    row# to codename#
46605>>>>>      set psDisplayName.i row# to displayname#
46606>>>>>    end_procedure
46607>>>>>    function iValue2Row.i integer value# returns integer
46609>>>>>      integer row# max#
46609>>>>>      get row_count to max#
46610>>>>>      for row# from 0 to (max#-1)
46616>>>>>>
46616>>>>>        if (piValue.i(self,row#)) eq value# function_return row#
46619>>>>>      loop
46620>>>>>>
46620>>>>>      function_return -1
46621>>>>>    end_function
46622>>>>>  end_class // cAPI_AttrValueArray
46623>>>>>  object oAPI_Attributes is a cArray no_image
46625>>>>>    item_property_list
46625>>>>>      item_property string  psName.i
46625>>>>>      item_property integer piAttrType.i     // Attribute type
46625>>>>>      item_property string  psDisplayName.i  // Attribute display name
46625>>>>>      item_property integer piWrite.i        // Write access?
46625>>>>>      item_property integer piOnlyDAC.i      // Internal DAC use
46625>>>>>      item_property integer piValueType.i    // DF_BCD or DF_ASCII
46625>>>>>      item_property integer piValueArray.i   // Legal values
46625>>>>>      item_property integer piRuntimeOnly.i  // Runtime only attribute (FILE attr)
46625>>>>>    end_item_property_list
#REM 46680 DEFINE FUNCTION PIRUNTIMEONLY.I INTEGER LIROW RETURNS INTEGER
#REM 46685 DEFINE PROCEDURE SET PIRUNTIMEONLY.I INTEGER LIROW INTEGER VALUE
#REM 46690 DEFINE FUNCTION PIVALUEARRAY.I INTEGER LIROW RETURNS INTEGER
#REM 46695 DEFINE PROCEDURE SET PIVALUEARRAY.I INTEGER LIROW INTEGER VALUE
#REM 46700 DEFINE FUNCTION PIVALUETYPE.I INTEGER LIROW RETURNS INTEGER
#REM 46705 DEFINE PROCEDURE SET PIVALUETYPE.I INTEGER LIROW INTEGER VALUE
#REM 46710 DEFINE FUNCTION PIONLYDAC.I INTEGER LIROW RETURNS INTEGER
#REM 46715 DEFINE PROCEDURE SET PIONLYDAC.I INTEGER LIROW INTEGER VALUE
#REM 46720 DEFINE FUNCTION PIWRITE.I INTEGER LIROW RETURNS INTEGER
#REM 46725 DEFINE PROCEDURE SET PIWRITE.I INTEGER LIROW INTEGER VALUE
#REM 46730 DEFINE FUNCTION PSDISPLAYNAME.I INTEGER LIROW RETURNS STRING
#REM 46735 DEFINE PROCEDURE SET PSDISPLAYNAME.I INTEGER LIROW STRING VALUE
#REM 46740 DEFINE FUNCTION PIATTRTYPE.I INTEGER LIROW RETURNS INTEGER
#REM 46745 DEFINE PROCEDURE SET PIATTRTYPE.I INTEGER LIROW INTEGER VALUE
#REM 46750 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 46755 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
46761>>>>>
46761>>>>>    procedure callback_attrtype.iii integer attrtype# integer msg# integer lhObj
46764>>>>>      integer max# attr#
46764>>>>>      get row_count to max#
46765>>>>>      for attr# from 0 to (max#-1)
46771>>>>>>
46771>>>>>        if (piAttrType.i(self,attr#)=attrtype#) send msg# to lhObj attr#
46774>>>>>      loop
46775>>>>>>
46775>>>>>    end_procedure
46776>>>>>
46776>>>>>    procedure callback_attrvalue.iii integer attr# integer msg# integer lhObj
46779>>>>>      integer arr# max# row#
46779>>>>>      get piValueArray.i attr# to arr#
46780>>>>>      if arr# begin
46782>>>>>        get row_count of arr# to max#
46783>>>>>        for row# from 0 to (max#-1)
46789>>>>>>
46789>>>>>          send msg# to lhObj (piValue.i(arr#,row#)) (psCodeName.i(arr#,row#)) (psDisplayName.i(arr#,row#))
46790>>>>>        loop
46791>>>>>>
46791>>>>>      end
46791>>>>>>
46791>>>>>    end_procedure
46792>>>>>
46792>>>>>    function iAttrValueArrayObj integer attr# returns integer
46795>>>>>      integer rval#
46795>>>>>      get piValueArray.i attr# to rval#
46796>>>>>      ifnot rval# begin
46798>>>>>        object oAPI_AttrValueArray is a cAPI_AttrValueArray no_image
46800>>>>>          move self to rval#
46801>>>>>        end_object
46802>>>>>        set piValueArray.i attr# to rval#
46803>>>>>      end
46803>>>>>>
46803>>>>>      function_return rval#
46804>>>>>    end_function
46805>>>>>
46805>>>>>    procedure AddAttrValue integer attr# integer value# string codename# string displayname#
46808>>>>>      integer lhObj
46808>>>>>      get iAttrValueArrayObj attr# to lhObj
46809>>>>>      send add_value to lhObj value# codename# displayname#
46810>>>>>    end_procedure
46811>>>>>
46811>>>>>    send AddAttrValue DF_FIELD_TYPE DF_ASCII   "DF_ASCII"   "Ascii"
46812>>>>>    send AddAttrValue DF_FIELD_TYPE DF_BCD     "DF_BCD"     "Bcd"
46813>>>>>    send AddAttrValue DF_FIELD_TYPE DF_DATE    "DF_DATE"    "Date"
46814>>>>>    send AddAttrValue DF_FIELD_TYPE DF_OVERLAP "DF_OVERLAP" "Overlap"
46815>>>>>    send AddAttrValue DF_FIELD_TYPE DF_TEXT    "DF_TEXT"    "Text"
46816>>>>>    send AddAttrValue DF_FIELD_TYPE DF_BINARY  "DF_BINARY"  "Binary"
46817>>>>>
46817>>>>>    send AddAttrValue DF_FILE_HANDLE_TYPE DF_FILE_HANDLE_BAD                   "DF_FILE_HANDLE_BAD"                  "Bad"
46818>>>>>    send AddAttrValue DF_FILE_HANDLE_TYPE DF_FILE_HANDLE_CLOSED                "DF_FILE_HANDLE_CLOSED"               "Closed"
46819>>>>>    send AddAttrValue DF_FILE_HANDLE_TYPE DF_FILE_HANDLE_OPENED                "DF_FILE_HANDLE_OPENED"               "Opened"
46820>>>>>    send AddAttrValue DF_FILE_HANDLE_TYPE DF_FILE_HANDLE_EXISTING_RESTRUCTURE  "DF_FILE_HANDLE_EXISTING_RESTRUCTURE" "Existing restructure"
46821>>>>>    send AddAttrValue DF_FILE_HANDLE_TYPE DF_FILE_HANDLE_NEW_RESTRUCTURE       "DF_FILE_HANDLE_NEW_RESTRUCTURE"      "New restructure"
46822>>>>>
46822>>>>>    send AddAttrValue DF_DATE_FORMAT DF_DATE_USA      "DF_DATE_USA"      "USA (mm/dd/yyyy)"
46823>>>>>    send AddAttrValue DF_DATE_FORMAT DF_DATE_EUROPEAN "DF_DATE_EUROPEAN" "European (dd/mm/yyyy)"
46824>>>>>    send AddAttrValue DF_DATE_FORMAT DF_DATE_MILITARY "DF_DATE_MILITARY" "Military (yyyy/mm/dd)"
46825>>>>>
46825>>>>>    send AddAttrValue DF_FILE_LOCK_TYPE DF_LOCK_TYPE_NONE   "DF_LOCK_TYPE_NONE"   "None"
46826>>>>>    send AddAttrValue DF_FILE_LOCK_TYPE DF_LOCK_TYPE_FILE   "DF_LOCK_TYPE_FILE"   "File"
46827>>>>>    send AddAttrValue DF_FILE_LOCK_TYPE DF_LOCK_TYPE_RECORD "DF_LOCK_TYPE_RECORD" "Record"
46828>>>>>
46828>>>>>    send AddAttrValue DF_FILE_OPEN_MODE DF_SHARE     "DF_SHARE"     "Share"
46829>>>>>    send AddAttrValue DF_FILE_OPEN_MODE DF_EXCLUSIVE "DF_EXCLUSIVE" "Exclusive"
46830>>>>>
46830>>>>>    send AddAttrValue DF_FILE_COMPRESSION DF_FILE_COMPRESS_NONE     "DF_FILE_COMPRESS_NONE"     "None"
46831>>>>>    send AddAttrValue DF_FILE_COMPRESSION DF_FILE_COMPRESS_FAST     "DF_FILE_COMPRESS_FAST"     "Fast"
46832>>>>>    send AddAttrValue DF_FILE_COMPRESSION DF_FILE_COMPRESS_STANDARD "DF_FILE_COMPRESS_STANDARD" "Standard"
46833>>>>>    send AddAttrValue DF_FILE_COMPRESSION DF_FILE_COMPRESS_CUSTOM   "DF_FILE_COMPRESS_CUSTOM"   "Custom"
46834>>>>>
46834>>>>>    send AddAttrValue DF_FILE_TRANSACTION DF_FILE_TRANSACTION_NONE          "DF_FILE_TRANSACTION_NONE"          "None"
46835>>>>>    send AddAttrValue DF_FILE_TRANSACTION DF_FILE_TRANSACTION_CLIENT_ATOMIC "DF_FILE_TRANSACTION_CLIENT_ATOMIC" "Client atomic"
46836>>>>>    send AddAttrValue DF_FILE_TRANSACTION DF_FILE_TRANSACTION_SERVER_ATOMIC "DF_FILE_TRANSACTION_SERVER_ATOMIC" "Server atomic"
46837>>>>>    send AddAttrValue DF_FILE_TRANSACTION DF_FILE_TRANSACTION_SERVER_LOGGED "DF_FILE_TRANSACTION_SERVER_LOGGED" "Server logged"
46838>>>>>
46838>>>>>    send AddAttrValue DF_FILE_STATUS DF_FILE_INACTIVE       "DF_FILE_INACTIVE"       "Inactive"
46839>>>>>    send AddAttrValue DF_FILE_STATUS DF_FILE_ACTIVE         "DF_FILE_ACTIVE"         "Active"
46840>>>>>    send AddAttrValue DF_FILE_STATUS DF_FILE_ACTIVE_CHANGED "DF_FILE_ACTIVE_CHANGED" "Changed"
46841>>>>>
46841>>>>>    send AddAttrValue DF_FILE_COMMITTED DFTRUE  "DFTRUE"  "True"
46842>>>>>    send AddAttrValue DF_FILE_COMMITTED DFFALSE "DFFALSE" "False"
46843>>>>>
46843>>>>>    send AddAttrValue DF_FILE_RESTRUCTURE DF_NO_RESTRUCTURE    "DF_NO_RESTRUCTURE"    "None"
46844>>>>>    send AddAttrValue DF_FILE_RESTRUCTURE DF_RESTRUCTURE_FILE  "DF_RESTRUCTURE_FILE"  "File"
46845>>>>>    send AddAttrValue DF_FILE_RESTRUCTURE DF_RESTRUCTURE_INDEX "DF_RESTRUCTURE_INDEX" "Index"
46846>>>>>    send AddAttrValue DF_FILE_RESTRUCTURE DF_RESTRUCTURE_BOTH  "DF_RESTRUCTURE_BOTH"  "File/Index"
46847>>>>>
46847>>>>>    send AddAttrValue DF_FILE_MULTIUSER DF_FILE_USER_SINGLE "DF_FILE_USER_SINGLE" "Single user"
46848>>>>>    send AddAttrValue DF_FILE_MULTIUSER DF_FILE_USER_MULTI  "DF_FILE_USER_MULTI"  "Multi user"
46849>>>>>
46849>>>>>    send AddAttrValue DF_FILE_MODE DF_FILE_ALIAS_DEFAULT "DF_FILE_ALIAS_DEFAULT" "Default"
46850>>>>>    send AddAttrValue DF_FILE_MODE DF_FILE_IS_MASTER     "DF_FILE_IS_MASTER"     "Master"
46851>>>>>    send AddAttrValue DF_FILE_MODE DF_FILE_IS_ALIAS      "DF_FILE_IS_ALIAS"      "Alias"
46852>>>>>
46852>>>>>    send AddAttrValue DF_FILE_REUSE_DELETED DF_FILE_DELETED_NOREUSE "DF_FILE_DELETED_NOREUSE" "No reuse"
46853>>>>>    send AddAttrValue DF_FILE_REUSE_DELETED DF_FILE_DELETED_REUSE   "DF_FILE_DELETED_REUSE"   "Reuse"
46854>>>>>
46854>>>>>    send AddAttrValue DF_FILE_INTEGRITY_CHECK DFTRUE  "DFTRUE"  "True"
46855>>>>>    send AddAttrValue DF_FILE_INTEGRITY_CHECK DFFALSE "DFFALSE" "False"
46856>>>>>
46856>>>>>    send AddAttrValue DF_INDEX_TYPE DF_INDEX_TYPE_ONLINE "DF_INDEX_TYPE_ONLINE" "Online"
46857>>>>>    send AddAttrValue DF_INDEX_TYPE DF_INDEX_TYPE_BATCH  "DF_INDEX_TYPE_BATCH"  "Batch"
46858>>>>>
46858>>>>>    send AddAttrValue DF_INDEX_SEGMENT_DIRECTION DF_ASCENDING  "DF_ASCENDING"  "Ascending"
46859>>>>>    send AddAttrValue DF_INDEX_SEGMENT_DIRECTION DF_DESCENDING "DF_DESCENDING" "Descending"
46860>>>>>
46860>>>>>    send AddAttrValue DF_INDEX_SEGMENT_CASE DF_CASE_USED    "DF_CASE_USED"    "Case used"
46861>>>>>    send AddAttrValue DF_INDEX_SEGMENT_CASE DF_CASE_IGNORED "DF_CASE_IGNORED" "Case ignored"
46862>>>>>
46862>>>>>    function sValueRead_separator.i integer value# returns string
46865>>>>>      function_return (character(value#)+" ("+string(value#)+")")
46866>>>>>    end_function
46867>>>>>
46867>>>>>    procedure DefAttr integer attr# string name# integer attrtype# string dname# integer write# integer onlyDAC# integer valuetype# integer rt_only#
46870>>>>>      set psName.i        attr# to name#
46871>>>>>      set piAttrType.i    attr# to attrtype#
46872>>>>>      set psDisplayName.i attr# to dname#
46873>>>>>      set piWrite.i       attr# to write#
46874>>>>>      set piOnlyDAC.i     attr# to onlyDAC#
46875>>>>>       set piValueType.i   attr# to valuetype#
46876>>>>>      set piRuntimeOnly.i attr# to rt_only#
46877>>>>>    end_procedure
46878>>>>>    //                                     Runtime onlyRuntime onlyĿ
46878>>>>>    //                                     Value typeValue typeĿ        
46878>>>>>    //                                     Internal DAC?Internal DAC?Ŀ         
46878>>>>>    //                                     Write access?Write access?          
46878>>>>>    send DefAttr DF_LOCK_DELAY              "DF_LOCK_DELAY"              ATTRTYPE_GLOBAL   "Lock delay"            1 0 DF_BCD   0
46879>>>>>    send DefAttr DF_LOCK_TIMEOUT            "DF_LOCK_TIMEOUT"            ATTRTYPE_GLOBAL   "Lock timeout"          1 0 DF_BCD   0
46880>>>>>    send DefAttr DF_OPEN_PATH               "DF_OPEN_PATH"               ATTRTYPE_GLOBAL   "Open path"             1 0 DF_ASCII 0
46881>>>>>    send DefAttr DF_DATE_FORMAT             "DF_DATE_FORMAT"             ATTRTYPE_GLOBAL   "Date format"           1 0 DF_BCD   0
46882>>>>>    send DefAttr DF_DATE_SEPARATOR          "DF_DATE_SEPARATOR"          ATTRTYPE_GLOBAL   "Date separator"        1 0 DF_BCD   0
46883>>>>>    send DefAttr DF_DECIMAL_SEPARATOR       "DF_DECIMAL_SEPARATOR"       ATTRTYPE_GLOBAL   "Decimal separator"     1 0 DF_BCD   0
46884>>>>>    send DefAttr DF_THOUSANDS_SEPARATOR     "DF_THOUSANDS_SEPARATOR"     ATTRTYPE_GLOBAL   "Thousands separator"   1 0 DF_BCD   0
46885>>>>>    send DefAttr DF_ALL_FILES_TOUCHED       "DF_ALL_FILES_TOUCHED"       ATTRTYPE_GLOBAL   "All files touched"     0 0 DF_BCD   0
46886>>>>>    send DefAttr DF_HIGH_DATA_INTEGRITY     "DF_HIGH_DATA_INTEGRITY"     ATTRTYPE_GLOBAL   "High data integrity"   1 0 DF_BCD   0
46887>>>>>    send DefAttr DF_TRAN_COUNT              "DF_TRAN_COUNT"              ATTRTYPE_GLOBAL   "Transact. nest. level" 0 0 DF_BCD   0
46888>>>>>    send DefAttr DF_TRANSACTION_ABORT       "DF_TRANSACTION_ABORT"       ATTRTYPE_GLOBAL   "Transaction abort"     0 0 DF_BCD   0
46889>>>>>    send DefAttr DF_REREAD_REQUIRED         "DF_REREAD_REQUIRED"         ATTRTYPE_GLOBAL   "Reread required"       0 0 DF_BCD   0
46890>>>>>    send DefAttr DF_FILELIST_NAME           "DF_FILELIST_NAME"           ATTRTYPE_GLOBAL   "Filelist name"         1 0 DF_ASCII 0
46891>>>>>    send DefAttr DF_REPORT_UNSUPPORTED_ATTRIBUTES ;                                        "DF_REPORT_UNSUPPORTED_ATTRIBUTES" ;                                                                         ATTRTYPE_GLOBAL   "Report unsup. attr."   1 0 DF_BCD   0
46892>>>>>    send DefAttr DF_STRICT_ATTRIBUTES       "DF_STRICT_ATTRIBUTES"       ATTRTYPE_GLOBAL   "Strict attributes"     1 0 DF_BCD   0
46893>>>>>    send DefAttr DF_NUMBER_DRIVERS          "DF_NUMBER_DRIVERS"          ATTRTYPE_GLOBAL   "Number drivers"        0 0 DF_BCD   0
46894>>>>>    send DefAttr DF_DRIVER_NAME             "DF_DRIVER_NAME"             ATTRTYPE_DRIVER   "Driver name"           0 0 DF_ASCII 0
46895>>>>>    send DefAttr DF_DRIVER_NUMBER_SERVERS   "DF_DRIVER_NUMBER_SERVERS"   ATTRTYPE_DRIVER   "Driver number servers" 0 0 DF_BCD   0
46896>>>>>    send DefAttr DF_DRIVER_SERVER_NAME      "DF_DRIVER_SERVER_NAME"      ATTRTYPE_DRVSRV   "Driver server name"    0 0 DF_ASCII 0
46897>>>>>    send DefAttr DF_API_DISABLED            "DF_API_DISABLED"            ATTRTYPE_GLOBAL   "API disabled"          0 1 DF_BCD   0
46898>>>>>    send DefAttr DF_API_DISABLED_ERROR      "DF_API_DISABLED_ERROR"      ATTRTYPE_GLOBAL   "API disabled error"    0 1 DF_BCD   0
46899>>>>>
46899>>>>>    send DefAttr DF_FILE_STATUS             "DF_FILE_STATUS"             ATTRTYPE_FILE     "Status"                0 0 DF_BCD   1
46900>>>>>    send DefAttr DF_FILE_MODE               "DF_FILE_MODE"               ATTRTYPE_FILE     "Mode"                  1 0 DF_BCD   1
46901>>>>>    send DefAttr DF_FILE_MAX_RECORDS        "DF_FILE_MAX_RECORDS"        ATTRTYPE_FILE     "Max records"           1 0 DF_BCD   0
46902>>>>>    send DefAttr DF_FILE_RECORDS_USED       "DF_FILE_RECORDS_USED"       ATTRTYPE_FILE     "Records used"          0 0 DF_BCD   0
46903>>>>>    send DefAttr DF_FILE_TYPE               "DF_FILE_TYPE"               ATTRTYPE_FILE     "Type"                  0 0 DF_BCD   0
46904>>>>>    send DefAttr DF_FILE_MULTIUSER          "DF_FILE_MULTIUSER"          ATTRTYPE_FILE     "Multiuser"             1 0 DF_BCD   0
46905>>>>>    send DefAttr DF_FILE_REUSE_DELETED      "DF_FILE_REUSE_DELETED"      ATTRTYPE_FILE     "Reuse deleted"         1 0 DF_BCD   0
46906>>>>>    send DefAttr DF_FILE_NUMBER             "DF_FILE_NUMBER"             ATTRTYPE_FILE     "Number"                0 0 DF_BCD   1
46907>>>>>    send DefAttr DF_FILE_COMPRESSION        "DF_FILE_COMPRESSION"        ATTRTYPE_FILE     "Compression"           1 0 DF_BCD   0
46908>>>>>    send DefAttr DF_FILE_LAST_INDEX_NUMBER  "DF_FILE_LAST_INDEX_NUMBER"  ATTRTYPE_FILE     "Last index number"     0 0 DF_BCD   0
46909>>>>>    send DefAttr DF_FILE_NUMBER_FIELDS      "DF_FILE_NUMBER_FIELDS"      ATTRTYPE_FILE     "Number fields"         0 0 DF_BCD   0
46910>>>>>    // Max 8 characters:
46910>>>>>    send DefAttr DF_FILE_LOGICAL_NAME       "DF_FILE_LOGICAL_NAME"       ATTRTYPE_FILELIST "Logical name"          1 0 DF_ASCII 0
46911>>>>>    // Max 40 characters:
46911>>>>>    send DefAttr DF_FILE_ROOT_NAME          "DF_FILE_ROOT_NAME"          ATTRTYPE_FILELIST "Root name"             1 0 DF_ASCII 0
46912>>>>>    send DefAttr DF_FILE_CHANGED            "DF_FILE_CHANGED"            ATTRTYPE_FILE     "Changed"               0 0 DF_BCD   1
46913>>>>>    send DefAttr DF_FILE_ALIAS              "DF_FILE_ALIAS"              ATTRTYPE_FILE     "Alias"                 1 0 DF_BCD   1
46914>>>>>    send DefAttr DF_FILE_TOUCHED            "DF_FILE_TOUCHED"            ATTRTYPE_FILE     "Touched"               0 0 DF_BCD   1
46915>>>>>    send DefAttr DF_FILE_TRANSACTION        "DF_FILE_TRANSACTION"        ATTRTYPE_FILE     "Transaction"           1 0 DF_BCD   0
46916>>>>>    send DefAttr DF_FILE_OPENED             "DF_FILE_OPENED"             ATTRTYPE_FILE     "Opened"                0 0 DF_BCD   1
46917>>>>>    // Max 32 characters:
46917>>>>>    send DefAttr DF_FILE_DISPLAY_NAME       "DF_FILE_DISPLAY_NAME"       ATTRTYPE_FILELIST "Display name"          1 0 DF_ASCII 0
46918>>>>>    send DefAttr DF_FILE_PHYSICAL_NAME      "DF_FILE_PHYSICAL_NAME"      ATTRTYPE_FILE     "Physical name"         0 0 DF_ASCII 0
46919>>>>>    send DefAttr DF_FILE_NEXT_OPENED        "DF_FILE_NEXT_OPENED"        ATTRTYPE_FLSTNAV  "Next opened"           0 0 DF_BCD   0
46920>>>>>    send DefAttr DF_FILE_NEXT_USED          "DF_FILE_NEXT_USED"          ATTRTYPE_FLSTNAV  "Next used"             0 0 DF_BCD   0
46921>>>>>    send DefAttr DF_FILE_NEXT_EMPTY         "DF_FILE_NEXT_EMPTY"         ATTRTYPE_FLSTNAV  "Next empty"            0 0 DF_BCD   0
46922>>>>>    send DefAttr DF_FILE_RECORD_LENGTH      "DF_FILE_RECORD_LENGTH"      ATTRTYPE_FILE     "Record length"         1 0 DF_BCD   0
46923>>>>>    send DefAttr DF_FILE_RESTRUCTURE        "DF_FILE_RESTRUCTURE"        ATTRTYPE_FILE     "Restructure"           0 0 DF_BCD   1
46924>>>>>    send DefAttr DF_FILE_OPEN_MODE          "DF_FILE_OPEN_MODE"          ATTRTYPE_FILE     "Open mode"             0 0 DF_BCD   1
46925>>>>>    send DefAttr DF_FILE_INTEGRITY_CHECK    "DF_FILE_INTEGRITY_CHECK"    ATTRTYPE_FILE     "Integrity check"       1 0 DF_BCD   0
46926>>>>>    send DefAttr DF_FILE_OWNER              "DF_FILE_OWNER"              ATTRTYPE_FILE     "Owner"                 0 0 DF_ASCII 1
46927>>>>>    send DefAttr DF_FILE_IS_SYSTEM_FILE     "DF_FILE_IS_SYSTEM_FILE"     ATTRTYPE_FILE     "Is system file"        0 0 DF_BCD   0
46928>>>>>    send DefAttr DF_FILE_LOCK_TYPE          "DF_FILE_LOCK_TYPE"          ATTRTYPE_FILE     "Lock type"             0 0 DF_BCD   0
46929>>>>>    send DefAttr DF_FILE_COMMITTED          "DF_FILE_COMMITTED"          ATTRTYPE_FILE     "Committed"             0 0 DF_BCD   1
46930>>>>>    send DefAttr DF_FILE_DRIVER             "DF_FILE_DRIVER"             ATTRTYPE_FILE     "Driver"                0 0 DF_ASCII 0
46931>>>>>    send DefAttr DF_FILE_RECORD_LENGTH_USED "DF_FILE_RECORD_LENGTH_USED" ATTRTYPE_FILE     "Record length used"    0 0 DF_BCD   0
46932>>>>>    send DefAttr DF_FILE_HANDLE_TYPE        "DF_FILE_HANDLE_TYPE"        ATTRTYPE_FILE     "Handle type"           0 1 DF_BCD   1
46933>>>>>    send DefAttr DF_FILE_RECORD_IDENTITY    "DF_FILE_RECORD_IDENTITY"    ATTRTYPE_FILE     "Record identity"       1 0 DF_BCD   0
46934>>>>>    send DefAttr DF_FILE_LOGIN              "DF_FILE_LOGIN"              ATTRTYPE_FILE     "Login"                 1 0 DF_ASCII 1
46935>>>>>    send DefAttr DF_FILE_RECORD_PRIVILEGE   "DF_FILE_RECORD_PRIVILEGE"   ATTRTYPE_FILE     "Record privilege"      0 1 DF_BCD   1
46936>>>>>    send DefAttr DF_FILE_PRIVILEGE          "DF_FILE_PRIVILEGE"          ATTRTYPE_FILE     "Privilege"             0 1 DF_BCD   1
46937>>>>>    send DefAttr DF_FILE_CREATION_SERIAL    "DF_FILE_CREATION_SERIAL"    ATTRTYPE_FILE     "Creation serial"       0 1 DF_BCD   1
46938>>>>>    send DefAttr DF_FILE_REVISION           "DF_FILE_REVISION"           ATTRTYPE_FILE     "Revision"              0 0 DF_ASCII 0
46939>>>>>    send DefAttr DF_FILE_RELATED_COUNT      "DF_FILE_RELATED_COUNT"      ATTRTYPE_FILE     "Related count"         0 1 DF_BCD   1
46940>>>>>    send DefAttr DF_FILE_RELATED_FIELDS     "DF_FILE_RELATED_FIELDS"     ATTRTYPE_FILE     "Related fields"        0 1 DF_BCD   1
46941>>>>>    send DefAttr DF_FILE_SYSTEM_FILE        "DF_FILE_SYSTEM_FILE"        ATTRTYPE_FILE     "System file"           0 1 DF_BCD   1
46942>>>>>    send DefAttr DF_FILE_SYSTEM_FIELD       "DF_FILE_SYSTEM_FIELD"       ATTRTYPE_FILE     "System field"          0 1 DF_BCD   1
46943>>>>>    send DefAttr DF_FILE_RECORD_REREAD      "DF_FILE_RECORD_REREAD"      ATTRTYPE_FILE     "Record reread"         0 1 DF_BCD   1
46944>>>>>    send DefAttr DF_FIELD_NUMBER            "DF_FIELD_NUMBER"            ATTRTYPE_FIELD    "Number"                0 1 DF_BCD   0
46945>>>>>    send DefAttr DF_FIELD_TYPE              "DF_FIELD_TYPE"              ATTRTYPE_FIELD    "Type"                  1 0 DF_BCD   0
46946>>>>>    send DefAttr DF_FIELD_LENGTH            "DF_FIELD_LENGTH"            ATTRTYPE_FIELD    "Length"                1 0 DF_BCD   0
46947>>>>>    send DefAttr DF_FIELD_PRECISION         "DF_FIELD_PRECISION"         ATTRTYPE_FIELD    "Precision"             1 0 DF_BCD   0
46948>>>>>    send DefAttr DF_FIELD_RELATED_FILE      "DF_FIELD_RELATED_FILE"      ATTRTYPE_FIELD    "Related file"          1 0 DF_BCD   0
46949>>>>>    send DefAttr DF_FIELD_RELATED_FIELD     "DF_FIELD_RELATED_FIELD"     ATTRTYPE_FIELD    "Related field"         1 0 DF_BCD   0
46950>>>>>    send DefAttr DF_FIELD_NAME              "DF_FIELD_NAME"              ATTRTYPE_FIELD    "Name"                  1 0 DF_ASCII 0
46951>>>>>    send DefAttr DF_FIELD_INDEX             "DF_FIELD_INDEX"             ATTRTYPE_FIELD    "Index"                 1 0 DF_BCD   0
46952>>>>>    send DefAttr DF_FIELD_OFFSET            "DF_FIELD_OFFSET"            ATTRTYPE_FIELD    "Offset"                1 0 DF_BCD   0
46953>>>>>    send DefAttr DF_FIELD_OLD_NUMBER        "DF_FIELD_OLD_NUMBER"        ATTRTYPE_FIELD    "Old number"            0 0 DF_BCD   0
46954>>>>>    send DefAttr DF_FIELD_OVERLAP           "DF_FIELD_OVERLAP"           ATTRTYPE_SPECIAL1 "Overlap"               0 0 DF_BCD   0
46955>>>>>    send DefAttr DF_FIELD_NATIVE_LENGTH     "DF_FIELD_NATIVE_LENGTH"     ATTRTYPE_FIELD    "Native length"         0 0 DF_BCD   0
46956>>>>>
46956>>>>>    send DefAttr DF_INDEX_NUMBER_SEGMENTS   "DF_INDEX_NUMBER_SEGMENTS"   ATTRTYPE_INDEX    "Number segments"       1 0 DF_BCD   0
46957>>>>>    send DefAttr DF_INDEX_NUMBER_BUFFERS    "DF_INDEX_NUMBER_BUFFERS"    ATTRTYPE_INDEX    "Number buffers"        0 0 DF_BCD   0
46958>>>>>    send DefAttr DF_INDEX_TYPE              "DF_INDEX_TYPE"              ATTRTYPE_INDEX    "Type"                  1 0 DF_BCD   0
46959>>>>>    send DefAttr DF_INDEX_LEVELS            "DF_INDEX_LEVELS"            ATTRTYPE_INDEX    "Levels"                0 0 DF_BCD   0
46960>>>>>    send DefAttr DF_INDEX_KEY_LENGTH        "DF_INDEX_KEY_LENGTH"        ATTRTYPE_INDEX    "Key length"            0 0 DF_BCD   0
46961>>>>>
46961>>>>>    send DefAttr DF_INDEX_SEGMENT_DIRECTION "DF_INDEX_SEGMENT_DIRECTION" ATTRTYPE_IDXSEG   "Segment direction"     1 0 DF_BCD   0
46962>>>>>    send DefAttr DF_INDEX_SEGMENT_CASE      "DF_INDEX_SEGMENT_CASE"      ATTRTYPE_IDXSEG   "Segment case"          1 0 DF_BCD   0
46963>>>>>    send DefAttr DF_INDEX_SEGMENT_FIELD     "DF_INDEX_SEGMENT_FIELD"     ATTRTYPE_IDXSEG   "Segment field"         1 0 DF_BCD   0
46964>>>>>    function sAttrCodeValueText.is integer attr# string value# returns string
46967>>>>>      integer arr# row#
46967>>>>>      get piValueArray.i attr# to arr#
46968>>>>>      if arr# begin
46970>>>>>        get iValue2Row.i of arr# value# to row#
46971>>>>>        if row# eq -1 move "Unknown" to value#
46974>>>>>        else move (psCodeName.i(arr#,row#)) to value#
46976>>>>>      end
46976>>>>>>
46976>>>>>      function_return value#
46977>>>>>    end_function
46978>>>>>    function sAttrReadValueText.is integer attr# string value# returns string
46981>>>>>      integer arr# row#
46981>>>>>      get piValueArray.i attr# to arr#
46982>>>>>      if arr# begin
46984>>>>>        get iValue2Row.i of arr# value# to row#
46985>>>>>        if row# eq -1 move "Unknown" to value#
46988>>>>>        else move (psDisplayName.i(arr#,row#)) to value#
46990>>>>>      end
46990>>>>>>
46990>>>>>      function_return value#
46991>>>>>    end_function
46992>>>>>  end_object // oAPI_Attributes
46993>>>>>end_desktop_section
46998>>>>>
46998>>>>>function API_AttrType_Count global returns integer
47000>>>>>  function_return (row_count(oAPI_AttributeTypes(self)))
47001>>>>>end_function
47002>>>>>function API_AttrType_Name global integer type# returns string
47004>>>>>  function_return (psName.i(oAPI_AttributeTypes(self),type#))
47005>>>>>end_function
47006>>>>>function API_AttrType_Params global integer type# returns integer
47008>>>>>  function_return (piParams.i(oAPI_AttributeTypes(self),type#))
47009>>>>>end_function
47010>>>>>
47010>>>>>function API_Attr_Count global returns integer
47012>>>>>  function_return (row_count(oAPI_Attributes(self)))
47013>>>>>end_function
47014>>>>>function API_Attr_WriteAccess global integer attr# returns integer
47016>>>>>  function_return (piWrite.i(oAPI_Attributes(self),attr#))
47017>>>>>end_function
47018>>>>>function API_Attr_Name global integer attr# returns string
47020>>>>>  function_return (psName.i(oAPI_Attributes(self),attr#))
47021>>>>>end_function
47022>>>>>function API_Attr_DisplayName global integer attr# returns string
47024>>>>>  function_return (psDisplayName.i(oAPI_Attributes(self),attr#))
47025>>>>>end_function
47026>>>>>function API_Attr_ValueName global integer attr# string value# returns string
47028>>>>>  function_return (sAttrCodeValueText.is(oAPI_Attributes(self),attr#,value#))
47029>>>>>end_function
47030>>>>>function API_Attr_DisplayValueName global integer attr# string value# returns string
47032>>>>>  function_return (sAttrReadValueText.is(oAPI_Attributes(self),attr#,value#))
47033>>>>>end_function
47034>>>>>function API_Attr_NumberOfParams global integer attr# returns integer
47036>>>>>  function_return (API_AttrType_Params(piAttrType.i(oAPI_Attributes(self),attr#)))
47037>>>>>end_function
47038>>>>>function API_AttrType global integer attr# returns integer
47040>>>>>  function_return (piAttrType.i(oAPI_Attributes(self),attr#))
47041>>>>>end_function
47042>>>>>function API_AttrValueType global integer attr# returns integer
47044>>>>>  function_return (piValueType.i(oAPI_Attributes(self),attr#))
47045>>>>>end_function
47046>>>>>function API_AttrRuntimeOnly global integer attr# returns integer
47048>>>>>  function_return (piRuntimeOnly.i(oAPI_Attributes(self),attr#))
47049>>>>>end_function
47050>>>>>//> Is the attribute represented by a set of (symbolic) discrete values?
47050>>>>>function API_AttrDiscreteValues global integer attr# returns integer
47052>>>>>  function_return (piValueArray.i(oAPI_Attributes(self),attr#))
47053>>>>>end_function
47054>>>>>procedure API_AttrType_Callback global integer attrtype# integer msg# integer lhObj
47056>>>>>  send callback_attrtype.iii to (oAPI_Attributes(self)) attrtype# msg# lhObj
47057>>>>>end_procedure
47058>>>>>procedure API_AttrValue_Callback global integer attr# integer msg# integer lhObj
47060>>>>>  send callback_attrvalue.iii to (oAPI_Attributes(self)) attr# msg# lhObj
47061>>>>>end_procedure
47062>>>>>
47062>>>>>//> Returns true if Attribute queried is relevant to restructure
47062>>>>>//> oprations.
47062>>>>>function API_AttrWorksOnStructure global integer attr# returns integer
47064>>>>>  integer type#
47064>>>>>  get API_AttrType attr# to type#
47065>>>>>  if type# eq ATTRTYPE_FILE function_return 1
47068>>>>>  if type# eq ATTRTYPE_FIELD function_return 1
47071>>>>>  if type# eq ATTRTYPE_INDEX function_return 1
47074>>>>>  if type# eq ATTRTYPE_IDXSEG function_return 1
47077>>>>>  if type# eq ATTRTYPE_SPECIAL1 function_return 1
47080>>>>>  // function_return 0
47080>>>>>end_function
47081>>>>>
47081>>>>>function API_ShortFieldTypeName global integer type# returns string
47083>>>>>  if type# eq DF_ASCII   function_return "Asc"
47086>>>>>  if type# eq DF_BCD     function_return "Num"
47089>>>>>  if type# eq DF_DATE    function_return "Dat"
47092>>>>>  if type# eq DF_OVERLAP function_return "Ove"
47095>>>>>  if type# eq DF_TEXT    function_return "Tex"
47098>>>>>  if type# eq DF_BINARY  function_return "Bin"
47101>>>>>end_function
47102>>>>>
47102>>>>>function API_AttrValue_GLOBAL global integer attr# returns string
47104>>>>>  string rval#
47104>>>>>  if (API_AttrType(attr#)=ATTRTYPE_GLOBAL) get_attribute attr# to rval#
47109>>>>>  else begin
47110>>>>>    error 666 "Attribute queried is not of GLOBAL type"
47111>>>>>>
47111>>>>>    move "" to rval#
47112>>>>>  end
47112>>>>>>
47112>>>>>  function_return rval#
47113>>>>>end_function
47114>>>>>function API_AttrValue_FILELIST global integer attr# integer file# returns string
47116>>>>>  string rval#
47116>>>>>  if (API_AttrType(attr#)=ATTRTYPE_FILELIST) get_attribute attr# of file# to rval#
47121>>>>>  else begin
47122>>>>>    //send obs (API_Attr_Name(attr#)+" on file "+string(file#))
47122>>>>>    error 666 "Attribute queried is not of FILELIST type"
47123>>>>>>
47123>>>>>    move "" to rval#
47124>>>>>  end
47124>>>>>>
47124>>>>>  function_return rval#
47125>>>>>end_function
47126>>>>>function API_AttrValue_FILE global integer attr# integer file# returns string
47128>>>>>  string rval#
47128>>>>>  if (API_AttrType(attr#)=ATTRTYPE_FILE) get_attribute attr# of file# to rval#
47133>>>>>  else begin
47134>>>>>    //send obs (API_Attr_Name(attr#)+" on file "+string(file#))
47134>>>>>    error 666 ("Attribute queried is not of FILE type")
47135>>>>>>
47135>>>>>    move "" to rval#
47136>>>>>  end
47136>>>>>>
47136>>>>>  function_return rval#
47137>>>>>end_function
47138>>>>>function API_AttrValue_FIELD global integer attr# integer file# integer field# returns string
47140>>>>>  string rval#
47140>>>>>  if (API_AttrType(attr#)=ATTRTYPE_FIELD) get_attribute attr# of file# field# to rval#
47145>>>>>  else begin
47146>>>>>    error 666 "Attribute queried is not of FIELD type"
47147>>>>>>
47147>>>>>    move "" to rval#
47148>>>>>  end
47148>>>>>>
47148>>>>>  function_return rval#
47149>>>>>end_function
47150>>>>>function API_AttrValue_INDEX global integer attr# integer file# integer index# returns string
47152>>>>>  string rval# lsDriver
47152>>>>>  if (API_AttrType(attr#)=ATTRTYPE_INDEX) begin
47154>>>>>    get_attribute DF_FILE_DRIVER of file# to lsDriver
47157>>>>>    if lsDriver eq "ODBC_DRV" function_return ""
47160>>>>>    get_attribute attr# of file# index# to rval#
47163>>>>>  end
47163>>>>>>
47163>>>>>  else begin
47164>>>>>    error 666 "Attribute queried is not of INDEX type"
47165>>>>>>
47165>>>>>    move "" to rval#
47166>>>>>  end
47166>>>>>>
47166>>>>>  function_return rval#
47167>>>>>end_function
47168>>>>>function API_AttrValue_IDXSEG global integer attr# integer file# integer index# integer segment# returns string
47170>>>>>  string rval#
47170>>>>>  if (API_AttrType(attr#)=ATTRTYPE_IDXSEG) get_attribute attr# of file# index# segment# to rval#
47175>>>>>  else begin
47176>>>>>    error 666 "Attribute queried is not of IDXSEG type"
47177>>>>>>
47177>>>>>    move "" to rval#
47178>>>>>  end
47178>>>>>>
47178>>>>>  function_return rval#
47179>>>>>end_function
47180>>>>>function API_AttrValue_SPECIAL1 global integer attr# integer file# integer field1# integer field2# returns string
47182>>>>>  string rval#
47182>>>>>  if (API_AttrType(attr#)=ATTRTYPE_SPECIAL1) get_attribute attr# of file# field1# field2# to rval#
47187>>>>>  else begin
47188>>>>>    error 666 "Attribute queried is not of SPECIAL1 type"
47189>>>>>>
47189>>>>>    move "" to rval#
47190>>>>>  end
47190>>>>>>
47190>>>>>  function_return rval#
47191>>>>>end_function
47192>>>>>function API_AttrValue_FLSTNAV global integer attr# integer file# returns string
47194>>>>>  string rval#
47194>>>>>  if (API_AttrType(attr#)=ATTRTYPE_FLSTNAV) get_attribute attr# of file# to rval#
47199>>>>>  else begin
47200>>>>>    error 666 "Attribute queried is not of FLSTNAV type"
47201>>>>>>
47201>>>>>    move "" to rval#
47202>>>>>  end
47202>>>>>>
47202>>>>>  function_return rval#
47203>>>>>end_function
47204>>>>>function API_AttrValue_DRIVER global integer attr# integer driver# returns string
47206>>>>>  string rval#
47206>>>>>  if (API_AttrType(attr#)=ATTRTYPE_DRIVER) get_attribute attr# of driver# to rval#
47211>>>>>  else begin
47212>>>>>    error 666 "Attribute queried is not of DRIVER type"
47213>>>>>>
47213>>>>>    move "" to rval#
47214>>>>>  end
47214>>>>>>
47214>>>>>  function_return rval#
47215>>>>>end_function
47216>>>>>function API_AttrValue_DRVSRV global integer attr# integer driver# integer server# returns string
47218>>>>>  string rval#
47218>>>>>  if (API_AttrType(attr#)=ATTRTYPE_DRVSRV) get_attribute attr# of driver# server# to rval#
47223>>>>>  else begin
47224>>>>>    error 666 "Attribute queried is not of DRVSRV type"
47225>>>>>>
47225>>>>>    move "" to rval#
47226>>>>>  end
47226>>>>>>
47226>>>>>  function_return rval#
47227>>>>>end_function
47228>>>>>
47228>>>>>function API_FieldNameToNumber global integer file# string name# returns integer
47230>>>>>  integer max# field#
47230>>>>>  move (API_AttrValue_FILE(DF_FILE_NUMBER_FIELDS,file#)) to max#
47231>>>>>  for field# from 1 to max#
47237>>>>>>
47237>>>>>    if name# eq (API_AttrValue_FIELD(DF_FIELD_NAME,file#,field#)) function_return field#
47240>>>>>  loop
47241>>>>>>
47241>>>>>  //function_return 0
47241>>>>>end_function
47242>>>>>
47242>>>>>desktop_section // Compile as if on desktop
47247>>>>>  object oFilesThatCanBeOpened is a cArray NO_IMAGE
47249>>>>>    property integer piValidContents public 0
47251>>>>>    procedure reset
47254>>>>>      set piValidContents to false
47255>>>>>      send delete_data
47256>>>>>    end_procedure
47257>>>>>    procedure RegisterValidEntries
47260>>>>>      integer file#
47260>>>>>      send reset
47261>>>>>      move 0 to file#
47262>>>>>      repeat
47262>>>>>>
47262>>>>>        move (API_AttrValue_FLSTNAV(DF_FILE_NEXT_USED,file#)) to file#
47263>>>>>        if file# set value item file# to (DBMS_CanOpenFile(file#))
47266>>>>>      until (not(file#))
47268>>>>>      set piValidContents to true
47269>>>>>    end_procedure
47270>>>>>    function iNextFileThatCanOpen integer file# returns integer
47273>>>>>      integer itm# max#
47273>>>>>      ifnot (piValidContents(self)) send RegisterValidEntries
47276>>>>>      get item_count to max#
47277>>>>>      move (file#+1) to itm#
47278>>>>>      while itm# lt max#
47282>>>>>        if (value(self,itm#)) ne 0 function_return itm#
47285>>>>>        increment itm#
47286>>>>>      end
47287>>>>>>
47287>>>>>      //function_return 0
47287>>>>>    end_function
47288>>>>>  end_object // oFilesThatCanBeOpened
47289>>>>>end_desktop_section
47294>>>>>
47294>>>>>function API_NextFileThatCanOpen global integer liFile returns integer
47296>>>>>  function_return (iNextFileThatCanOpen(oFilesThatCanBeOpened(self),liFile))
47297>>>>>end_function
47298>>>>>procedure API_ResetListOfFilesThatCanOpen global
47300>>>>>  send reset to (oFilesThatCanBeOpened(self))
47301>>>>>end_procedure
47302>>>>>
47302>>>>>function API_OtherAttr_Value global integer liScAttr returns string
47304>>>>>  string lsRval lsValue
47304>>>>>  if liScAttr eq OA_DIR_SEPARATOR    function_return (SysConf(SYSCONF_DIR_SEPARATOR))
47307>>>>>  if liScAttr eq OA_TIMER_RESOLUTION function_return (SysConf(SYSCONF_TIMER_RESOLUTION))
47310>>>>>  if liScAttr eq OA_OS_SHORT_NAME    function_return (SysConf(SYSCONF_OS_SHORT_NAME))
47313>>>>>  if liScAttr eq OA_OS_MAJOR_REV     function_return (SysConf(SYSCONF_OS_MAJOR_REV))
47316>>>>>  if liScAttr eq OA_OS_MINOR_REV     function_return (SysConf(SYSCONF_OS_MINOR_REV))
47319>>>>>  if liScAttr eq OA_OS_NAME          function_return (SysConf(SYSCONF_OS_NAME))
47322>>>>>  if liScAttr eq OA_MACHINE_NAME     function_return (SysConf(SYSCONF_MACHINE_NAME))
47325>>>>>  if liScAttr eq OA_FILE_MASK        function_return (SysConf(SYSCONF_FILE_MASK))
47328>>>>>  if liScAttr eq OA_DATAFLEX_REV     function_return (SysConf(SYSCONF_DATAFLEX_REV))
47331>>>>>  if liScAttr eq OA_SYSTEM_NAME      function_return (SysConf(SYSCONF_SYSTEM_NAME))
47334>>>>>  if liScAttr eq OA_PATH_SEPARATOR   function_return (SysConf(SYSCONF_PATH_SEPARATOR))
47337>>>>>  if liScAttr eq OA_SERIAL_NUMBER    registration lsValue lsRval
47340>>>>>  if liScAttr eq OA_REG_NAME         registration lsRval lsValue
47343>>>>>  if liScAttr eq OA_WORKDIR          begin
47345>>>>>    get_current_directory to lsRval
47346>>>>>    move (ToOem(lsRval)) to lsRval
47347>>>>>  end
47347>>>>>>
47347>>>>>  if liScAttr eq OA_PATH             begin
47349>>>>>    get_environment "PATH" to lsRval
47350>>>>>>
47350>>>>>    move (ToOem(lsRval)) to lsRval
47351>>>>>  end
47351>>>>>>
47351>>>>>  if liScAttr eq OA_MAX_USERS        get_licensed_max_users to lsRval
47354>>>>>  if liScAttr eq OA_DATE4_STATE      get_date_attribute DATE4_STATE to lsRval
47357>>>>>  if liScAttr eq OA_SYSDATE4_STATE   get_date_attribute SYSDATE4_STATE to lsRval
47360>>>>>  if liScAttr eq OA_EPOCH_VALUE      get_date_attribute EPOCH_VALUE to lsRval
47363>>>>>  //if liScAttr eq OA_COLLATE_PATH move (SEQ_FindFileAlongDFPath("collate.cfg")) to lsRval
47363>>>>>  if liScAttr eq OA_COLLATE_PATH begin
47365>>>>>    get_profile_string "defaults" "VDFRootDir" to lsRval
47368>>>>>    get SEQ_ComposeAbsoluteFileName lsRval "\bin\" to lsRval
47369>>>>>    if (SEQ_FileExists(lsRval+"\collate.cfg")=SEQIT_FILE) function_return lsRval
47372>>>>>    move (SEQ_FindFileAlongPath(API_OtherAttr_Value(OA_PATH),"collate.cfg")) to lsRval
47373>>>>>  end
47373>>>>>>
47373>>>>>  if liScAttr eq OA_COLLATE_SIZE move (SEQ_FileSize(SEQ_ComposeAbsoluteFileName(API_OtherAttr_Value(OA_COLLATE_PATH),"collate.cfg"))) to lsRval
47376>>>>>  if liScAttr eq OA_COLLATE_TIME move (SEQ_FileModTime(SEQ_ComposeAbsoluteFileName(API_OtherAttr_Value(OA_COLLATE_PATH),"collate.cfg"))) to lsRval
47379>>>>>    if liScAttr eq OA_RUNTIME_NAME    function_return (ToOem(SysConf(SYSCONF_RUNTIME_NAME)))
47382>>>>>    if liScAttr eq OA_UTC_TIME_OFFSET function_return (SysConf(SYSCONF_UTC_TIME_OFFSET))
47385>>>>>  if liScAttr eq OA_MAX_ARGUMENT_SIZE get_argument_size to lsRval
47388>>>>>  if liScAttr eq OA_CURRENT_USER_COUNT move -1 to lsRval //get_current_user_count to lsRval
47391>>>>>  if liScAttr eq OA_DFPRINTER get_environment "DFPRINTER" to lsRval
47394>>>>>  if liScAttr eq OA_LOCK_COUNT get_current_lockcount to lsRval
47397>>>>>
47397>>>>>
47397>>>>>  if liScAttr eq OA_FOLDER_FILELIST  get AppFolder APPFOLDER_FILELIST to lsRval
47400>>>>>  if liScAttr eq OA_FOLDER_PROGRAM   get AppFolder APPFOLDER_PROGRAM  to lsRval
47403>>>>>  if liScAttr eq OA_FOLDER_HTML      get AppFolder APPFOLDER_HTML     to lsRval
47406>>>>>  if liScAttr eq OA_FOLDER_VDF_ROOT  get AppFolder APPFOLDER_VDF_ROOT to lsRval
47409>>>>>  function_return lsRval
47410>>>>>end_function // API_OtherAttr_Value
47411>>>>>function OtherAttr_ValueDisplayName global integer liScAttr string lsValue returns string
47413>>>>>  if liScAttr eq OA_DIR_SEPARATOR     function_return lsValue
47416>>>>>  if liScAttr eq OA_TIMER_RESOLUTION  function_return lsValue
47419>>>>>  if liScAttr eq OA_OS_SHORT_NAME     function_return lsValue
47422>>>>>  if liScAttr eq OA_OS_MAJOR_REV      function_return lsValue
47425>>>>>  if liScAttr eq OA_OS_MINOR_REV      function_return lsValue
47428>>>>>  if liScAttr eq OA_OS_NAME           function_return lsValue
47431>>>>>  if liScAttr eq OA_MACHINE_NAME      function_return lsValue
47434>>>>>  if liScAttr eq OA_FILE_MASK         function_return lsValue
47437>>>>>  if liScAttr eq OA_DATAFLEX_REV      function_return lsValue
47440>>>>>  if liScAttr eq OA_SYSTEM_NAME       function_return lsValue
47443>>>>>  if liScAttr eq OA_PATH_SEPARATOR    function_return lsValue
47446>>>>>  if liScAttr eq OA_SERIAL_NUMBER     function_return lsValue
47449>>>>>  if liScAttr eq OA_REG_NAME          function_return lsValue
47452>>>>>  if liScAttr eq OA_WORKDIR           function_return lsValue
47455>>>>>  if liScAttr eq OA_PATH              function_return lsValue
47458>>>>>  if liScAttr eq OA_MAX_USERS         function_return lsValue
47461>>>>>  if liScAttr eq OA_DATE4_STATE       function_return (if(integer(lsValue),"True","False"))
47464>>>>>  if liScAttr eq OA_SYSDATE4_STATE    function_return (if(integer(lsValue),"True","False"))
47467>>>>>  if liScAttr eq OA_EPOCH_VALUE       function_return lsValue
47470>>>>>  if liScAttr eq OA_COLLATE_PATH      function_return lsValue
47473>>>>>  if liScAttr eq OA_COLLATE_SIZE      function_return (lsValue+" bytes")
47476>>>>>  if liScAttr eq OA_COLLATE_TIME      function_return (TS_ConvertToString(lsValue))
47479>>>>>  if liScAttr eq OA_RUNTIME_NAME      function_return lsValue
47482>>>>>  if liScAttr eq OA_UTC_TIME_OFFSET   function_return (TS_ExtractTime(lsValue))
47485>>>>>  if liScAttr eq OA_MAX_ARGUMENT_SIZE  function_return lsValue
47488>>>>>  if liScAttr eq OA_CURRENT_USER_COUNT function_return lsValue
47491>>>>>  if liScAttr eq OA_DFPRINTER         function_return lsValue
47494>>>>>  if liScAttr eq OA_LOCK_COUNT        function_return lsValue
47497>>>>>  if liScAttr eq OA_FOLDER_HTML       function_return lsValue
47500>>>>>  if liScAttr eq OA_FOLDER_FILELIST   function_return lsValue
47503>>>>>  if liScAttr eq OA_FOLDER_PROGRAM    function_return lsValue
47506>>>>>  if liScAttr eq OA_FOLDER_VDF_ROOT   function_return lsValue
47509>>>>>end_function
47510>>>>>function OtherAttr_DisplayName global integer liScAttr returns string
47512>>>>>  if liScAttr eq OA_DIR_SEPARATOR     function_return "Dir separator"
47515>>>>>  if liScAttr eq OA_TIMER_RESOLUTION  function_return "Timer resolution"
47518>>>>>  if liScAttr eq OA_OS_SHORT_NAME     function_return "OS short name"
47521>>>>>  if liScAttr eq OA_OS_MAJOR_REV      function_return "OS major rev."
47524>>>>>  if liScAttr eq OA_OS_MINOR_REV      function_return "OS minor rev."
47527>>>>>  if liScAttr eq OA_OS_NAME           function_return "OS name"
47530>>>>>  if liScAttr eq OA_MACHINE_NAME      function_return "Machine name"
47533>>>>>  if liScAttr eq OA_FILE_MASK         function_return "File mask"
47536>>>>>  if liScAttr eq OA_DATAFLEX_REV      function_return "DF revision"
47539>>>>>  if liScAttr eq OA_SYSTEM_NAME       function_return "System name"
47542>>>>>  if liScAttr eq OA_PATH_SEPARATOR    function_return "Path separator"
47545>>>>>  if liScAttr eq OA_SERIAL_NUMBER     function_return "Serial number"
47548>>>>>  if liScAttr eq OA_REG_NAME          function_return "Registration name"
47551>>>>>  if liScAttr eq OA_WORKDIR           function_return "Working dir."
47554>>>>>  if liScAttr eq OA_PATH              function_return "Search path"
47557>>>>>  if liScAttr eq OA_MAX_USERS         function_return "Max. users"
47560>>>>>  if liScAttr eq OA_DATE4_STATE       function_return "Date4 state"
47563>>>>>  if liScAttr eq OA_SYSDATE4_STATE    function_return "Sysdate4 state"
47566>>>>>  if liScAttr eq OA_EPOCH_VALUE       function_return "Epoch value"
47569>>>>>  if liScAttr eq OA_COLLATE_PATH      function_return "Collate file"
47572>>>>>  if liScAttr eq OA_COLLATE_SIZE      function_return "Collate size"
47575>>>>>  if liScAttr eq OA_COLLATE_TIME      function_return "Collate timestamp"
47578>>>>>  if liScAttr eq OA_RUNTIME_NAME      function_return "Module path & name"
47581>>>>>  if liScAttr eq OA_UTC_TIME_OFFSET   function_return "Seconds from Meridian"
47584>>>>>  if liScAttr eq OA_MAX_ARGUMENT_SIZE function_return "Max string size"
47587>>>>>  if liScAttr eq OA_CURRENT_USER_COUNT function_return "Current user count"
47590>>>>>  if liScAttr eq OA_DFPRINTER         function_return "Default printer (DF3.2)"
47593>>>>>  if liScAttr eq OA_LOCK_COUNT        function_return "Current lock count"
47596>>>>>  if liScAttr eq OA_FOLDER_HTML       function_return "HTML folder"
47599>>>>>  if liScAttr eq OA_FOLDER_FILELIST   function_return "Filelist folder"
47602>>>>>  if liScAttr eq OA_FOLDER_PROGRAM    function_return "Programs folder"
47605>>>>>  if liScAttr eq OA_FOLDER_VDF_ROOT   function_return "VDF root folder"
47608>>>>>end_function
47609>>>>>
47609>>>>>procedure API_OtherAttributes_CallBack global integer lhMsg integer lhObj
47611>>>>>  integer liAttr
47611>>>>>  for liAttr from 0 to (OA_MAX-1)
47617>>>>>>
47617>>>>>    send lhMsg to lhObj (OtherAttr_DisplayName(liAttr)) (OtherAttr_ValueDisplayName(liAttr,API_OtherAttr_Value(liAttr)))
47618>>>>>  loop
47619>>>>>>
47619>>>>>end_procedure
47620>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
47620>>>Use Files.nui    // Utilities for handling file related stuff
47620>>>Use DBMS.nui     // Basic DBMS functions
47620>>>Use Dates.nui    // Date manipulation for VDF and DF3.2
47620>>>Use Strings.nui  // String manipulation for VDF
47620>>>Use Mapper.nui   // Classes for (field) mapping
Including file: mapper.nui    (C:\Apps\VDFQuery\AppSrc\mapper.nui)
47620>>>>>// Use Mapper.nui   // Classes for (field) mapping
47620>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
47620>>>>>
47620>>>>>class cMapObject is a cArray
47621>>>>>  procedure construct_object integer liImage
47623>>>>>    forward send construct_object liImage
47625>>>>>    property string psTitle public ""
47626>>>>>  end_procedure
47627>>>>>  item_property_list
47627>>>>>    item_property integer piIdentifier.i
47627>>>>>    item_property string  psName.i
47627>>>>>    item_property string  psExtraInfo.i
47627>>>>>  end_item_property_list cMapObject
#REM 47662 DEFINE FUNCTION PSEXTRAINFO.I INTEGER LIROW RETURNS STRING
#REM 47666 DEFINE PROCEDURE SET PSEXTRAINFO.I INTEGER LIROW STRING VALUE
#REM 47670 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 47674 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
#REM 47678 DEFINE FUNCTION PIIDENTIFIER.I INTEGER LIROW RETURNS INTEGER
#REM 47682 DEFINE PROCEDURE SET PIIDENTIFIER.I INTEGER LIROW INTEGER VALUE
47687>>>>>  procedure DoAddItem integer liIdentifier string lsName string lsExtraInfo
47689>>>>>    integer liRow
47689>>>>>    get row_count to liRow
47690>>>>>    set piIdentifier.i liRow to liIdentifier
47691>>>>>    set psName.i   liRow to lsName
47692>>>>>    set psExtraInfo.i  liRow to lsExtraInfo
47693>>>>>  end_procedure
47694>>>>>  function iFindName.s string lsName returns integer
47696>>>>>    integer liMax liRow
47696>>>>>    get row_count to liMax
47697>>>>>    move (uppercase(lsName)) to lsName
47698>>>>>    decrement liMax
47699>>>>>    for liRow from 0 to liMax
47705>>>>>>
47705>>>>>      if (uppercase(psName.i(self,liRow))=lsName) function_return liRow
47708>>>>>    loop
47709>>>>>>
47709>>>>>    function_return -1
47710>>>>>  end_function
47711>>>>>  function iFindIdentifier.i integer liIdent returns integer
47713>>>>>    integer liMax liRow
47713>>>>>    get row_count to liMax
47714>>>>>    decrement liMax
47715>>>>>    for liRow from 0 to liMax
47721>>>>>>
47721>>>>>      if (piIdentifier.i(self,liRow)=liIdent) function_return liRow
47724>>>>>    loop
47725>>>>>>
47725>>>>>    function_return -1
47726>>>>>  end_function
47727>>>>>  procedure DoReset
47729>>>>>    send delete_data
47730>>>>>  end_procedure
47731>>>>>end_class // cMapObject
47732>>>>>
47732>>>>>class cMapper is a cArray
47733>>>>>  procedure construct_object integer liImage
47735>>>>>    forward send construct_object liImage
47737>>>>>    property integer piMapMode public 0 // 0=Random, 1=Sequential
47738>>>>>    property integer phObject1 public 0
47739>>>>>    property integer phObject2 public 0
47740>>>>>    property string  psTitle1  public ""
47741>>>>>    property string  psTitle2  public ""
47742>>>>>    property string  psTitle3  public ""
47743>>>>>    object oTmpArray is a cArray
47745>>>>>    end_object
47746>>>>>    object oPushStatus is a cArray
47748>>>>>    end_object
47749>>>>>    object oFastMap is a cArray
47751>>>>>    end_object
47752>>>>>    property integer pbFastMapState public DFFALSE
47753>>>>>  end_procedure
47754>>>>>  procedure DoPushStatus
47756>>>>>    send Clone_Array self (oPushStatus(self))
47757>>>>>  end_procedure
47758>>>>>  procedure DoPopStatus
47760>>>>>    send Clone_Array (oPushStatus(self)) self
47761>>>>>  end_procedure
47762>>>>>  item_property_list
47762>>>>>    item_property integer piItem1.i
47762>>>>>    item_property integer piItem2.i
47762>>>>>  end_item_property_list cMapper
#REM 47794 DEFINE FUNCTION PIITEM2.I INTEGER LIROW RETURNS INTEGER
#REM 47798 DEFINE PROCEDURE SET PIITEM2.I INTEGER LIROW INTEGER VALUE
#REM 47802 DEFINE FUNCTION PIITEM1.I INTEGER LIROW RETURNS INTEGER
#REM 47806 DEFINE PROCEDURE SET PIITEM1.I INTEGER LIROW INTEGER VALUE
47811>>>>>  function piIdent1.i integer liRow returns integer
47813>>>>>    function_return (piIdentifier.i(phObject1(self),piItem1.i(self,liRow)))
47814>>>>>  end_function
47815>>>>>  function piIdent2.i integer liRow returns integer
47817>>>>>    function_return (piIdentifier.i(phObject2(self),piItem2.i(self,liRow)))
47818>>>>>  end_function
47819>>>>>  procedure DoReset
47821>>>>>    send delete_data
47822>>>>>    set pbFastMapState to DFFALSE
47823>>>>>  end_procedure
47824>>>>>  function iFindItem2Row integer liItem2 returns integer
47826>>>>>    integer liMax liRow
47826>>>>>    get row_count to liMax
47827>>>>>    decrement liMax
47828>>>>>    for liRow from 0 to liMax
47834>>>>>>
47834>>>>>      if (piItem2.i(self,liRow)=liItem2) function_return liRow
47837>>>>>    loop
47838>>>>>>
47838>>>>>    function_return -1
47839>>>>>  end_function
47840>>>>>  procedure DoBuildFastMap
47842>>>>>    integer lhFastMap liRow liMax liIdent1 liIdent2
47842>>>>>    move (oFastMap(self)) to lhFastMap
47843>>>>>    send delete_data to lhFastMap
47844>>>>>    get row_count to liMax
47845>>>>>    decrement liMax
47846>>>>>    for liRow from 0 to liMax
47852>>>>>>
47852>>>>>      get piItem1.i liRow to liIdent1
47853>>>>>      get piItem2.i liRow to liIdent2
47854>>>>>      set value of lhFastMap liIdent1 to (liIdent2+1)
47855>>>>>    loop
47856>>>>>>
47856>>>>>    set pbFastMapState to DFTRUE
47857>>>>>  end_procedure
47858>>>>>  function iIdent1MapsTo.i integer liIdent1 returns integer
47860>>>>>    function_return (integer(value(oFastMap(self),liIdent1))-1)
47861>>>>>  end_function
47862>>>>>  procedure DoAddMap integer liIdent1 integer liIdent2
47864>>>>>    integer liRow liRow1 liRow2
47864>>>>>
47864>>>>>    get iFindIdentifier.i of (phObject1(self)) liIdent1 to liRow1
47865>>>>>    get iFindIdentifier.i of (phObject2(self)) liIdent2 to liRow2
47866>>>>>
47866>>>>>    get iFindItem2Row liRow2 to liRow
47867>>>>>    if liRow eq -1 get row_count to liRow
47870>>>>>
47870>>>>>    set piItem1.i liRow to liRow1
47871>>>>>    set piItem2.i liRow to liRow2
47872>>>>>    set pbFastMapState to DFFALSE
47873>>>>>  end_procedure
47874>>>>>  procedure DoClearMap integer liIdent2
47876>>>>>    integer liRow liRow2
47876>>>>>    get iFindIdentifier.i of (phObject2(self)) liIdent2 to liRow2
47877>>>>>    get iFindItem2Row liRow2 to liRow
47878>>>>>    if liRow ne -1 begin
47880>>>>>      send delete_row liRow
47881>>>>>      set pbFastMapState to DFFALSE
47882>>>>>    end
47882>>>>>>
47882>>>>>  end_procedure
47883>>>>>            // Puts a 1 in each position in oTmpArray that is mapped
47883>>>>>            procedure MarkMappedItems1
47885>>>>>              integer lhTmpArray liRow liMax
47885>>>>>              move (oTmpArray(self)) to lhTmpArray
47886>>>>>              send delete_data to lhTmpArray
47887>>>>>              get row_count to liMax
47888>>>>>              decrement liMax
47889>>>>>              for liRow from 0 to liMax
47895>>>>>>
47895>>>>>                set value of lhTmpArray item (piItem1.i(self,liRow)) to (piItem2.i(self,liRow)+1)
47896>>>>>              loop
47897>>>>>>
47897>>>>>            end_procedure
47898>>>>>            // Puts a 1 in each position in oTmpArray that is mapped
47898>>>>>            procedure MarkMappedItems2
47900>>>>>              integer lhTmpArray liRow liMax
47900>>>>>              move (oTmpArray(self)) to lhTmpArray
47901>>>>>              send delete_data to lhTmpArray
47902>>>>>              get row_count to liMax
47903>>>>>              decrement liMax
47904>>>>>              for liRow from 0 to liMax
47910>>>>>>
47910>>>>>                set value of lhTmpArray item (piItem2.i(self,liRow)) to (piItem1.i(self,liRow)+1)
47911>>>>>              loop
47912>>>>>>
47912>>>>>            end_procedure
47913>>>>>  procedure DoCallback_UnmappedItems1 integer liMsg integer lhObj
47915>>>>>    integer lhTmpArray liRow liMax lhObj1
47915>>>>>    send MarkMappedItems1
47916>>>>>    move (oTmpArray(self)) to lhTmpArray
47917>>>>>    get phObject1 to lhObj1
47918>>>>>    get row_count of lhObj1 to liMax
47919>>>>>    decrement liMax
47920>>>>>    for liRow from 0 to liMax
47926>>>>>>
47926>>>>>      ifnot (integer(value(lhTmpArray,liRow))) send liMsg to lhObj (piIdentifier.i(lhObj1,liRow)) (psName.i(lhObj1,liRow)) (psExtraInfo.i(lhObj1,liRow))
47929>>>>>    loop
47930>>>>>>
47930>>>>>  end_procedure
47931>>>>>  procedure DoCallback_UnmappedItems2 integer liMsg integer lhObj
47933>>>>>    integer lhTmpArray liRow liMax lhObj2
47933>>>>>    send MarkMappedItems2
47934>>>>>    move (oTmpArray(self)) to lhTmpArray
47935>>>>>    get phObject2 to lhObj2
47936>>>>>    get row_count of lhObj2 to liMax
47937>>>>>    decrement liMax
47938>>>>>    for liRow from 0 to liMax
47944>>>>>>
47944>>>>>      ifnot (integer(value(lhTmpArray,liRow))) send liMsg to lhObj (piIdentifier.i(lhObj2,liRow)) (psName.i(lhObj2,liRow)) (psExtraInfo.i(lhObj2,liRow))
47947>>>>>    loop
47948>>>>>>
47948>>>>>  end_procedure
47949>>>>>  procedure DoCallback_AllItems1 integer liMsg integer lhObj
47951>>>>>    integer lhTmpArray liRow liMax lhObj1 lhObj2 liMapRow
47951>>>>>    send MarkMappedItems1
47952>>>>>    move (oTmpArray(self)) to lhTmpArray
47953>>>>>    get phObject1 to lhObj1
47954>>>>>    get phObject2 to lhObj2
47955>>>>>    get row_count of lhObj1 to liMax
47956>>>>>    decrement liMax
47957>>>>>    for liRow from 0 to liMax
47963>>>>>>
47963>>>>>      get value of lhTmpArray liRow to liMapRow
47964>>>>>      ifnot liMapRow send liMsg to lhObj (piIdentifier.i(lhObj1,liRow)) (psName.i(lhObj1,liRow)) (psExtraInfo.i(lhObj1,liRow)) DFFALSE 0 "" ""
47967>>>>>      else begin
47968>>>>>        decrement liMapRow
47969>>>>>        send liMsg to lhObj (piIdentifier.i(lhObj1,liRow)) (psName.i(lhObj1,liRow)) (psExtraInfo.i(lhObj1,liRow)) DFTRUE (piIdentifier.i(lhObj2,liMapRow)) (psName.i(lhObj2,liMapRow)) (psExtraInfo.i(lhObj2,liMapRow))
47970>>>>>      end
47970>>>>>>
47970>>>>>    loop
47971>>>>>>
47971>>>>>  end_procedure
47972>>>>>  procedure DoCallback_AllItems2 integer liMsg integer lhObj
47974>>>>>    integer lhTmpArray liRow liMax lhObj1 lhObj2 liMapRow
47974>>>>>    send MarkMappedItems2
47975>>>>>    move (oTmpArray(self)) to lhTmpArray
47976>>>>>    get phObject1 to lhObj1
47977>>>>>    get phObject2 to lhObj2
47978>>>>>    get row_count of lhObj2 to liMax
47979>>>>>    decrement liMax
47980>>>>>    for liRow from 0 to liMax
47986>>>>>>
47986>>>>>      get value of lhTmpArray liRow to liMapRow
47987>>>>>      ifnot liMapRow send liMsg to lhObj (piIdentifier.i(lhObj2,liRow)) (psName.i(lhObj2,liRow)) (psExtraInfo.i(lhObj2,liRow)) DFFALSE 0 "" ""
47990>>>>>      else begin
47991>>>>>        decrement liMapRow
47992>>>>>        send liMsg to lhObj (piIdentifier.i(lhObj2,liRow)) (psName.i(lhObj2,liRow)) (psExtraInfo.i(lhObj2,liRow)) DFTRUE (piIdentifier.i(lhObj1,liMapRow)) (psName.i(lhObj1,liMapRow)) (psExtraInfo.i(lhObj1,liMapRow))
47993>>>>>      end
47993>>>>>>
47993>>>>>    loop
47994>>>>>>
47994>>>>>  end_procedure
47995>>>>>  procedure DoAutoMapName_Help integer liIdent2 string lsName string lsExtra
47997>>>>>    integer lhObj1 liIdent1 liRow1
47997>>>>>    get phObject1 to lhObj1
47998>>>>>    get iFindName.s of lhObj1 lsName to liRow1
47999>>>>>    if (liRow1=-1) begin
48001>>>>>      // If we didn't find a match, we try one more time by
48001>>>>>      // replacing _ characters for spaces:
48001>>>>>      move (replaces("_",lsName," ")) to lsName
48002>>>>>      get iFindName.s of lhObj1 lsName to liRow1
48003>>>>>    end
48003>>>>>>
48003>>>>>    if (liRow1>-1) begin
48005>>>>>      get piIdentifier.i of lhObj1 liRow1 to liIdent1
48006>>>>>      send DoAddMap liIdent1 liIdent2
48007>>>>>    end
48007>>>>>>
48007>>>>>  end_procedure
48008>>>>>  procedure DoAutoMapName
48010>>>>>    send DoCallback_UnmappedItems2 msg_DoAutoMapName_Help self
48011>>>>>  end_procedure
48012>>>>>end_class // cMapper
48013>>>
48013>>>define FILELIST_MAX_ENTRY   for 4095
48013>>>define t.fdx.attr_not_avail for "ATTRIBUTE NOT AVAILABLE"
48013>>>
48013>>>class cFdxMonitoredAttributes is a cArray
48014>>>  procedure construct_object integer liImage
48016>>>    forward send construct_object liImage
48018>>>    property integer piLowIndex public 65536
48019>>>    property integer piHighIndex public -1
48020>>>  end_procedure
48021>>>  item_property_list
48021>>>    item_property integer piMonitored.i // Is the attribute monitored?
48021>>>    item_property integer piAttrIndex.i // Translate to index used in the subset of attributes
48021>>>  end_item_property_list cFdxMonitoredAttributes
#REM 48053 DEFINE FUNCTION PIATTRINDEX.I INTEGER LIROW RETURNS INTEGER
#REM 48057 DEFINE PROCEDURE SET PIATTRINDEX.I INTEGER LIROW INTEGER VALUE
#REM 48061 DEFINE FUNCTION PIMONITORED.I INTEGER LIROW RETURNS INTEGER
#REM 48065 DEFINE PROCEDURE SET PIMONITORED.I INTEGER LIROW INTEGER VALUE
48070>>>  procedure add_attribute integer liAttr
48072>>>    set piMonitored.i liAttr to 1
48073>>>    if liAttr lt (piLowIndex(self))  set piLowIndex to liAttr
48076>>>    if liAttr gt (piHighIndex(self)) set piHighIndex to liAttr
48079>>>  end_procedure
48080>>>  procedure CalcAttrIndices // Sent by end_construct_object
48082>>>    integer liAttr liMin liMax liIndex
48082>>>    move 0 to liIndex
48083>>>    get piLowIndex  to liMin
48084>>>    get piHighIndex to liMax
48085>>>    for liAttr from liMin to liMax
48091>>>>
48091>>>      if (piMonitored.i(self,liAttr)) begin
48093>>>        set piAttrIndex.i liAttr to liIndex
48094>>>        increment liIndex
48095>>>      end
48095>>>>
48095>>>    loop
48096>>>>
48096>>>  end_procedure
48097>>>  procedure end_construct_object
48099>>>    forward send end_construct_object
48101>>>    send CalcAttrIndices
48102>>>  end_procedure
48103>>>end_class // cFdxMonitoredAttributes
48104>>>
48104>>>desktop_section // Make sure object is instantiated on desktop level
48109>>>  object oMonitoredGlobalAttributes is a cFdxMonitoredAttributes no_image
48111>>>    send add_attribute DF_ALL_FILES_TOUCHED
48112>>>    send add_attribute DF_API_DISABLED
48113>>>    send add_attribute DF_API_DISABLED_ERROR
48114>>>    send add_attribute DF_DATE_FORMAT
48115>>>    send add_attribute DF_DATE_SEPARATOR
48116>>>    send add_attribute DF_DECIMAL_SEPARATOR
48117>>>    send add_attribute DF_FILELIST_NAME
48118>>>    send add_attribute DF_HIGH_DATA_INTEGRITY
48119>>>    send add_attribute DF_LOCK_DELAY
48120>>>    send add_attribute DF_LOCK_TIMEOUT
48121>>>    send add_attribute DF_NUMBER_DRIVERS
48122>>>    send add_attribute DF_OPEN_PATH
48123>>>    send add_attribute DF_REREAD_REQUIRED
48124>>>    send add_attribute DF_STRICT_ATTRIBUTES
48125>>>    send add_attribute DF_THOUSANDS_SEPARATOR
48126>>>    send add_attribute DF_TRANSACTION_ABORT
48127>>>    send add_attribute DF_TRAN_COUNT
48128>>>  end_object // oMonitoredGlobalAttributes
48129>>>  object oMonitoredFileAttributes is a cFdxMonitoredAttributes no_image
48131>>>    send add_attribute DF_FILE_COMPRESSION
48132>>>    send add_attribute DF_FILE_DISPLAY_NAME  // Type: FILELIST
48133>>>    send add_attribute DF_FILE_DRIVER
48134>>>    send add_attribute DF_FILE_INTEGRITY_CHECK
48135>>>    send add_attribute DF_FILE_IS_SYSTEM_FILE
48136>>>    send add_attribute DF_FILE_LAST_INDEX_NUMBER
48137>>>    send add_attribute DF_FILE_LOCK_TYPE
48138>>>    send add_attribute DF_FILE_LOGICAL_NAME  // Type: FILELIST
48139>>>    send add_attribute DF_FILE_MAX_RECORDS
48140>>>    send add_attribute DF_FILE_MULTIUSER
48141>>>    send add_attribute DF_FILE_NUMBER_FIELDS
48142>>>    send add_attribute DF_FILE_RECORDS_USED
48143>>>    send add_attribute DF_FILE_RECORD_LENGTH
48144>>>    send add_attribute DF_FILE_RECORD_LENGTH_USED
48145>>>    send add_attribute DF_FILE_REUSE_DELETED
48146>>>    send add_attribute DF_FILE_REVISION
48147>>>    send add_attribute DF_FILE_ROOT_NAME     // Type: FILELIST
48148>>>    send add_attribute DF_FILE_TRANSACTION
48149>>>    send add_attribute DF_FILE_PHYSICAL_NAME
48150>>>    send add_attribute DF_FILE_RECORD_IDENTITY
48151>>>    send add_attribute DF_FILE_TYPE
48152>>>  end_object // oMonitoredFileAttributes
48153>>>end_desktop_section
48158>>>
48158>>>enumeration_list // File list read modes
48158>>>  define FDX_ALL_OPEN  // All files currently open
48158>>>  define FDX_ALL_FILES // All files
48158>>>  define FDX_FROM_SET  // From pre-specified set of files (not implemented)
48158>>>end_enumeration_list
48158>>>
48158>>>enumeration_list // Data origin modes
48158>>>  define FDX_EMPTY          // The FDX object is empty
48158>>>  define FDX_REAL_WORLD     // Definitions have been read from current filelist
48158>>>  define FDX_READ_FROM_FILE // Definitions have been read from a sequential file
48158>>>end_enumeration_list
48158>>>
48158>>>enumeration_list // Relation origins for cFdxFileRelations
48158>>>  define FDX_RELORIG_ALL
48158>>>  define FDX_RELORIG_GENERIC
48158>>>end_enumeration_list
48158>>>
48158>>>//> An object of this class is inside a FDX object, but it is really just an
48158>>>//> appendix to the FDX object. It only holds redundant information about
48158>>>//> relations between file tables and is therefore not written to the .FDX
48158>>>//> files.
48158>>>class cFdxFileRelations is a cArray
48159>>>  procedure construct_object integer liImage
48161>>>    forward send construct_object liImage
48163>>>    property integer piArray_Filled public 0
48164>>>    property string  psTmpString    public ""
48165>>>  end_procedure
48166>>>  item_property_list
48166>>>    item_property integer piType.i
48166>>>    item_property integer piFileFrom.i
48166>>>    item_property integer piFieldFrom.i
48166>>>    item_property integer piFileTo.i
48166>>>    item_property integer piFieldTo.i
48166>>>  end_item_property_list cFdxFileRelations
#REM 48207 DEFINE FUNCTION PIFIELDTO.I INTEGER LIROW RETURNS INTEGER
#REM 48211 DEFINE PROCEDURE SET PIFIELDTO.I INTEGER LIROW INTEGER VALUE
#REM 48215 DEFINE FUNCTION PIFILETO.I INTEGER LIROW RETURNS INTEGER
#REM 48219 DEFINE PROCEDURE SET PIFILETO.I INTEGER LIROW INTEGER VALUE
#REM 48223 DEFINE FUNCTION PIFIELDFROM.I INTEGER LIROW RETURNS INTEGER
#REM 48227 DEFINE PROCEDURE SET PIFIELDFROM.I INTEGER LIROW INTEGER VALUE
#REM 48231 DEFINE FUNCTION PIFILEFROM.I INTEGER LIROW RETURNS INTEGER
#REM 48235 DEFINE PROCEDURE SET PIFILEFROM.I INTEGER LIROW INTEGER VALUE
#REM 48239 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 48243 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
48248>>>  //>
48248>>>  procedure aux_callback.iiiii integer liMsg integer liObj integer liSelectType integer liSelectToFile integer liSelectToField
48250>>>    integer liMax liRow liOK
48250>>>    ifnot (piArray_Filled(self)) send fill_array
48253>>>    get row_count to liMax
48254>>>    for liRow from 0 to (liMax-1)
48260>>>>
48260>>>      move 1 to liOK
48261>>>      if liSelectType if (piType.i(self,liRow)) ne liSelectType move 0 to liOK
48266>>>      if liOK if (piFileTo.i(self,liRow))  ne liSelectToFile move 0 to liOK
48271>>>      if liOK if (piFieldTo.i(self,liRow)) ne liSelectToField move 0 to liOK
48276>>>      if liOK send liMsg to liObj (piType.i(self,liRow)) (piFileFrom.i(self,liRow)) (piFieldFrom.i(self,liRow)) (piFileTo.i(self,liRow)) (piFieldTo.i(self,liRow))
48279>>>    loop
48280>>>>
48280>>>  end_procedure
48281>>>  procedure callback.iiiii integer liMsg integer liObj integer liSelectType integer liSelectFrom integer liSelectTo
48283>>>    integer liMax liRow liOK
48283>>>    ifnot (piArray_Filled(self)) send fill_array
48286>>>    get row_count to liMax
48287>>>    for liRow from 0 to (liMax-1)
48293>>>>
48293>>>      move 1 to liOK
48294>>>      if liSelectType if (piType.i(self,liRow)) ne liSelectType move 0 to liOK
48299>>>      if (liOK and liSelectFrom) if (piFileFrom.i(self,liRow)) ne liSelectFrom move 0 to liOK
48304>>>      if (liOK and liSelectTo) if (piFileTo.i(self,liRow)) ne liSelectTo move 0 to liOK
48309>>>      if liOK send liMsg to liObj (piType.i(self,liRow)) (piFileFrom.i(self,liRow)) (piFieldFrom.i(self,liRow)) (piFileTo.i(self,liRow)) (piFieldTo.i(self,liRow))
48312>>>    loop
48313>>>>
48313>>>  end_procedure
48314>>>  procedure add_relation.iiiii integer liType integer liFile1 integer liField1 integer liFile2 integer liField2
48316>>>    integer liRow
48316>>>    get row_count to liRow
48317>>>    set piType.i      liRow to liType
48318>>>    set piFileFrom.i  liRow to liFile1
48319>>>    set piFieldFrom.i liRow to liField1
48320>>>    set piFileTo.i    liRow to liFile2
48321>>>    set piFieldTo.i   liRow to liField2
48322>>>  end_procedure
48323>>>  procedure reset
48325>>>    send delete_data
48326>>>    set piArray_Filled to false
48327>>>  end_procedure
48328>>>  procedure fill_array
48330>>>    integer liFile liField liToFile liToField liMax liParent liAvailable
48330>>>    send reset
48331>>>    move (parent(self)) to liParent // Save time delegation
48332>>>    move 0 to liFile
48333>>>    repeat
48333>>>>
48333>>>      get AttrValue_FLSTNAV of liParent DF_FILE_NEXT_USED liFile to liFile
48334>>>      if liFile begin
48336>>>        get iCanOpen.i liFile to liAvailable
48337>>>        if liAvailable begin
48339>>>          get AttrValue_FILE of liParent DF_FILE_NUMBER_FIELDS liFile to liMax
48340>>>          for liField from 1 to liMax
48346>>>>
48346>>>            get AttrValue_FIELD of liParent DF_FIELD_RELATED_FILE  liFile liField to liToFile
48347>>>            if liToFile begin
48349>>>              get AttrValue_FIELD of liParent DF_FIELD_RELATED_FIELD liFile liField to liToField
48350>>>              send add_relation.iiiii FDX_RELORIG_GENERIC liFile liField liToFile liToField
48351>>>            end
48351>>>>
48351>>>          loop
48352>>>>
48352>>>        end
48352>>>>
48352>>>      end
48352>>>>
48352>>>    until (not(liFile))
48354>>>    set piArray_Filled to true
48355>>>  end_procedure
48356>>>  procedure ParentFilesHelp integer liType integer liFile integer liFld integer liRFile integer liRFld
48358>>>    string lsStr
48358>>>    get psTmpString to lsStr
48359>>>    ifnot (IsIntegerPresent(lsStr,liRFile)) begin
48361>>>      move (AddIntegerToString(lsStr,liRFile)) to lsStr
48362>>>      set psTmpString to lsStr
48363>>>      send callback.iiiii msg_ParentFilesHelp self FDX_RELORIG_ALL liRFile 0
48364>>>    end
48364>>>>
48364>>>  end_procedure
48365>>>  function sParentFiles.i integer liFile returns string
48367>>>    set psTmpString to ""
48368>>>    send callback.iiiii msg_ParentFilesHelp self FDX_RELORIG_ALL liFile 0
48369>>>    function_return (psTmpString(self))
48370>>>  end_function
48371>>>  procedure ChildFilesHelp integer liType integer liFile integer liFld integer liRFile integer liRFld
48373>>>    string lsStr
48373>>>    get psTmpString to lsStr
48374>>>    ifnot (IsIntegerPresent(lsStr,liFile)) begin
48376>>>      move (AddIntegerToString(lsStr,liFile)) to lsStr
48377>>>      set psTmpString to lsStr
48378>>>      send callback.iiiii msg_ChildFilesHelp self FDX_RELORIG_ALL 0 liFile
48379>>>    end
48379>>>>
48379>>>  end_procedure
48380>>>  function sChildFiles.i integer liFile returns string
48382>>>    set psTmpString to ""
48383>>>    send callback.iiiii msg_ChildFilesHelp self FDX_RELORIG_ALL 0 liFile
48384>>>    function_return (psTmpString(self))
48385>>>  end_function
48386>>>end_class // cFdxFileRelations
48387>>>
48387>>>class cFdxFileDef_IndexAttr is a cArray
48388>>>  item_property_list
48388>>>    item_property integer piType.i
48388>>>    item_property integer piSegments.i
48388>>>    item_property integer piBuffers.i
48388>>>    item_property integer piKey_Length.i
48388>>>    item_property integer piLevels.i
48388>>>    item_property string  psFields.i
48388>>>    item_property string  psUppercase.i
48388>>>    item_property string  psDirection.i
48388>>>  end_item_property_list cFdxFileDef_IndexAttr // Repeat class name here!
#REM 48438 DEFINE FUNCTION PSDIRECTION.I INTEGER LIROW RETURNS STRING
#REM 48442 DEFINE PROCEDURE SET PSDIRECTION.I INTEGER LIROW STRING VALUE
#REM 48446 DEFINE FUNCTION PSUPPERCASE.I INTEGER LIROW RETURNS STRING
#REM 48450 DEFINE PROCEDURE SET PSUPPERCASE.I INTEGER LIROW STRING VALUE
#REM 48454 DEFINE FUNCTION PSFIELDS.I INTEGER LIROW RETURNS STRING
#REM 48458 DEFINE PROCEDURE SET PSFIELDS.I INTEGER LIROW STRING VALUE
#REM 48462 DEFINE FUNCTION PILEVELS.I INTEGER LIROW RETURNS INTEGER
#REM 48466 DEFINE PROCEDURE SET PILEVELS.I INTEGER LIROW INTEGER VALUE
#REM 48470 DEFINE FUNCTION PIKEY_LENGTH.I INTEGER LIROW RETURNS INTEGER
#REM 48474 DEFINE PROCEDURE SET PIKEY_LENGTH.I INTEGER LIROW INTEGER VALUE
#REM 48478 DEFINE FUNCTION PIBUFFERS.I INTEGER LIROW RETURNS INTEGER
#REM 48482 DEFINE PROCEDURE SET PIBUFFERS.I INTEGER LIROW INTEGER VALUE
#REM 48486 DEFINE FUNCTION PISEGMENTS.I INTEGER LIROW RETURNS INTEGER
#REM 48490 DEFINE PROCEDURE SET PISEGMENTS.I INTEGER LIROW INTEGER VALUE
#REM 48494 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 48498 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
48503>>>  procedure reset
48505>>>    send delete_data
48506>>>  end_procedure
48507>>>end_class // cFdxFileDef_IndexAttr
48508>>>class cFdxFileDef_FileAttr is a cArray
48509>>>  procedure add_attr_value string lsValue
48511>>>    set value item (item_count(self)) to lsValue
48512>>>  end_procedure
48513>>>  procedure reset
48515>>>    send delete_data
48516>>>  end_procedure
48517>>>end_class // cFdxFileDef_FileAttr
48518>>>
48518>>>class cFdxFileDef_DataAndConfigurationFilesHelp is a cArray
48519>>>  procedure construct_object integer liImage
48521>>>    forward send construct_object liImage
48523>>>    property integer pbFileNotFound public DFTRUE
48524>>>    property string  psFileName     public ""
48525>>>    property string  psFilePath     public ""
48526>>>    property number  pnFileTime     public 0
48527>>>    property number  pnFileSize     public 0
48528>>>  end_procedure
48529>>>  procedure Reset
48531>>>    send delete_data
48532>>>    set pbFileNotFound to DFTRUE
48533>>>    set psFileName to ""
48534>>>    set psFilePath to ""
48535>>>    set pnFileTime to 0
48536>>>    set pnFileSize to 0
48537>>>  end_procedure
48538>>>  procedure Read_FileFromDisk string lsFileName
48540>>>    integer liChannel lbSeqEof
48540>>>    string lsLine
48540>>>    send Reset
48541>>>    if (SEQ_FileExists(lsFileName)=SEQIT_FILE) begin
48543>>>      set pbFileNotFound to DFFALSE
48544>>>      set psFileName to lsFileName
48545>>>      set psFilePath to (SEQ_FindFileAlongDFPath(lsFileName))
48546>>>      set pnFileTime to (SEQ_FileModTime(lsFileName))
48547>>>      set pnFileSize to (SEQ_FileSize(lsFileName))
48548>>>      get SEQ_DirectInput lsFileName to liChannel
48549>>>      if (liChannel>=0) begin
48551>>>        repeat
48551>>>>
48551>>>          readln channel liChannel lsLine
48553>>>          move (seqeof) to lbSeqEof
48554>>>          ifnot lbSeqEof set value item (item_count(self)) to lsLine
48557>>>        until lbSeqEof
48559>>>        send SEQ_CloseInput liChannel
48560>>>      end
48560>>>>
48560>>>    end
48560>>>>
48560>>>  end_procedure
48561>>>  procedure Seq_Read integer liChannel
48563>>>    set pbFileNotFound to (SEQ_ReadLn(liChannel))
48564>>>    set psFileName     to (SEQ_ReadLn(liChannel))
48565>>>    set psFilePath     to (SEQ_ReadLn(liChannel))
48566>>>    set pnFileTime     to (SEQ_ReadLn(liChannel))
48567>>>    set pnFileSize     to (SEQ_ReadLn(liChannel))
48568>>>    send SEQ_ReadArrayItems liChannel self
48569>>>  end_procedure
48570>>>  procedure Seq_Write integer liChannel
48572>>>    writeln channel liChannel (pbFileNotFound(self))
48575>>>    writeln (psFileName(self))
48577>>>    writeln (psFilePath(self))
48579>>>    writeln (pnFileTime(self))
48581>>>    writeln (pnFileSize(self))
48583>>>    send SEQ_WriteArrayItems liChannel self
48584>>>  end_procedure
48585>>>end_class // cFdxFileDef_DataAndConfigurationFilesHelp
48586>>>
48586>>>class cFdxFileDef_DataAndConfigurationFiles is a cArray
48587>>>  procedure construct_object integer liImage
48589>>>    forward send construct_object liImage
48591>>>    property integer pbDataIncluded   public DFFALSE
48592>>>    property integer pbDataByteOffset public 0
48593>>>    object oTagFile is a cFdxFileDef_DataAndConfigurationFilesHelp
48595>>>    end_object
48596>>>    object oFdFile is a cFdxFileDef_DataAndConfigurationFilesHelp
48598>>>    end_object
48599>>>    object oIntFile is a cFdxFileDef_DataAndConfigurationFilesHelp
48601>>>    end_object
48602>>>    object oFutureUse is a cFdxFileDef_DataAndConfigurationFilesHelp
48604>>>    end_object
48605>>>    property number priv.pnOffset public 0
48606>>>  end_procedure
48607>>>  procedure Reset
48609>>>    send Reset to (oTagFile(self))
48610>>>    send Reset to (oFdFile(self))
48611>>>    send Reset to (oIntFile(self))
48612>>>    send Reset to (oFutureUse(self))
48613>>>  end_procedure
48614>>>  procedure Read_AuxillaryFiles string lsRoot
48616>>>    send Read_FileFromDisk to (oTagFile(self))   (lsRoot+".tag")
48617>>>    send Read_FileFromDisk to (oFdFile(self))    (lsRoot+".fd")
48618>>>    send Read_FileFromDisk to (oIntFile(self))   (lsRoot+".int")
48619>>>//  send Read_FileFromDisk to (oFutureUse(self)) (lsRoot+".")
48619>>>  end_procedure
48620>>>  procedure Seq_Read integer liChannel
48622>>>    set pbDataIncluded   to (Seq_ReadLn(liChannel))
48623>>>    set pbDataByteOffset to (Seq_ReadLn(liChannel))
48624>>>    send Seq_Read to (oTagFile(self)) liChannel
48625>>>    send Seq_Read to (oFdFile(self)) liChannel
48626>>>    send Seq_Read to (oIntFile(self)) liChannel
48627>>>    send Seq_Read to (oFutureUse(self)) liChannel
48628>>>  end_procedure
48629>>>  procedure Seq_Write integer liChannel
48631>>>    number lnChannelPos
48631>>>    writeln channel liChannel (pbDataIncluded(self))
48634>>>    get_channel_position liChannel to lnChannelPos
48635>>>>
48635>>>    set priv.pnOffset to lnChannelPos
48636>>>    writeln (repeat(" ",20))
48638>>>    send Seq_Write to (oTagFile(self)) liChannel
48639>>>    send Seq_Write to (oFdFile(self)) liChannel
48640>>>    send Seq_Write to (oIntFile(self)) liChannel
48641>>>    send Seq_Write to (oFutureUse(self)) liChannel
48642>>>  end_procedure
48643>>>  procedure Write_DataOffset integer liChannel number lnOffset
48645>>>    number lnChannelPos
48645>>>    get_channel_position liChannel to lnChannelPos
48646>>>>
48646>>>    set_channel_position liChannel to (priv.pnOffset(self))
48647>>>>
48647>>>    write channel liChannel lnOffset
48649>>>    set_channel_position liChannel to lnChannelPos
48650>>>>
48650>>>  end_procedure
48651>>>end_class // cFdxFileDef_DataAndConfigurationFiles
48652>>>
48652>>>
48652>>>class cFdxFileDef is a cArray
48653>>>  procedure construct_object integer liImage
48655>>>    forward send construct_object liImage
48657>>>    property integer piMainFile public 0
48658>>>    object oFileAttr is a cFdxFileDef_FileAttr NO_IMAGE
48660>>>    end_object
48661>>>    object oIndexAttr is a cFdxFileDef_IndexAttr NO_IMAGE
48663>>>    end_object
48664>>>    object oDatAndConf is a cFdxFileDef_DataAndConfigurationFiles NO_IMAGE
48666>>>    end_object
48667>>>    property string  psDatPath            public "" // Where is the dat file?
48668>>>    property number  pnTimeStamp          public 0  // How old is it?
48669>>>    // Property piReadDuringRestruct should always be false. Except when
48669>>>    // a cFdxFileDef object is used to read a file definition during a
48669>>>    // restructure operation.
48669>>>    property integer piReadDuringRestruct public DFFALSE  //
48670>>>    property integer piDataOrigin   public FDX_EMPTY // 0=empty 1=Read from current 2=Read from file
48671>>>  end_procedure
48672>>>  function iCanOpen.i integer liFile returns integer
48674>>>    integer liDelegate liRval
48674>>>    if liFile eq (piMainFile(self)) function_return 1
48677>>>    get iFdxIsEncapsulated to liDelegate
48678>>>    if liDelegate delegate get iCanOpen.i liFile to liRval
48682>>>    else move 0 to liRval
48684>>>    function_return liRval
48685>>>  end_function
48686>>>
48686>>>  function AttrValue_IsEmpty integer liFile returns integer
48688>>>    function_return 0
48689>>>  end_function
48690>>>
48690>>>  item_property_list // Field parameters
48690>>>    item_property string  psName.i        // DF_FIELD_NAME
48690>>>    item_property integer piNumber.i      // DF_FIELD_NUMBER
48690>>>    item_property integer piOldNumber.i   // DF_FIELD_OLD_NUMBER
48690>>>    item_property integer piType.i        // DF_FIELD_TYPE
48690>>>    item_property integer piLen.i         // DF_FIELD_LENGTH
48690>>>    item_property integer piNative_len.i  // DF_FIELD_NATIVE_LENGTH
48690>>>    item_property integer piPrec.i        // DF_FIELD_PRECISION
48690>>>    item_property integer piRfile.i       // DF_FIELD_RELATED_FILE
48690>>>    item_property integer piRfld.i        // DF_FIELD_RELATED_FIELD
48690>>>    item_property integer piIdx.i         // DF_FIELD_INDEX
48690>>>    item_property integer piOffset.i      // DF_FIELD_OFFSET
48690>>>  end_item_property_list cFdxFileDef
#REM 48749 DEFINE FUNCTION PIOFFSET.I INTEGER LIROW RETURNS INTEGER
#REM 48753 DEFINE PROCEDURE SET PIOFFSET.I INTEGER LIROW INTEGER VALUE
#REM 48757 DEFINE FUNCTION PIIDX.I INTEGER LIROW RETURNS INTEGER
#REM 48761 DEFINE PROCEDURE SET PIIDX.I INTEGER LIROW INTEGER VALUE
#REM 48765 DEFINE FUNCTION PIRFLD.I INTEGER LIROW RETURNS INTEGER
#REM 48769 DEFINE PROCEDURE SET PIRFLD.I INTEGER LIROW INTEGER VALUE
#REM 48773 DEFINE FUNCTION PIRFILE.I INTEGER LIROW RETURNS INTEGER
#REM 48777 DEFINE PROCEDURE SET PIRFILE.I INTEGER LIROW INTEGER VALUE
#REM 48781 DEFINE FUNCTION PIPREC.I INTEGER LIROW RETURNS INTEGER
#REM 48785 DEFINE PROCEDURE SET PIPREC.I INTEGER LIROW INTEGER VALUE
#REM 48789 DEFINE FUNCTION PINATIVE_LEN.I INTEGER LIROW RETURNS INTEGER
#REM 48793 DEFINE PROCEDURE SET PINATIVE_LEN.I INTEGER LIROW INTEGER VALUE
#REM 48797 DEFINE FUNCTION PILEN.I INTEGER LIROW RETURNS INTEGER
#REM 48801 DEFINE PROCEDURE SET PILEN.I INTEGER LIROW INTEGER VALUE
#REM 48805 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 48809 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
#REM 48813 DEFINE FUNCTION PIOLDNUMBER.I INTEGER LIROW RETURNS INTEGER
#REM 48817 DEFINE PROCEDURE SET PIOLDNUMBER.I INTEGER LIROW INTEGER VALUE
#REM 48821 DEFINE FUNCTION PINUMBER.I INTEGER LIROW RETURNS INTEGER
#REM 48825 DEFINE PROCEDURE SET PINUMBER.I INTEGER LIROW INTEGER VALUE
#REM 48829 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 48833 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
48838>>>
48838>>>  procedure Reset
48840>>>    send delete_data
48841>>>    send delete_data to (oFileAttr(self))
48842>>>    send delete_data to (oIndexAttr(self))
48843>>>    send Reset       to (oDatAndConf(self))
48844>>>    set psDatPath   to ""
48845>>>    set pnTimeStamp to 0
48846>>>    set piDataOrigin to FDX_EMPTY
48847>>>  end_procedure
48848>>>
48848>>>  procedure DoTransferToMapableObject integer lhMapObject
48850>>>    integer liMax liRow
48850>>>    send DoReset to lhMapObject
48851>>>    get row_count to liMax
48852>>>    decrement liMax
48853>>>    for liRow from 1 to liMax
48859>>>>
48859>>>      if (piType.i(self,liRow)<>DF_OVERLAP) ;        send DoAddItem to lhMapObject liRow (psName.i(self,liRow)) ""
48862>>>    loop
48863>>>>
48863>>>  end_procedure
48864>>>
48864>>>  procedure Seq_Write integer liChannel
48866>>>    writeln channel liChannel "*** File definition: **********************"
48869>>>    writeln channel liChannel (piMainFile(self))
48872>>>    writeln channel liChannel "--- Field data ----------------------------"
48875>>>    send SEQ_WriteArrayItems liChannel self
48876>>>    writeln channel liChannel "--- File data -----------------------------"
48879>>>    send SEQ_WriteArrayItems liChannel (oFileAttr(self))
48880>>>    writeln channel liChannel "--- Index data ----------------------------"
48883>>>    send SEQ_WriteArrayItems liChannel (oIndexAttr(self))
48884>>>    writeln channel liChannel "-------------------------------------------"
48887>>>    writeln channel liChannel (psDatPath(self))
48890>>>    writeln channel liChannel (pnTimeStamp(self))
48893>>>//  send Seq_Write to (oDatAndConf(self)) liChannel
48893>>>    writeln channel liChannel "*** End of file definition ****************"
48896>>>  end_procedure
48897>>>
48897>>>  //> Read definition from sequential file
48897>>>  procedure Seq_Read integer liChannel
48899>>>    integer liMainFile
48899>>>    string lsThrowAway
48899>>>    set piDataOrigin to FDX_READ_FROM_FILE
48900>>>    readln channel liChannel lsThrowAway
48902>>>    readln liMainFile
48903>>>    set piMainFile to liMainFile
48904>>>    readln lsThrowAway
48905>>>    send SEQ_ReadArrayItems liChannel self
48906>>>    readln lsThrowAway
48907>>>    send SEQ_ReadArrayItems liChannel (oFileAttr(self))
48908>>>    readln lsThrowAway
48909>>>    send SEQ_ReadArrayItems liChannel (oIndexAttr(self))
48910>>>    readln lsThrowAway
48911>>>    set psDatPath   to (SEQ_ReadLn(liChannel))
48912>>>    set pnTimeStamp to (SEQ_ReadLn(liChannel))
48913>>>//  send Seq_Read to (oDatAndConf(self)) liChannel
48913>>>    readln lsThrowAway
48914>>>  end_procedure
48915>>>
48915>>>  procedure Read_File_Attr integer liFile // Get monitored file(list) attributes from record buffer
48917>>>    integer liMin liMax liAttr liReadDuringRestruct
48917>>>    integer liFileAttrObj liMonitoredFileAttributesObj
48917>>>    string lsValue
48917>>>    move (oFileAttr(self)) to liFileAttrObj
48918>>>    move (oMonitoredFileAttributes(self)) to liMonitoredFileAttributesObj
48919>>>    get piReadDuringRestruct to liReadDuringRestruct
48920>>>    send reset to liFileAttrObj
48921>>>    get piLowIndex  of liMonitoredFileAttributesObj to liMin
48922>>>    get piHighIndex of liMonitoredFileAttributesObj to liMax
48923>>>    for liAttr from liMin to liMax
48929>>>>
48929>>>      if (piMonitored.i(liMonitoredFileAttributesObj,liAttr)) begin // If it's monitored
48931>>>        if (not(liReadDuringRestruct) or API_AttrType(liAttr)<>ATTRTYPE_FILELIST) ;          get_attribute liAttr of liFile to lsValue
48936>>>        else move "" to lsValue
48938>>>        send add_attr_value to liFileAttrObj lsValue
48939>>>      end
48939>>>>
48939>>>    loop
48940>>>>
48940>>>  end_procedure
48941>>>  procedure Read_Field_Attr integer liFile // Get field attributes from record buffer
48943>>>    integer liField liMax liRestruct
48943>>>    get piReadDuringRestruct to liRestruct
48944>>>    get_attribute DF_FILE_NUMBER_FIELDS of liFile to liMax
48947>>>    for liField from 1 to liMax
48953>>>>
48953>>>      set psName.i       liField to (API_AttrValue_FIELD(DF_FIELD_NAME,liFile,liField))
48954>>>      set piNumber.i     liField to (API_AttrValue_FIELD(DF_FIELD_NUMBER,liFile,liField))
48955>>>      if liRestruct set piOldNumber.i  liField to (API_AttrValue_FIELD(DF_FIELD_OLD_NUMBER,liFile,liField))
48958>>>      else set piOldNumber.i  liField to liField
48960>>>      set piType.i       liField to (API_AttrValue_FIELD(DF_FIELD_TYPE,liFile,liField))
48961>>>      set piLen.i        liField to (API_AttrValue_FIELD(DF_FIELD_LENGTH,liFile,liField))
48962>>>      set piNative_Len.i liField to (API_AttrValue_FIELD(DF_FIELD_NATIVE_LENGTH,liFile,liField))
48963>>>      set piPrec.i       liField to (API_AttrValue_FIELD(DF_FIELD_PRECISION,liFile,liField))
48964>>>      set piRfile.i      liField to (API_AttrValue_FIELD(DF_FIELD_RELATED_FILE,liFile,liField))
48965>>>      set piRfld.i       liField to (API_AttrValue_FIELD(DF_FIELD_RELATED_FIELD,liFile,liField))
48966>>>      set piIdx.i        liField to (API_AttrValue_FIELD(DF_FIELD_INDEX,liFile,liField))
48967>>>      set piOffset.i     liField to (API_AttrValue_FIELD(DF_FIELD_OFFSET,liFile,liField))
48968>>>    loop
48969>>>>
48969>>>  end_procedure
48970>>>  procedure Read_Index_Attr integer liFile
48972>>>    integer liIndexAttrObj liSegment liMax liIndex liRestruct
48972>>>    string lsFields lsUppercases lsDirections
48972>>>    move (oIndexAttr(self)) to liIndexAttrObj
48973>>>    send reset to liIndexAttrObj
48974>>>    get piReadDuringRestruct to liRestruct
48975>>>    for liIndex from 1 to 15
48981>>>>
48981>>>      get_attribute DF_INDEX_NUMBER_SEGMENTS of liFile liIndex to liMax
48984>>>      if liMax begin // If there's an index at all
48986>>>        set piType.i       of liIndexAttrObj liIndex to (API_AttrValue_INDEX(DF_INDEX_TYPE,liFile,liIndex))
48987>>>        set piSegments.i   of liIndexAttrObj liIndex to liMax
48988>>>        ifnot liRestruct set piBuffers.i of liIndexAttrObj liIndex to (API_AttrValue_INDEX(DF_INDEX_NUMBER_BUFFERS,liFile,liIndex))
48991>>>        set piKey_Length.i of liIndexAttrObj liIndex to (API_AttrValue_INDEX(DF_INDEX_KEY_LENGTH,liFile,liIndex))
48992>>>        set piLevels.i     of liIndexAttrObj liIndex to (API_AttrValue_INDEX(DF_INDEX_LEVELS,liFile,liIndex))
48993>>>        move "" to lsFields
48994>>>        move "" to lsUppercases
48995>>>        move "" to lsDirections
48996>>>        for liSegment from 1 to liMax
49002>>>>
49002>>>          move (lsFields    +pad(API_AttrValue_IDXSEG(DF_INDEX_SEGMENT_FIELD    ,liFile,liIndex,liSegment),4)) to lsFields
49003>>>          move (lsUppercases+pad(API_AttrValue_IDXSEG(DF_INDEX_SEGMENT_CASE     ,liFile,liIndex,liSegment),4)) to lsUppercases
49004>>>          move (lsDirections+pad(API_AttrValue_IDXSEG(DF_INDEX_SEGMENT_DIRECTION,liFile,liIndex,liSegment),4)) to lsDirections
49005>>>        loop
49006>>>>
49006>>>        set psFields.i    of liIndexAttrObj liIndex to lsFields
49007>>>        set psUppercase.i of liIndexAttrObj liIndex to lsUppercases
49008>>>        set psDirection.i of liIndexAttrObj liIndex to lsDirections
49009>>>      end
49009>>>>
49009>>>    loop
49010>>>>
49010>>>  end_procedure
49011>>>
49011>>>  //> Read definition from table
49011>>>  procedure Read_File_Definition.i integer liFile
49013>>>    string lsDriver lsExt lsPhysFileName lsPath
49013>>>    set piDataOrigin to FDX_REAL_WORLD
49014>>>    set piMainFile to liFile
49015>>>    send Read_File_Attr liFile
49016>>>    send Read_Field_Attr liFile
49017>>>    send Read_Index_Attr liFile
49018>>>    get AttrValue_FILE DF_FILE_DRIVER liFile to lsDriver
49019>>>    if lsDriver eq "DATAFLEX" move ".DAT" to lsExt
49022>>>    else move ".INT" to lsExt
49024>>>    get AttrValue_FILE DF_FILE_PHYSICAL_NAME liFile to lsPhysFileName
49025>>>    ifnot "." in (SEQ_RemovePathFromFileName(lsPhysFileName)) move (lsPhysFileName+lsExt) to lsPhysFileName
49028>>>
49028>>>//  send Read_AuxillaryFiles to (oDatAndConf(self)) (StringLeftBut(lsPhysFileName,4))
49028>>>
49028>>>    if (SEQ_ExtractPathFromFileName(lsPhysFileName)) eq "" begin
49030>>>      move (SEQ_FindFileAlongDFPath(lsPhysFileName)) to lsPath
49031>>>      move (SEQ_ComposeAbsoluteFileName(lsPath,lsPhysFileName)) to lsPhysFileName
49032>>>    end
49032>>>>
49032>>>    set psDatPath   to lsPhysFileName
49033>>>    set pnTimeStamp to (SEQ_FileModTime(lsPhysFileName))
49034>>>  end_procedure
49035>>>
49035>>>  // *************************************************************************
49035>>>  // *** These attribute value functions are used by the cFdx class ******
49035>>>  //> Call back for every entry with a rootname
49035>>>  function sAttrValueFile.i integer liAttr returns string
49037>>>    integer liMonitoredFileAttributesObj
49037>>>    move (oMonitoredFileAttributes(self)) to liMonitoredFileAttributesObj
49038>>>    if (piMonitored.i(liMonitoredFileAttributesObj,liAttr)) begin
49040>>>      get piAttrIndex.i of liMonitoredFileAttributesObj liAttr to liAttr
49041>>>      function_return (value(oFileAttr(self),liAttr))
49042>>>    end
49042>>>>
49042>>>    function_return t.fdx.attr_not_avail
49043>>>  end_function
49044>>>  function sAttrValueField.ii integer liAttr integer liField returns string
49046>>>    if liAttr eq DF_FIELD_NAME          function_return (psName.i(self,liField))
49049>>>    if liAttr eq DF_FIELD_NUMBER        function_return (piNumber.i(self,liField))
49052>>>    if liAttr eq DF_FIELD_OLD_NUMBER    function_return (piOldNumber.i(self,liField))
49055>>>    if liAttr eq DF_FIELD_TYPE          function_return (piType.i(self,liField))
49058>>>    if liAttr eq DF_FIELD_LENGTH        function_return (piLen.i(self,liField))
49061>>>    if liAttr eq DF_FIELD_NATIVE_LENGTH function_return (piNative_Len.i(self,liField))
49064>>>    if liAttr eq DF_FIELD_PRECISION     function_return (piPrec.i(self,liField))
49067>>>    if liAttr eq DF_FIELD_RELATED_FILE  function_return (piRfile.i(self,liField))
49070>>>    if liAttr eq DF_FIELD_RELATED_FIELD function_return (piRfld.i(self,liField))
49073>>>    if liAttr eq DF_FIELD_INDEX         function_return (piIdx.i(self,liField))
49076>>>    if liAttr eq DF_FIELD_OFFSET        function_return (piOffset.i(self,liField))
49079>>>    function_return t.fdx.attr_not_avail
49080>>>  end_function
49081>>>  function sAttrValueIndex.ii integer liAttr integer liIndex returns string
49083>>>    integer liObj
49083>>>    move (oIndexAttr(self)) to liObj
49084>>>    if liAttr eq DF_INDEX_NUMBER_SEGMENTS function_return (piSegments.i(liObj,liIndex))
49087>>>    if liAttr eq DF_INDEX_NUMBER_BUFFERS  function_return (piBuffers.i(liObj,liIndex))
49090>>>    if liAttr eq DF_INDEX_TYPE            function_return (piType.i(liObj,liIndex))
49093>>>    if liAttr eq DF_INDEX_LEVELS          function_return (piLevels.i(liObj,liIndex))
49096>>>    if liAttr eq DF_INDEX_KEY_LENGTH      function_return (piKey_Length.i(liObj,liIndex))
49099>>>    function_return t.fdx.attr_not_avail
49100>>>  end_function
49101>>>  function sAttrValueIndexSegment.iii integer liAttr integer liIndex integer liSegment returns string
49103>>>    integer liObj
49103>>>    string lsStr
49103>>>    move (oIndexAttr(self)) to liObj
49104>>>    if liAttr eq DF_INDEX_SEGMENT_FIELD     move (psFields.i(liObj,liIndex)) to lsStr
49107>>>    if liAttr eq DF_INDEX_SEGMENT_CASE      move (psUppercase.i(liObj,liIndex)) to lsStr
49110>>>    if liAttr eq DF_INDEX_SEGMENT_DIRECTION move (psDirection.i(liObj,liIndex)) to lsStr
49113>>>    function_return (mid(lsStr,4,liSegment-1*4+1))
49114>>>  end_function
49115>>>  function sAttrValueSpecial1.iii integer liAttr integer liField1 integer liField2 returns string
49117>>>    integer liStart1 liEnd1 liStart2 liEnd2 liFile
49117>>>    get piMainFile to liFile // The liFile parameter is ignored whe called from in here.
49118>>>    get AttrValue_FIELD DF_FIELD_OFFSET liFile liField1 to liStart1
49119>>>    get AttrValue_FIELD DF_FIELD_OFFSET liFile liField2 to liStart2
49120>>>    get AttrValue_FIELD DF_FIELD_NATIVE_LENGTH liFile liField1 to liEnd1 // overload
49121>>>    get AttrValue_FIELD DF_FIELD_NATIVE_LENGTH liFile liField2 to liEnd2 // overload
49122>>>    move (liStart1+liEnd1-1) to liEnd1
49123>>>    move (liStart2+liEnd2-1) to liEnd2
49124>>>    //send obs  (string(liStart1)+"<="+string(liEnd2)+"and"+string(liStart2)+"<="+string(liEnd1)) (liStart1<=liEnd2 and liStart2<=liEnd1)
49124>>>    function_return (liStart1<=liEnd2 and liStart2<=liEnd1)
49125>>>  end_function
49126>>>
49126>>>  function AttrValue_FILE integer liAttr integer liFile returns string
49128>>>    integer liDelegate
49128>>>    string lsRval
49128>>>    if liFile eq (piMainFile(self)) function_return (sAttrValueFile.i(self,liAttr))
49131>>>    get iFdxIsEncapsulated to liDelegate
49132>>>    if liDelegate delegate get AttrValue_FILE liAttr liFile to lsRval
49136>>>    else move "Not available" to lsRval
49138>>>    function_return lsRval
49139>>>  end_function
49140>>>
49140>>>  procedure set AttrValue_FILE integer liAttr integer liFile string lsValue
49142>>>    integer liMonitoredFileAttributesObj
49142>>>    if (liFile=piMainFile(self)) begin
49144>>>      move (oMonitoredFileAttributes(self)) to liMonitoredFileAttributesObj
49145>>>      if (piMonitored.i(liMonitoredFileAttributesObj,liAttr)) begin
49147>>>        get piAttrIndex.i of liMonitoredFileAttributesObj liAttr to liAttr
49148>>>        set value of (oFileAttr(self)) item liAttr to lsValue
49149>>>      end
49149>>>>
49149>>>    end
49149>>>>
49149>>>    else error 666 "Illegal file number"
49151>>>  end_procedure
49152>>>
49152>>>  function AttrValue_FILELIST integer liAttr integer liFile returns string
49154>>>    integer liDelegate
49154>>>    string lsRval
49154>>>    get iFdxIsEncapsulated to liDelegate
49155>>>    if liDelegate delegate get AttrValue_FILELIST liAttr liFile to lsRval
49159>>>    else begin
49160>>>      move t.fdx.attr_not_avail to lsRval
49161>>>      if liAttr eq DF_FILE_ROOT_NAME    move ("FILE"+string(liFile)) to lsRval
49164>>>      if liAttr eq DF_FILE_LOGICAL_NAME move ("DFFILE"+string(liFile)) to lsRval
49167>>>      if liAttr eq DF_FILE_DISPLAY_NAME move ("File"+string(liFile)) to lsRval
49170>>>      move (rtrim(lsRval)) to lsRval
49171>>>    end
49171>>>>
49171>>>    function_return lsRval
49172>>>  end_function
49173>>>
49173>>>  function AttrValue_FIELD integer liAttr integer liFile integer liField returns string
49175>>>    integer liDelegate
49175>>>    string lsRval
49175>>>    if liFile eq (piMainFile(self)) function_return (sAttrValueField.ii(self,liAttr,liField))
49178>>>    get iFdxIsEncapsulated to liDelegate
49179>>>    if liDelegate delegate get AttrValue_FIELD liAttr liFile liField to lsRval
49183>>>    else begin
49184>>>      move "Not available" to lsRval
49185>>>      if liAttr eq DF_FIELD_NAME move ("FIELD"+string(liField)) to lsRval
49188>>>    end
49188>>>>
49188>>>    function_return lsRval
49189>>>  end_function
49190>>>
49190>>>  procedure set AttrValue_FIELD integer liAttr integer liFile integer liField string lsValue
49192>>>    if (liFile=piMainFile(self)) begin
49194>>>      if liAttr eq DF_FIELD_NAME          set psName.i       liField to lsValue
49197>>>      if liAttr eq DF_FIELD_NUMBER        set piNumber.i     liField to lsValue
49200>>>      if liAttr eq DF_FIELD_OLD_NUMBER    set piOldNumber.i  liField to lsValue
49203>>>      if liAttr eq DF_FIELD_TYPE          set piType.i       liField to lsValue
49206>>>      if liAttr eq DF_FIELD_LENGTH        set piLen.i        liField to lsValue
49209>>>      if liAttr eq DF_FIELD_NATIVE_LENGTH set piNative_Len.i liField to lsValue
49212>>>      if liAttr eq DF_FIELD_PRECISION     set piPrec.i       liField to lsValue
49215>>>      if liAttr eq DF_FIELD_RELATED_FILE  set piRfile.i      liField to lsValue
49218>>>      if liAttr eq DF_FIELD_RELATED_FIELD set piRfld.i       liField to lsValue
49221>>>      if liAttr eq DF_FIELD_INDEX         set piIdx.i        liField to lsValue
49224>>>      if liAttr eq DF_FIELD_OFFSET        set piOffset.i     liField to lsValue
49227>>>    end
49227>>>>
49227>>>    else error 666 "Illegal file number"
49229>>>  end_procedure
49230>>>
49230>>>  function AttrValue_INDEX integer liAttr integer liFile integer liIndex returns string
49232>>>    integer liDelegate
49232>>>    string lsRval
49232>>>    if liFile eq (piMainFile(self)) function_return (sAttrValueIndex.ii(self,liAttr,liIndex))
49235>>>    get iFdxIsEncapsulated to liDelegate
49236>>>    if liDelegate delegate get AttrValue_INDEX liAttr liFile liIndex to lsRval
49240>>>    else move "Not available" to lsRval
49242>>>    function_return lsRval
49243>>>  end_function
49244>>>
49244>>>  procedure set AttrValue_INDEX integer liAttr integer liFile integer liIndex string lsValue
49246>>>    integer liObj
49246>>>    if (liFile=piMainFile(self)) begin
49248>>>      move (oIndexAttr(self)) to liObj
49249>>>      if liAttr eq DF_INDEX_NUMBER_SEGMENTS set piSegments.i   of liObj liIndex to lsValue
49252>>>      if liAttr eq DF_INDEX_NUMBER_BUFFERS  set piBuffers.i    of liObj liIndex to lsValue
49255>>>      if liAttr eq DF_INDEX_TYPE            set piType.i       of liObj liIndex to lsValue
49258>>>      if liAttr eq DF_INDEX_LEVELS          set piLevels.i     of liObj liIndex to lsValue
49261>>>      if liAttr eq DF_INDEX_KEY_LENGTH      set piKey_Length.i of liObj liIndex to lsValue
49264>>>    end
49264>>>>
49264>>>    else error 666 "Illegal file number"
49266>>>  end_procedure
49267>>>
49267>>>  function AttrValue_IDXSEG integer liAttr integer liFile integer liIndex integer liSegment returns string
49269>>>    integer liDelegate
49269>>>    string lsRval
49269>>>    if liFile eq (piMainFile(self)) function_return (sAttrValueIndexSegment.iii(self,liAttr,liIndex,liSegment))
49272>>>    get iFdxIsEncapsulated to liDelegate
49273>>>    if liDelegate delegate get AttrValue_IDXSEG liAttr liFile liIndex liSegment to lsRval
49277>>>    else move "Not available" to lsRval
49279>>>    function_return lsRval
49280>>>  end_function
49281>>>
49281>>>  procedure set AttrValue_IDXSEG integer liAttr integer liFile integer liIndex integer liSegment string lsValue
49283>>>    integer liObj
49283>>>    string lsStr
49283>>>    if (liFile=piMainFile(self)) begin
49285>>>      move (oIndexAttr(self)) to liObj
49286>>>      if liAttr eq DF_INDEX_SEGMENT_FIELD     get psFields.i    of liObj liIndex to lsStr
49289>>>      if liAttr eq DF_INDEX_SEGMENT_CASE      get psUppercase.i of liObj liIndex to lsStr
49292>>>      if liAttr eq DF_INDEX_SEGMENT_DIRECTION get psDirection.i of liObj liIndex to lsStr
49295>>>
49295>>>      move (overstrike(pad(trim(lsValue),4),lsStr,liSegment-1*4+1)) to lsStr
49296>>>
49296>>>      if liAttr eq DF_INDEX_SEGMENT_FIELD     set psFields.i    of liObj liIndex to lsStr
49299>>>      if liAttr eq DF_INDEX_SEGMENT_CASE      set psUppercase.i of liObj liIndex to lsStr
49302>>>      if liAttr eq DF_INDEX_SEGMENT_DIRECTION set psDirection.i of liObj liIndex to lsStr
49305>>>    end
49305>>>>
49305>>>    else error 666 "Illegal file number"
49307>>>  end_procedure
49308>>>
49308>>>  function AttrValue_SPECIAL1 integer liAttr integer liFile integer liField1 integer liField2 returns string
49310>>>    integer liDelegate
49310>>>    string lsRval
49310>>>    if liFile eq (piMainFile(self)) function_return (sAttrValueSpecial1.iii(self,liAttr,liField1,liField2))
49313>>>    get iFdxIsEncapsulated to liDelegate
49314>>>    if liDelegate delegate get AttrValue_SPECIAL1 liAttr liFile liField1 liField2 to lsRval
49318>>>    else move "Not available" to lsRval
49320>>>    function_return lsRval
49321>>>  end_function
49322>>>  function sDatPath.i integer liFile returns string
49324>>>    if liFile eq (piMainFile(self)) function_return (psDatPath(self))
49327>>>    function_return ""
49328>>>  end_function
49329>>>  function nTimeStamp.i integer liFile returns number
49331>>>    if liFile eq (piMainFile(self)) function_return (pnTimeStamp(self))
49334>>>    function_return 0
49335>>>  end_function
49336>>>
49336>>>  function psFileName returns string
49338>>>    integer lbDelegate
49338>>>    string lsRval
49338>>>    get iFdxIsEncapsulated to lbDelegate
49339>>>    if lbDelegate delegate get psFileName to lsRval
49343>>>    else move "" to lsRval
49345>>>    function_return lsRval
49346>>>  end_function
49347>>>
49347>>>  function AttrValue_IsEmpty integer liFile returns integer
49349>>>    string lsStr
49349>>>    get psRootName.i liFile to lsStr
49350>>>    function_return (lsStr="")
49351>>>  end_function
49352>>>
49352>>>
49352>>>  function iFdxIsEncapsulated returns integer
49354>>>    integer liRval
49354>>>    delegate get iFdxIsEncapsulated to liRval
49356>>>    function_return liRval
49357>>>  end_function
49358>>>end_class // cFdxFileDef
49359>>>
49359>>>define FDX_FILE_VERSION for "FDX2.0"
49359>>>
49359>>>class cFdx is a cArray
49360>>>  procedure construct_object integer liImage
49362>>>    forward send construct_object liImage
49364>>>    property integer piFileDefClass public U_cFdxFileDef  // Class ID for FileDefObject
49365>>>    property string  psVersion      public FDX_FILE_VERSION
49366>>>    property integer piReadMode     public -1 // All files, open files or custom selection?
49367>>>    property string  psIdTag        public "" // For future use
49368>>>    property number  pnTS_Time      public 0  // Date of snapshot (TS format)
49369>>>    property string  psTitle        public ""
49370>>>    property string  psFileName     public "Un-known"
49371>>>    property integer piDataOrigin   public FDX_EMPTY // 0=empty 1=Read from current 2=Read from file
49372>>>
49372>>>    property integer pbIncludeFDTAGINT public DFFALSE
49373>>>
49373>>>    object oGlobalAttributes is a cArray no_image
49375>>>    end_object
49376>>>    object oOtherAttributes is a cArray no_image
49378>>>    end_object
49379>>>    object oFdxFileRelations is a cFdxFileRelations no_image
49381>>>    end_object
49382>>>    property integer piReadResult   public 0 // Was last Seq_Read operation successful?
49383>>>  end_procedure
49384>>>
49384>>>  function sOriginAsText returns string
49386>>>    if (piDataOrigin(self)) eq FDX_EMPTY function_return "Empty"
49389>>>    if (piDataOrigin(self)) eq FDX_REAL_WORLD function_return "Current"
49392>>>    function_return (SEQ_RemovePathFromFileName(psFileName(self)))
49393>>>  end_function
49394>>>
49394>>>  item_property_list
49394>>>    item_property string  psRootName.i
49394>>>    item_property string  psDFName.i
49394>>>    item_property string  psDisplayName.i
49394>>>    item_property integer piFileDefObject.i
49394>>>    item_property integer piAuxArray.i
49394>>>    item_property integer aux_value
49394>>>  end_item_property_list cFdx
#REM 49438 DEFINE FUNCTION AUX_VALUE INTEGER LIROW RETURNS INTEGER
#REM 49442 DEFINE PROCEDURE SET AUX_VALUE INTEGER LIROW INTEGER VALUE
#REM 49446 DEFINE FUNCTION PIAUXARRAY.I INTEGER LIROW RETURNS INTEGER
#REM 49450 DEFINE PROCEDURE SET PIAUXARRAY.I INTEGER LIROW INTEGER VALUE
#REM 49454 DEFINE FUNCTION PIFILEDEFOBJECT.I INTEGER LIROW RETURNS INTEGER
#REM 49458 DEFINE PROCEDURE SET PIFILEDEFOBJECT.I INTEGER LIROW INTEGER VALUE
#REM 49462 DEFINE FUNCTION PSDISPLAYNAME.I INTEGER LIROW RETURNS STRING
#REM 49466 DEFINE PROCEDURE SET PSDISPLAYNAME.I INTEGER LIROW STRING VALUE
#REM 49470 DEFINE FUNCTION PSDFNAME.I INTEGER LIROW RETURNS STRING
#REM 49474 DEFINE PROCEDURE SET PSDFNAME.I INTEGER LIROW STRING VALUE
#REM 49478 DEFINE FUNCTION PSROOTNAME.I INTEGER LIROW RETURNS STRING
#REM 49482 DEFINE PROCEDURE SET PSROOTNAME.I INTEGER LIROW STRING VALUE
49487>>>
49487>>>  function iCanOpen.i integer liFile returns integer
49489>>>    function_return (piFileDefObject.i(self,liFile))
49490>>>  end_function
49491>>>
49491>>>  procedure AttrType_Callback integer liAttrType integer liMsg integer liObj
49493>>>    integer liMin liMax liSelf liMonAttrObj liAttr
49493>>>    move (oMonitoredGlobalAttributes(self)) to liMonAttrObj
49494>>>    move self to liSelf
49495>>>    if liAttrType eq ATTRTYPE_GLOBAL begin
49497>>>      get piLowIndex of liMonAttrObj to liMin
49498>>>      get piHighIndex of liMonAttrObj to liMax
49499>>>      for liAttr from liMin to liMax
49505>>>>
49505>>>        if (piMonitored.i(liMonAttrObj,liAttr)) send liMsg to liObj liSelf liAttr
49508>>>      loop
49509>>>>
49509>>>    end
49509>>>>
49509>>>  end_procedure
49510>>>
49510>>>  procedure Wait_SetText string lsStr
49512>>>  end_procedure
49513>>>  procedure Wait_SetText2 string lsStr
49515>>>  end_procedure
49516>>>
49516>>>  procedure Reset
49518>>>    integer liMax liRow liObj
49518>>>    get row_count to liMax
49519>>>    for liRow from 0 to (liMax-1)
49525>>>>
49525>>>      get piFileDefObject.i liRow to liObj
49526>>>      if liObj send request_destroy_object to liObj
49529>>>      get piAuxArray.i liRow to liObj
49530>>>      if liObj send request_destroy_object to liObj
49533>>>    loop
49534>>>>
49534>>>    send delete_data
49535>>>    send delete_data to (oGlobalAttributes(self))
49536>>>    send delete_data to (oOtherAttributes(self))
49537>>>    send reset to (oFdxFileRelations(self))
49538>>>    set piDataOrigin to FDX_EMPTY
49539>>>    set psTitle    to ""
49540>>>    set psFileName to ""
49541>>>  end_procedure
49542>>>
49542>>>  procedure Callback_RelationsToField integer liMsg integer liObj integer liSelectType integer liSelectToFile integer liSelectToField
49544>>>    send aux_callback.iiiii to (oFdxFileRelations(self)) liMsg liObj liSelectType liSelectToFile liSelectToField
49545>>>  end_procedure
49546>>>  procedure Callback_Relations integer liMsg integer liObj integer liSelectType integer liSelectFrom integer liSelectTo
49548>>>    send callback.iiiii to (oFdxFileRelations(self)) liMsg liObj liSelectType liSelectFrom liSelectTo
49549>>>  end_procedure
49550>>>  function sChildFiles.i integer liFile returns string
49552>>>    function_return (sChildFiles.i(oFdxFileRelations(self),liFile))
49553>>>  end_function
49554>>>  function sParentFiles.i integer liFile returns string
49556>>>    function_return (sParentFiles.i(oFdxFileRelations(self),liFile))
49557>>>  end_function
49558>>>
49558>>>  function iCreate_FileDef_Object returns integer
49560>>>    integer liRval liCurrentObject liClass
49560>>>    get piFileDefClass to liClass
49561>>>    if liClass begin
49563>>>      name liClass U_aps_class
49563>>>      move self to liCurrentObject
49564>>>      object dynamo_object is a aps_class
49566>>>        move self to liRval
49567>>>      end_object
49568>>>      move liCurrentObject to self
49569>>>    end
49569>>>>
49569>>>    else move 0 to liRval
49571>>>    function_return liRval
49572>>>  end_function
49573>>>
49573>>>  procedure OnFileAdded integer liFile
49575>>>    send Wait_SetText2 (psDisplayName.i(self,liFile))
49576>>>  end_procedure
49577>>>
49577>>>  procedure Read_Global_Attributes
49579>>>    integer liGlobalAttributesObj liAttr liMin liMax liMonGlAttrObj
49579>>>    move (oMonitoredGlobalAttributes(self)) to liMonGlAttrObj
49580>>>    move (oGlobalAttributes(self)) to liGlobalAttributesObj
49581>>>    get piLowIndex  of liMonGlAttrObj to liMin
49582>>>    get piHighIndex of liMonGlAttrObj to liMax
49583>>>    for liAttr from liMin to liMax
49589>>>>
49589>>>      if (piMonitored.i(liMonGlAttrObj,liAttr)) set value of liGlobalAttributesObj item (piAttrIndex.i(liMonGlAttrObj,liAttr)) to (API_AttrValue_GLOBAL(liAttr))
49592>>>    loop
49593>>>>
49593>>>  end_procedure
49594>>>  procedure Read_Other_Attributes
49596>>>    integer liAttr liMax liOtherAttributesObj
49596>>>    move (oOtherAttributes(self)) to liOtherAttributesObj
49597>>>    for liAttr from 0 to (OA_MAX-1) // OA_MAX is a constant (API_ATTR.UTL)
49603>>>>
49603>>>      set value of liOtherAttributesObj item liAttr to (API_OtherAttr_Value(liAttr))
49604>>>    loop
49605>>>>
49605>>>  end_procedure
49606>>>  procedure Read_Driver_Information // We currently don't do drivers
49608>>>  end_procedure
49609>>>
49609>>>  procedure Read_File_Definition integer liFile
49611>>>    integer liOpen liWasOpen liObj
49611>>>    set psRootName.i    liFile to (DBMS_Rootname(liFile))
49612>>>    set psDFName.i      liFile to (DBMS_DFName(liFile))
49613>>>    set psDisplayName.i liFile to (DBMS_DisplayName(liFile))
49614>>>    get_attribute DF_FILE_OPENED of liFile to liWasOpen
49617>>>    ifnot liWasOpen move (DBMS_OpenFile(liFile,DF_SHARE,0)) to liOpen
49620>>>    else move 1 to liOpen
49622>>>    if liOpen begin
49624>>>      get iCreate_FileDef_Object to liObj
49625>>>      send Read_File_Definition.i to liObj liFile
49626>>>      set piFileDefObject.i liFile to liObj
49627>>>    end
49627>>>>
49627>>>    send OnFileAdded liFile
49628>>>    if (liOpen and not(liWasOpen)) close liFile
49631>>>  end_procedure
49632>>>
49632>>>  //> This is used for rereading a definition after
49632>>>  //> it has been restructured
49632>>>  procedure Read_File_Definition_Again integer liFile
49634>>>    integer liObj
49634>>>    get piFileDefObject.i liFile to liObj
49635>>>    if liObj begin
49637>>>      send request_destroy_object to liObj
49638>>>      set piFileDefObject.i liFile to 0
49639>>>    end
49639>>>>
49639>>>    send Read_File_Definition liFile
49640>>>  end_procedure
49641>>>
49641>>>  procedure Read_File_RootName_Again string lsRootName
49643>>>    integer liFile
49643>>>    move (uppercase(lsRootName)) to lsRootName
49644>>>    move 0 to liFile
49645>>>    repeat
49645>>>>
49645>>>      get_attribute DF_FILE_NEXT_USED of liFile to liFile
49648>>>      if liFile begin
49650>>>        if lsRootName eq (uppercase(API_AttrValue_FILELIST(DF_FILE_ROOT_NAME,liFile))) send Read_File_Definition_Again liFile
49653>>>      end
49653>>>>
49653>>>    until liFile eq 0
49655>>>  end_procedure
49656>>>
49656>>>  procedure Read_Current_Filelist integer liReadMode // FDX_ALL_OPEN FDX_ALL_FILES FDX_FROM_SET
49658>>>    integer liFile
49658>>>    send Wait_SetText "Reading current table definitions"
49659>>>    send Reset
49660>>>    set psVersion  to FDX_FILE_VERSION
49661>>>    set piReadMode to liReadMode
49662>>>    set psIdTag    to "Un-tagged"
49663>>>    set pnTS_Time  to (TS_SysTime())
49664>>>    set psTitle    to ""
49665>>>    send Read_Global_Attributes
49666>>>    send Read_Other_Attributes
49667>>>    if liReadMode eq FDX_ALL_OPEN begin
49669>>>      move 0 to liFile
49670>>>      repeat
49670>>>>
49670>>>        get_attribute DF_FILE_NEXT_OPENED of liFile to liFile
49673>>>        if liFile send Read_File_Definition liFile
49676>>>      until liFile eq 0
49678>>>    end
49678>>>>
49678>>>    if liReadMode eq FDX_ALL_FILES begin
49680>>>      move 0 to liFile
49681>>>      repeat
49681>>>>
49681>>>        get_attribute DF_FILE_NEXT_USED of liFile to liFile
49684>>>        if liFile send Read_File_Definition liFile
49687>>>      until liFile eq 0
49689>>>    end
49689>>>>
49689>>>    send Read_Driver_Information // We wait until here because at this point drivers have been loaded in order to open the files that were included
49690>>>    set piDataOrigin to FDX_REAL_WORLD
49691>>>  end_procedure
49692>>>
49692>>>  // *************************************************************************
49692>>>  // *** Sequential read/write methods ***************************************
49692>>>  procedure OnFileRead integer liChannel integer liFile
49694>>>  end_procedure
49695>>>  procedure OnFileWrite integer liChannel integer liFile
49697>>>  end_procedure
49698>>>
49698>>>  procedure Seq_Read_AuxArray integer liChannel integer liFile
49700>>>    integer liDo liObj
49700>>>    readln channel liChannel liDo
49702>>>    if liDo begin
49704>>>      object oArray is a cArray
49706>>>        move self to liObj
49707>>>      end_object
49708>>>      send SEQ_ReadArrayItems liChannel liObj
49709>>>      set piAuxArray.i liFile to liObj
49710>>>    end
49710>>>>
49710>>>  end_procedure
49711>>>
49711>>>  procedure Seq_Read_FileDefObject integer liChannel integer liFile
49713>>>    integer liDo liObj
49713>>>    readln channel liChannel liDo
49715>>>    if liDo begin
49717>>>      get iCreate_FileDef_Object to liObj
49718>>>      if liObj begin
49720>>>        send Seq_Read to liObj liChannel liFile
49721>>>        set piFileDefObject.i liFile to liObj
49722>>>      end
49722>>>>
49722>>>      else error 666 "File definition class has not been specified in cFDX_Container object"
49724>>>    end
49724>>>>
49724>>>  end_procedure
49725>>>
49725>>>  procedure Seq_Read integer liChannel
49727>>>    integer liSeqEof liFile
49727>>>    string lsDisplayName lsDFName lsRootName lsTemp
49727>>>    send Wait_SetText "Importing table definitions"
49728>>>    send Wait_SetText2 ""
49729>>>    move (SEQ_ReadLn(liChannel)) to lsTemp
49730>>>    set piReadResult to 0
49731>>>    if lsTemp eq (psVersion(self)) begin
49733>>>      send reset
49734>>>      set piReadMode to (SEQ_ReadLn(liChannel))
49735>>>      set psIdTag    to (SEQ_ReadLn(liChannel))
49736>>>      set pnTS_Time  to (SEQ_ReadLn(liChannel))
49737>>>      set psTitle    to (SEQ_ReadLn(liChannel))
49738>>>      send SEQ_ReadArrayItems liChannel (oGlobalAttributes(self))
49739>>>      send SEQ_ReadArrayItems liChannel (oOtherAttributes(self))
49740>>>      move 0 to liSeqEof
49741>>>      repeat
49741>>>>
49741>>>        readln channel liChannel lsTemp
49743>>>        if lsTemp eq "END.OF.FILELIST.CFG" move 1 to liSeqEof
49746>>>        else begin
49747>>>          move lsTemp to liFile
49748>>>          readln lsRootName
49749>>>          readln lsDFName
49750>>>          readln lsDisplayName
49751>>>        end
49751>>>>
49751>>>        if (seqeof) move 1 to liSeqEof
49754>>>        ifnot liSeqEof begin
49756>>>          set psRootName.i    liFile to lsRootName
49757>>>          set psDFName.i      liFile to lsDFName
49758>>>          set psDisplayName.i liFile to lsDisplayName
49759>>>          send Seq_Read_AuxArray liChannel liFile
49760>>>          send Seq_Read_FileDefObject liChannel liFile
49761>>>          send OnFileRead liChannel liFile
49762>>>          send OnFileAdded liFile
49763>>>        end
49763>>>>
49763>>>      until liSeqEof
49765>>>      set piDataOrigin to FDX_READ_FROM_FILE
49766>>>      set piReadResult to 1
49767>>>    end
49767>>>>
49767>>>    else error 736 "Incompatible FDX file!"
49769>>>//    else send obs "Incompatible FDX file!" "Reading abandoned." ("Version in file: "+lsTemp) ("This program reads only: "+psVersion(self))
49769>>>  end_procedure
49770>>>
49770>>>  procedure Seq_Write_AuxArray integer liChannel integer liFile
49772>>>    integer liObj
49772>>>    get piAuxArray.i liFile to liObj
49773>>>    if liObj begin
49775>>>      writeln channel liChannel 1
49778>>>      send SEQ_WriteArrayItems liChannel liObj
49779>>>    end
49779>>>>
49779>>>    else writeln channel liChannel 0
49783>>>  end_procedure
49784>>>
49784>>>  procedure Seq_Write_FileDefObject integer liChannel integer liFile
49786>>>    integer liObj
49786>>>    get piFileDefObject.i liFile to liObj
49787>>>    if liObj begin
49789>>>      writeln channel liChannel 1
49792>>>      send Seq_Write to liObj liChannel liFile
49793>>>    end
49793>>>>
49793>>>    else writeln channel liChannel 0
49797>>>  end_procedure
49798>>>
49798>>>  procedure Seq_Write integer liChannel
49800>>>    integer liFile liMax
49800>>>    string lsRootName
49800>>>    writeln channel liChannel (psVersion(self))
49803>>>    writeln (piReadMode(self))
49805>>>    writeln (psIdTag(self))
49807>>>    writeln (pnTS_Time(self))
49809>>>    writeln (psTitle(self))
49811>>>    send SEQ_WriteArrayItems liChannel (oGlobalAttributes(self))
49812>>>    send SEQ_WriteArrayItems liChannel (oOtherAttributes(self))
49813>>>    get row_count to liMax
49814>>>    for liFile from 1 to (liMax-1)
49820>>>>
49820>>>      move (psRootName.i(self,liFile)) to lsRootName
49821>>>      if lsRootName ne "" begin
49823>>>        writeln channel liChannel (string(liFile))
49826>>>        writeln (psRootName.i(self,liFile))
49828>>>        writeln (psDFName.i(self,liFile))
49830>>>        writeln (psDisplayName.i(self,liFile))
49832>>>        send Seq_Write_AuxArray liChannel liFile
49833>>>        send Seq_Write_FileDefObject liChannel liFile
49834>>>        send OnFileWrite liChannel liFile
49835>>>      end
49835>>>>
49835>>>    loop
49836>>>>
49836>>>    writeln channel liChannel "END.OF.FILELIST.CFG"
49839>>>  end_procedure
49840>>>
49840>>>  // *************************************************************************
49840>>>  // *** Call back methods ***************************************************
49840>>>
49840>>>  //
49840>>>  //  Procedure called back should be defined like this
49840>>>  //    procedure HandleTable integer liFile string lsRoot string lsDFName string lsUserName
49840>>>  //
49840>>>
49840>>>  //> Call back for every entry with a rootname
49840>>>  procedure Callback.ii integer liMsg integer liObj
49842>>>    integer liFile liMax
49842>>>    string lsRootName
49842>>>    get row_count to liMax
49843>>>    for liFile from 1 to (liMax-1)
49849>>>>
49849>>>      move (psRootName.i(self,liFile)) to lsRootName
49850>>>      if lsRootName ne "" send liMsg to liObj liFile lsRootName (psDFName.i(self,liFile)) (psDisplayName.i(self,liFile)) (aux_value(self,liFile))
49853>>>    loop
49854>>>>
49854>>>  end_procedure
49855>>>  //> Call back for one specified file
49855>>>  procedure Callback_File.iii integer liFile integer liMsg integer liObj
49857>>>    send liMsg to liObj liFile (psRootName.i(self,liFile)) (psDFName.i(self,liFile)) (psDisplayName.i(self,liFile)) (aux_value(self,liFile))
49858>>>  end_procedure
49859>>>  //> Call a function for one specified file
49859>>>  function iCallback_File.iii integer liFile integer liGet integer liObj returns integer
49861>>>    integer liRval
49861>>>    get liGet of liObj liFile (psRootName.i(self,liFile)) (psDFName.i(self,liFile)) (psDisplayName.i(self,liFile)) (aux_value(self,liFile)) to liRval
49862>>>    function_return liRval
49863>>>  end_function
49864>>>
49864>>>  // *************************************************************************
49864>>>  // *** Attribute value access **********************************************
49864>>>  function AttrValue_GLOBAL integer liAttr returns string
49866>>>    integer liMonitoredGlobalAttributesObj
49866>>>    move (oMonitoredGlobalAttributes(self)) to liMonitoredGlobalAttributesObj
49867>>>    if (piMonitored.i(liMonitoredGlobalAttributesObj,liAttr)) begin
49869>>>      get piAttrIndex.i of liMonitoredGlobalAttributesObj liAttr to liAttr
49870>>>      function_return (value(oGlobalAttributes(self),liAttr))
49871>>>    end
49871>>>>
49871>>>    function_return t.fdx.attr_not_avail
49872>>>  end_function
49873>>>  function AttrValue_FILELIST integer liAttr integer liFile returns string
49875>>>    string lsStr
49875>>>    move "" to lsStr
49876>>>    if liAttr eq DF_FILE_ROOT_NAME    move (psRootName.i(self,liFile)) to lsStr
49879>>>    if liAttr eq DF_FILE_LOGICAL_NAME move (psDFName.i(self,liFile)) to lsStr
49882>>>    if liAttr eq DF_FILE_DISPLAY_NAME move (psDisplayName.i(self,liFile)) to lsStr
49885>>>    move (rtrim(lsStr)) to lsStr
49886>>>    if lsStr ne "" function_return lsStr
49889>>>    if liAttr eq DF_FILE_ROOT_NAME    function_return ("FILE"+string(liFile))
49892>>>    if liAttr eq DF_FILE_LOGICAL_NAME function_return ("DFFILE"+string(liFile))
49895>>>    if liAttr eq DF_FILE_DISPLAY_NAME function_return ("File"+string(liFile))
49898>>>    function_return t.fdx.attr_not_avail
49899>>>  end_function
49900>>>  function AttrValue_IsEmpty integer liFile returns integer
49902>>>    string lsStr
49902>>>    get psRootName.i liFile to lsStr
49903>>>    function_return (lsStr="")
49904>>>  end_function
49905>>>  function AttrValue_FILE integer liAttr integer liFile returns string
49907>>>    integer liObj
49907>>>    get piFileDefObject.i liFile to liObj
49908>>>    if liObj function_return (sAttrValueFile.i(liObj,liAttr))
49911>>>    function_return t.fdx.attr_not_avail
49912>>>  end_function
49913>>>  function AttrValue_FIELD integer liAttr integer liFile integer liField returns string
49915>>>    integer liObj
49915>>>    get piFileDefObject.i liFile to liObj
49916>>>    if liObj function_return (sAttrValueField.ii(liObj,liAttr,liField))
49919>>>    if liAttr eq DF_FIELD_NAME function_return ("FIELD"+string(liField))
49922>>>    function_return t.fdx.attr_not_avail
49923>>>  end_function
49924>>>  function AttrValue_INDEX integer liAttr integer liFile integer liIndex returns string
49926>>>    integer liObj
49926>>>    get piFileDefObject.i liFile to liObj
49927>>>    if liObj function_return (sAttrValueIndex.ii(liObj,liAttr,liIndex))
49930>>>    function_return t.fdx.attr_not_avail
49931>>>  end_function
49932>>>  function AttrValue_IDXSEG integer liAttr integer liFile integer liIndex integer liSegment returns string
49934>>>    integer liObj
49934>>>    get piFileDefObject.i liFile to liObj
49935>>>    if liObj function_return (sAttrValueIndexSegment.iii(liObj,liAttr,liIndex,liSegment))
49938>>>    function_return t.fdx.attr_not_avail
49939>>>  end_function
49940>>>  function AttrValue_SPECIAL1 integer liAttr integer liFile integer liField1 integer liField2 returns string
49942>>>    integer liObj
49942>>>    get piFileDefObject.i liFile to liObj
49943>>>    if liObj function_return (sAttrValueSpecial1.iii(liObj,liAttr,liField1,liField2))
49946>>>    function_return t.fdx.attr_not_avail
49947>>>  end_function
49948>>>  function sDatPath.i integer liFile returns string
49950>>>    integer liObj
49950>>>    get piFileDefObject.i liFile to liObj
49951>>>    if liObj function_return (psDatPath(liObj))
49954>>>    function_return ""
49955>>>  end_function
49956>>>  function nTimeStamp.i integer liFile returns number
49958>>>    integer liObj
49958>>>    get piFileDefObject.i liFile to liObj
49959>>>    if liObj function_return (pnTimeStamp(liObj))
49962>>>    function_return 0
49963>>>  end_function
49964>>>  function AttrValue_FLSTNAV integer liAttr integer liFile returns string
49966>>>    if liAttr eq DF_FILE_NEXT_OPENED function_return t.fdx.attr_not_avail
49969>>>    if liAttr eq DF_FILE_NEXT_USED begin
49971>>>      repeat
49971>>>>
49971>>>        increment liFile
49972>>>        if (psRootName.i(self,liFile)) ne "" function_return liFile
49975>>>      until (liFile>FILELIST_MAX_ENTRY)
49977>>>      function_return 0
49978>>>    end
49978>>>>
49978>>>    if liAttr eq DF_FILE_NEXT_EMPTY begin
49980>>>      repeat
49980>>>>
49980>>>        increment liFile
49981>>>        if (psRootName.i(self,liFile)) eq "" function_return liFile
49984>>>      until (liFile>FILELIST_MAX_ENTRY)
49986>>>      function_return 0
49987>>>    end
49987>>>>
49987>>>  end_function
49988>>>  function AttrValue_DRIVER integer liAttr integer liDriver returns string
49990>>>    function_return t.fdx.attr_not_avail
49991>>>  end_function
49992>>>  function AttrValue_DRVSRV integer liAttr integer liDriver integer liServer returns string
49994>>>    function_return t.fdx.attr_not_avail
49995>>>  end_function
49996>>>  function OtherAttr_Value integer liAttr returns string
49998>>>    function_return (value(oOtherAttributes(self),liAttr))
49999>>>  end_function
50000>>>
50000>>>  function iNextFileThatCanOpen integer liFile returns integer
50002>>>    repeat
50002>>>>
50002>>>      move (AttrValue_FLSTNAV(self,DF_FILE_NEXT_USED,liFile)) to liFile
50003>>>      if liFile if (iCanOpen.i(self,liFile)) function_return liFile
50008>>>    until (not(liFile))
50010>>>    //function_return 0
50010>>>  end_function
50011>>>
50011>>>  //> Function iFindRootName.sii goes through the table definitions and looks
50011>>>  //> for an entry with root name as specified in the lsRootName parameter. The
50011>>>  //> search is not case sensitive.
50011>>>  //>   Parameter root_of_root# is a boolean. If TRUE path and driver
50011>>>  //> information is stripped from the root name before the comparison is
50011>>>  //> made.
50011>>>  //>   The search starts at entry liFile+1
50011>>>  function iFindRootName.sii string lsRootName integer liFile integer liRootOfRoot returns integer
50013>>>    string lsTestRoot
50013>>>    move (uppercase(lsRootName)) to lsRootName
50014>>>//    increment liFile
50014>>>    if liRootOfRoot get DBMS_StripPathAndDriver lsRootName to lsRootName
50017>>>    repeat
50017>>>>
50017>>>      get AttrValue_FLSTNAV DF_FILE_NEXT_USED liFile to liFile
50018>>>      if liFile begin
50020>>>        get AttrValue_FILELIST DF_FILE_ROOT_NAME liFile to lsTestRoot
50021>>>        move (uppercase(lsTestRoot)) to lsTestRoot
50022>>>        if liRootOfRoot get DBMS_StripPathAndDriver lsTestRoot to lsTestRoot
50025>>>        if lsTestRoot eq lsRootName function_return liFile
50028>>>      end
50028>>>>
50028>>>    until (not(liFile))
50030>>>    //function_return 0
50030>>>  end_function
50031>>>
50031>>>  //> Function iFindLogicalName.s goes through the table definitions and looks
50031>>>  //> for an entry with loagical name as specified in the ln# parameter. The
50031>>>  //> search is not case sensitive.
50031>>>  function iFindLogicalName.si string lsLogicalName integer liFile returns integer
50033>>>    string lsTestLogicalName
50033>>>    move (uppercase(lsLogicalName)) to lsLogicalName
50034>>>    repeat
50034>>>>
50034>>>      get AttrValue_FLSTNAV DF_FILE_NEXT_USED liFile to liFile
50035>>>      if liFile begin
50037>>>        get AttrValue_FILELIST DF_FILE_LOGICAL_NAME liFile to lsTestLogicalName
50038>>>        move (uppercase(lsTestLogicalName)) to lsTestLogicalName
50039>>>        if lsTestLogicalName eq lsLogicalName function_return liFile
50042>>>      end
50042>>>>
50042>>>    until (not(liFile))
50044>>>    //function_return 0
50044>>>  end_function
50045>>>
50045>>>  //> This function returns a list of files with identical rootname
50045>>>  //> to that of the liFile passed. The list of files will exclude
50045>>>  //> the passed file itself.
50045>>>  function sAliasFiles.i integer liFile returns string
50047>>>    integer liExcludeFile
50047>>>    string lsRval lsRootName
50047>>>    move "" to lsRval
50048>>>    get AttrValue_FILELIST DF_FILE_ROOT_NAME liFile to lsRootName
50049>>>    move liFile to liExcludeFile
50050>>>    move 0 to liFile
50051>>>    repeat
50051>>>>
50051>>>      get iFindRootName.sii lsRootName liFile 0 to liFile
50052>>>      if (liFile<>0 and liFile<>liExcludeFile) move (AddIntegerToString(lsRval,liFile)) to lsRval
50055>>>    until liFile eq 0
50057>>>    function_return lsRval
50058>>>  end_function
50059>>>end_class // cFDX
50060>>>
50060>>>function iFdxIsEncapsulated for Desktop returns integer
50062>>>  function_return DFFALSE
50063>>>end_function
50064>>>
50064>>>function iFdxIsEncapsulated for cFdx returns integer
50066>>>  function_return DFTRUE
50067>>>end_function
50068>>>
50068>>>function NewFdxObject global integer liTable returns integer
50070>>>  integer lhObj
50070>>>  object oFdxObject is a cFdxFileDef
50072>>>    move self to lhObj
50073>>>    if liTable send Read_File_Definition.i liTable
50076>>>  end_object
50077>>>  function_return lhObj
50078>>>end_function
50079>Use Fdx1.utl     // FDX aware display global attributes (FDX_DisplayGlobalAttributes procedure)
Including file: fdx1.utl    (C:\Apps\VDFQuery\AppSrc\fdx1.utl)
50079>>>//**********************************************************************
50079>>>// Use Fdx1.utl     // FDX aware display global attributes (FDX_DisplayGlobalAttributes procedure)
50079>>>//
50079>>>// By Sture Andersen
50079>>>//
50079>>>// Create: Sun  16-01-2000
50079>>>// Update:
50079>>>//
50079>>>//**********************************************************************
50079>>>
50079>>>Use APS          // Auto Positioning and Sizing classes for VDF
50079>>>Use Fdx_Attr.nui // FDX compatible attribute functions
Including file: fdx_attr.nui    (C:\Apps\VDFQuery\AppSrc\fdx_attr.nui)
50079>>>>>// Use FDX_Attr.nui // FDX compatible attribute functions
50079>>>>>//
50079>>>>>//> The functions defined in this class allows you to query the setting
50079>>>>>//> of all the API attrbutes whether from the current runtime or from
50079>>>>>//> an FDX object, using the same calling syntax.
50079>>>>>
50079>>>>>
50079>>>>>Use API_Attr.nui // Database API attributes characteristics
50079>>>>>Use DBMS.nui     // Basic DBMS functions
50079>>>>>
50079>>>>>// The functions below are only declared if FDX.nui is used.
50079>>>>>register_function AttrValue_GLOBAL integer attr# returns string
50079>>>>>register_function AttrValue_FILELIST integer attr# integer file# returns string
50079>>>>>register_function AttrValue_FILE integer attr# integer file# returns string
50079>>>>>register_function AttrValue_FIELD integer attr# integer file# integer field# returns string
50079>>>>>register_function AttrValue_INDEX integer attr# integer file# integer index# returns string
50079>>>>>register_function AttrValue_IDXSEG integer attr# integer file# integer index# integer segment# returns string
50079>>>>>register_function AttrValue_SPECIAL1 integer attr# integer file# integer field1# integer field2# returns string
50079>>>>>register_function AttrValue_FLSTNAV integer attr# integer file# returns string
50079>>>>>register_function AttrValue_DRIVER integer attr# integer driver# returns string
50079>>>>>register_function AttrValue_DRVSRV integer attr# integer driver# integer server# returns string
50079>>>>>register_function OtherAttr_Value integer attr# returns string
50079>>>>>register_function piFileDefObject.i integer file# returns integer
50079>>>>>register_function psFileName returns string
50079>>>>>register_function iNextFileThatCanOpen integer file# returns integer
50079>>>>>
50079>>>>>function FDX_AttrValue_GLOBAL global integer oFDX# integer attr# returns string
50081>>>>>  if oFDX# function_return (AttrValue_GLOBAL(oFDX#,attr#))
50084>>>>>  else function_return (API_AttrValue_GLOBAL(attr#))
50086>>>>>end_function
50087>>>>>function FDX_AttrValue_FILELIST global integer oFDX# integer attr# integer file# returns string
50089>>>>>  if oFDX# function_return (AttrValue_FILELIST(oFDX#,attr#,file#))
50092>>>>>  else function_return (API_AttrValue_FILELIST(attr#,file#))
50094>>>>>end_function
50095>>>>>function FDX_AttrValue_FILE global integer oFDX# integer attr# integer file# returns string
50097>>>>>  if oFDX# function_return (AttrValue_FILE(oFDX#,attr#,file#))
50100>>>>>  else function_return (API_AttrValue_FILE(attr#,file#))
50102>>>>>end_function
50103>>>>>function FDX_AttrValue_FIELD global integer oFDX# integer attr# integer file# integer field# returns string
50105>>>>>  if oFDX# function_return (AttrValue_FIELD(oFDX#,attr#,file#,field#))
50108>>>>>  else function_return (API_AttrValue_FIELD(attr#,file#,field#))
50110>>>>>end_function
50111>>>>>function FDX_AttrValue_INDEX global integer oFDX# integer attr# integer file# integer index# returns string
50113>>>>>  if oFDX# function_return (AttrValue_INDEX(oFDX#,attr#,file#,index#))
50116>>>>>  else function_return (API_AttrValue_INDEX(attr#,file#,index#))
50118>>>>>end_function
50119>>>>>function FDX_AttrValue_IDXSEG global integer oFDX# integer attr# integer file# integer index# integer segment# returns string
50121>>>>>  if oFDX# function_return (AttrValue_IDXSEG(oFDX#,attr#,file#,index#,segment#))
50124>>>>>  else function_return (API_AttrValue_IDXSEG(attr#,file#,index#,segment#))
50126>>>>>end_function
50127>>>>>function FDX_AttrValue_SPECIAL1 global integer oFDX# integer attr# integer file# integer field1# integer field2# returns string
50129>>>>>  if oFDX# function_return (AttrValue_SPECIAL1(oFDX#,attr#,file#,field1#,field2#))
50132>>>>>  else function_return (API_AttrValue_SPECIAL1(attr#,file#,field1#,field2#))
50134>>>>>end_function
50135>>>>>function FDX_AttrValue_FLSTNAV global integer oFDX# integer attr# integer file# returns string
50137>>>>>  if oFDX# function_return (AttrValue_FLSTNAV(oFDX#,attr#,file#))
50140>>>>>  else function_return (API_AttrValue_FLSTNAV(attr#,file#))
50142>>>>>end_function
50143>>>>>function FDX_AttrValue_DRIVER global integer oFDX# integer attr# integer driver# returns string
50145>>>>>  if oFDX# function_return (AttrValue_DRIVER(oFDX#,attr#,driver#))
50148>>>>>  else function_return (API_AttrValue_DRIVER(attr#,driver#))
50150>>>>>end_function
50151>>>>>function FDX_AttrValue_DRVSRV global integer oFDX# integer attr# integer driver# integer server# returns string
50153>>>>>  if oFDX# function_return (AttrValue_DRVSRV(oFDX#,attr#,driver#,server#))
50156>>>>>  else function_return (API_AttrValue_DRVSRV(attr#,driver#,server#))
50158>>>>>end_function
50159>>>>>function FDX_OtherAttr_Value global integer oFDX# integer attr# returns string
50161>>>>>  if oFDX# function_return (OtherAttr_Value(oFDX#,attr#))
50164>>>>>  else function_return (API_OtherAttr_Value(attr#))
50166>>>>>end_function
50167>>>>>function FDX_CanOpenFile global integer oFDX# integer file# returns integer
50169>>>>>  if oFDX# function_return (piFileDefObject.i(oFdx#,file#))
50172>>>>>  else function_return (DBMS_CanOpenFile(file#))
50174>>>>>end_function
50175>>>>>function FDX_NextFileThatCanOpen global integer oFDX# integer file# returns integer
50177>>>>>  if oFDX# function_return (iNextFileThatCanOpen(oFdx#,file#))
50180>>>>>  else function_return (API_NextFileThatCanOpen(file#))
50182>>>>>end_function
50183>>>>>function FDX_FindRootName global integer lhFDX string lsFindRootName integer liFile returns integer
50185>>>>>  string lsRootStripped
50185>>>>>  get DBMS_StripPathAndDriver lsFindRootName to lsFindRootName
50186>>>>>  repeat
50186>>>>>>
50186>>>>>    move (FDX_AttrValue_FLSTNAV(lhFDX,DF_FILE_NEXT_USED,liFile)) to liFile
50187>>>>>    if liFile begin
50189>>>>>      get FDX_AttrValue_FILELIST lhFDX DF_FILE_ROOT_NAME liFile to lsRootStripped
50190>>>>>      get DBMS_StripPathAndDriver lsRootStripped to lsRootStripped
50191>>>>>      if (lowercase(lsFindRootName)=lowercase(lsRootStripped)) function_return liFile
50194>>>>>    end
50194>>>>>>
50194>>>>>  until liFile eq 0
50196>>>>>  function_return 0
50197>>>>>end_function
50198>>>>>function FDX_FindLogicalName global integer lhFDX string lsFindLogName integer liFile returns integer
50200>>>>>  string lsLogName
50200>>>>>  repeat
50200>>>>>>
50200>>>>>    move (FDX_AttrValue_FLSTNAV(lhFDX,DF_FILE_NEXT_USED,liFile)) to liFile
50201>>>>>    if liFile begin
50203>>>>>      get FDX_AttrValue_FILELIST lhFDX DF_FILE_LOGICAL_NAME liFile to lsLogName
50204>>>>>      if (lowercase(lsFindLogName)=lowercase(lsLogName)) function_return liFile
50207>>>>>    end
50207>>>>>>
50207>>>>>  until liFile eq 0
50209>>>>>  function_return 0
50210>>>>>end_function
50211>>>>>
50211>>>>>// ******** Samples ********************************************
50211>>>>>//
50211>>>>>// A loop through all files/all fields:
50211>>>>>//
50211>>>>>//   procedure GoThoughAllFields
50211>>>>>//     integer oFDX# file# field# max#
50211>>>>>//     get piFDX_Server to oFDX#
50211>>>>>//     move 0 to file#
50211>>>>>//     repeat
50211>>>>>//       move (FDX_AttrValue_FLSTNAV(oFDX#,DF_FILE_NEXT_USED,file#)) to file#
50211>>>>>//       if file# begin
50211>>>>>//         move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,file#)) to max#
50211>>>>>//         for field# from 1 to max#
50211>>>>>//           (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_NAME,file#,field#))
50211>>>>>//         loop
50211>>>>>//       end
50211>>>>>//     until file# eq 0
50211>>>>>//   end_procedure
50211>>>>>//
50211>>>>>// A loop through all indices/segments of a file:
50211>>>>>//
50211>>>>>//   procedure GoThoughAllIndices integer file#
50211>>>>>//     integer oFDX# index# seg_max# segment# field#
50211>>>>>//     get piFDX_Server to oFDX#
50211>>>>>//
50211>>>>>//     for index# from 1 to 16
50211>>>>>//       get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index# to seg_max#
50211>>>>>//       if max_seg# begin // If there's an index at all
50211>>>>>//         for segment# from 1 to seg_max#
50211>>>>>//           get FDX_AttrValue_IDXSEG oFDX# DF_INDEX_SEGMENT_FIELD file# index# segment# to field#
50211>>>>>//         loop
50211>>>>>//       end
50211>>>>>//     loop
50211>>>Use Strings.nui  // String manipulation for VDF
50211>>>Use GridUtil.utl // Grid and List utilities (not for dbGrid's or Table's)
Including file: gridutil.utl    (C:\Apps\VDFQuery\AppSrc\gridutil.utl)
50211>>>>>// Use GridUtil.utl // Grid and List utilities (not for dbGrid's or Table's)
50211>>>>>
50211>>>>>//> This package provides a number of functions working on objects of
50211>>>>>//> these classes
50211>>>>>//>
50211>>>>>//>       Grid (VDF)
50211>>>>>//>       List (DF)
50211>>>>>//>
50211>>>>>//> And not: dbGrid (VDF), List (VDF), dbList (VDF) or Table (DF)
50211>>>>>//>
50211>>>>>//> The Grid of VDF and the List of DF are so much alike that it makes
50211>>>>>//> sence to give them a common interface via this package.
50211>>>>>//>
50211>>>>>//> For the rest of this package (except the first sentence of the next
50211>>>>>//> paragraph) VDF Grid's and DF List's will be referred to as grids.
50211>>>>>//>
50211>>>>>//> Rather than having these functions implemented in a subclass of the
50211>>>>>//> Grid- or List classes I have made global functions and procedures
50211>>>>>//> that all takes the object ID of the Grid as the first parameter.
50211>>>>>//>
50211>>>>>//> You may therefore use the functions of this package regardless of
50211>>>>>//> the class hierarchy you are using.
50211>>>>>//>
50211>>>>>//> To sort the contents of a grid by the contents of column liColumn use:
50211>>>>>//>
50211>>>>>//>    procedure Grid_SortByColumn global integer lhGrid integer liColumn
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> The set the entry_state of all items in a grid in one go use:
50211>>>>>//>
50211>>>>>//>    procedure Grid_SetEntryState global integer lhObj integer liState
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> To figure out the number of the first item in the current row use:
50211>>>>>//>
50211>>>>>//>    function Grid_BaseItem global integer lhObj returns integer
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> To figure out the current column use:
50211>>>>>//>
50211>>>>>//>    function Grid_CurrentColumn global integer lhObj returns integer
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> And finally, to figure out the number of columns used:
50211>>>>>//>
50211>>>>>//>    function Grid_Columns global integer lhObj returns integer
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> Added much later:
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> Use this to switch the contents of two rows (including aux_value, color
50211>>>>>//> entry_state and what have you):
50211>>>>>//>
50211>>>>>//>    procedure Grid_SwapRows global integer lhObj integer liRow1 ;
50211>>>>>//>                                                        integer liRow2
50211>>>>>//>
50211>>>>>//> Most often, when swapping rows you'd really like to swap the current row
50211>>>>>//> up or down:
50211>>>>>//>
50211>>>>>//>    procedure Grid_SwapCurrentRowUp global integer lhGrid
50211>>>>>//>    procedure Grid_SwapCurrentRowDown global integer lhGrid
50211>>>>>//>
50211>>>>>//>    Use like this (from within a Grid object):
50211>>>>>//>
50211>>>>>//>      procedure MoveItemUp
50211>>>>>//>        send Grid_SwapCurrentRowUp self
50211>>>>>//>      end_procedure
50211>>>>>//>      procedure MoveItemDown
50211>>>>>//>        send Grid_SwapCurrentRowDown self
50211>>>>>//>      end_procedure
50211>>>>>//>      on_key KEY_CTRL+KEY_UP_ARROW   send MoveItemUp
50211>>>>>//>      on_key KEY_CTRL+KEY_DOWN_ARROW send MoveItemDown
50211>>>>>//>
50211>>>>>//> In some cases you may want to swap the current row to the top or to the
50211>>>>>//> bottom of the grid. Use:
50211>>>>>//>
50211>>>>>//>    procedure Grid_SwapCurrentRowTop global integer lhGrid
50211>>>>>//>    procedure Grid_SwapCurrentRowBottom global integer lhGrid
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> Delete a row:
50211>>>>>//>
50211>>>>>//>   procedure Grid_DeleteRow global integer lhObj integer liRow
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> Delete current row:
50211>>>>>//>
50211>>>>>//>   procedure Grid_DeleteCurrentRow global integer lhObj
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> If the first column of the grid is a checkbox column you may use these
50211>>>>>//> methods:
50211>>>>>//>
50211>>>>>//>          Select all rows:
50211>>>>>//>
50211>>>>>//>             procedure Grid_RowSelectAll global integer lhGrid
50211>>>>>//>
50211>>>>>//>
50211>>>>>//>          Deselect all rows:
50211>>>>>//>
50211>>>>>//>             procedure Grid_RowDeselectAll global integer lhGrid
50211>>>>>//>
50211>>>>>//>
50211>>>>>//>          Invert row selection:
50211>>>>>//>
50211>>>>>//>             procedure Grid_RowSelectInvert global integer lhGrid
50211>>>>>//>
50211>>>>>//>
50211>>>>>//>          Call function liGet for each row in lhGrid to set the select
50211>>>>>//>          or deselect each row. The liGet function ID will receive two
50211>>>>>//>          parameter (Row number and number of the base item of that row)
50211>>>>>//>          and should return an integer value:
50211>>>>>//>
50211>>>>>//>             procedure Grid_RowSelectCostum global integer lhGrid ;
50211>>>>>//>                                                           integer liGet
50211>>>>>//>
50211>>>>>//>
50211>>>>>//>          Use this to call procedure liMsg in lhGrid for each selected
50211>>>>>//>          row. The procedure will receive two parameters (row number and
50211>>>>>//>          number of the base item of that row):
50211>>>>>//>
50211>>>>>//>             procedure Grid_RowCallBackSelected global integer lhGrid ;
50211>>>>>//>                                                             integer liMsg
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> To write the contents of the Grid to a sequential channel use
50211>>>>>//>
50211>>>>>//>    procedure Grid_WriteToFile global integer lhGrid integer liChannel ;
50211>>>>>//>                                                         integer liFormat
50211>>>>>//>
50211>>>>>//> where liFormat may be GD_FORMAT (Nicely formatted into colums), GD_COMMA
50211>>>>>//> (each line containing a row with comma separated items) or GD_TAB (same
50211>>>>>//> as the former, but separated by a TAB character).
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> In order to dump the grid data into an editor use
50211>>>>>//>
50211>>>>>//>    procedure Grid_DoWriteToFile global integer lhGrid
50211>>>>>//>
50211>>>>>//> This will create a file called 'temp.txt' and launch an editor on it
50211>>>>>//> (NotePad, Edit or vi).
50211>>>>>//>
50211>>>>>//>
50211>>>>>//> This is one of my best packages!
50211>>>>>//>
50211>>>>>//> =========================================================================
50211>>>>>//
50211>>>>>//  Update: Wed  07-11-2001 - Changed procedures Grid_RowSelectAll,
50211>>>>>//                            Grid_RowDeselectAll and Grid_RowSelectInvert
50211>>>>>//                            to avoid changing the select_state of a
50211>>>>>//                            shadowed item.
50211>>>>>//          Tue  25-12-2001 - Now also applies form_datatype it compiled
50211>>>>>//                            with VDF
50211>>>>>//          Wed  18-04-2002 - desktop_section problem corrected
50211>>>>>//          Mon  12-08-2002 - Function Grid_ItemRow added
50211>>>>>//          Thu  16-06-2003 - Added optional parameter to Grid_RowCallBackSelected
50211>>>>>//          Thu  01-07-2003 - Added functions Grid_AppendRow, Grid_InsertRow
50211>>>>>//                            and Grid_InsertCurrentRow
50211>>>>>//          Fri  21-10-2005 - Added procedure Grid_SetRowColor and Grid_AddRowToGrid
50211>>>>>//
50211>>>>>//    set Header_Visible_State to DFTRUE|DFFALSE
50211>>>>>//
50211>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
50211>>>>>Use Strings.nui  // String manipulation for VDF
50211>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
50211>>>>>
50211>>>>>desktop_section // This makes sure the object is located on the desktop
50216>>>>>  object oGridMoveSelectedListItems is an cArray NO_IMAGE
50218>>>>>  end_object
50219>>>>>end_desktop_section
50224>>>>>
50224>>>>>//> Procedure Grid_CopySelectedListItems is meant for List objects (AHA! This
50224>>>>>//> is the only procedure that deals with the VDF list class)
50224>>>>>procedure Grid_CopySelectedListItems global integer lhSourceGrid integer lhTargetGrid integer lbAllItems integer lbDeleteFromSource
50226>>>>>  integer liMax liItem liSelect lhObj liDeleteItem
50226>>>>>  string lsValue
50226>>>>>  move (oGridMoveSelectedListItems(self)) to lhObj
50227>>>>>  get item_count of lhSourceGrid to liMax
50228>>>>>  for liItem from 0 to (liMax-1) // Copy selected items
50234>>>>>>
50234>>>>>    ifnot lbAllItems get select_state of lhSourceGrid item liItem to liSelect
50237>>>>>    if (liSelect or lbAllItems) begin
50239>>>>>      get value of lhSourceGrid item liItem to lsValue
50240>>>>>      send add_item to lhTargetGrid msg_none lsValue
50241>>>>>      set value of lhObj item (item_count(lhObj)) to liItem
50242>>>>>    end
50242>>>>>>
50242>>>>>  loop
50243>>>>>>
50243>>>>>  if lbAllItems send delete_data to lhSourceGrid
50246>>>>>  else begin
50247>>>>>    get item_count of lhObj to liMax
50248>>>>>    for_ex liItem from (liMax-1) down_to 0 // Remove selected items
50255>>>>>      get value of lhObj item liItem to liDeleteItem
50256>>>>>      send delete_item to lhSourceGrid liDeleteItem
50257>>>>>    loop
50258>>>>>>
50258>>>>>  end
50258>>>>>>
50258>>>>>  send delete_data to lhObj
50259>>>>>  send sort_items to lhSourceGrid
50260>>>>>  send sort_items to lhTargetGrid
50261>>>>>  set dynamic_update_state of lhSourceGrid to DFTRUE
50262>>>>>  set dynamic_update_state of lhTargetGrid to DFTRUE
50263>>>>>end_procedure
50264>>>>>
50264>>>>>//> Set Entry_State for all items in a Grid (that are not checkboxes)
50264>>>>>procedure Grid_SetEntryState global integer lhObj integer liState
50266>>>>>  integer liItem liMax
50266>>>>>  get item_count of lhObj to liMax
50267>>>>>  for liItem from 0 to (liMax-1)
50273>>>>>>
50273>>>>>    ifnot (checkbox_item_state(lhObj,liItem)) set entry_state of lhObj item liItem to liState
50276>>>>>  loop
50277>>>>>>
50277>>>>>end_procedure
50278>>>>>
50278>>>>>//> Function Grid_Columns takes the object ID of a Grid or List
50278>>>>>//> object and returns the number of columns in that object.
50278>>>>>function Grid_Columns global integer lhObj returns integer
50280>>>>>  integer liMs
50280>>>>>  get line_size of lhObj to liMs
50281>>>>>  function_return liMs
50282>>>>>end_function
50283>>>>>
50283>>>>>function Grid_CurrentColumn global integer lhObj returns integer
50285>>>>>  integer liColumns liCurrentItem liBase
50285>>>>>  get Grid_Columns lhObj to liColumns
50286>>>>>  get current_item of lhObj to liCurrentItem
50287>>>>>  move ((liCurrentItem/liColumns)*liColumns) to liBase
50288>>>>>  function_return (liCurrentItem-liBase)
50289>>>>>end_function
50290>>>>>
50290>>>>>function Grid_BaseItem global integer lhObj returns integer
50292>>>>>  integer liColumns liCurrentItem
50292>>>>>  get Grid_Columns lhObj to liColumns
50293>>>>>  get current_item of lhObj to liCurrentItem
50294>>>>>  function_return ((liCurrentItem/liColumns)*liColumns)
50295>>>>>end_function
50296>>>>>
50296>>>>>function Grid_ItemColumn global integer lhObj integer liItem returns integer
50298>>>>>  integer liColumns
50298>>>>>  get Grid_Columns lhObj to liColumns
50299>>>>>  if liItem eq -99 get current_item of lhObj to liItem
50302>>>>>  function_return (mod(liItem,liColumns))
50303>>>>>end_function
50304>>>>>
50304>>>>>function Grid_ItemRow global integer lhObj integer liItem returns integer
50306>>>>>  integer liColumns
50306>>>>>  get Grid_Columns lhObj to liColumns
50307>>>>>  if liItem eq -99 get current_item of lhObj to liItem
50310>>>>>  function_return (liItem/liColumns)
50311>>>>>end_function
50312>>>>>
50312>>>>>function Grid_ItemBaseItem global integer lhObj integer liItem returns integer
50314>>>>>  integer liColumns
50314>>>>>  if liItem eq -99 get current_item of lhObj to liItem
50317>>>>>  get Grid_Columns lhObj to liColumns
50318>>>>>  function_return ((liItem/liColumns)*liColumns)
50319>>>>>end_function
50320>>>>>
50320>>>>>//> What is the number of the base item of row liRow
50320>>>>>function Grid_RowBaseItem global integer lhObj integer liRow returns integer
50322>>>>>  integer liColumns
50322>>>>>  get Grid_Columns lhObj to liColumns
50323>>>>>  function_return (liRow*liColumns)
50324>>>>>end_function
50325>>>>>
50325>>>>>//> Return the number of the row that includes the current_item
50325>>>>>function Grid_CurrentRow global integer lhObj returns integer
50327>>>>>  integer liCurrentItem
50327>>>>>  get current_item of lhObj to liCurrentItem
50328>>>>>  function_return (liCurrentItem/Grid_Columns(lhObj))
50329>>>>>end_function
50330>>>>>
50330>>>>>//> Return the number of rows currently in the Grid
50330>>>>>function Grid_RowCount global integer lhObj returns integer
50332>>>>>  integer liColumns
50332>>>>>  get Grid_Columns lhObj to liColumns
50333>>>>>  function_return (item_count(lhObj)/liColumns)
50334>>>>>end_function
50335>>>>>
50335>>>>>procedure Grid_SwapRows global integer lhObj integer liRow1 integer liRow2
50337>>>>>  integer liBase1 liBase2 liItem liMax
50337>>>>>  string lsValue
50337>>>>>  get Grid_RowBaseItem lhObj liRow1 to liBase1
50338>>>>>  get Grid_RowBaseItem lhObj liRow2 to liBase2
50339>>>>>  get Grid_Columns lhObj to liMax
50340>>>>>  for liItem from 0 to (liMax-1)
50346>>>>>>
50346>>>>>    // value
50346>>>>>    get value of lhObj item (liBase1+liItem) to lsValue
50347>>>>>    set value of lhObj item (liBase1+liItem) to (value(lhObj,liBase2+liItem))
50348>>>>>    set value of lhObj item (liBase2+liItem) to lsValue
50349>>>>>    // entry_state
50349>>>>>    get entry_state of lhObj item (liBase1+liItem) to lsValue
50350>>>>>    set entry_state of lhObj item (liBase1+liItem) to (entry_state(lhObj,liBase2+liItem))
50351>>>>>    set entry_state of lhObj item (liBase2+liItem) to lsValue
50352>>>>>    // color
50352>>>>>    get itemcolor of lhObj item (liBase1+liItem) to lsValue
50353>>>>>    set itemcolor of lhObj item (liBase1+liItem) to (itemcolor(lhObj,liBase2+liItem))
50354>>>>>    set itemcolor of lhObj item (liBase2+liItem) to lsValue
50355>>>>>    // checkbox_item_state
50355>>>>>    get checkbox_item_state of lhObj item (liBase1+liItem) to lsValue
50356>>>>>    set checkbox_item_state of lhObj item (liBase1+liItem) to (checkbox_item_state(lhObj,liBase2+liItem))
50357>>>>>    set checkbox_item_state of lhObj item (liBase2+liItem) to lsValue
50358>>>>>    // aux_value
50358>>>>>    get aux_value of lhObj item (liBase1+liItem) to lsValue
50359>>>>>    set aux_value of lhObj item (liBase1+liItem) to (aux_value(lhObj,liBase2+liItem))
50360>>>>>    set aux_value of lhObj item (liBase2+liItem) to lsValue
50361>>>>>    // select_state
50361>>>>>    get select_state of lhObj item (liBase1+liItem) to lsValue
50362>>>>>    set select_state of lhObj item (liBase1+liItem) to (select_state(lhObj,liBase2+liItem))
50363>>>>>    set select_state of lhObj item (liBase2+liItem) to lsValue
50364>>>>>    // What about shadow_state (and item_shadow_state)?
50364>>>>>  loop
50365>>>>>>
50365>>>>>end_procedure
50366>>>>>
50366>>>>>function Grid_AppendRow global integer lhObj returns integer
50368>>>>>  integer liCount liMax liRow
50368>>>>>  set dynamic_update_state of lhObj to DFFALSE
50369>>>>>  get Grid_RowCount lhObj to liRow
50370>>>>>  get Grid_Columns lhObj to liMax
50371>>>>>  decrement liMax
50372>>>>>  for liCount from 0 to liMax
50378>>>>>>
50378>>>>>    send add_item to lhObj MSG_NONE ""
50379>>>>>  loop
50380>>>>>>
50380>>>>>  set dynamic_update_state of lhObj to DFTRUE
50381>>>>>  function_return liRow
50382>>>>>end_function
50383>>>>>
50383>>>>>function Grid_InsertRow global integer lhObj integer liRow returns integer
50385>>>>>  integer liCount liMax liItem
50385>>>>>  get Grid_RowBaseItem lhObj liRow to liItem
50386>>>>>  set dynamic_update_state of lhObj to DFFALSE
50387>>>>>  get Grid_Columns lhObj to liMax
50388>>>>>  decrement liMax
50389>>>>>  for liCount from 0 to liMax
50395>>>>>>
50395>>>>>    send insert_item to lhObj MSG_NONE "" liItem
50396>>>>>  loop
50397>>>>>>
50397>>>>>  set dynamic_update_state of lhObj to DFTRUE
50398>>>>>  function_return liRow
50399>>>>>end_function
50400>>>>>
50400>>>>>function Grid_InsertCurrentRow global integer lhObj returns integer
50402>>>>>  integer liRow
50402>>>>>  get Grid_InsertRow lhObj (Grid_CurrentRow(lhObj)) to liRow
50403>>>>>  function_return liRow
50404>>>>>end_function
50405>>>>>
50405>>>>>procedure Grid_DeleteRow global integer lhObj integer liRow
50407>>>>>  integer liBase liCount liMax
50407>>>>>  if (item_count(lhObj)) begin
50409>>>>>    set dynamic_update_state of lhObj to DFFALSE
50410>>>>>    get Grid_RowBaseItem lhObj liRow to liBase
50411>>>>>    get Grid_Columns lhObj to liMax
50412>>>>>    decrement liMax
50413>>>>>    for liCount from 0 to liMax
50419>>>>>>
50419>>>>>      send delete_item to lhObj liBase
50420>>>>>    loop
50421>>>>>>
50421>>>>>    set dynamic_update_state of lhObj to DFTRUE
50422>>>>>  end
50422>>>>>>
50422>>>>>end_procedure
50423>>>>>procedure Grid_DeleteCurrentRow global integer lhObj
50425>>>>>  send Grid_DeleteRow lhObj (Grid_CurrentRow(lhObj))
50426>>>>>end_procedure
50427>>>>>
50427>>>>>procedure Grid_SwapCurrentRowUp global integer lhObj
50429>>>>>  integer liCurrentRow liCurrentItem
50429>>>>>  get Grid_CurrentRow lhObj to liCurrentRow
50430>>>>>  if liCurrentRow gt 0 begin
50432>>>>>    get Current_Item of lhObj to liCurrentItem
50433>>>>>    send Grid_SwapRows lhObj liCurrentRow (liCurrentRow-1)
50434>>>>>    set Current_Item of lhObj to (liCurrentItem-Grid_Columns(lhObj))
50435>>>>>  end
50435>>>>>>
50435>>>>>end_procedure
50436>>>>>procedure Grid_SwapCurrentRowTop global integer lhObj
50438>>>>>  integer liCurrentRow liCurrentItem
50438>>>>>  repeat
50438>>>>>>
50438>>>>>    get Grid_CurrentRow lhObj to liCurrentRow
50439>>>>>    if liCurrentRow gt 0 send Grid_SwapCurrentRowUp lhObj
50442>>>>>  until (liCurrentRow=0)
50444>>>>>end_procedure
50445>>>>>procedure Grid_SwapCurrentRowDown global integer lhObj
50447>>>>>  integer liCurrentRow liCurrentItem
50447>>>>>  get Grid_CurrentRow lhObj to liCurrentRow
50448>>>>>  if liCurrentRow lt (Grid_RowCount(lhObj)-1) begin
50450>>>>>    get Current_Item of lhObj to liCurrentItem
50451>>>>>    send Grid_SwapRows lhObj liCurrentRow (liCurrentRow+1)
50452>>>>>    set Current_Item of lhObj to (liCurrentItem+Grid_Columns(lhObj))
50453>>>>>  end
50453>>>>>>
50453>>>>>end_procedure
50454>>>>>procedure Grid_SwapCurrentRowBottom global integer lhObj
50456>>>>>  integer liCurrentRow liCurrentItem
50456>>>>>  repeat
50456>>>>>>
50456>>>>>    get Grid_CurrentRow lhObj to liCurrentRow
50457>>>>>    if liCurrentRow lt (Grid_RowCount(lhObj)-1) send Grid_SwapCurrentRowDown lhObj
50460>>>>>  until (liCurrentRow=(Grid_RowCount(lhObj)-1))
50462>>>>>end_procedure
50463>>>>>
50463>>>>>Use FieldInf     // Global field info objects and abstract field types
50463>>>>>desktop_section
50468>>>>>  object oGridPrepare is a cArray
50470>>>>>    property integer piNextPrevious public 1
50472>>>>>    item_property_list
50472>>>>>      item_property string  psHeaderLabel.i
50472>>>>>      item_property integer piAbstractOrFile.i
50472>>>>>      item_property integer piField.i
50472>>>>>    end_item_property_list
#REM 50512 DEFINE FUNCTION PIFIELD.I INTEGER LIROW RETURNS INTEGER
#REM 50517 DEFINE PROCEDURE SET PIFIELD.I INTEGER LIROW INTEGER VALUE
#REM 50522 DEFINE FUNCTION PIABSTRACTORFILE.I INTEGER LIROW RETURNS INTEGER
#REM 50527 DEFINE PROCEDURE SET PIABSTRACTORFILE.I INTEGER LIROW INTEGER VALUE
#REM 50532 DEFINE FUNCTION PSHEADERLABEL.I INTEGER LIROW RETURNS STRING
#REM 50537 DEFINE PROCEDURE SET PSHEADERLABEL.I INTEGER LIROW STRING VALUE
50543>>>>>    procedure add_column string lsLabel integer liAbstract integer liField
50546>>>>>      integer liRow
50546>>>>>      get row_count to liRow
50547>>>>>      set psHeaderLabel.i liRow to lsLabel
50548>>>>>      set piAbstractOrFile.i liRow to liAbstract
50549>>>>>      set piField.i liRow to liField
50550>>>>>    end_procedure
50551>>>>>    procedure reset
50554>>>>>      send delete_data
50555>>>>>      set piNextPrevious to 1
50556>>>>>    end_procedure
50557>>>>>    procedure apply_settings integer lhObj integer lbDoColor
50560>>>>>      integer liRow liMax
50560>>>>>      get row_count to liMax
50561>>>>>      set line_width of lhObj to liMax 0
50562>>>>>      decrement liMax
50563>>>>>      for liRow from 0 to liMax
50569>>>>>>
50569>>>>>        set header_label of lhObj liRow to (psHeaderLabel.i(self,liRow))
50570>>>>>        if (piField.i(self,liRow)) eq -1 begin // Then it's an Abstract
50572>>>>>          set form_margin of lhObj liRow to (integer_value.ii(form_margin_array#,0,piAbstractOrFile.i(self,liRow)))
50573>>>>>          set form_datatype of lhObj liRow to (integer_value.ii(form_datatype_array#,0,piAbstractOrFile.i(self,liRow)))
50574>>>>>        end
50574>>>>>>
50574>>>>>        else begin // It's a file.field
50575>>>>>          set form_margin of lhObj liRow to (gl_effective_form_margin(piAbstractOrFile.i(self,liRow),piField.i(self,liRow)))
50576>>>>>          set form_datatype of lhObj liRow to (gl_effective_form_datatype(piAbstractOrFile.i(self,liRow),piField.i(self,liRow)))
50577>>>>>        end
50577>>>>>>
50577>>>>>      loop
50578>>>>>>
50578>>>>>      set select_mode of lhObj to no_select
50579>>>>>      if lbDoColor begin
50581>>>>>        set highlight_row_state of lhObj to DFTRUE
50582>>>>>        set CurrentCellColor     of lhObj to clHighlight
50583>>>>>        set CurrentCellTextColor of lhObj to clHighlightText
50584>>>>>        set CurrentRowColor      of lhObj to clHighlight
50585>>>>>        set CurrentRowTextColor  of lhObj to clHighlightText
50586>>>>>      end
50586>>>>>>
50586>>>>>      if (piNextPrevious(self)) begin
50588>>>>>        move self to liMax // Overload
50589>>>>>        move lhObj to self
50590>>>>>        on_key knext_item send switch
50591>>>>>        on_key kprevious_item send switch_back
50592>>>>>        move liMax to self
50593>>>>>      end
50593>>>>>>
50593>>>>>    end_procedure
50594>>>>>  end_object // oGridPrepare
50595>>>>>  procedure GridPrepare_Reset global
50597>>>>>    send reset to (oGridPrepare(self))
50598>>>>>  end_procedure
50599>>>>>  procedure GridPrepare_AddCheckBoxColumn global string lsHeader
50601>>>>>    string lsTmp
50601>>>>>    if num_arguments gt 0 move lsHeader to lsTmp
50604>>>>>    else move "" to lsTmp
50606>>>>>    send add_column to (oGridPrepare(self)) lsTmp AFT_ASCII3 -1
50607>>>>>  end_procedure
50608>>>>>  procedure GridPrepare_AddColumn global string lsLabel integer liAbstract
50610>>>>>    send add_column to (oGridPrepare(self)) lsLabel liAbstract -1
50611>>>>>  end_procedure
50612>>>>>  procedure GridPrepare_AddColumnFileField global string lsLabel integer liFile integer liField
50614>>>>>    send add_column to (oGridPrepare(self)) lsLabel liFile liField
50615>>>>>  end_procedure
50616>>>>>  procedure GridPrepare_Apply global integer lhObj integer lbDoColor
50618>>>>>    integer liTemp
50618>>>>>    if num_arguments gt 1 move lbDoColor to liTemp
50621>>>>>    else move 1 to liTemp
50623>>>>>    send apply_settings to (oGridPrepare(self)) lhObj liTemp
50624>>>>>    send GridPrepare_Reset
50625>>>>>  end_procedure
50626>>>>>end_desktop_section
50631>>>>>
50631>>>>>desktop_section
50636>>>>>  // Here is a temporary array used for storing different values while
50636>>>>>  // a grid is being sorted.
50636>>>>>  object oSortGrid_Data is a cArray NO_IMAGE
50638>>>>>    property integer piCurrentGridID public 0 // Not used
50640>>>>>    property integer piCurrentRow    public 0
50642>>>>>    property integer piCurrentColumn public 0
50644>>>>>    object oSortedData is a cArray NO_IMAGE
50646>>>>>    end_object
50647>>>>>    object oAuxValues is a cArray NO_IMAGE
50649>>>>>    end_object
50650>>>>>    object oEntryStates is a cArray NO_IMAGE
50652>>>>>    end_object
50653>>>>>    object oSelectStates is a cArray NO_IMAGE
50655>>>>>    end_object
50656>>>>>    object oItemColors is a cArray NO_IMAGE
50658>>>>>    end_object
50659>>>>>    object oCheckboxItemStates is a cArray NO_IMAGE
50661>>>>>    end_object
50662>>>>>    // Get data out of the grid to this structure
50662>>>>>    procedure reset
50665>>>>>      send delete_data
50666>>>>>      send delete_data to (oAuxValues(self))
50667>>>>>      send delete_data to (oSortedData(self))
50668>>>>>      send delete_data to (oEntryStates(self))
50669>>>>>      send delete_data to (oSelectStates(self))
50670>>>>>      send delete_data to (oCheckboxItemStates(self))
50671>>>>>    //send delete_data to (oMessages(self))
50671>>>>>      send delete_data to (oItemColors(self))
50672>>>>>      set piCurrentGridID to 0
50673>>>>>      set piCurrentRow to 0
50674>>>>>      set piCurrentColumn to 0
50675>>>>>    end_procedure
50676>>>>>    // Get data from grid
50676>>>>>    procedure load_grid_data integer lhGrid
50679>>>>>      integer liMax liItem lhAuxValues lhEntryStates liCurrentItem liColumns
50679>>>>>      integer lhSelectStates lhCheckboxItemStates lhItemColors
50679>>>>>      move (oAuxValues(self)) to lhAuxValues
50680>>>>>      move (oEntryStates(self)) to lhEntryStates
50681>>>>>      move (oSelectStates(self)) to lhSelectStates
50682>>>>>      move (oCheckboxItemStates(self)) to lhCheckboxItemStates
50683>>>>>      move (oItemColors(self)) to lhItemColors
50684>>>>>      send delete_data
50685>>>>>      send delete_data to lhAuxValues
50686>>>>>      send delete_data to lhEntryStates
50687>>>>>      send delete_data to lhSelectStates
50688>>>>>      send delete_data to lhCheckboxItemStates
50689>>>>>      send delete_data to lhItemColors
50690>>>>>      set piCurrentGridID to lhGrid
50691>>>>>      get item_count of lhGrid to liMax
50692>>>>>      for liItem from 0 to (liMax-1)
50698>>>>>>
50698>>>>>        set value item liItem to (value(lhGrid,liItem))
50699>>>>>        set value of lhAuxValues item liItem to (aux_value(lhGrid,liItem))
50700>>>>>        set value of lhEntryStates item liItem to (entry_state(lhGrid,liItem))
50701>>>>>        set value of lhSelectStates item liItem to (select_state(lhGrid,liItem))
50702>>>>>        set value of lhCheckboxItemStates item liItem to (checkbox_item_state(lhGrid,liItem))
50703>>>>>        set value of lhItemColors item liItem to (ItemColor(lhGrid,liItem))
50704>>>>>      loop
50705>>>>>>
50705>>>>>      get current_item of lhGrid to liCurrentItem
50706>>>>>      get Grid_Columns lhGrid to liColumns
50707>>>>>      set piCurrentRow    to (liCurrentItem/liColumns)
50708>>>>>      set piCurrentColumn to (liCurrentItem-(liColumns*piCurrentRow(self)))
50709>>>>>    end_procedure
50710>>>>>
50710>>>>>    register_function iSpecialSortValueOnColumn.i integer liColumn returns integer
50710>>>>>    register_function sSortValue.ii integer liColumn integer liItem returns string
50710>>>>>    procedure sort_data integer lhGrid integer liColumn integer liDir
50713>>>>>      integer lhSortArr liRow liMax liColumns liItem liState lbCustom
50713>>>>>      string lsValue
50713>>>>>      move (oSortedData(self)) to lhSortArr
50714>>>>>      send delete_data to lhSortArr
50715>>>>>      get Grid_Columns lhGrid to liColumns
50716>>>>>      get item_count of lhGrid to liMax
50717>>>>>      get delegation_mode of lhGrid to liState
50718>>>>>      set delegation_mode of lhGrid to NO_DELEGATE_OR_ERROR
50719>>>>>      get iSpecialSortValueOnColumn.i of lhGrid liColumn to lbCustom
50720>>>>>      set delegation_mode of lhGrid to liState
50721>>>>>      move (liMax/liColumns) to liMax // Number of rows
50722>>>>>      for liRow from 0 to (liMax-1)
50728>>>>>>
50728>>>>>        move (liRow*liColumns+liColumn) to liItem
50729>>>>>        if lbCustom get sSortValue.ii of lhGrid liColumn liItem to lsValue
50732>>>>>        else get value of lhGrid item liItem to lsValue
50734>>>>>        move (lsValue+IntToStrR(liRow,6)) to lsValue
50735>>>>>        set value of lhSortArr item liRow to lsValue
50736>>>>>      loop
50737>>>>>>
50737>>>>>      send sort_items to lhSortArr liDir //ASCENDING
50738>>>>>    end_procedure
50739>>>>>    procedure fill_grid integer lhGrid
50742>>>>>      integer lhSortArr liRow liMax liItem liColumns liItmMin liItmMax liCurrentRow
50742>>>>>      integer grid_liRow
50742>>>>>      integer lhEntryStates lhAuxValues grid_liItem
50742>>>>>      integer lhSelectStates lhCheckboxItemStates lhItemColors
50742>>>>>      move (oSortedData(self)) to lhSortArr
50743>>>>>      move (oAuxValues(self)) to lhAuxValues
50744>>>>>      move (oEntryStates(self)) to lhEntryStates
50745>>>>>      move (oSelectStates(self)) to lhSelectStates
50746>>>>>      move (oCheckboxItemStates(self)) to lhCheckboxItemStates
50747>>>>>      move (oItemColors(self)) to lhItemColors
50748>>>>>      send delete_data to lhGrid
50749>>>>>      get Grid_Columns lhGrid to liColumns
50750>>>>>      get item_count of lhSortArr to liMax
50751>>>>>      get piCurrentRow to liCurrentRow
50752>>>>>      move 0 to grid_liItem
50753>>>>>      for liRow from 0 to (liMax-1)
50759>>>>>>
50759>>>>>        move (right(value(lhSortArr,liRow),6)) to grid_liRow
50760>>>>>        if grid_liRow eq liCurrentRow set piCurrentRow to liRow
50763>>>>>        move (grid_liRow*liColumns) to liItmMin
50764>>>>>        move (liItmMin+liColumns-1) to liItmMax
50765>>>>>        for liItem from liItmMin to liItmMax
50771>>>>>>
50771>>>>>          send add_item to lhGrid msg_none (value(self,liItem))
50772>>>>>          set checkbox_item_state of lhGrid item grid_liItem to (value(lhCheckboxItemStates,liItem))
50773>>>>>          set select_state        of lhGrid item grid_liItem to (value(lhSelectStates,liItem))
50774>>>>>          set aux_value           of lhGrid item grid_liItem to (value(lhAuxValues,liItem))
50775>>>>>          set entry_state         of lhGrid item grid_liItem to (value(lhEntryStates,liItem))
50776>>>>>          set itemcolor          of lhGrid item grid_liItem to (value(lhItemColors,liItem))
50777>>>>>          increment grid_liItem
50778>>>>>        loop
50779>>>>>>
50779>>>>>      loop
50780>>>>>>
50780>>>>>    end_procedure
50781>>>>>    procedure Sort_Grid integer lhGrid integer liColumn integer liDir
50784>>>>>      integer liCurrentRow liCurrentColumn liColumns
50784>>>>>      send cursor_wait to (cursor_control(self))
50785>>>>>      set dynamic_update_state of lhGrid to DFFALSE
50786>>>>>      send reset
50787>>>>>      send load_grid_data lhGrid
50788>>>>>      send sort_data lhGrid liColumn liDir
50789>>>>>      send fill_grid lhGrid
50790>>>>>      set dynamic_update_state of lhGrid to DFTRUE
50791>>>>>      get piCurrentRow to liCurrentRow
50792>>>>>      get piCurrentColumn to liCurrentColumn
50793>>>>>      get Grid_Columns lhGrid to liColumns
50794>>>>>      set current_item of lhGrid to (liColumns*liCurrentRow+liCurrentColumn)
50795>>>>>      send reset // Clean it up
50796>>>>>      send cursor_ready to (cursor_control(self))
50797>>>>>    end_procedure
50798>>>>>  end_object // oSortGrid_Data
50799>>>>>end_desktop_section
50804>>>>>
50804>>>>>//> Sort grid ascending by column liColumn. Note that unless special
50804>>>>>//> sort value functions are set up all columns are sorted by their
50804>>>>>//> ASCII value (not what the user expects if the column contains numeric
50804>>>>>//> or date data).
50804>>>>>procedure Grid_SortByColumn global integer lhGrid integer liColumn
50806>>>>>  send Sort_Grid to (oSortGrid_Data(self)) lhGrid liColumn ASCENDING
50807>>>>>end_procedure
50808>>>>>
50808>>>>>//> Sort grid descending by column liColumn. Note that unless special
50808>>>>>//> sort value functions are set up all columns are sorted by their
50808>>>>>//> ASCII value (not what the user expects if the column contains numeric
50808>>>>>//> or date data).
50808>>>>>procedure Grid_SortByColumn_Descending global integer lhGrid integer liColumn
50810>>>>>  send Sort_Grid to (oSortGrid_Data(self)) lhGrid liColumn DESCENDING
50811>>>>>end_procedure
50812>>>>>
50812>>>>>procedure Grid_AddCheckBoxItem global integer lhGrid integer liState
50814>>>>>  integer liItm
50814>>>>>  get item_count of lhGrid to liItm
50815>>>>>  send add_item to lhGrid msg_none ""
50816>>>>>  set checkbox_item_state of lhGrid item liItm to DFTRUE
50817>>>>>  set select_state of lhGrid item liItm to liState
50818>>>>>end_procedure
50819>>>>>procedure Grid_RowMakeSelectable global integer lhGrid
50821>>>>>end_procedure
50822>>>>>procedure Grid_RowSelectAll global integer lhGrid
50824>>>>>  integer liRow liMax liBase
50824>>>>>  get Grid_RowCount lhGrid to liMax
50825>>>>>  decrement liMax
50826>>>>>  for liRow from 0 to liMax
50832>>>>>>
50832>>>>>    get Grid_RowBaseItem lhGrid liRow to liBase
50833>>>>>    ifnot (item_shadow_state(lhGrid,liBase)) set select_state of lhGrid item liBase to DFTRUE
50836>>>>>  loop
50837>>>>>>
50837>>>>>end_procedure
50838>>>>>procedure Grid_RowDeselectAll global integer lhGrid
50840>>>>>  integer liRow liMax liBase
50840>>>>>  get Grid_RowCount lhGrid to liMax
50841>>>>>  decrement liMax
50842>>>>>  for liRow from 0 to liMax
50848>>>>>>
50848>>>>>    get Grid_RowBaseItem lhGrid liRow to liBase
50849>>>>>    ifnot (item_shadow_state(lhGrid,liBase)) set select_state of lhGrid item liBase to DFFALSE
50852>>>>>  loop
50853>>>>>>
50853>>>>>end_procedure
50854>>>>>procedure Grid_RowSelectInvert global integer lhGrid
50856>>>>>  integer liRow liMax liSelect liBase
50856>>>>>  get Grid_RowCount lhGrid to liMax
50857>>>>>  decrement liMax
50858>>>>>  for liRow from 0 to liMax
50864>>>>>>
50864>>>>>    get Grid_RowBaseItem lhGrid liRow to liBase
50865>>>>>    get select_state of lhGrid item liBase to liSelect
50866>>>>>    ifnot (item_shadow_state(lhGrid,liBase)) set select_state of lhGrid item liBase to (not(liSelect))
50869>>>>>  loop
50870>>>>>>
50870>>>>>end_procedure
50871>>>>>procedure Grid_RowSelectCostum global integer lhGrid integer liGet
50873>>>>>  integer liRow liMax liSelect liBase
50873>>>>>  get Grid_RowCount lhGrid to liMax
50874>>>>>  decrement liMax
50875>>>>>  for liRow from 0 to liMax
50881>>>>>>
50881>>>>>    move (Grid_RowBaseItem(lhGrid,liRow)) to liBase
50882>>>>>    get liGet of lhGrid liRow liBase to liSelect
50883>>>>>    set select_state of lhGrid item liBase to liSelect
50884>>>>>  loop
50885>>>>>>
50885>>>>>end_procedure
50886>>>>>procedure Grid_RowCallBackSelected global integer lhGrid integer liMsg integer lhObj
50888>>>>>  integer liRow liMax liBase liSelect lhTmpObj
50888>>>>>  if (num_arguments>2) move lhObj to lhTmpObj
50891>>>>>  else move lhGrid to lhTmpObj
50893>>>>>  get Grid_RowCount lhGrid to liMax
50894>>>>>  decrement liMax
50895>>>>>  for liRow from 0 to liMax
50901>>>>>>
50901>>>>>    move (Grid_RowBaseItem(lhGrid,liRow)) to liBase
50902>>>>>    get select_state of lhGrid item liBase to liSelect
50903>>>>>    if liSelect send liMsg to lhTmpObj liRow liBase
50906>>>>>  loop
50907>>>>>>
50907>>>>>end_procedure
50908>>>>>
50908>>>>>procedure Grid_RowCallBackAll global integer lhGrid integer liMsg integer lhObj
50910>>>>>  integer liRow liMax liBase lhTmpObj
50910>>>>>  if (num_arguments>2) move lhObj to lhTmpObj
50913>>>>>  else move lhGrid to lhTmpObj
50915>>>>>  get Grid_RowCount lhGrid to liMax
50916>>>>>  decrement liMax
50917>>>>>  for liRow from 0 to liMax
50923>>>>>>
50923>>>>>    move (Grid_RowBaseItem(lhGrid,liRow)) to liBase
50924>>>>>    send liMsg to lhTmpObj liRow liBase
50925>>>>>  loop
50926>>>>>>
50926>>>>>end_procedure
50927>>>>>
50927>>>>>//> Returns number of selected rows
50927>>>>>function Grid_SelectedRows global integer lhGrid returns integer
50929>>>>>  integer liRow liMax liBase liSelect liRval
50929>>>>>  move 0 to liRval
50930>>>>>  get Grid_RowCount lhGrid to liMax
50931>>>>>  decrement liMax
50932>>>>>  for liRow from 0 to liMax
50938>>>>>>
50938>>>>>    move (Grid_RowBaseItem(lhGrid,liRow)) to liBase
50939>>>>>    get select_state of lhGrid item liBase to liSelect
50940>>>>>    if liSelect increment liRval
50943>>>>>  loop
50944>>>>>>
50944>>>>>  function_return liRval
50945>>>>>end_function
50946>>>>>
50946>>>>>procedure Set Grid_CurrentRow global integer lhGrid integer liRow
50948>>>>>  integer liBase
50948>>>>>  get Grid_RowBaseItem lhGrid liRow to liBase
50949>>>>>  set current_item to liBase
50950>>>>>end_procedure
50951>>>>>
50951>>>>>enumeration_list
50951>>>>>  define GD_FORMAT
50951>>>>>  define GD_COMMA
50951>>>>>  define GD_TAB
50951>>>>>end_enumeration_list
50951>>>>>
50951>>>>>desktop_section
50956>>>>>  object Grid_WriteToFileColumnWidthArray is a cArray
50958>>>>>    property integer phCurrentGrid public ""
50960>>>>>    item_property_list
50960>>>>>      item_property integer piWidth.i
50960>>>>>      item_property integer piRightAlign.i
50960>>>>>    end_item_property_list
#REM 50997 DEFINE FUNCTION PIRIGHTALIGN.I INTEGER LIROW RETURNS INTEGER
#REM 51002 DEFINE PROCEDURE SET PIRIGHTALIGN.I INTEGER LIROW INTEGER VALUE
#REM 51007 DEFINE FUNCTION PIWIDTH.I INTEGER LIROW RETURNS INTEGER
#REM 51012 DEFINE PROCEDURE SET PIWIDTH.I INTEGER LIROW INTEGER VALUE
51018>>>>>    procedure DoReadGrid integer lhGrid
51021>>>>>      integer liRows liColumns liRow liColumn liWidth liDecSep
51021>>>>>      string lsValue
51021>>>>>      get_attribute DF_DECIMAL_SEPARATOR to liDecSep
51024>>>>>      send delete_data
51025>>>>>      get Grid_Columns lhGrid to liColumns
51026>>>>>      get Grid_RowCount lhGrid to liRows
51027>>>>>      for liColumn from 0 to (liColumns-1)
51033>>>>>>
51033>>>>>        set piRightAlign.i liColumn to DFTRUE
51034>>>>>      loop
51035>>>>>>
51035>>>>>      for liRow from 0 to (liRows-1)
51041>>>>>>
51041>>>>>        for liColumn from 0 to (liColumns-1)
51047>>>>>>
51047>>>>>          if (checkbox_item_state(lhGrid,liRow*liColumns+liColumn)) move "XXX" to lsValue
51050>>>>>          else get value of lhGrid item (liRow*liColumns+liColumn) to lsValue
51052>>>>>          move (rtrim(lsValue)) to lsValue
51053>>>>>          move (length(lsValue)) to liWidth
51054>>>>>          if (liWidth>integer(piWidth.i(self,liColumn))) set piWidth.i liColumn to liWidth
51057>>>>>          ifnot (StringIsNumber(lsValue,liDecSep)) set piRightAlign.i liColumn to DFFALSE
51060>>>>>        loop
51061>>>>>>
51061>>>>>      loop
51062>>>>>>
51062>>>>>      set phCurrentGrid to liWidth
51063>>>>>    end_procedure
51064>>>>>  end_object
51065>>>>>end_desktop_section
51070>>>>>
51070>>>>>function Grid_DataWidth global integer lhGrid integer liColumn returns integer
51072>>>>>  function_return (piWidth.i(Grid_WriteToFileColumnWidthArray(self),liColumn))
51073>>>>>end_function
51074>>>>>
51074>>>>>procedure Grid_DoReadDataWidth global integer lhGrid
51076>>>>>  send DoReadGrid to (Grid_WriteToFileColumnWidthArray(self)) lhGrid
51077>>>>>end_procedure
51078>>>>>
51078>>>>>function Grid_WriteToFile_Help global integer liFormat string lsValue integer liWidth integer liRightAlign returns string
51080>>>>>  if (liFormat=GD_FORMAT) begin
51082>>>>>    if (length(lsValue)>liWidth) move (left(lsValue,liWidth)) to lsValue
51085>>>>>    if liRightAlign move (RightShift(lsValue,liWidth)) to lsValue
51088>>>>>    else move (pad(lsValue,liWidth)) to lsValue
51090>>>>>  end
51090>>>>>>
51090>>>>>  if (liFormat=GD_COMMA) begin
51092>>>>>    if "," in lsValue begin
51094>>>>>      move (replaces('"',lsValue,"'")) to lsValue
51095>>>>>      move ('"'+lsValue+'"') to lsValue
51096>>>>>    end
51096>>>>>>
51096>>>>>  end
51096>>>>>>
51096>>>>>  function_return lsValue
51097>>>>>end_function
51098>>>>>
51098>>>>>// This procedure will write the entire contents of the Grid passed as
51098>>>>>// object handle object to a
51098>>>>>// sequential
51098>>>>>procedure Grid_WriteToFile global integer lhGrid integer liChannel integer liFormat
51100>>>>>  integer liRows liColumns liRow liColumn liWidth liRightAlign
51100>>>>>  string lsValue
51100>>>>>  get Grid_Columns lhGrid to liColumns
51101>>>>>  get Grid_RowCount lhGrid to liRows
51102>>>>>  send Grid_DoReadDataWidth lhGrid
51103>>>>>  for liColumn from 0 to (liColumns-1)
51109>>>>>>
51109>>>>>    get header_label of lhGrid liColumn to lsValue
51110>>>>>    get Grid_DataWidth lhGrid liColumn to liWidth
51111>>>>>    get piRightAlign.i of (Grid_WriteToFileColumnWidthArray(self)) liColumn to liRightAlign
51112>>>>>    get Grid_WriteToFile_Help liFormat lsValue liWidth liRightAlign to lsValue
51113>>>>>    write channel liChannel (ToAnsi(lsValue))
51115>>>>>    if liColumn ne (liColumns-1) begin
51117>>>>>      if (liFormat=GD_FORMAT) write " "
51120>>>>>      if (liFormat=GD_COMMA ) write ","
51123>>>>>      if (liFormat=GD_TAB   ) write (character(8))
51126>>>>>    end
51126>>>>>>
51126>>>>>  loop
51127>>>>>>
51127>>>>>  writeln channel liChannel ""
51130>>>>>  for liRow from 0 to (liRows-1)
51136>>>>>>
51136>>>>>    for liColumn from 0 to (liColumns-1)
51142>>>>>>
51142>>>>>      if (checkbox_item_state(lhGrid,liRow*liColumns+liColumn)) get select_state of lhGrid item (liRow*liColumns+liColumn) to lsValue
51145>>>>>      else get value of lhGrid item (liRow*liColumns+liColumn) to lsValue
51147>>>>>      get Grid_DataWidth lhGrid liColumn to liWidth
51148>>>>>      get piRightAlign.i of (Grid_WriteToFileColumnWidthArray(self)) liColumn to liRightAlign
51149>>>>>      get Grid_WriteToFile_Help liFormat lsValue liWidth liRightAlign to lsValue
51150>>>>>      write channel liChannel (ToAnsi(lsValue))
51152>>>>>      if liColumn ne (liColumns-1) begin
51154>>>>>        if (liFormat=GD_FORMAT) write " "
51157>>>>>        if (liFormat=GD_COMMA ) write ","
51160>>>>>        if (liFormat=GD_TAB   ) write (character(8))
51163>>>>>      end
51163>>>>>>
51163>>>>>    loop
51164>>>>>>
51164>>>>>    writeln channel liChannel ""
51167>>>>>  loop
51168>>>>>>
51168>>>>>end_procedure
51169>>>>>
51169>>>>>// The Grid_StateValue was developed in order to be able to check if a Grid (not a dbGrid) had
51169>>>>>// been changed by the user (by comparing the Grid
51169>>>>>function Grid_StateValue global integer lhGrid returns string
51171>>>>>  integer liColumns liRows liColumn liRow
51171>>>>>  string lsState lsValue
51171>>>>>  get Grid_Columns lhGrid to liColumns
51172>>>>>  get Grid_RowCount lhGrid to liRows
51173>>>>>  for liRow from 0 to (liRows-1)
51179>>>>>>
51179>>>>>    for liColumn from 0 to (liColumns-1)
51185>>>>>>
51185>>>>>
51185>>>>>      if (checkbox_item_state(lhGrid,liRow*liColumns+liColumn)) get select_state of lhGrid item (liRow*liColumns+liColumn) to lsValue
51188>>>>>      else get value of lhGrid item (liRow*liColumns+liColumn) to lsValue
51190>>>>>      move (lsState+"|"+lsValue) to lsValue
51191>>>>>    loop
51192>>>>>>
51192>>>>>  loop
51193>>>>>>
51193>>>>>  function_return lsState
51194>>>>>end_function
51195>>>>>
51195>>>>>// procedure row_change integer liRowFrom integer liRowTo
51195>>>>>// end_procedure
51195>>>>>// procedure item_change integer liItm1 integer liItm2 returns integer
51195>>>>>//   integer liRval liColumns
51195>>>>>//   get Grid_Columns self to liColumns
51195>>>>>//   forward get msg_item_change liItm1 liItm2 to liRval
51195>>>>>//   if (liItm1/liColumns) ne (liItm2/liColumns) send row_change (liItm1/liColumns) (liItm2/liColumns)
51195>>>>>//   procedure_return liRval
51195>>>>>// end_procedure
51195>>>>>
51195>>>>>// procedure select_toggling integer liItem integer lbState
51195>>>>>//   integer liCurrentItem liColumns
51195>>>>>//   get Grid_Columns self to liColumns
51195>>>>>//   get current_item to liCurrentItem
51195>>>>>//   move ((liCurrentItem/liColumns)*liColumns) to liCurrentItem // Redirect to first column
51195>>>>>//   forward send select_toggling liCurrentItem lbState
51195>>>>>// end_procedure
51195>>>>>
51195>>>>>procedure Grid_DoWriteToFile global integer lhGrid
51197>>>>>  integer liChannel
51197>>>>>  string lsTempFileName
51197>>>>>  get SEQ_FirstDirInDfPath to lsTempFileName
51198>>>>>  get SEQ_ComposeAbsoluteFileName lsTempFileName "temp.txt" to lsTempFileName
51199>>>>>
51199>>>>>  get SEQ_DirectOutput lsTempFileName to liChannel
51200>>>>>  if liChannel ge 0 begin
51202>>>>>    send Grid_WriteToFile lhGrid liChannel GD_FORMAT
51203>>>>>    send SEQ_CloseOutput liChannel
51204>>>>>    runprogram BACKGROUND ("notepad "+lsTempFileName)
51205>>>>>  end
51205>>>>>>
51205>>>>>end_procedure
51206>>>>>
51206>>>>>procedure Grid_SetRowColor global integer lhGrid integer liRow integer liColor
51208>>>>>  integer liBase liMax liItem
51208>>>>>  get Grid_RowBaseItem lhGrid liRow to liBase
51209>>>>>  get Grid_Columns lhGrid to liMax
51210>>>>>  for liItem from 0 to (liMax-1)
51216>>>>>>
51216>>>>>    set itemcolor of lhGrid item (liBase+liItem) to liColor
51217>>>>>  loop
51218>>>>>>
51218>>>>>end_procedure
51219>>>>>
51219>>>>>procedure Grid_AddRowToGrid global integer lhGrid integer liRow integer lhTargetGrid
51221>>>>>  integer liBase liMax liItem liTargetBase
51221>>>>>  string lsValue
51221>>>>>  get Grid_RowBaseItem lhGrid liRow to liBase
51222>>>>>  get Grid_Columns lhGrid to liMax
51223>>>>>  get item_count of lhTargetGrid to liTargetBase
51224>>>>>  for liItem from 0 to (liMax-1)
51230>>>>>>
51230>>>>>    get value of lhGrid item (liBase+liItem) to lsValue
51231>>>>>    send add_item to lhTargetGrid MSG_NONE lsValue
51232>>>>>    set entry_state         of lhTargetGrid item (liTargetBase+liItem) to (entry_state(lhGrid,liBase+liItem))
51233>>>>>    set checkbox_item_state of lhTargetGrid item (liTargetBase+liItem) to (checkbox_item_state(lhGrid,liBase+liItem))
51234>>>>>    set aux_value           of lhTargetGrid item (liTargetBase+liItem) to (aux_value(lhGrid,liBase+liItem))
51235>>>>>    set select_state        of lhTargetGrid item (liTargetBase+liItem) to (select_state(lhGrid,liBase+liItem))
51236>>>>>    set itemcolor           of lhTargetGrid item (liTargetBase+liItem) to (itemcolor(lhGrid,liBase+liItem))
51237>>>>>  loop
51238>>>>>>
51238>>>>>end_procedure
51239>>>>>
51239>>>
51239>>>// This are only declared if FDX.UTL has been included by the program source:
51239>>>register_procedure AttrType_Callback integer attrtype# integer msg# integer obj#
51239>>>
51239>>>class cFdxGlobalAttrGrid is a aps.Grid
51240>>>  procedure construct_object integer img#
51242>>>    forward send construct_object img#
51244>>>    set line_width to 2 0
51245>>>    set aps_column_abstract 0 to 0 AFT_ASCII30
51246>>>    set aps_column_abstract 1 to 0 AFT_ASCII60
51247>>>    set header_label 0 to "Parameter"
51248>>>    set header_label 1 to "Value"
51249>>>    set highlight_row_state to true
51250>>> // set highlight_row_color to (rgb(0,255,255))
51250>>> // set current_item_color to (rgb(0,255,255))
51250>>>    set CurrentCellColor     to clHighlight
51251>>>    set CurrentCellTextColor to clHighlightText
51252>>>    set CurrentRowColor      to clHighlight
51253>>>    set CurrentRowTextColor  to clHighlightText
51254>>>    set select_mode to no_select
51255>>>    set size to 180 0
51256>>>    object oAttributeFilter is a cArray no_image // Attributes that should not display
51258>>>    end_object
51259>>>    send IgnoreAttribute DF_TRAN_COUNT
51260>>>    send IgnoreAttribute DF_TRANSACTION_ABORT
51261>>>    send IgnoreAttribute DF_ALL_FILES_TOUCHED
51262>>>    on_key key_ctrl+key_w send DoWriteToFile
51263>>>  end_procedure
51264>>>
51264>>>  procedure DoWriteToFile
51266>>>    send Grid_DoWriteToFile self
51267>>>  end_procedure
51268>>>
51268>>>  function MakeTitleNice string title# returns string
51270>>>    function_return title#
51271>>>  end_function
51272>>>  procedure IgnoreAttribute integer attr#
51274>>>    integer arr#
51274>>>    move (oAttributeFilter(self)) to arr#
51275>>>    set value of arr# item (item_count(arr#)) to attr#
51276>>>  end_procedure
51277>>>  function iIgnoreAttribute integer attr# returns integer
51279>>>    integer arr# itm# max#
51279>>>    move (oAttributeFilter(self)) to arr#
51280>>>    get item_count of arr# to max#
51281>>>    for itm# from 0 to (max#-1)
51287>>>>
51287>>>      if (integer(value(arr#,itm#))) eq attr# function_return 1
51290>>>    loop
51291>>>>
51291>>>    function_return 0
51292>>>  end_function
51293>>>  procedure add_item integer msg# string value#
51295>>>    forward send add_item msg# value#
51297>>>    set entry_state item (item_count(self)-1) to false
51298>>>  end_procedure
51299>>>  procedure add_path_value string title# string path# string sep#
51301>>>    integer itm# max#
51301>>>    get MakeTitleNice title# to title#
51302>>>    move (HowManyWords(path#,sep#)) to max#
51303>>>    if max# begin
51305>>>      for itm# from 1 to max#
51311>>>>
51311>>>        send add_item msg_none title#
51312>>>        send add_item msg_none (ExtractWord(path#,sep#,itm#))
51313>>>        move "" to title#
51314>>>      loop
51315>>>>
51315>>>    end
51315>>>>
51315>>>    else begin
51316>>>      send add_item msg_none title#
51317>>>      send add_item msg_none ""
51318>>>    end
51318>>>>
51318>>>  end_procedure
51319>>>  procedure fill_list_fdx_help integer oFDX# integer attr#
51321>>>    ifnot (iIgnoreAttribute(self,attr#)) begin
51323>>>      if attr# eq DF_OPEN_PATH send add_path_value (API_Attr_DisplayName(attr#)) (API_Attr_DisplayValueName(attr#,AttrValue_GLOBAL(oFDX#,attr#))) (FDX_OtherAttr_Value(oFDX#,OA_PATH_SEPARATOR))
51326>>>      else begin
51327>>>        send add_item msg_none (MakeTitleNice(self,API_Attr_DisplayName(attr#)))
51328>>>        send add_item msg_none (API_Attr_DisplayValueName(attr#,AttrValue_GLOBAL(oFDX#,attr#)))
51329>>>      end
51329>>>>
51329>>>    end
51329>>>>
51329>>>  end_procedure
51330>>>  procedure fill_list_api_help integer attr#
51332>>>    ifnot (iIgnoreAttribute(self,attr#)) begin
51334>>>      if attr# eq DF_OPEN_PATH send add_path_value (API_Attr_DisplayName(attr#)) (API_Attr_DisplayValueName(attr#,API_AttrValue_GLOBAL(attr#))) (API_OtherAttr_Value(OA_PATH_SEPARATOR))
51337>>>      else begin
51338>>>        send add_item msg_none (MakeTitleNice(self,API_Attr_DisplayName(attr#)))
51339>>>        send add_item msg_none (API_Attr_DisplayValueName(attr#,API_AttrValue_GLOBAL(attr#)))
51340>>>      end
51340>>>>
51340>>>    end
51340>>>>
51340>>>  end_procedure
51341>>>  procedure fill_list.i integer oFDX#
51343>>>    integer attr# max#
51343>>>    send delete_data
51344>>>    for attr# from 0 to (OA_MAX-1)
51350>>>>
51350>>>      if (attr#=OA_PATH) send add_path_value (OtherAttr_DisplayName(attr#)) (FDX_OtherAttr_Value(oFDX#,attr#)) (FDX_OtherAttr_Value(oFDX#,OA_PATH_SEPARATOR))
51353>>>      else begin
51354>>>        send add_item msg_none (MakeTitleNice(self,OtherAttr_DisplayName(attr#)))
51355>>>        send add_item msg_none (OtherAttr_ValueDisplayName(attr#,FDX_OtherAttr_Value(oFDX#,attr#)))
51356>>>      end
51356>>>>
51356>>>    loop
51357>>>>
51357>>>    if oFDX# send AttrType_Callback to oFDX# ATTRTYPE_GLOBAL msg_fill_list_fdx_help self
51360>>>    else send API_AttrType_Callback ATTRTYPE_GLOBAL msg_fill_list_api_help self
51362>>>  end_procedure
51363>>>end_class
51364>>>object oFdxModalDisplayGlobalAttributes is a aps.ModalPanel label "Global attributes"
51367>>>  on_key kcancel send close_panel
51368>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
51369>>>  set Locate_Mode to CENTER_ON_SCREEN
51370>>>  object oLst is a cFdxGlobalAttrGrid
51372>>>  end_object
51373>>>  object oBtn is a aps.Multi_Button
51375>>>    on_item t.btn.close send close_panel
51376>>>  end_object
51377>>>  send aps_locate_multi_buttons
51378>>>  procedure run.i integer oFDX#
51381>>>    if oFDX# set label to ("Global attributes ("+psFileName(oFDX#)+")")
51384>>>    else set label     to "Global attributes (Current system)"
51386>>>    send fill_list.i to (oLst(self)) oFDX#
51387>>>    send popup
51388>>>  end_procedure
51389>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
51392>>>    send aps_resize (oLst(self)) delta_rw# 0
51393>>>    send aps_register_multi_button (oBtn(self))
51394>>>    send aps_locate_multi_buttons
51395>>>    send aps_auto_size_container
51396>>>  end_procedure
51397>>>end_object
51398>>>
51398>>>//> The FDX_DisplayGlobalAttributes procedure will display the global
51398>>>//> attribute settings either for the current runtime (if parameter
51398>>>//> oFDX# is 0) or as read from a FDX object (if oFDX# the object ID
51398>>>//> of an FDX object).
51398>>>procedure FDX_ModalDisplayGlobalAttributes global integer oFDX#
51400>>>  send run.i to (oFdxModalDisplayGlobalAttributes(self)) oFDX#
51401>>>end_procedure
51402>>>
51402>>>
51402>>>// *** TEST CODE ****************************************************************
51402>>>
51402>>>// Use FDX.nui      // cFDX class
51402>>>// set verbose_state of error_info_object to true // Always display line number!
51402>>>//
51402>>>// send FDX_ModalDisplayGlobalAttributes 0 // 0 Means without an FDX object
51402>>>//
51402>>>// object oFDX is a cFDX
51402>>>//  send Read_Current_Filelist FDX_ALL_FILES
51402>>>// end_object
51402>>>//
51402>>>// send FDX_ModalDisplayGlobalAttributes (oFDX(self))
51402>Use Fdx2.utl     // FDX aware object for displaying a table definiton
Including file: fdx2.utl    (C:\Apps\VDFQuery\AppSrc\fdx2.utl)
51402>>>//**********************************************************************
51402>>>// Use Fdx2.utl     // FDX aware object for displaying a table definition
51402>>>//
51402>>>// By Sture Andersen
51402>>>//
51402>>>// Create: Tue  09-02-2000
51402>>>// Update:
51402>>>//
51402>>>//**********************************************************************
51402>>>Use Fdx_Attr.nui // FDX compatible attribute functions
51402>>>Use DBMS.utl     // Basic DBMS functions
Including file: dbms.utl    (C:\Apps\VDFQuery\AppSrc\dbms.utl)
51402>>>>>Use DBMS.nui     // Basic DBMS functions
51402>>>>>Use MsgBox.utl   // obs procedure
Including file: msgbox.utl    (C:\Apps\VDFQuery\AppSrc\msgbox.utl)
51402>>>>>>>// Use MsgBox.utl   // obs procedure
51402>>>>>>>Use UI // Necessary to define IS$WINDOWS (if windows)
51402>>>>>>>Use Language
51402>>>>>>>
51402>>>>>>>
51402>>>>>>>// ======================================================================
51402>>>>>>>//                           OBS MESSAGE
51402>>>>>>>// ======================================================================
51402>>>>>>>Use MsgBox      // DAC class
51402>>>>>>>Use Buttons.utl // Button texts
51402>>>>>>>
51402>>>>>>>procedure obs global string str#
51404>>>>>>>  integer iArg max# self# focus#
51404>>>>>>>  string msg# line#
51404>>>>>>>  move "" to msg#
51405>>>>>>>  for iArg from 1 to num_arguments
51411>>>>>>>>
51411>>>>>>>    MoveStr iArg& to line# // tricky way to parse passed arguments
51412>>>>>>>>
51412>>>>>>>    move (msg#+line#) to msg#
51413>>>>>>>    if iArg ne num_arguments move (msg#+character(10)) to msg#
51416>>>>>>>  loop
51417>>>>>>>>
51417>>>>>>>  move self to self#
51418>>>>>>>  get focus of desktop to focus#
51419>>>>>>>  if focus# gt desktop move focus# to self
51422>>>>>>>  send info_box msg# t.MsgBox.Message
51423>>>>>>>  move self# to self
51424>>>>>>>end_procedure
51425>>>>>>>
51425>>>>>>>// ======================================================================
51425>>>>>>>//                          CONFIRM LIST
51425>>>>>>>// ======================================================================
51425>>>>>>>
51425>>>>>>>use APS
51425>>>>>>>object oConfirm_List is a aps.ModalPanel
51427>>>>>>>  set locate_mode to center_on_screen
51428>>>>>>>  property integer pResult public 0
51430>>>>>>>  on_key kcancel send close_panel_ok
51431>>>>>>>  object lbl is a aps.textbox
51433>>>>>>>  end_object
51434>>>>>>>  send aps_goto_max_row
51435>>>>>>>  object lst is a aps.list no_image
51437>>>>>>>    set size to 105 150
51438>>>>>>>    set select_mode to no_select
51439>>>>>>>  end_object
51440>>>>>>>  procedure close_panel_ok
51443>>>>>>>    set pResult to 1
51444>>>>>>>    send close_panel
51445>>>>>>>  end_procedure
51446>>>>>>>  object btn1 is a aps.Multi_Button
51448>>>>>>>    on_item t.btn.ok send close_panel_ok
51449>>>>>>>  end_object
51450>>>>>>>  object btn2 is a aps.Multi_Button
51452>>>>>>>    on_item t.btn.cancel send close_panel
51453>>>>>>>  end_object
51454>>>>>>>  send aps_locate_multi_buttons
51455>>>>>>>  procedure delete_data
51458>>>>>>>    send delete_data to (lst(self))
51459>>>>>>>  end_procedure
51460>>>>>>>  procedure run.ss string title# string header#
51463>>>>>>>    integer grb#
51463>>>>>>>    set label to title#
51464>>>>>>>    set value of (lbl(self)) to header#
51465>>>>>>>    send popup
51466>>>>>>>    send delete_data
51467>>>>>>>  end_procedure
51468>>>>>>>  function irun.ss string title# string header# returns integer
51471>>>>>>>    integer rval#
51471>>>>>>>    set label to title#
51472>>>>>>>    set value of (lbl(self)) to header#
51473>>>>>>>    set pResult to 0
51474>>>>>>>    send popup
51475>>>>>>>    get pResult to rval#
51476>>>>>>>    send delete_data
51477>>>>>>>    function_return rval#
51478>>>>>>>  end_function
51479>>>>>>>end_object
51480>>>>>>>
51480>>>>>>>procedure Confirm_List_Reset
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
51482>>>>>>>  send delete_data to (oConfirm_List(self))
51483>>>>>>>end_procedure
51484>>>>>>>procedure Confirm_List_Add string str#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
51486>>>>>>>  integer obj#
51486>>>>>>>  move (lst(oConfirm_List(self))) to obj#
51487>>>>>>>  send add_item to obj# msg_none str#
51488>>>>>>>end_procedure
51489>>>>>>>procedure Confirm_List_Go string title# string header#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
51491>>>>>>>  send run.ss to (oConfirm_List(self)) title# header#
51492>>>>>>>end_procedure
51493>>>>>>>function Confirm_List_Confirm global string title# string header# returns integer
51495>>>>>>>  function_return (irun.ss(oConfirm_List(self),title#,header#))
51496>>>>>>>end_function
51497>>>>>>>
51497>>>>>>>// ======================================================================
51497>>>>>>>//                          YES/NO OBJECT
51497>>>>>>>// ======================================================================
51497>>>>>>>
51497>>>>>>>
51497>>>>>>>function MB_Verify global string str# integer def# returns integer
51499>>>>>>>  integer rval#
51499>>>>>>>  if def# move MB_DEFBUTTON1 to def#
51502>>>>>>>  else move MB_DEFBUTTON2 to def#
51504>>>>>>>  move (yesno_box(str#,t.MsgBox.Question,def#)) to rval#
51505>>>>>>>  function_return (rval#=mbr_yes)
51506>>>>>>>end_function
51507>>>>>>>
51507>>>>>>>function MB_Verify4 global string str1# string str2# string str3# string str4# integer def# returns integer
51509>>>>>>>  string lf#
51509>>>>>>>  move (character(10)) to lf#
51510>>>>>>>  function_return (MB_verify(str1#+lf#+str2#+lf#+str3#+lf#+str4#,def#))
51511>>>>>>>end_function
51512>>>>>>>
51512>>>>>>>function MB_CancelOnKeypress global string str# returns integer
51514>>>>>>>end_function
51515>>>>>>>
51515>>>>>
51515>>>>>Use Windows
51515>>>>>Use file_dlg    // OpenDialog class (DAC)
51515>>>>>object oDBMS_FlDlg is a OpenDialog
51517>>>>>  set NoChangeDir_State to true
51518>>>>>end_object
51519>>>>>
51519>>>>>function DBMS_OpenFileBrowse global string fn# integer file# integer mode# integer buf_index# returns integer
51521>>>>>  integer obj# rval#
51521>>>>>  move 0 to rval#
51522>>>>>  move (oDBMS_FlDlg(self)) to obj#
51523>>>>>  set Dialog_Caption of obj# to ("Locate "+fn#)
51524>>>>>  set Filter_String  of obj# to ("Standard ("+fn#+")|"+fn#+"|DAT files|*.dat|All files|*.*")
51525>>>>>  if (Show_Dialog(obj#)) begin
51527>>>>>    move (File_Name(obj#)) to fn#
51528>>>>>    if fn# ne "" move (DBMS_OpenFileAs(fn#,file#,mode#,buf_index#)) to rval#
51531>>>>>  end
51531>>>>>>
51531>>>>>  function_return rval#
51532>>>>>end_function
51533>>>>>
51533>>>>>// Procedure private.DBMS_OpenFile is used by the DBMS_OPEN command.
51533>>>>>// It takes the following parameters:
51533>>>>>//
51533>>>>>// line_no#   integer Number of the calling command line
51533>>>>>// file#      integer Number of the file to open
51533>>>>>// as#        boolean Is this an 'OPEN AS' thing?
51533>>>>>// as_string# string  Name of the file to open if opened as
51533>>>>>// mode#      integer DF_SHARE or DF_EXCLUSIVE
51533>>>>>// index#     integer If non zero this specifies which index should be buffered
51533>>>>>// dfname#    string  Logical name of the file#
51533>>>>>
51533>>>>>procedure private.DBMS_OpenFile global integer line_no# integer file# integer as# string as_str# integer mode# integer index# string dffile#
51535>>>>>  integer ok#
51535>>>>>  string msg#
51535>>>>>  if as# move (DBMS_OpenFileAs(as_str#,file#,mode#,index#)) to ok#
51538>>>>>  else move (DBMS_OpenFile(file#,mode#,index#)) to ok#
51540>>>>>  ifnot ok# begin
51542>>>>>    move ("Datafile could not be opened."+character(10)) to msg#
51543>>>>>    move (msg#+"File number "+string(file#)+" was attempted opened in line "+string(line_no#)+"."+character(10)) to msg#
51544>>>>>    if as# move (msg#+"Physical file name is: "+as_str#+character(10)) to msg#
51547>>>>>    else   move (msg#+"Physical file name is: "+DBMS_Rootname(file#)+character(10)) to msg#
51549>>>>>    if dffile# eq "DFFILE_NAME_NOT_FOUND" move (msg#+"No logical file name was specified.") to msg#
51552>>>>>    else move (msg#+"Logical file name is: "+dffile#) to msg#
51554>>>>>    send obs msg#
51555>>>>>  end
51555>>>>>>
51555>>>>>end_procedure
51556>>>>>
51556>>>Use GridUtil.utl // Grid and List utilities
51556>>>
51556>>>Use APS          // Auto Positioning and Sizing classes for VDF
51556>>>class cFDX.Display.FieldList is a aps.Grid
51557>>>  register_function piFDX_Server returns integer
51557>>>  register_function piMain_File  returns integer
51557>>>  procedure construct_object integer img#
51559>>>    forward send construct_object img#
51561>>>    property integer piDisplayOldNumbers public 0
51562>>>    on_key kuser send ToggleDisplayOldNumbers
51563>>>    send GridPrepare_AddColumn "#"        AFT_ASCII2
51564>>>    send GridPrepare_AddColumn "Name"     AFT_ASCII15
51565>>>    send GridPrepare_AddColumn "Type"     AFT_ASCII4
51566>>>    send GridPrepare_AddColumn "Len"      AFT_ASCII5
51567>>>    send GridPrepare_AddColumn "Offset"   AFT_ASCII5
51568>>>    send GridPrepare_AddColumn "Idx"      AFT_ASCII3
51569>>>    send GridPrepare_AddColumn "Relation" AFT_ASCII30
51570>>>    send GridPrepare_Apply self
51571>>>    set select_mode to no_select
51572>>>    on_key key_ctrl+key_w send DoWriteToFile
51573>>>  end_procedure
51574>>>  procedure DoWriteToFile
51576>>>    send Grid_DoWriteToFile self
51577>>>  end_procedure
51578>>>  procedure add_item integer msg# string value#
51580>>>    forward send add_item msg# value#
51582>>>    set entry_state item (item_count(self)-1) to false
51583>>>  end_procedure
51584>>>  function sRelFieldName.ii integer file# integer field# returns string
51586>>>    integer fdx#
51586>>>    string file_name# field_name#
51586>>>    ifnot file# function_return ""
51589>>>    get piFDX_Server to fdx#
51590>>>    if fdx# begin
51592>>>      get FDX_AttrValue_FILELIST fdx# DF_FILE_LOGICAL_NAME file# to file_name#
51593>>>      get FDX_AttrValue_FIELD fdx# DF_FIELD_NAME file# field# to field_name#
51594>>>    end
51594>>>>
51594>>>    else begin
51595>>>      get API_AttrValue_FILELIST DF_FILE_LOGICAL_NAME file# to file_name#
51596>>>      if file_name# eq "" move ("FILE"+string(file#)) to file_name#
51599>>>      if (DBMS_IsOpenFile(file#)) get API_AttrValue_FIELD DF_FIELD_NAME file# field# to field_name#
51602>>>      else move ("FIELD"+string(field#)) to field_name#
51604>>>    end
51604>>>>
51604>>>    function_return (file_name#+"."+field_name#)
51605>>>  end_function
51606>>>  procedure fill_list
51608>>>    integer file# fdx# max# field# st# type# len# dec# idx# iDisplayOldNumbers#
51608>>>    string str#
51608>>>    get piMain_File to file#
51609>>>    get piFDX_Server to fdx#
51610>>>    get dynamic_update_state to st#
51611>>>    set dynamic_update_state to false
51612>>>    get FDX_AttrValue_FILE fdx# DF_FILE_NUMBER_FIELDS file# to max#
51613>>>    get piDisplayOldNumbers to iDisplayOldNumbers#
51614>>>    send delete_data
51615>>>    for field# from 1 to max#
51621>>>>
51621>>>      send add_item msg_none (string(field#))
51622>>>      send add_item msg_none (FDX_AttrValue_FIELD(fdx#,DF_FIELD_NAME,file#,field#))
51623>>>      move (FDX_AttrValue_FIELD(fdx#,DF_FIELD_TYPE,file#,field#)) to type#
51624>>>      send add_item msg_none (API_ShortFieldTypeName(type#))
51625>>>      move (FDX_AttrValue_FIELD(fdx#,DF_FIELD_LENGTH,file#,field#)) to len#
51626>>>      if type# eq DF_BCD begin
51628>>>        move (FDX_AttrValue_FIELD(fdx#,DF_FIELD_PRECISION,file#,field#)) to dec#
51629>>>        send add_item msg_none (string(len#-dec#)+"."+string(dec#))
51630>>>      end
51630>>>>
51630>>>      else send add_item msg_none (string(len#))
51632>>>      send add_item msg_none (FDX_AttrValue_FIELD(fdx#,DF_FIELD_OFFSET,file#,field#))
51633>>>      move (FDX_AttrValue_FIELD(fdx#,DF_FIELD_INDEX,file#,field#)) to idx#
51634>>>      if idx# send add_item msg_none (string(idx#))
51637>>>      else    send add_item msg_none ""
51639>>>
51639>>>      if iDisplayOldNumbers# begin
51641>>>        move "(Old #) PhysLen: #" to str#
51642>>>        replace "#" in str# with (FDX_AttrValue_FIELD(fdx#,DF_FIELD_OLD_NUMBER,file#,field#))
51644>>>        replace "#" in str# with (FDX_AttrValue_FIELD(fdx#,DF_FIELD_NATIVE_LENGTH,file#,field#))
51646>>>        send add_item msg_none str#
51647>>>      end
51647>>>>
51647>>>      else send add_item msg_none (sRelFieldName.ii(self,FDX_AttrValue_FIELD(fdx#,DF_FIELD_RELATED_FILE,file#,field#),FDX_AttrValue_FIELD(fdx#,DF_FIELD_RELATED_FIELD,file#,field#)))
51649>>>    loop
51650>>>>
51650>>>    set dynamic_update_state to st#
51651>>>  end_procedure
51652>>>
51652>>>  procedure ToggleDisplayOldNumbers
51654>>>    set piDisplayOldNumbers to (not(piDisplayOldNumbers(self)))
51655>>>    send fill_list
51656>>>  end_procedure
51657>>>end_class // cFDX.Display.FieldList
51658>>>
51658>>>class cFDX.Display.IndexList is a aps.Grid
51659>>>  procedure construct_object integer img#
51661>>>    forward send construct_object img#
51663>>>    set select_mode to auto_select
51664>>>    set Line_Width to 1 0
51665>>>    set header_label item 0 to "#"
51666>>>    set form_margin  item 0 to  8
51667>>>    set highlight_row_state to true
51668>>>//   set highlight_row_color to (rgb(0,255,255))
51668>>>//   set current_item_color to (rgb(0,255,255))
51668>>>    set CurrentCellColor     to clHighlight
51669>>>    set CurrentCellTextColor to clHighlightText
51670>>>    set CurrentRowColor      to clHighlight
51671>>>    set CurrentRowTextColor  to clHighlightText
51672>>>    set select_mode to no_select
51673>>>    on_key knext_item send switch
51674>>>    on_key kprevious_item send switch_back
51675>>>    on_key key_ctrl+key_w send DoWriteToFile
51676>>>  end_procedure
51677>>>  procedure DoWriteToFile
51679>>>    send Grid_DoWriteToFile self
51680>>>  end_procedure
51681>>>  procedure add_item integer msg# string value#
51683>>>    forward send add_item msg# value#
51685>>>    set entry_state item (item_count(self)-1) to false
51686>>>  end_procedure
51687>>>  procedure fill_list
51689>>>    integer idx# file# fdx#
51689>>>    send delete_data
51690>>>    get piMain_File to file#
51691>>>    get piFDX_Server to fdx#
51692>>>    for idx# from 1 to 15
51698>>>>
51698>>>      send add_item msg_none ("Index "+string(idx#))
51699>>>      ifnot (integer(FDX_AttrValue_INDEX(fdx#,DF_INDEX_NUMBER_SEGMENTS,file#,idx#))) set shadow_state item (item_count(self)-1) to true
51702>>>    loop
51703>>>>
51703>>>    set dynamic_update_state to true
51704>>>  end_procedure
51705>>>end_class // cFDX.Display.IndexList
51706>>>
51706>>>class cFDX.Display.IndexSegmentList is a aps.Grid
51707>>>  procedure construct_object integer img#
51709>>>    forward send construct_object img#
51711>>>    set Line_Width to 3 0
51712>>>    set header_label item 0 to "Field"
51713>>>    set header_label item 1 to "U/C"
51714>>>    set header_label item 2 to "Dsc"
51715>>>    set form_margin  item 0 to 15
51716>>>    set form_margin  item 1 to 3
51717>>>    set form_margin  item 2 to 3
51718>>>    set highlight_row_state to true
51719>>>    set CurrentCellColor     to clHighlight
51720>>>    set CurrentCellTextColor to clHighlightText
51721>>>    set CurrentRowColor      to clHighlight
51722>>>    set CurrentRowTextColor  to clHighlightText
51723>>>//   set highlight_row_color to (rgb(0,255,255))
51723>>>//   set current_item_color to (rgb(0,255,255))
51723>>>    set select_mode to no_select
51724>>>    on_key knext_item send switch
51725>>>    on_key kprevious_item send switch_back
51726>>>    on_key key_ctrl+key_w send DoWriteToFile
51727>>>  end_procedure
51728>>>  procedure DoWriteToFile
51730>>>    send Grid_DoWriteToFile self
51731>>>  end_procedure
51732>>>  procedure add_item integer msg# string value#
51734>>>    forward send add_item msg# value#
51736>>>    set entry_state item (item_count(self)-1) to false
51737>>>  end_procedure
51738>>>  procedure fill_list
51740>>>    integer max# seg# file# field# attr# fdx# value# idx#
51740>>>    string fname#
51740>>>    send delete_data
51741>>>    get piMain_File to file#
51742>>>    get piFDX_Server to fdx#
51743>>>    get piIndex to idx#
51744>>>    move (FDX_AttrValue_INDEX(fdx#,DF_INDEX_NUMBER_SEGMENTS,file#,idx#)) to max#
51745>>>    for seg# from 1 to max#
51751>>>>
51751>>>      move (FDX_AttrValue_IDXSEG(fdx#,DF_INDEX_SEGMENT_FIELD,file#,idx#,seg#)) to field#
51752>>>      if field# move (FDX_AttrValue_FIELD(fdx#,DF_FIELD_NAME,file#,field#)) to fname#
51755>>>      else move "RECNUM" to fname#
51757>>>      send add_item msg_none fname#
51758>>>      move (FDX_AttrValue_IDXSEG(fdx#,DF_INDEX_SEGMENT_CASE,file#,idx#,seg#)) to value#
51759>>>      send add_item msg_none (if(value#=DF_CASE_IGNORED,"Yes","No"))
51760>>>      move (FDX_AttrValue_IDXSEG(fdx#,DF_INDEX_SEGMENT_DIRECTION,file#,idx#,seg#)) to value#
51761>>>      send add_item msg_none (if(value#=DF_DESCENDING,"Yes","No"))
51762>>>    loop
51763>>>>
51763>>>    set dynamic_update_state to true
51764>>>  end_procedure
51765>>>end_class // cFDX.Display.IndexSegmentList
51766>>>class cFDX.Display.FileOtherList is a aps.Grid
51767>>>  procedure construct_object integer img#
51769>>>    forward send construct_object img#
51771>>>    set Line_Width to 2 0
51772>>>    set header_label item 0 to "Parameter"
51773>>>    set header_label item 1 to "Value"
51774>>>    set form_margin  item 0 to  30
51775>>>    set form_margin  item 1 to  30
51776>>>    set highlight_row_state to true
51777>>>    set CurrentCellColor     to clHighlight
51778>>>    set CurrentCellTextColor to clHighlightText
51779>>>    set CurrentRowColor      to clHighlight
51780>>>    set CurrentRowTextColor  to clHighlightText
51781>>>//   set highlight_row_color to (rgb(0,255,255))
51781>>>//   set current_item_color to (rgb(0,255,255))
51781>>>    set select_mode to no_select
51782>>>    property integer piDisplayRuntimeOnlies public 0
51783>>>    on_key key_ctrl+key_w send DoWriteToFile
51784>>>  end_procedure
51785>>>  procedure DoWriteToFile
51787>>>    send Grid_DoWriteToFile self
51788>>>  end_procedure
51789>>>  procedure add_item integer msg# string value#
51791>>>    forward send add_item msg# value#
51793>>>    set entry_state item (item_count(self)-1) to false
51794>>>  end_procedure
51795>>>  procedure add_entry string param# string value#
51797>>>    send add_item msg_none param#
51798>>>    send add_item msg_none value#
51799>>>  end_procedure
51800>>>  procedure fill_list_help integer attr#
51802>>>    integer file# fdx#
51802>>>    string str#
51802>>>    if (piDisplayRuntimeOnlies(self) or not(API_AttrRuntimeOnly(attr#))) begin
51804>>>      get piMain_File to file#
51805>>>      get piFDX_Server to fdx#
51806>>>      move (FDX_AttrValue_FILE(fdx#,attr#,file#)) to str#
51807>>>      send add_entry (API_Attr_DisplayName(attr#)) (API_Attr_DisplayValueName(attr#,str#))
51808>>>    end
51808>>>>
51808>>>  end_procedure
51809>>>  procedure fill_list
51811>>>    send delete_data
51812>>>    send API_AttrType_Callback ATTRTYPE_FILE msg_fill_list_help self
51813>>>    set dynamic_update_state to true
51814>>>  end_procedure
51815>>>end_class // cFDX.Display.FileOtherList
51816>>>
51816>>>object oFdxModalDisplayFileAttributes is a aps.ModalPanel label "Display table definition"
51819>>>  property integer piFDX_Server public 0
51821>>>  property integer piMain_File  public 0
51823>>>  property integer piIndex      public 1
51825>>>  on_key kcancel send close_panel
51826>>>  set Locate_Mode to CENTER_ON_SCREEN
51827>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
51828>>>  object oTabs is a aps.TabDialog
51830>>>    set peAnchors to (anTop+anLeft+anBottom+anRight)
51831>>>    object oTab1 is a aps.TabPage label "Fields"
51834>>>      set p_Auto_Column to false
51835>>>      object oFields is a cFDX.Display.FieldList
51837>>>        set size to 160 0
51838>>>        set peAnchors to (anTop+anLeft+anBottom+anRight)
51839>>>        set peResizeColumn to rcAll
51840>>>      end_object
51841>>>    end_object
51842>>>    register_object oIndexFields
51842>>>    object oTab2 is a aps.TabPage label "Indices"
51845>>>      object oIndexNo is a cFDX.Display.IndexList
51847>>>        set size to 160 0
51848>>>        set peAnchors to (anTop+anBottom)
51849>>>        set peResizeColumn to rcAll
51850>>>        procedure item_change integer from# integer to# returns integer
51853>>>          integer rval#
51853>>>          forward get msg_item_change from# to# to rval#
51855>>>          set piIndex to (rval#+1)
51856>>>          send fill_list to (oIndexFields(self))
51857>>>          send display_info
51858>>>          procedure_return rval#
51859>>>        end_procedure
51860>>>      end_object
51861>>>      set p_auto_column to false
51862>>>      object oIndexFields is a cFDX.Display.IndexSegmentList
51864>>>        set peAnchors to (anTop+anLeft+anBottom+anRight)
51865>>>        set peResizeColumn to rcAll
51866>>>        set size to 160 0
51867>>>      end_object
51868>>>      object oFrm1 is a aps.Form label "Key length:" abstract aft_numeric4.0 snap sl_right_space
51873>>>        set peAnchors to (anTop+anRight)
51874>>>        set object_shadow_state to true
51875>>>      end_object
51876>>>      object oFrm2 is a aps.Form label "Levels:" abstract aft_numeric4.0 snap sl_down
51881>>>        set peAnchors to (anTop+anRight)
51882>>>        set object_shadow_state to true
51883>>>        set label_offset to 0 0
51884>>>        set label_justification_mode to jmode_right
51885>>>      end_object
51886>>>      object oFrm3 is a aps.Form label "Batch:" abstract aft_ascii4 snap sl_down
51891>>>        set peAnchors to (anTop+anRight)
51892>>>        set object_shadow_state to true
51893>>>        set label_offset to 0 0
51894>>>        set label_justification_mode to jmode_right
51895>>>      end_object
51896>>>      procedure display_info
51899>>>        integer idx# attr#
51899>>>        integer file# fdx#
51899>>>        get piMain_File to file#
51900>>>        get piFDX_Server to fdx#
51901>>>        get piIndex to idx#
51902>>>        move (FDX_AttrValue_INDEX(fdx#,DF_INDEX_KEY_LENGTH,file#,idx#)) to attr#
51903>>>        set value of (oFrm1(self)) item 0 to attr#
51904>>>        move (FDX_AttrValue_INDEX(fdx#,DF_INDEX_LEVELS,file#,idx#)) to attr#
51905>>>        set value of (oFrm2(self)) item 0 to attr#
51906>>>        move (FDX_AttrValue_INDEX(fdx#,DF_INDEX_TYPE,file#,idx#)) to attr#
51907>>>        if attr# eq DF_INDEX_TYPE_ONLINE set value of (oFrm3(self)) item 0 to "No"
51910>>>        else                             set value of (oFrm3(self)) item 0 to "Yes"
51912>>>      end_procedure
51913>>>    end_object
51914>>>    object oTab3 is a aps.TabPage label "Attributes"
51917>>>      object oOther is a cFDX.Display.FileOtherList
51919>>>        set size to 160 0
51920>>>        set peAnchors to (anTop+anLeft+anBottom+anRight)
51921>>>        set peResizeColumn to rcAll
51922>>>      end_object
51923>>>    end_object
51924>>>  end_object
51925>>>  object oBtn is a aps.Multi_Button
51927>>>    on_item t.btn.close send close_panel
51928>>>    set peAnchors to (anBottom+anRight)
51929>>>  end_object
51930>>>  send aps_locate_multi_buttons
51931>>>  procedure run.ii integer obj# integer file#
51934>>>    set piFDX_Server to obj#
51935>>>    set piMain_File  to file#
51936>>>    send fill_list to (oFields(oTab1(oTabs(self))))
51937>>>    set piIndex to 1
51938>>>    send fill_list to (oIndexNo(oTab2(oTabs(self))))
51939>>>    send fill_list to (oIndexFields(oTab2(oTabs(self))))
51940>>>    send display_info to (oTab2(oTabs(self)))
51941>>>    send fill_list to (oOther(oTab3(oTabs(self)))) obj#
51942>>>    send popup
51943>>>  end_procedure
51944>>>end_object
51945>>>send aps_SetMinimumDialogSize (oFdxModalDisplayFileAttributes(self))
51946>>>
51946>>>object oABCDEFG is a cArray NO_IMAGE
51948>>>  register_function iFdxIsEncapsulated returns integer
51948>>>end_object
51949>>>
51949>>>register_function piMainFile returns integer
51949>>>procedure FDX_ModalDisplayFileAttributes global integer oFDX# integer file#
51951>>>  integer open# was_open# lbIsEncapsulated
51951>>>  ifnot oFDX# begin
51953>>>    move (DBMS_IsOpenFile(file#)) to was_open#
51954>>>    if was_open# move 1 to open#
51957>>>    else move (DBMS_OpenFile(file#,DF_SHARE,0)) to open#
51959>>>  end
51959>>>>
51959>>>  else begin
51960>>>    move 1 to open#
51961>>>    if file# eq 0 begin
51963>>>      // File not specified means the oFDX# holds only one file
51963>>>      get iFdxIsEncapsulated of oFDX# to lbIsEncapsulated
51964>>>      if lbIsEncapsulated begin
51966>>>        send obs "Missing file number argument"
51967>>>        move 0 to open#
51968>>>      end
51968>>>>
51968>>>      else get piMainFile of oFDX# to file#
51970>>>    end
51970>>>>
51970>>>  end
51970>>>>
51970>>>  if open# send run.ii to (oFdxModalDisplayFileAttributes(self)) oFDX# file#
51973>>>  else send obs "Table is not available"
51975>>>  ifnot oFDX# if (open# and not(was_open#)) close file#
51980>>>end_procedure
51981>>>
51981>>>// Test code
51981>>>//
51981>>>// open prtcomm
51981>>>// send FDX_DisplayFileAttributes 0 PrtComm.File_Number
51981>Use Fdx4.utl     // FDX aware cFileList_List selector object
Including file: fdx4.utl    (C:\Apps\VDFQuery\AppSrc\fdx4.utl)
51981>>>//**********************************************************************
51981>>>// Use Fdx4.utl     // FDX aware cFileList_List selector object
51981>>>//
51981>>>// By Sture Andersen
51981>>>//
51981>>>// Create: Sun  16-01-2000
51981>>>// Update:
51981>>>//
51981>>>//**********************************************************************
51981>>>Use Fdx2.utl     // FDX aware object for displaying a table definiton
51981>>>Use Fdx3.utl     // FDX aware cFileList_List selector class
Including file: fdx3.utl    (C:\Apps\VDFQuery\AppSrc\fdx3.utl)
51981>>>>>//**********************************************************************
51981>>>>>// Use Fdx3.utl     // FDX aware cFileList_List selector class
51981>>>>>//
51981>>>>>// By Sture Andersen
51981>>>>>//
51981>>>>>// Create: Sun  16-01-2000
51981>>>>>// Update:
51981>>>>>//
51981>>>>>//**********************************************************************
51981>>>>>
51981>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
51981>>>>>Use DBMS.utl     // Basic DBMS functions
51981>>>>>Use Strings.nui  // String manipulation for VDF
51981>>>>>Use FieldInf     // Global field info objects
51981>>>>>Use Fdx2.utl     // FDX aware object for displaying a table definiton
51981>>>>>Use Files.utl    // Utilities for handling file related stuff
Including file: files.utl    (C:\Apps\VDFQuery\AppSrc\files.utl)
51981>>>>>>>//**********************************************************************
51981>>>>>>>// Use Files.utl    // Utilities for handling file related stuff
51981>>>>>>>//
51981>>>>>>>// By Sture Andersen
51981>>>>>>>//
51981>>>>>>>// Create: Wed  01-02-1998
51981>>>>>>>// Update: Sat  02-05-1998 - Functions SEQ_FindFileAlongPath, SEQ_FileLineCount
51981>>>>>>>//                           and SEQ_FindFileAlongDFPath added.
51981>>>>>>>//         Fri  08-05-1998 - Error in cChannelAdmin fixed. Something to do with
51981>>>>>>>//                           channel positions has changed between 3.0x and
51981>>>>>>>//                           3.1c. On_Error trick has been taken out and a
51981>>>>>>>//                           'sneak in' on the right position trick has been
51981>>>>>>>//                           introduced.
51981>>>>>>>//              09-07-1998 - Procedure SEQ_WriteRecordBuffer_LD added.
51981>>>>>>>//              14-07-1998 - Grave error fixed in SEQ_WriteRecordBuffer_LD
51981>>>>>>>//                           by Jrgen Legin and Torsten Balslw.
51981>>>>>>>//                         - SEQ_ReadRecordBuffer_LD added
51981>>>>>>>//              05-09-1998 - SEQ_ExtractPathFromFileName added
51981>>>>>>>//              06-09-1998 - SEQ_DfPath fixed
51981>>>>>>>//         Sun  07-02-1999 - Directory selector added. Based on work of
51981>>>>>>>//                           Dennis Piccioni and Torben Lund. Function
51981>>>>>>>//                           name is SEQ_SelectDirectory. Windows only!
51981>>>>>>>//                         - aps.SelectDirForm class added. Windows only!
51981>>>>>>>//         Fri  23-04-1999 - SEQ_DeleteFileToBin added. Based entirely on
51981>>>>>>>//                           upload from Andy Kaplan
51981>>>>>>>//                           (DAC NG user-contributed-files)
51981>>>>>>>//         Sun  02-05-1999 - Added function SEQ_FileModTime
51981>>>>>>>//         Mon  10-05-1999 - Fixes for VDF 6 (Vincent Oorsprong)
51981>>>>>>>//         Mon  30-08-1999 - Function SEQ_DirectInput and SEQ_DirectOutput added
51981>>>>>>>//         Wed  29-09-1999 - Function SEQ_SelectDirectory now converts to
51981>>>>>>>//                           OEM before returning its value.
51981>>>>>>>//         Sat  09-10-1999 - Procedures SEQ_CloseOutput, SEQ_CloseInput and
51981>>>>>>>//                           SEQ_AppendOutput added.
51981>>>>>>>//         Wed  01-12-1999 - Function SEQ_ReadLnProbe added.
51981>>>>>>>//         Sun  06-02-2000 - Save- and OpenDialogs are now created dynamically
51981>>>>>>>//                           in appropriate places
51981>>>>>>>//         Sat  11-03-2000 - Fix in SEQ_FileExists
51981>>>>>>>//         Wed  22-03-2000 - Function SEQ_FindFileAlongPath would cause an
51981>>>>>>>//                           "Access violation" if asked to locate a file
51981>>>>>>>//                           opened exclusive by an application (including the
51981>>>>>>>//                           current). Fixed.
51981>>>>>>>//         Mon  10-07-2000 - Function SEQ_FileSizeToString added
51981>>>>>>>//         Wed  01-11-2000 - Functions SEQ_EraseFile, SEQ_CopyFile and
51981>>>>>>>//                           SEQ_MoveFile added.
51981>>>>>>>//         Tue  07-11-2000 - Added function SEQ_ConvertToAbsoluteFileName
51981>>>>>>>//         Tue  02-01-2001 - Added procedures SEQ_AppendOutputImageClose and
51981>>>>>>>//                           SEQ_AppendLineClose.
51981>>>>>>>//         Thu  04-01-2001 - Added function SEQ_FindDataFileFromRootName
51981>>>>>>>//         Mon  15-04-2002 - aps.dbSelectDirForm added
51981>>>>>>>//         Mon  27-01-2003 - Function SEQ_SelectFileStartDir added
51981>>>>>>>//         Sat  06-09-2003 - Added function SEQ_ValidateFolder
51981>>>>>>>//         Thu  06-07-2006 - Fixed SEQ_SelectOutFile. It assumed work space
51981>>>>>>>//                           objects VDF 7 style.
51981>>>>>>>//
51981>>>>>>>//**********************************************************************
51981>>>>>>>use ui
51981>>>>>>>Use Files.nui    // Utilities for handling file related stuff
51981>>>>>>>Use MsgBox.utl   // obs procedure
51981>>>>>>>Use Strings.nui  // String manipulation for VDF
51981>>>>>>>Use Dates.nui    // Date manipulation for VDF
51981>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
51981>>>>>>>Use Version.nui
51981>>>>>>>Use Language
51981>>>>>>>
51981>>>>>>>Use wvaW32fh.pkg // Package by Wil van Antwerpen from www.vdf-guidance.com
51981>>>>>>>
51981>>>>>>>
51981>>>>>>>Use File_Dlg   // DAC package
51981>>>>>>>integer oSEQ_OpenFlDlg# oSEQ_SaveFlDlg#
51981>>>>>>>move 0 to oSEQ_OpenFlDlg#
51982>>>>>>>move 0 to oSEQ_SaveFlDlg#
51983>>>>>>>class cSEQ_OpenFlDlg is a OpenDialog
51984>>>>>>>  procedure construct_object
51986>>>>>>>    forward send construct_object
51988>>>>>>>    set NoChangeDir_State to true
51989>>>>>>>    set HideReadOnly_State To True
51990>>>>>>>    move self to oSEQ_OpenFlDlg#
51991>>>>>>>  end_procedure
51992>>>>>>>end_class
51993>>>>>>>class cSEQ_SaveFlDlg is a SaveAsDialog
51994>>>>>>>  procedure construct_object
51996>>>>>>>    forward send construct_object
51998>>>>>>>    set NoChangeDir_State to true
51999>>>>>>>    set HideReadOnly_State To True
52000>>>>>>>    move self to oSEQ_SaveFlDlg#
52001>>>>>>>  end_procedure
52002>>>>>>>  procedure set Dialog_Caption string lsCaption
52004>>>>>>>    forward set Dialog_Caption to lsCaption
52006>>>>>>>  end_procedure
52007>>>>>>>end_class
52008>>>>>>>
52008>>>>>>>procedure SEQ_Prepare_OpenDialog global
52010>>>>>>>  integer parent# self#
52010>>>>>>>  move (focus(desktop)) to parent#
52011>>>>>>>  ifnot parent# move desktop to parent#
52014>>>>>>>  if oSEQ_OpenFlDlg# send request_destroy_object to oSEQ_OpenFlDlg#
52017>>>>>>>  move self to self#
52018>>>>>>>  move parent# to self
52019>>>>>>>  object oSEQ_OpenFlDlg is a cSEQ_OpenFlDlg
52021>>>>>>>  end_object
52022>>>>>>>  move self# to self
52023>>>>>>>end_procedure
52024>>>>>>>
52024>>>>>>>procedure SEQ_Prepare_SaveDialog global
52026>>>>>>>  integer parent# self#
52026>>>>>>>  move (focus(desktop)) to parent#
52027>>>>>>>  ifnot parent# move desktop to parent#
52030>>>>>>>  if oSEQ_SaveFlDlg# send request_destroy_object to oSEQ_SaveFlDlg#
52033>>>>>>>  move self to self#
52034>>>>>>>  move parent# to self
52035>>>>>>>  object oSEQ_SaveFlDlg is a cSEQ_SaveFlDlg
52037>>>>>>>  end_object
52038>>>>>>>  move self# to self
52039>>>>>>>end_procedure
52040>>>>>>>
52040>>>>>>>//declare C structure struct_browseinfo
52040>>>>>>>//as documented in MSDN under Windows Shell API
52040>>>>>>>Type tFilesBrowseInfo
52040>>>>>>>  Field tFilesBrowseInfo.hWndOwner      as handle
52040>>>>>>>  Field tFilesBrowseInfo.pIDLRoot       as Pointer
52040>>>>>>>  Field tFilesBrowseInfo.pszDisplayName as Pointer
52040>>>>>>>  Field tFilesBrowseInfo.lpszTitle      as Pointer
52040>>>>>>>  Field tFilesBrowseInfo.ulFlags        as dWord
52040>>>>>>>  Field tFilesBrowseInfo.lpfnCallback   as Pointer
52040>>>>>>>  Field tFilesBrowseInfo.lParam         as dWord
52040>>>>>>>  Field tFilesBrowseInfo.iImage         as dWord
52040>>>>>>>End_Type  // tFilesBrowseInfo
52040>>>>>>>
52040>>>>>>>External_Function FilesSHBrowseForFolder   "SHBrowseForFolder"   shell32.dll pointer lpdWordx returns dWord
52041>>>>>>>External_Function FilesSHGetPathFromIDList "SHGetPathFromIDList" shell32.dll pointer pidList pointer lpBuffer returns dWord
52042>>>>>>>External_Function FilesCoTaskMemFree       "CoTaskMemFree"       ole32.dll   pointer pv returns Integer
52043>>>>>>>
52043>>>>>>>// If function ConvertChar is not already defined we define it here:
52043>>>>>>>
52043>>>>>>>// returns folder name if a folder was selected, otherwise returns ""
52043>>>>>>>function SEQ_SelectDirectory global string lsCaption returns string
52045>>>>>>>  string sFolder sBrowseInfo sTitle sRval
52045>>>>>>>  pointer lpItemIdList lpsFolder lpsBrowseInfo lpsTitle
52045>>>>>>>  integer iFolderSelected iObj iRetval
52045>>>>>>>
52045>>>>>>>  // fill string variable with null characters
52045>>>>>>>  ZeroType tFilesBrowseInfo to sBrowseInfo
52046>>>>>>>
52046>>>>>>>  if (lsCaption<>"") begin
52048>>>>>>>    move (ConvertChar(1,lsCaption)) to sTitle // toAnsi
52049>>>>>>>    GetAddress of sTitle to lpsTitle
52050>>>>>>>    put lpsTitle to sBrowseInfo at tFilesBrowseInfo.lpszTitle
52051>>>>>>>  end
52051>>>>>>>>
52051>>>>>>>
52051>>>>>>>  put (window_handle(focus(desktop))) to sBrowseInfo at tFilesBrowseInfo.hWndOwner
52052>>>>>>>
52052>>>>>>>  GetAddress of sBrowseInfo to lpsBrowseInfo
52053>>>>>>>
52053>>>>>>>  // null 128 chars into var (make space)
52053>>>>>>>  move (repeat(character(0), 128)) to sFolder
52054>>>>>>>  GetAddress of sFolder to lpsFolder
52055>>>>>>>
52055>>>>>>>  // select folder
52055>>>>>>>  move (FilesSHBrowseForFolder(lpsBrowseInfo)) to lpItemIdList
52056>>>>>>>  // get selected folder name
52056>>>>>>>  move (FilesSHGetPathFromIDList(lpItemIdList, lpsFolder)) to iFolderSelected
52057>>>>>>>
52057>>>>>>>  // free memory and IDL
52057>>>>>>>  Move (FilesCoTaskMemFree(lpItemIdList)) To iRetval
52058>>>>>>>
52058>>>>>>>  if (iFolderSelected<>0) move (CString(sFolder)) to sRval
52061>>>>>>>  else move "" to sRval
52063>>>>>>>  function_return (ConvertChar(0,sRval))
52064>>>>>>>End_Function  // GetSelectFolder
52065>>>>>>>
52065>>>>>>>class aps.SelectDirForm is a aps.Form
52066>>>>>>>  procedure construct_object
52068>>>>>>>    forward send construct_object
52070>>>>>>>    property string pSelectDialogCaption public t.files.SelectDir
52071>>>>>>>    set form_button item 0 to 1           // Manually add a prompt button
52072>>>>>>>    set form_button_value item 0 to "..." //              "
52073>>>>>>>    on_key kprompt send prompt
52074>>>>>>>  end_procedure
52075>>>>>>>  procedure OnDirectorySelected
52077>>>>>>>  end_procedure
52078>>>>>>>  Procedure Prompt
52080>>>>>>>    string sDir
52080>>>>>>>    move (SEQ_SelectDirectory(pSelectDialogCaption(self))) to sDir
52081>>>>>>>    if sDir ne "" begin
52083>>>>>>>      set Value item 0 to sDir
52084>>>>>>>      send OnDirectorySelected
52085>>>>>>>    end
52085>>>>>>>>
52085>>>>>>>  End_Procedure
52086>>>>>>>  procedure form_button_notification integer itm#
52088>>>>>>>    send prompt
52089>>>>>>>  end_procedure
52090>>>>>>>end_class
52091>>>>>>>class aps.dbSelectDirForm is a aps.dbForm
52092>>>>>>>  procedure construct_object
52094>>>>>>>    forward send construct_object
52096>>>>>>>    property string pSelectDialogCaption public t.files.SelectDir
52097>>>>>>>//   set form_button item 0 to 1           // Manually add a prompt button
52097>>>>>>>//   set form_button_value item 0 to "..." //              "
52097>>>>>>>    set prompt_button_mode to PB_PromptOn
52098>>>>>>>    on_key kprompt send prompt
52099>>>>>>>  end_procedure
52100>>>>>>>  procedure OnDirectorySelected
52102>>>>>>>  end_procedure
52103>>>>>>>  Procedure Prompt
52105>>>>>>>    string sDir
52105>>>>>>>    move (SEQ_SelectDirectory(pSelectDialogCaption(self))) to sDir
52106>>>>>>>    if sDir ne "" begin
52108>>>>>>>      set changed_value item 0 to sDir
52109>>>>>>>      send OnDirectorySelected
52110>>>>>>>    end
52110>>>>>>>>
52110>>>>>>>  End_Procedure
52111>>>>>>>  procedure form_button_notification integer itm#
52113>>>>>>>    send prompt
52114>>>>>>>  end_procedure
52115>>>>>>>end_class
52116>>>>>>>class aps.SelectFileForm is a aps.Form
52117>>>>>>>  procedure construct_object
52119>>>>>>>    forward send construct_object
52121>>>>>>>    property string psFileMask public ""
52122>>>>>>>    property string pSelectDialogCaption public t.files.SelectFile
52123>>>>>>>    set form_button item 0 to 1           // Manually add a prompt button
52124>>>>>>>    set form_button_value item 0 to "..." //              "
52125>>>>>>>    on_key kprompt send prompt
52126>>>>>>>  end_procedure
52127>>>>>>>  Procedure Prompt
52129>>>>>>>    string fn#
52129>>>>>>>    get SEQ_SelectInFile (pSelectDialogCaption(self)) (psFileMask(self)) to fn#
52130>>>>>>>    if fn# ne ""  set Value item 0 to fn#
52133>>>>>>>  End_Procedure
52134>>>>>>>  procedure form_button_notification integer itm#
52136>>>>>>>    send prompt
52137>>>>>>>  end_procedure
52138>>>>>>>end_class
52139>>>>>>>
52139>>>>>>>function SEQ_SelectOutFile global string lsCaption string filter# returns string
52141>>>>>>>  string fn#
52141>>>>>>>  send SEQ_Prepare_SaveDialog
52142>>>>>>>  set NoChangeDir_State of oSEQ_SaveFlDlg# to True
52143>>>>>>>  set Dialog_Caption of oSEQ_SaveFlDlg# to lsCaption
52144>>>>>>>  set Filter_String of oSEQ_SaveFlDlg# to filter#
52145>>>>>>>  if (Show_Dialog(oSEQ_SaveFlDlg#)) move (File_Name(oSEQ_SaveFlDlg#)) to fn#
52148>>>>>>>  else move "" to fn#
52150>>>>>>>  function_return fn#
52151>>>>>>>end_function
52152>>>>>>>
52152>>>>>>>// Example of filter# values for VDF program:   "Text files|*.txt|XML files|*.xml|All files|*.*"
52152>>>>>>>
52152>>>>>>>function SEQ_SelectOutFileStartDir global string lsCaption string filter# string lsStartDir returns string
52154>>>>>>>  string fn#
52154>>>>>>>  send SEQ_Prepare_SaveDialog
52155>>>>>>>  set Initial_Folder of oSEQ_SaveFlDlg# to lsStartDir
52156>>>>>>>  set NoChangeDir_State of oSEQ_SaveFlDlg# to True
52157>>>>>>>  set Dialog_Caption of oSEQ_SaveFlDlg# to lsCaption
52158>>>>>>>  set Filter_String of oSEQ_SaveFlDlg# to filter#
52159>>>>>>>  if (Show_Dialog(oSEQ_SaveFlDlg#)) move (File_Name(oSEQ_SaveFlDlg#)) to fn#
52162>>>>>>>  else move "" to fn#
52164>>>>>>>  function_return fn#
52165>>>>>>>end_function
52166>>>>>>>
52166>>>>>>>function SEQ_SelectInFile global string lsCaption string filter# returns string
52168>>>>>>>  string fn#
52168>>>>>>>  send SEQ_Prepare_OpenDialog
52169>>>>>>>  set NoChangeDir_State of oSEQ_OpenFlDlg# to True
52170>>>>>>>  set Dialog_Caption of oSEQ_OpenFlDlg# to lsCaption
52171>>>>>>>  set Filter_String of oSEQ_OpenFlDlg# to filter#
52172>>>>>>>  if (Show_Dialog(oSEQ_OpenFlDlg#)) move (File_Name(oSEQ_OpenFlDlg#)) to fn#
52175>>>>>>>  else move "" to fn#
52177>>>>>>>  function_return fn#
52178>>>>>>>end_function
52179>>>>>>>
52179>>>>>>>function SEQ_SelectFile global string lsCaption string filter# returns string
52181>>>>>>>  function_return (SEQ_SelectInFile(lsCaption,filter#))
52182>>>>>>>end_function
52183>>>>>>>
52183>>>>>>>function SEQ_SelectFileStartDir global string lsCaption string filter# string dir# returns string
52185>>>>>>>  string fn#
52185>>>>>>>  send SEQ_Prepare_OpenDialog
52186>>>>>>>  set Initial_Folder of oSEQ_OpenFlDlg# to dir#
52187>>>>>>>  set NoChangeDir_State of oSEQ_OpenFlDlg# to True //False
52188>>>>>>>  set Dialog_Caption of oSEQ_OpenFlDlg# to lsCaption
52189>>>>>>>  set Filter_String of oSEQ_OpenFlDlg# to filter#
52190>>>>>>>  if (Show_Dialog(oSEQ_OpenFlDlg#)) move (File_Name(oSEQ_OpenFlDlg#)) to fn#
52193>>>>>>>  else move "" to fn#
52195>>>>>>>  function_return fn#
52196>>>>>>>end_function
52197>>>>>>>
52197>>>>>>>//[found ~found] begin
52197>>>>>>>//  files$nothing: return
52197>>>>>>>//end
52197>>>>>>>
52197>>>>>>>use APS
52197>>>>>>>use Wait.utl
Including file: wait.utl    (C:\Apps\VDFQuery\AppSrc\wait.utl)
52197>>>>>>>>>// **********************************************************************
52197>>>>>>>>>// Use Wait.utl     // Something to put on screen while batching.
52197>>>>>>>>>//
52197>>>>>>>>>// By Sture Andersen & Jakob Kruse
52197>>>>>>>>>//
52197>>>>>>>>>// Create: Sat  10-05-1997 -
52197>>>>>>>>>// Update: Fri  03-04-1998 - Top-most-thing added by Jakob Kruse
52197>>>>>>>>>//         Wed  03-03-1999 - Procedure batch_on now initalizes all text areas
52197>>>>>>>>>//
52197>>>>>>>>>// ***********************************************************************
52197>>>>>>>>>
52197>>>>>>>>>Use ui
52197>>>>>>>>>Use statpnl
52197>>>>>>>>>Use Strings.nui  // String manipulation for VDF
52197>>>>>>>>>Use OldStatPnl.pkg // load the old status panel. Status_Panel is now this old object
Including file: OldStatPnl.pkg    (c:\VDF12\Pkg\OldStatPnl.pkg)
52197>>>>>>>>>>>//************************************************************************
52197>>>>>>>>>>>// NOTE: As of 12.0, this is obsolete. See StatPnl.pkg for more information about this.
52197>>>>>>>>>>>//       You encouraged to use the new cProcessStatusPanel class and Status_panel object
52197>>>>>>>>>>>//       defined in Status_panel.pkg       
52197>>>>>>>>>>>//
52197>>>>>>>>>>>// This adds support for the old Status_Panel object.
52197>>>>>>>>>>>// If you only need to add support for the old StatusPanel class, use OldStatusPanel.pkg
52197>>>>>>>>>>>// In earlier revisions, both the class and object were defined in a single file
52197>>>>>>>>>>>// named StatPnl.pkg. They have been moved to two files, OldStatusPanel.pkg, which
52197>>>>>>>>>>>// defines the class StatusPanel, and OldStatPnl.pkg (here), which defines the object
52197>>>>>>>>>>>//************************************************************************
52197>>>>>>>>>>>
52197>>>>>>>>>>>
52197>>>>>>>>>>>Use OldStatusPanel.pkg
Including file: OldStatusPanel.pkg    (c:\VDF12\Pkg\OldStatusPanel.pkg)
52197>>>>>>>>>>>>>//************************************************************************
52197>>>>>>>>>>>>>// NOTE: As of 12.0, this is obsolete. See StatPnl.pkg for more information about this.
52197>>>>>>>>>>>>>//       You encouraged to use the new cProcessStatusPanel class and Status_panel object
52197>>>>>>>>>>>>>//       defined in Status_panel.pkg       
52197>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>// This adds support for the old StatusPanel class.
52197>>>>>>>>>>>>>// If you also need to add support for the old Status_panel object, use OldStatPnl.pkg
52197>>>>>>>>>>>>>// In earlier revisions, both the class and object were defined in a single file
52197>>>>>>>>>>>>>// named StatPnl.pkg. They have been moved to two files, OldStatusPanel.pkg, (here) which
52197>>>>>>>>>>>>>// defines the class StatusPanel, and OldStatPnl.pkg, which defines the object
52197>>>>>>>>>>>>>//************************************************************************
52197>>>>>>>>>>>>>
52197>>>>>>>>>>>>>
52197>>>>>>>>>>>>>
52197>>>>>>>>>>>>>//************************************************************************
52197>>>>>>>>>>>>>// Confidential Trade Secret.
52197>>>>>>>>>>>>>// Copyright (c) 1997 Data Access Corporation, Miami Florida
52197>>>>>>>>>>>>>// as an unpublished work.  All rights reserved.
52197>>>>>>>>>>>>>// DataFlex is a registered trademark of Data Access Corporation.
52197>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>//************************************************************************
52197>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>// $File name  : OldStatPnl.pkg
52197>>>>>>>>>>>>>// $File title : OldStatus Panel Support for VDF. This has been replaced in 12.0
52197>>>>>>>>>>>>>// Notice      :
52197>>>>>>>>>>>>>// $Author(s)  : John Tuohy
52197>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>// $Rev History
52197>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>// SWB 11/15/00  Changed Start_StatusPanel, so that the Sentinel program could be a long-filename.
52197>>>>>>>>>>>>>// JT  5/18/00   Added code to keep panel on top.
52197>>>>>>>>>>>>>// JT  9/22/97   Added status_params, status_default_params and changed
52197>>>>>>>>>>>>>//               interface for no-cancel, and created interface for additional
52197>>>>>>>>>>>>>//               parameter passing
52197>>>>>>>>>>>>>// JT 06/27/97   Added no-cancel support w/ Allow_cancel_state
52197>>>>>>>>>>>>>// JT ??/??/96   File created for VDF 4.0
52197>>>>>>>>>>>>>//************************************************************************
52197>>>>>>>>>>>>>
52197>>>>>>>>>>>>>
52197>>>>>>>>>>>>>// Host/Sentinel Status Panel
52197>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>use Windows.pkg
52197>>>>>>>>>>>>>use SentDat.pkg // define shared data positions
Including file: Sentdat.pkg    (c:\VDF12\Pkg\Sentdat.pkg)
52197>>>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>>>//  Sentinel/Host common shared data
52197>>>>>>>>>>>>>>>//
52197>>>>>>>>>>>>>>>
52197>>>>>>>>>>>>>>>DEFINE BUTTONSTART   for 10
52197>>>>>>>>>>>>>>>DEFINE BUTTONLENGTH  for 25
52197>>>>>>>>>>>>>>>
52197>>>>>>>>>>>>>>>DEFINE CAPTIONSTART  for 35
52197>>>>>>>>>>>>>>>DEFINE CAPTIONLENGTH for 250
52197>>>>>>>>>>>>>>>
52197>>>>>>>>>>>>>>>DEFINE TITLESTART    for 285
52197>>>>>>>>>>>>>>>DEFINE TITLELENGTH   for 250
52197>>>>>>>>>>>>>>>
52197>>>>>>>>>>>>>>>DEFINE MESSAGESTART  for 535
52197>>>>>>>>>>>>>>>DEFINE MESSAGELENGTH for 250
52197>>>>>>>>>>>>>>>
52197>>>>>>>>>>>>>>>DEFINE ACTIONSTART   for 785
52197>>>>>>>>>>>>>>>DEFINE ACTIONLENGTH  for 250
52197>>>>>>>>>>>>>use msgbox.pkg
52197>>>>>>>>>>>>>
52197>>>>>>>>>>>>>
52197>>>>>>>>>>>>>Class StatusPanel is a cObject
52198>>>>>>>>>>>>>
52198>>>>>>>>>>>>>   Procedure Construct_Object
52200>>>>>>>>>>>>>      Forward Send Construct_Object
52202>>>>>>>>>>>>>
52202>>>>>>>>>>>>>      Property String  Sentinel_Name      "Sentinel"
52203>>>>>>>>>>>>>      Property Integer Sentinel_Running_State     False
52204>>>>>>>>>>>>>      // progress bar stuff is not implemented
52204>>>>>>>>>>>>>      Property Integer ProgressBar_State  False
52205>>>>>>>>>>>>>      Property Integer Progress_Minimum   0
52206>>>>>>>>>>>>>      Property Integer Progress_Maximum   100
52207>>>>>>>>>>>>>      Property String  Private.Button_Text        ""
52208>>>>>>>>>>>>>      Property String  Private.Title_Text         ""
52209>>>>>>>>>>>>>      Property String  Private.Caption_Text       ""
52210>>>>>>>>>>>>>      Property String  Private.Message_Text       ""
52211>>>>>>>>>>>>>      Property String  Private.Action_Text        ""
52212>>>>>>>>>>>>>
52212>>>>>>>>>>>>>      Property Integer Allow_Cancel_State         True
52213>>>>>>>>>>>>>      // whenever a status is initialized, the default
52213>>>>>>>>>>>>>      // is used unless a different value is passed in
52213>>>>>>>>>>>>>      // initialize_StatusPanel
52213>>>>>>>>>>>>>      property string  Status_Params              ''
52214>>>>>>>>>>>>>      property string  Status_Default_params      ''
52215>>>>>>>>>>>>>      Set Button_Text to "Cancel"
52216>>>>>>>>>>>>>
52216>>>>>>>>>>>>>   End_Procedure // Construct_Object
52217>>>>>>>>>>>>>
52217>>>>>>>>>>>>>   Procedure Close_Panel
52219>>>>>>>>>>>>>   End_Procedure
52220>>>>>>>>>>>>>
52220>>>>>>>>>>>>>   Procedure Initialize_StatusPanel String sCaption String sTitle ;                        String sMessage String sParams
52222>>>>>>>>>>>>>      Set ProgressBar_State to False
52223>>>>>>>>>>>>>      Set Caption_text to sCaption
52224>>>>>>>>>>>>>      Set Title_Text   to sTitle
52225>>>>>>>>>>>>>      Set Message_Text to sMessage
52226>>>>>>>>>>>>>      // the 4th param is optional because it was not supported
52226>>>>>>>>>>>>>      // in vdf4. You are encouraged to supply this
52226>>>>>>>>>>>>>      If num_arguments gt 3 ;        set Status_params to sParams
52229>>>>>>>>>>>>>      else ;        set Status_params to (Status_Default_params(self))
52231>>>>>>>>>>>>>   End_Procedure
52232>>>>>>>>>>>>>
52232>>>>>>>>>>>>>   Procedure Set Caption_Text string sText
52234>>>>>>>>>>>>>      Send DoStatusPaneltoForeground
52235>>>>>>>>>>>>>      Set Private.Caption_Text to sText
52236>>>>>>>>>>>>>      Set SentinelData of Desktop to sText CAPTIONSTART CAPTIONLENGTH
52237>>>>>>>>>>>>>   End_Procedure // Set Caption_Text
52238>>>>>>>>>>>>>
52238>>>>>>>>>>>>>   Function Caption_Text returns string
52240>>>>>>>>>>>>>      Function_Return (Private.Caption_Text(self))
52241>>>>>>>>>>>>>   End_Function // Caption_Text
52242>>>>>>>>>>>>>
52242>>>>>>>>>>>>>   Procedure Set Message_Text string sText
52244>>>>>>>>>>>>>      Send DoStatusPaneltoForeground
52245>>>>>>>>>>>>>      Set Private.Message_Text to sText
52246>>>>>>>>>>>>>      Set SentinelData of Desktop to sText MESSAGESTART MESSAGELENGTH
52247>>>>>>>>>>>>>   End_Procedure // Set Message_Text
52248>>>>>>>>>>>>>
52248>>>>>>>>>>>>>   Function Message_Text returns string
52250>>>>>>>>>>>>>      Function_Return (Private.Message_Text(self))
52251>>>>>>>>>>>>>   End_Function // Message_Text
52252>>>>>>>>>>>>>
52252>>>>>>>>>>>>>   Procedure Set Action_Text string sText
52254>>>>>>>>>>>>>      Send DoStatusPaneltoForeground
52255>>>>>>>>>>>>>      Set Private.Action_Text to sText
52256>>>>>>>>>>>>>      Set SentinelData of Desktop to sText ACTIONSTART ACTIONLENGTH
52257>>>>>>>>>>>>>   End_Procedure // Set Action_Text
52258>>>>>>>>>>>>>
52258>>>>>>>>>>>>>   Function Action_Text returns string
52260>>>>>>>>>>>>>      Function_Return (Private.Action_Text(self))
52261>>>>>>>>>>>>>   End_Function // Action_Text
52262>>>>>>>>>>>>>
52262>>>>>>>>>>>>>   Procedure Set Button_Text string sText
52264>>>>>>>>>>>>>      Send DoStatusPaneltoForeground
52265>>>>>>>>>>>>>      Set Private.Button_Text to sText
52266>>>>>>>>>>>>>      Set SentinelData of Desktop to sText BUTTONSTART BUTTONLENGTH
52267>>>>>>>>>>>>>   End_Procedure // Set Button_Text
52268>>>>>>>>>>>>>
52268>>>>>>>>>>>>>   Function Button_Text returns string
52270>>>>>>>>>>>>>      Function_Return (Private.Button_Text(self))
52271>>>>>>>>>>>>>   End_Function // Button_Text
52272>>>>>>>>>>>>>
52272>>>>>>>>>>>>>   Procedure Set Title_Text string sText
52274>>>>>>>>>>>>>      Send DoStatusPaneltoForeground
52275>>>>>>>>>>>>>      Set Private.Title_Text to sText
52276>>>>>>>>>>>>>      Set SentinelData of Desktop to sText TITLESTART TITLELENGTH
52277>>>>>>>>>>>>>   End_Procedure // Set Title_Text
52278>>>>>>>>>>>>>
52278>>>>>>>>>>>>>   Function Title_Text returns string
52280>>>>>>>>>>>>>      Function_Return (Private.Title_Text(self))
52281>>>>>>>>>>>>>   End_Function // Title_Text
52282>>>>>>>>>>>>>
52282>>>>>>>>>>>>>   Procedure Start_StatusPanel
52284>>>>>>>>>>>>>      Integer iVal
52284>>>>>>>>>>>>>      String sParams
52284>>>>>>>>>>>>>
52284>>>>>>>>>>>>>      If Not (Sentinel_Running_State(self)) Begin
52286>>>>>>>>>>>>>         Get status_params to sParams
52287>>>>>>>>>>>>>         If Not (Allow_Cancel_State(self)) ;             Move (sParams * "-c0") to sParams
52290>>>>>>>>>>>>>
52290>>>>>>>>>>>>>         Set Sentinel_Program of Desktop to ('"' + Sentinel_Name(self) +'"' * sParams)
52291>>>>>>>>>>>>>
52291>>>>>>>>>>>>>         Get Start_Sentinel_Program of Desktop to iVal
52292>>>>>>>>>>>>>         //showln "start sent = " ival
52292>>>>>>>>>>>>>         //If iVal ;
52292>>>>>>>>>>>>>         Set Sentinel_Running_State to TRUE
52293>>>>>>>>>>>>>      End
52293>>>>>>>>>>>>>>
52293>>>>>>>>>>>>>   End_Procedure // Start_StatusPanel
52294>>>>>>>>>>>>>
52294>>>>>>>>>>>>>   Procedure Update_StatusPanel String sAction
52296>>>>>>>>>>>>>      Set Action_Text to sAction
52297>>>>>>>>>>>>>   End_Procedure
52298>>>>>>>>>>>>>
52298>>>>>>>>>>>>>   Function Check_StatusPanel returns integer
52300>>>>>>>>>>>>>      integer iRet
52300>>>>>>>>>>>>>      Send DoStatusPaneltoForeground
52301>>>>>>>>>>>>>      Get Sentinel_return_value of Desktop to iRet
52302>>>>>>>>>>>>>      // modified to cancel the status panel if MSG_CANCEL is returned. This way you
52302>>>>>>>>>>>>>      // don't have to remember to send Stop_StatusPanel
52302>>>>>>>>>>>>>      If (iRet=MSG_CANCEL) Send Stop_StatusPanel
52305>>>>>>>>>>>>>      Function_Return iRet
52306>>>>>>>>>>>>>   End_Function
52307>>>>>>>>>>>>>
52307>>>>>>>>>>>>>   // Do what we can to force the status panel to the top. If the main program gets
52307>>>>>>>>>>>>>   // the focus force the status panel to take the focus.
52307>>>>>>>>>>>>>   Procedure DoStatusPaneltoForeground
52309>>>>>>>>>>>>>       integer hwStat hwMain hMain
52309>>>>>>>>>>>>>       Get main_window of desktop to hMain
52310>>>>>>>>>>>>>       If hMain Get window_handle of hMain to hwMain
52313>>>>>>>>>>>>>       If hwMain Begin
52315>>>>>>>>>>>>>          If (GetForegroundWindow()=hwMain) Begin
52317>>>>>>>>>>>>>              Move (SentinelWindow(desktop)) to hwStat
52318>>>>>>>>>>>>>              If hwStat Move (SetForegroundWindow(hwStat)) to hwStat
52321>>>>>>>>>>>>>          End
52321>>>>>>>>>>>>>>
52321>>>>>>>>>>>>>       End
52321>>>>>>>>>>>>>>
52321>>>>>>>>>>>>>   End_procedure
52322>>>>>>>>>>>>>
52322>>>>>>>>>>>>>   Procedure Stop_StatusPanel
52324>>>>>>>>>>>>>      Integer iVal
52324>>>>>>>>>>>>>      If (Sentinel_Running_State(self)) ;         Get Stop_Sentinel_Program of Desktop to iVal
52327>>>>>>>>>>>>>      Set Sentinel_Running_State to False
52328>>>>>>>>>>>>>   End_Procedure
52329>>>>>>>>>>>>>
52329>>>>>>>>>>>>>End_Class
52330>>>>>>>>>>>
52330>>>>>>>>>>>Object Status_Panel is a StatusPanel
52332>>>>>>>>>>>End_Object
52333>>>>>>>>>Use buttons.utl
52333>>>>>>>>>
52333>>>>>>>>>
52333>>>>>>>>>class cBatchCompanion is an StatusPanel
52334>>>>>>>>> // in 12: class cBatchCompanion is a cProcessStatusPanel
52334>>>>>>>>>  procedure construct_object
52336>>>>>>>>>    forward send construct_object
52338>>>>>>>>>    property string pCancelQuestionCaption public t.Wait.Question
52339>>>>>>>>>    property string pCancelQuestion        public t.Wait.Cancel
52340>>>>>>>>>    set button_text to t.btn.cancel
52341>>>>>>>>>  end_procedure
52342>>>>>>>>>// procedure Start_StatusPanel
52342>>>>>>>>>//   handle hwnd#
52342>>>>>>>>>//   integer swp#
52342>>>>>>>>>//   string caption_text#
52342>>>>>>>>>//   forward send Start_StatusPanel
52342>>>>>>>>>//   get Caption_Text to Caption_Text#
52342>>>>>>>>>//   move (StringOemToAnsi(Caption_Text#)) to Caption_Text#
52342>>>>>>>>>//   // To make the status_panel stay-on-top, we first find it's window handle ...
52342>>>>>>>>>//   move (FindWindow("DFDialogClass",Caption_Text#)) to hwnd#
52342>>>>>>>>>//   // ... then we add the extended style WS_EX_TOPMOST to the window, but we use SetWindowPos
52342>>>>>>>>>//   // to make sure the change takes effect immediately.
52342>>>>>>>>>//   move (SetWindowPos(hwnd#, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE ior SWP_NOSIZE)) to swp#
52342>>>>>>>>>//   // To manipulate this object further we could do
52342>>>>>>>>>//   //   get Object_From_Window hwnd# to realobj#
52342>>>>>>>>>//   // and then work with the DFDialog object realobj#
52342>>>>>>>>>// end_procedure
52342>>>>>>>>>  procedure batch_on string caption#
52344>>>>>>>>>    set caption_text to caption#
52345>>>>>>>>>    set title_text to ""
52346>>>>>>>>>    set message_text to ""
52347>>>>>>>>>    set action_text to ""
52348>>>>>>>>>    send Start_StatusPanel
52349>>>>>>>>>  end_procedure
52350>>>>>>>>>  procedure batch_off
52352>>>>>>>>>    send Stop_StatusPanel
52353>>>>>>>>>  end_procedure
52354>>>>>>>>>  procedure batch_update string str#
52356>>>>>>>>>    Set Message_Text to str#
52357>>>>>>>>>  end_procedure
52358>>>>>>>>>  procedure batch_update2 string str#
52360>>>>>>>>>    set Action_Text to str#
52361>>>>>>>>>  end_procedure
52362>>>>>>>>>  procedure batch_update3 string str#
52364>>>>>>>>>    set title_text to str#
52365>>>>>>>>>  end_procedure
52366>>>>>>>>>  function batch_interrupt returns integer
52368>>>>>>>>>    integer cancel#
52368>>>>>>>>>    get Check_StatusPanel to cancel#
52369>>>>>>>>>    if cancel# begin
52371>>>>>>>>>      send stop_statuspanel
52372>>>>>>>>>      move (yesno_box(pCancelQuestion(self),pCancelQuestionCaption(self),MB_DEFBUTTON2)) to cancel#
52373>>>>>>>>>      move (cancel#=mbr_yes) to cancel#
52374>>>>>>>>>      if cancel# function_return 1
52377>>>>>>>>>      send Start_StatusPanel
52378>>>>>>>>>    end
52378>>>>>>>>>>
52378>>>>>>>>>  end_function
52379>>>>>>>>>end_class // cBatchCompanion
52380>>>>>>>>>procedure ScreenEndWait_On integer min# integer max#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
52382>>>>>>>>>end_procedure
52383>>>>>>>>>procedure ScreenEndWait_Update integer pos#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
52385>>>>>>>>>end_procedure
52386>>>>>>>>>procedure ScreenEndWait_SetText string str#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
52388>>>>>>>>>end_procedure
52389>>>>>>>>>procedure ScreenEndWait_SetText2 string str#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
52391>>>>>>>>>end_procedure
52392>>>>>>>>>procedure ScreenEndWait_Off
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
52394>>>>>>>>>end_procedure
52395>>>>>>>object oFn_Exists is a aps.ModalPanel label t.files.Warning
52398>>>>>>>  on_key kCancel send fn_cancel
52399>>>>>>>  property integer pResult public 0
52401>>>>>>>  object oMsg is a aps.TextBox
52403>>>>>>>    set p_fixed_width to 240
52404>>>>>>>    set justification_mode to (JMODE_CENTER+JMODE_WRAP+JMODE_VCENTER)
52405>>>>>>>  end_object
52406>>>>>>>  procedure fn_Append
52409>>>>>>>    set pResult to 1
52410>>>>>>>    send close_panel
52411>>>>>>>  end_procedure
52412>>>>>>>  procedure fn_OverWr
52415>>>>>>>    set pResult to 2
52416>>>>>>>    send close_panel
52417>>>>>>>  end_procedure
52418>>>>>>>  procedure fn_Cancel
52421>>>>>>>    set pResult to 3
52422>>>>>>>    send close_panel
52423>>>>>>>  end_procedure
52424>>>>>>>  object oBtn_Over is a aps.Multi_Button
52426>>>>>>>    on_item t.files.Overwrite send fn_overwr
52427>>>>>>>  end_object
52428>>>>>>>  object oBtn_Append is a aps.Multi_Button
52430>>>>>>>    on_item t.files.Append send fn_append
52431>>>>>>>  end_object
52432>>>>>>>  object oBtn_Cancel is a aps.Multi_Button
52434>>>>>>>    on_item t.btn.cancel send fn_cancel
52435>>>>>>>  end_object
52436>>>>>>>  send aps_locate_multi_buttons
52437>>>>>>>  function iRun.si string file_name# integer allow_append# returns integer
52440>>>>>>>    integer rval#
52440>>>>>>>    //set shadow_state of (Btn(self)) item 1 to (not(allow_append#))
52440>>>>>>>    set value of (oMsg(self)) to (replace("#",t.files.FileExists,file_name#))
52441>>>>>>>    send popup
52442>>>>>>>    get pResult to rval#
52443>>>>>>>    if rval# eq 3 move 0 to rval#
52446>>>>>>>    function_return rval#
52447>>>>>>>  end_function
52448>>>>>>>end_object
52449>>>>>>>
52449>>>>>>>//         Return value: 0=cancel, 1=append, 2=overwrite
52449>>>>>>>function SEQ_Filename_Exists_Action global string file_name# integer allow_append# returns integer
52451>>>>>>>  function_return (iRun.si(oFn_Exists(self),file_name#,allow_append#))
52452>>>>>>>end_function
52453>>>>>>>
52453>>>>>>>procedure SEQ_WriteGridItems global integer ch# integer obj#
52455>>>>>>>  integer itm# max# shadow# checkbox# select# aux# msg#
52455>>>>>>>  get item_count of obj# to max#
52456>>>>>>>  writeln channel ch# max#
52459>>>>>>>  for itm# from 0 to (max#-1)
52465>>>>>>>>
52465>>>>>>>    writeln (value(obj#,itm#))
52467>>>>>>>    get checkbox_item_state of obj# item itm# to checkbox#
52468>>>>>>>    get select_state        of obj# item itm# to select#
52469>>>>>>>    get item_shadow_state  of obj# item itm# to shadow#
52470>>>>>>>    get aux_value of obj# item itm# to aux#
52471>>>>>>>    get message of obj# item itm# to msg#
52472>>>>>>>    writeln checkbox#
52474>>>>>>>    writeln select#
52476>>>>>>>    writeln shadow#
52478>>>>>>>    writeln aux#
52480>>>>>>>    writeln msg#
52482>>>>>>>  loop
52483>>>>>>>>
52483>>>>>>>end_procedure
52484>>>>>>>
52484>>>>>>>procedure SEQ_ReadGridItems global integer ch# integer obj#
52486>>>>>>>  integer itm# max# shadow# checkbox# select# aux# msg#
52486>>>>>>>  string value#
52486>>>>>>>  send delete_data to obj#
52487>>>>>>>  readln channel ch# max#
52489>>>>>>>  for itm# from 0 to (max#-1)
52495>>>>>>>>
52495>>>>>>>    readln value#
52496>>>>>>>    readln checkbox#
52497>>>>>>>    readln select#
52498>>>>>>>    readln shadow#
52499>>>>>>>    readln aux#
52500>>>>>>>    readln msg#
52501>>>>>>>    send add_item to obj# msg# value#
52502>>>>>>>    set checkbox_item_state of obj# item itm# to checkbox#
52503>>>>>>>    set select_state        of obj# item itm# to select#
52504>>>>>>>    set item_shadow_state of obj# item itm# to shadow#
52505>>>>>>>    set aux_value of obj# item itm# to aux#
52506>>>>>>>  loop
52507>>>>>>>>
52507>>>>>>>  set dynamic_update_state of obj# to true
52508>>>>>>>end_procedure
52509>>>>>>>
52509>>>>>>>define xFO_MOVE               for |CI$0001
52509>>>>>>>define xFO_COPY               for |CI$0002
52509>>>>>>>define xFO_DELETE             for |CI$0003
52509>>>>>>>define xFO_RENAME             for |CI$0004
52509>>>>>>>
52509>>>>>>>define xFOF_MULTIDESTFILES    for |CI$0001
52509>>>>>>>define xFOF_CONFIRMMOUSE      for |CI$0002
52509>>>>>>>define xFOF_SILENT            for |CI$0004  // don't create progress/report
52509>>>>>>>define xFOF_RENAMEONCOLLISION for |CI$0008
52509>>>>>>>define xFOF_NOCONFIRMATION    for |CI$0010  // Don't prompt the user.
52509>>>>>>>define xFOF_WANTMAPPINGHANDLE for |CI$0020  // Fill in SHFILEOPSTRUCT.hNameMappings
52509>>>>>>>                                           // Must be freed using SHFreeNameMappings
52509>>>>>>>define xFOF_ALLOWUNDO         for |CI$0040
52509>>>>>>>define xFOF_FILESONLY         for |CI$0080  // on *.*, do only files
52509>>>>>>>define xFOF_SIMPLEPROGRESS    for |CI$0100  // means don't show names of files
52509>>>>>>>define xFOF_NOCONFIRMMKDIR    for |CI$0200  // don't confirm making any needed dirs
52509>>>>>>>
52509>>>>>>>Type tFILES_SHFILEOPSTRUCT
52509>>>>>>>  Field files_hWnd                   as Handle
52509>>>>>>>  Field files_wFunc                  as Integer
52509>>>>>>>  Field files_pFrom                  as Pointer
52509>>>>>>>  Field files_pTo                    as Pointer
52509>>>>>>>  Field files_fFlags                 as Short
52509>>>>>>>  Field files_fAnyOperationsAborted  as Short
52509>>>>>>>  Field files_hNameMappings          as Pointer
52509>>>>>>>  Field files_lpszProgressTitle      as Pointer // only used if xFOF_SIMPLEPROGRESS
52509>>>>>>>End_Type
52509>>>>>>>
52509>>>>>>>External_Function FILES_SHFileOperation "SHFileOperationA" Shell32.dll ;        pointer lpFileOp returns integer
52510>>>>>>>
52510>>>>>>>procedure SEQ_DeleteFileToBin global string fn#
52512>>>>>>>  string  strFileOpt
52512>>>>>>>  Pointer lpFileOpt lpFileName
52512>>>>>>>  ZeroType tFILES_SHFILEOPSTRUCT to strFileOpt
52513>>>>>>>  Put xFO_DELETE to strFileOpt at files_wFunc
52514>>>>>>>  GetAddress of fn# to lpFileName
52515>>>>>>>  Put lpFileName to strFileOpt at files_pFrom
52516>>>>>>>  Put (xFOF_SILENT ior xFOF_NOCONFIRMATION ior xFOF_ALLOWUNDO) to strFileOpt at files_fFlags
52517>>>>>>>  GetAddress of strFileOpt to lpFileOpt
52518>>>>>>>  Move (FILES_SHFileOperation(lpFileOpt)) to strmark
52519>>>>>>>end_procedure
52520>>>>>>>
52520>>>>>>>class cSEQ_FileReader is a TS_TimeEstimator
52521>>>>>>>  procedure construct_object integer img#
52523>>>>>>>    forward send construct_object img#
52525>>>>>>>
52525>>>>>>>    property integer pReadCount      public 0  // record counter (lines or records)
52526>>>>>>>    property string  pFileName       public "" // name of input file
52527>>>>>>>    property integer pChannel        public 0  // input channel
52528>>>>>>>    property integer pPrevPos        public 0  // last record was read starting
52529>>>>>>>                                               // in this channel position
52529>>>>>>>    property integer pRejectRecord   public 0  //
52530>>>>>>>
52530>>>>>>>    property date    pReadDate       public 0  // Date and time of read
52531>>>>>>>    property string  pReadTime       public "" // initialization
52532>>>>>>>
52532>>>>>>>    property integer pOkToCancel     public 1  // Ok to interrupt?
52533>>>>>>>    property string  pCancelQuestion public t.files.StopRead
52534>>>>>>>
52534>>>>>>>    property integer piInterrupted   public 0
52535>>>>>>>  end_procedure
52536>>>>>>>
52536>>>>>>>  procedure display_init
52538>>>>>>>  end_procedure
52539>>>>>>>  procedure display_update
52541>>>>>>>  end_procedure
52542>>>>>>>
52542>>>>>>>  function iPreconditions_Direct_Input returns integer
52544>>>>>>>    integer fn_ok# file_size# ch# itm#
52544>>>>>>>    string fn#
52544>>>>>>>
52544>>>>>>>    get pChannel to ch#
52545>>>>>>>    get pFileName to fn#
52546>>>>>>>    trim fn# to fn#
52547>>>>>>>>
52547>>>>>>>    if fn# eq "" send obs t.files.FileNotSpec
52550>>>>>>>    direct_input channel ch# fn#
52552>>>>>>>    [ SeqEof] move 0 to fn_ok#
52553>>>>>>>    [~SeqEof] move 1 to fn_ok#
52554>>>>>>>    close_input
52555>>>>>>>    ifnot fn_ok# begin
52557>>>>>>>      send obs (replace("#",t.files.FileNotFound,fn#))
52558>>>>>>>      function_return 0
52559>>>>>>>    end
52559>>>>>>>>
52559>>>>>>>    else begin
52560>>>>>>>      append_output channel ch# fn#
52562>>>>>>>      get_channel_position ch# to file_size#
52563>>>>>>>>
52563>>>>>>>      set piMin to 0
52564>>>>>>>      set piMax to file_size#
52565>>>>>>>      close_output channel ch#
52567>>>>>>>    end
52567>>>>>>>>
52567>>>>>>>
52567>>>>>>>    set piInterrupted to 0
52568>>>>>>>    function_return 1
52569>>>>>>>  end_function
52570>>>>>>>
52570>>>>>>>  function iDirect_Input returns integer
52572>>>>>>>    integer ch#
52572>>>>>>>    string fn#
52572>>>>>>>    if (iPreconditions_Direct_Input(self)) begin
52574>>>>>>>      send display_init
52575>>>>>>>      get pChannel to ch#
52576>>>>>>>      get pFileName to fn#
52577>>>>>>>      direct_input channel ch# fn#
52579>>>>>>>      set pReadCount to 0 // initialize counter
52580>>>>>>>      set pReadDate to (dSysDate())
52581>>>>>>>      set pReadTime to (sSysTime())
52582>>>>>>>      set pPrevPos to 0
52583>>>>>>>      function_return 1
52584>>>>>>>    end
52584>>>>>>>>
52584>>>>>>>    function_return 0
52585>>>>>>>  end_function
52586>>>>>>>
52586>>>>>>>  procedure read_reset
52588>>>>>>>    set_channel_position (pChannel(self)) to (pPrevPos(self))
52589>>>>>>>>
52589>>>>>>>  end_procedure
52590>>>>>>>
52590>>>>>>>  procedure read_header returns integer // augment this
52592>>>>>>>    procedure_return 0
52593>>>>>>>  end_procedure
52594>>>>>>>
52594>>>>>>>  procedure read_one returns integer // augment this
52596>>>>>>>    procedure_return 1
52597>>>>>>>  end_procedure
52598>>>>>>>
52598>>>>>>>  function iUserInterrupt returns integer
52600>>>>>>>  end_function
52601>>>>>>>
52601>>>>>>>  procedure roll_back // augment this to undo the effect
52603>>>>>>>  end_procedure       // of a interrupted read
52604>>>>>>>
52604>>>>>>>  procedure read_begin
52606>>>>>>>  end_procedure
52607>>>>>>>  procedure read_end
52609>>>>>>>  end_procedure
52610>>>>>>>
52610>>>>>>>  procedure run string fn#
52612>>>>>>>    integer finish# ch# PrevPos#
52612>>>>>>>    if Num_Arguments gt 0 set pFileName to fn#
52615>>>>>>>    if (iDirect_Input(self)) begin
52617>>>>>>>      get pChannel to ch#
52618>>>>>>>      send read_begin
52619>>>>>>>      get msg_read_header to finish#
52620>>>>>>>      ifnot finish# begin
52622>>>>>>>        repeat
52622>>>>>>>>
52622>>>>>>>          set pRejectRecord to false
52623>>>>>>>          get msg_read_one to finish#
52624>>>>>>>          ifnot finish# begin
52626>>>>>>>            get_channel_position ch# to PrevPos#
52627>>>>>>>>
52627>>>>>>>            set pPrevPos to PrevPos#
52628>>>>>>>            set pReadCount to (pReadCount(self)+1)
52629>>>>>>>            send display_update
52630>>>>>>>          end
52630>>>>>>>>
52630>>>>>>>          if (iUserInterrupt(self)) move 1 to finish# // keypress
52633>>>>>>>          if (piInterrupted(self))  move 1 to finish# // program interrupt
52636>>>>>>>        until finish#
52638>>>>>>>      end
52638>>>>>>>>
52638>>>>>>>      close_input channel ch#
52640>>>>>>>      send read_end
52641>>>>>>>      if (piInterrupted(self)) send roll_back
52644>>>>>>>    end
52644>>>>>>>>
52644>>>>>>>  end_procedure
52645>>>>>>>end_class // cSEQ_FileReader
52646>>>>>>>
52646>>>>>>>define xMAX_PATH for 200
52646>>>>>>>External_function Files_GetWindowsDirectory "GetWindowsDirectoryA" kernel32.dll Pointer lpBuffer Integer nSize returns integer
52647>>>>>>>function SEQ_WindowsDirectory global returns string
52649>>>>>>>  string sVal
52649>>>>>>>  integer iGrb
52649>>>>>>>  pointer pVal
52649>>>>>>>  ZeroString xMAX_PATH to sVal
52650>>>>>>>  GetAddress of sVal to pVal
52651>>>>>>>  move (Files_GetWindowsDirectory(pVal, xMAX_PATH)) to iGrb
52652>>>>>>> function_return sVal
52653>>>>>>>end_function
52654>>>>>>>
52654>>>>>>>enumeration_list
52654>>>>>>>  define VALIDFOLDER_CREATE_FALSE
52654>>>>>>>  define VALIDFOLDER_CREATE_PROMPT
52654>>>>>>>  define VALIDFOLDER_CREATE_QUIET
52654>>>>>>>end_enumeration_list
52654>>>>>>>enumeration_list
52654>>>>>>>  define VALIDFOLDER_EXISTS                // The folder exists
52654>>>>>>>  define VALIDFOLDER_NAME_IS_FILE          // The specified name points to a file
52654>>>>>>>  define VALIDFOLDER_CREATION_FAILED       // Folder could not be created
52654>>>>>>>  define VALIDFOLDER_NO_FOLDER_SPECIFIED   // Folder not specified
52654>>>>>>>  define VALIDFOLDER_USER_CANCEL           // User cancelled directory create
52654>>>>>>>  define VALIDFOLDER_PARENT_PATH_NOT_FOUND // Path to parent folder not found
52654>>>>>>>  define VALIDFOLDER_PATH_NOT_FOUND        // Path to parent folder not found
52654>>>>>>>end_enumeration_list
52654>>>>>>>
52654>>>>>>>function SEQ_ValidateFolder_ErrorText global integer liError returns string
52656>>>>>>>  if (liError=VALIDFOLDER_EXISTS)                function_return ""
52659>>>>>>>  if (liError=VALIDFOLDER_NAME_IS_FILE)          function_return t.files.Error1
52662>>>>>>>  if (liError=VALIDFOLDER_CREATION_FAILED)       function_return t.files.Error2
52665>>>>>>>  if (liError=VALIDFOLDER_NO_FOLDER_SPECIFIED)   function_return t.files.Error3
52668>>>>>>>  if (liError=VALIDFOLDER_PATH_NOT_FOUND)        function_return t.files.Error5
52671>>>>>>>  if (liError=VALIDFOLDER_PARENT_PATH_NOT_FOUND) function_return t.files.Error5
52674>>>>>>>end_function
52675>>>>>>>
52675>>>>>>>function SEQ_ValidateFolder global string lsFolder integer liAllowCreate integer lbNoErrorMsg returns integer
52677>>>>>>>  integer liError liExists lbCreate liGarbage
52677>>>>>>>  string lsParentFolder lsError
52677>>>>>>>  move (trim(lsFolder)) to lsFolder
52678>>>>>>>  if (lsFolder="") move VALIDFOLDER_NO_FOLDER_SPECIFIED to liError // Error: No folder specified
52681>>>>>>>  else begin
52682>>>>>>>    if (length(lsFolder)>1 and right(lsFolder,2)=(":"+sysconf(SYSCONF_DIR_SEPARATOR))) ;                                               move (StringLeftBut(lsFolder,1)) to lsFolder
52685>>>>>>>    get SEQ_FileExists lsFolder to liExists
52686>>>>>>>    if (liExists=SEQIT_FILE) move VALIDFOLDER_NAME_IS_FILE to liError // Error: it's a file
52689>>>>>>>    else begin
52690>>>>>>>      if (liExists=SEQIT_DIRECTORY) move VALIDFOLDER_EXISTS to liError // All is well!
52693>>>>>>>      else begin
52694>>>>>>>        if (liAllowCreate<>VALIDFOLDER_CREATE_FALSE) begin
52696>>>>>>>          get SEQ_ExtractPathFromFileName lsFolder to lsParentFolder
52697>>>>>>>          get SEQ_FileExists lsParentFolder to liExists // Does parent folder exist?
52698>>>>>>>          if (liExists=SEQIT_DIRECTORY) begin
52700>>>>>>>            if (liAllowCreate=VALIDFOLDER_CREATE_PROMPT) get MB_Verify4 t.files.PromptDirCreate1 ("("+lsFolder+")") t.files.PromptDirCreate2 "" 1 to lbCreate
52703>>>>>>>            else move 1 to lbCreate
52705>>>>>>>            if lbCreate begin
52707>>>>>>>              get wvaWin32_CreateDirectory (ToAnsi(lsFolder)) to liGarbage
52708>>>>>>>              get SEQ_FileExists lsFolder to liExists // Does the folder exist now?
52709>>>>>>>              if (liExists=SEQIT_DIRECTORY) move VALIDFOLDER_EXISTS to liError
52712>>>>>>>              else move VALIDFOLDER_CREATION_FAILED to liError
52714>>>>>>>            end
52714>>>>>>>>
52714>>>>>>>            else move VALIDFOLDER_USER_CANCEL to liError
52716>>>>>>>          end
52716>>>>>>>>
52716>>>>>>>          else move VALIDFOLDER_PARENT_PATH_NOT_FOUND to liError
52718>>>>>>>        end
52718>>>>>>>>
52718>>>>>>>        else move VALIDFOLDER_PATH_NOT_FOUND to liError
52720>>>>>>>      end
52720>>>>>>>>
52720>>>>>>>    end
52720>>>>>>>>
52720>>>>>>>  end
52720>>>>>>>>
52720>>>>>>>  ifnot lbNoErrorMsg begin
52722>>>>>>>    get SEQ_ValidateFolder_ErrorText liError to lsError
52723>>>>>>>    if (liError=VALIDFOLDER_NAME_IS_FILE)          send obs lsError lsFolder
52726>>>>>>>    if (liError=VALIDFOLDER_CREATION_FAILED)       send obs lsError lsFolder
52729>>>>>>>    if (liError=VALIDFOLDER_NO_FOLDER_SPECIFIED)   send obs lsError
52732>>>>>>>    if (liError=VALIDFOLDER_PARENT_PATH_NOT_FOUND) send obs lsError lsParentFolder
52735>>>>>>>    if (liError=VALIDFOLDER_PATH_NOT_FOUND)        send obs lsError lsFolder
52738>>>>>>>  end
52738>>>>>>>>
52738>>>>>>>  function_return liError
52739>>>>>>>end_function // SEQ_ValidateFolder
52740>>>>>>>
52740>>>>>>>
52740>>>>>Use FDX.nui      // cFDX class
52740>>>>>
52740>>>>> define t.FDX.Btn.SelectOpen   for "Auto select"
52740>>>>> define t.FDX.Btn.SelectAll    for "Select all"
52740>>>>> define t.FDX.Btn.SelectNone   for "Clear selection"
52740>>>>> define t.FDX.Btn.SelectInvert for "Invert selection"
52740>>>>> define t.FDX.Btn.SelectPhys   for "Select master"
52740>>>>> define t.FDX.Btn.SelectParent for "Select parent"
52740>>>>> define t.FDX.Btn.SelectChild  for "Select children"
52740>>>>> define t.FDX.UserName         for "User name"
52740>>>>> define t.FDX.DFname           for "Logical name"
52740>>>>> define t.FDX.RootName         for "File name"
52740>>>>> define t.FDX.Selected         for "Selected:"
52740>>>>>
52740>>>>>enumeration_list
52740>>>>>  define BAD_ENTRIES_NO_CHECK  // This one also defers check for DB-Driver
52740>>>>>  define BAD_ENTRIES_SHADOW
52740>>>>>  define BAD_ENTRIES_EXCLUDE
52740>>>>>end_enumeration_list
52740>>>>>
52740>>>>>class cFdxFileMultiSelector is a aps.Grid
52741>>>>>  procedure DoHeaderLabels integer by#
52743>>>>>    set header_label item 1 to "#"
52744>>>>>    set header_label item 2 to t.FDX.UserName
52745>>>>>    set header_label item 3 to t.FDX.DFname
52746>>>>>    set header_label item 4 to t.FDX.RootName
52747>>>>>    set header_label item by# to ("*"+header_label(self,by#)+"*")
52748>>>>>  end_procedure
52749>>>>>  procedure construct_object
52751>>>>>    forward send construct_object
52753>>>>>    set line_width to 5 0
52754>>>>>    on_key key_ctrl+key_a send select_all_not_bad
52755>>>>>    set form_margin item 0 to  2
52756>>>>>    set form_margin item 1 to  3
52757>>>>>    set form_margin item 2 to 30
52758>>>>>    set form_margin item 3 to 15
52759>>>>>    set form_margin item 4 to 15
52760>>>>>    set highlight_row_state to true
52761>>>>>    set CurrentCellColor     to clHighlight
52762>>>>>    set CurrentCellTextColor to clHighlightText
52763>>>>>    set CurrentRowColor      to clHighlight
52764>>>>>    set CurrentRowTextColor  to clHighlightText
52765>>>>>//   set highlight_row_color to (rgb(0,255,255))
52765>>>>>//   set current_item_color to (rgb(0,255,255))
52765>>>>>    on_key knext_item send switch
52766>>>>>    on_key kprevious_item send switch_back
52767>>>>>    on_key kswitch send switch
52768>>>>>    on_key kswitch_back send switch_back
52769>>>>>    set auto_top_item_state to false // Does not work!
52770>>>>>    send DoHeaderLabels 1
52771>>>>>    set select_mode to multi_select
52772>>>>>    object oSortArray is an cArray no_image
52774>>>>>      //           Sort value          fil Select?
52774>>>>>      // Ĵ
52774>>>>>      //               30               3  1
52774>>>>>      // The first 30 characters of each item in this array will be used for
52774>>>>>      // sorting the values.
52774>>>>>    end_object
52775>>>>>    object oRootNames is a cSet no_image
52777>>>>>    end_object
52778>>>>>    property integer piNo_Alias_State             public false
52779>>>>>    property integer piBad_Entries_State          public BAD_ENTRIES_SHADOW
52780>>>>>    property integer piGeneric_Display_Name_State public false
52781>>>>>    property integer piDriverFilter_State         public false
52782>>>>>    property integer piFDX_Server                 public 0
52783>>>>>    object oDriversIncluded is a cArray no_image
52785>>>>>    end_object
52786>>>>>    on_key key_ctrl+key_d send display_file_things
52787>>>>>    on_key key_ctrl+key_l send display_file_location
52788>>>>>    on_key key_ctrl+key_w send DoWriteToFile
52789>>>>>  end_procedure
52790>>>>>  procedure DoWriteToFile
52792>>>>>    send Grid_DoWriteToFile self
52793>>>>>  end_procedure
52794>>>>>  procedure wait_on
52796>>>>>    send cursor_wait to (cursor_control(self))
52797>>>>>  end_procedure
52798>>>>>  procedure wait_off
52800>>>>>    send cursor_ready to (cursor_control(self))
52801>>>>>  end_procedure
52802>>>>>  procedure DriverFilter_Add integer driver_type#
52804>>>>>    set piDriverFilter_State to true
52805>>>>>    set value of (oDriversIncluded(self)) item driver_type# to 1
52806>>>>>  end_procedure
52807>>>>>  procedure DriverFilter_Reset
52809>>>>>    send delete_data to (oDriversIncluded(self))
52810>>>>>    set piDriverFilter_State to false
52811>>>>>  end_procedure
52812>>>>>  function DriverFilter_Include integer driver_type# returns integer
52814>>>>>    if (piDriverFilter_State(self)) function_return (value(oDriversIncluded(self),driver_type#))
52817>>>>>    function_return 1
52818>>>>>  end_function
52819>>>>>  procedure update_select_display // Intended for augmentation
52821>>>>>    // Called everytime the number of selected entries changes.
52821>>>>>  end_procedure
52822>>>>>  function Row_Count returns integer
52824>>>>>    function_return (item_count(self)/5)
52825>>>>>  end_function
52826>>>>>  function Row_Shadow_State integer row# returns integer
52828>>>>>    integer select#
52828>>>>>    get shadow_state item (row#*5) to select#
52829>>>>>    function_return select#
52830>>>>>  end_function
52831>>>>>  procedure set File_Select_State integer file# integer select#
52833>>>>>    integer row# max#
52833>>>>>    get Row_Count to max#
52834>>>>>    for row# from 0 to (max#-1)
52840>>>>>>
52840>>>>>      ifnot (Row_Shadow_State(self,row#)) if (integer(value(self,row#*5+1))=file#) set select_state item (row#*5) to select#
52845>>>>>    loop
52846>>>>>>
52846>>>>>    set dynamic_update_state to true // Force repaint
52847>>>>>  end_procedure
52848>>>>>  function File_Select_State integer file# returns integer
52850>>>>>    integer row# max# select#
52850>>>>>    get Row_Count to max#
52851>>>>>    for row# from 0 to (max#-1)
52857>>>>>>
52857>>>>>      if (integer(value(self,row#*5+1))=file#) begin
52859>>>>>        get select_state item (row#*5) to select#
52860>>>>>        function_return select#
52861>>>>>      end
52861>>>>>>
52861>>>>>    loop
52862>>>>>>
52862>>>>>  end_function
52863>>>>>  function Row_Select_State integer row# returns integer
52865>>>>>    integer select#
52865>>>>>    get select_state item (row#*5) to select#
52866>>>>>    function_return select#
52867>>>>>  end_function
52868>>>>>  procedure set Row_Select_State integer row# integer select#
52870>>>>>    ifnot (item_shadow_state(self,row#*5)) set select_state item (row#*5) to select#
52873>>>>>  end_procedure
52874>>>>>  function Row_File integer row# returns integer
52876>>>>>    function_return (value(self,row#*5+1))
52877>>>>>  end_function
52878>>>>>  function Row_DisplayName integer row# returns string
52880>>>>>    function_return (value(self,row#*5+2))
52881>>>>>  end_function
52882>>>>>  function Row_DfName integer row# returns string
52884>>>>>    function_return (value(self,row#*5+3))
52885>>>>>  end_function
52886>>>>>  function Row_RootName integer row# returns string
52888>>>>>    function_return (value(self,row#*5+4))
52889>>>>>  end_function
52890>>>>>  function Current_Row returns integer
52892>>>>>    integer itm#
52892>>>>>    get current_item to itm#
52893>>>>>    function_return (itm#/5)
52894>>>>>  end_function
52895>>>>>  function Current_Column returns integer
52897>>>>>    function_return (current_item(self)-(current_row(self)*5))
52898>>>>>  end_function
52899>>>>>  function Current_File returns integer
52901>>>>>    function_return (Row_File(self,Current_Row(self)))
52902>>>>>  end_function
52903>>>>>  function File_Select_Count returns integer
52905>>>>>    integer row# max# rval#
52905>>>>>    move 0 to rval#
52906>>>>>    get row_count to max#
52907>>>>>    for row# from 0 to (max#-1)
52913>>>>>>
52913>>>>>      if (Row_Select_State(self,row#)) increment rval#
52916>>>>>    loop
52917>>>>>>
52917>>>>>    function_return rval#
52918>>>>>  end_function
52919>>>>>  procedure sort.i integer by# // 1:Number 2:Display 3:DF 4:Root
52921>>>>>    integer row# max# arr# file# select#
52921>>>>>    string str#
52921>>>>>    if by# begin
52923>>>>>      send wait_on
52924>>>>>      move (oSortArray(self)) to arr#
52925>>>>>      send delete_data to arr#
52926>>>>>      get Row_Count to max#
52927>>>>>      for row# from 0 to (max#-1)
52933>>>>>>
52933>>>>>        move (value(self,row#*5+by#)) to str#
52934>>>>>        if by# eq 1 move (IntToStrR(str#,4)) to str#
52937>>>>>        move (integer(value(self,row#*5+1))) to file#
52938>>>>>        move (select_state(self,row#*5)) to select#
52939>>>>>        move (pad(str#,30)+IntToStrR(file#,4)+IntToStrR(select#,1)) to str#
52940>>>>>        set value of arr# item row# to str#
52941>>>>>      loop
52942>>>>>>
52942>>>>>      send sort_items to arr#
52943>>>>>      send DoHeaderLabels by#
52944>>>>>      send fill_list_from_sort_array
52945>>>>>      send delete_data to arr#
52946>>>>>      send wait_off
52947>>>>>    end
52947>>>>>>
52947>>>>>  end_procedure
52948>>>>>  procedure header_mouse_click integer itm#
52950>>>>>    send sort.i itm#
52951>>>>>    forward send header_mouse_click itm#
52953>>>>>  end_procedure
52954>>>>>  procedure add_row.isssi integer file# string dn# string ln# string rn# integer shade#
52956>>>>>    integer base#
52956>>>>>    get item_count to base#
52957>>>>>    send add_item msg_none ""
52958>>>>>    set checkbox_item_state item base# to true
52959>>>>>    send add_item msg_none (string(file#))
52960>>>>>    send add_item msg_none dn#
52961>>>>>    send add_item msg_none ln#
52962>>>>>    send add_item msg_none rn#
52963>>>>>    set entry_state item (base#+1) to false
52964>>>>>    set entry_state item (base#+2) to false
52965>>>>>    set entry_state item (base#+3) to false
52966>>>>>    set entry_state item (base#+4) to false
52967>>>>>    if shade# begin
52969>>>>>      set item_shadow_state item  base#    to true
52970>>>>>      set item_shadow_state item (base#+1) to true
52971>>>>>      set item_shadow_state item (base#+2) to true
52972>>>>>      set item_shadow_state item (base#+3) to true
52973>>>>>      set item_shadow_state item (base#+4) to true
52974>>>>>    end
52974>>>>>>
52974>>>>>  end_procedure
52975>>>>>  register_function iFile_loaded.i integer file# returns integer
52975>>>>>  function iFileAvailable.i integer file# returns integer
52977>>>>>    integer oFDX#
52977>>>>>    get piFDX_Server to oFDX#
52978>>>>>    function_return (FDX_CanOpenFile(oFDX#,file#))
52979>>>>>  end_function
52980>>>>>  procedure add_file.i integer file#
52982>>>>>    integer base# piNo_Alias_State# AddFile# bad# piBad_Entries_State# driver_type#
52982>>>>>    string dn# ln# rootname#
52982>>>>>    get piNo_Alias_State to piNo_Alias_State#
52983>>>>>    move (FDX_AttrValue_FILELIST(piFDX_Server(self),DF_FILE_ROOT_NAME,file#)) to RootName#
52984>>>>>    move 0 to bad#
52985>>>>>    get piBad_Entries_State to piBad_Entries_State#
52986>>>>>
52986>>>>>    if (piNo_Alias_State# and element_find(oRootNames(self),uppercase(RootName#))<>-1) move 0 to AddFile#
52989>>>>>    else begin
52990>>>>>      if piBad_Entries_State# ne BAD_ENTRIES_NO_CHECK begin
52992>>>>>        move (iFileAvailable.i(self,file#)) to driver_type#
52993>>>>>        move (not(driver_type#)) to bad#
52994>>>>>        ifnot bad# move (not(DriverFilter_Include(self,driver_type#))) to bad#
52997>>>>>      end
52997>>>>>>
52997>>>>>
52997>>>>>      if (bad# and piBad_Entries_State#=BAD_ENTRIES_EXCLUDE) move 0 to AddFile#
53000>>>>>      else move 1 to AddFile#
53002>>>>>    end
53002>>>>>>
53002>>>>>
53002>>>>>    if AddFile# begin
53004>>>>>      if (piGeneric_Display_Name_State(self)) move (rtrim(FDX_AttrValue_FILELIST(piFDX_Server(self),DF_FILE_DISPLAY_NAME,file#))) to dn#
53007>>>>>      else move (File_Display_Name(file#)) to dn#
53009>>>>>      //get_attribute DF_FILE_LOGICAL_NAME of file# to ln#
53009>>>>>      move (FDX_AttrValue_FILELIST(piFDX_Server(self),DF_FILE_LOGICAL_NAME,file#)) to ln#
53010>>>>>      if piNo_Alias_State# send element_add to (oRootNames(self)) (uppercase(rootname#))
53013>>>>>      send add_row.isssi file# dn# ln# rootname# (bad# and piBad_Entries_State#=BAD_ENTRIES_SHADOW)
53014>>>>>    end
53014>>>>>>
53014>>>>>  end_procedure // add_file.i
53015>>>>>  procedure row_change integer row_from# integer row_to#
53017>>>>>  end_procedure
53018>>>>>  procedure item_change integer i1# integer i2# returns integer
53020>>>>>    integer rval# row_from# row_to#
53020>>>>>    forward get msg_item_change i1# i2# to rval#
53022>>>>>    if (i1#/5) ne (i2#/5) send row_change (i1#/5) (i2#/5)
53025>>>>>    procedure_return rval#
53026>>>>>  end_procedure
53027>>>>>  procedure select_toggling integer itm# integer i#
53029>>>>>    integer ci#
53029>>>>>    get current_item to ci#
53030>>>>>    move ((ci#/5)*5) to ci# // Redirect to first column
53031>>>>>    forward send select_toggling ci# i#
53033>>>>>    send update_select_display
53034>>>>>  end_procedure
53035>>>>>  procedure fill_list_all_files
53037>>>>>    integer file# oFDX#
53037>>>>>    set dynamic_update_state to false
53038>>>>>    get piFDX_Server to oFDX#
53039>>>>>    send delete_data
53040>>>>>    send delete_data to (oRootNames(self))
53041>>>>>    move 0 to file#
53042>>>>>    send wait_on
53043>>>>>    repeat
53043>>>>>>
53043>>>>>      move (FDX_AttrValue_FLSTNAV(oFDX#,DF_FILE_NEXT_USED,file#)) to file#
53044>>>>>      if file# send add_file.i file#
53047>>>>>    until file# eq 0
53049>>>>>    send update_select_display
53050>>>>>    set dynamic_update_state to true
53051>>>>>    send wait_off
53052>>>>>  end_procedure
53053>>>>>  procedure fill_list_all_open // Only if we are working on real data
53055>>>>>    integer file# oFDX#
53055>>>>>    get piFDX_Server to oFDX#
53056>>>>>    set dynamic_update_state to false
53057>>>>>    ifnot oFDX# begin
53059>>>>>      send wait_on
53060>>>>>      send delete_data
53061>>>>>      send delete_data to (oRootNames(self))
53062>>>>>      move 0 to file#
53063>>>>>      repeat
53063>>>>>>
53063>>>>>        move (FDX_AttrValue_FLSTNAV(oFDX#,DF_FILE_NEXT_OPENED,file#)) to file#
53064>>>>>        if file# send add_file.i file#
53067>>>>>      until file# eq 0
53069>>>>>      send update_select_display
53070>>>>>      send wait_off
53071>>>>>    end
53071>>>>>>
53071>>>>>  end_procedure
53072>>>>>  procedure fill_list_from_sort_array
53074>>>>>    integer file# arr# itm# max# select# piNo_Alias_State#
53074>>>>>    string str#
53074>>>>>    set dynamic_update_state to false
53075>>>>>    get piNo_Alias_State to piNo_Alias_State#
53076>>>>>    set piNo_Alias_State to false
53077>>>>>    send delete_data
53078>>>>>    send delete_data to (oRootNames(self))
53079>>>>>    move (oSortArray(self)) to arr#
53080>>>>>    get item_count of arr# to max#
53081>>>>>    for itm# from 0 to (max#-1)
53087>>>>>>
53087>>>>>      get value of arr# item itm# to str#
53088>>>>>      move (integer(mid(str#,4,31))) to file#
53089>>>>>      move (integer(mid(str#,1,35))) to select#
53090>>>>>      send add_file.i file#
53091>>>>>      if select# set select_state item (item_count(self)-5) to true
53094>>>>>    loop
53095>>>>>>
53095>>>>>    set piNo_Alias_State to piNo_Alias_State# // Restore
53096>>>>>    set dynamic_update_state to true
53097>>>>>  end_procedure
53098>>>>>  procedure select_all
53100>>>>>    integer itm# max# row#
53100>>>>>    get Row_Count to max#
53101>>>>>    for row# from 0 to (max#-1)
53107>>>>>>
53107>>>>>      set Row_Select_State Row# to true
53108>>>>>    loop
53109>>>>>>
53109>>>>>    send update_select_display
53110>>>>>    set dynamic_update_state to true
53111>>>>>  end_procedure
53112>>>>>  procedure select_all_not_bad
53114>>>>>    integer itm# max# row# bad# file#
53114>>>>>    send wait_on
53115>>>>>    get Row_Count to max#
53116>>>>>    for row# from 0 to (max#-1)
53122>>>>>>
53122>>>>>      if (uppercase(Row_RootName(self,row#))<>"FLEXERRS") begin
53124>>>>>        get Row_File row# to file#
53125>>>>>        move (not(iFileAvailable.i(self,file#))) to bad#
53126>>>>>        if (not(bad#)) set Row_Select_State Row# to true
53129>>>>>      end
53129>>>>>>
53129>>>>>    loop
53130>>>>>>
53130>>>>>    send update_select_display
53131>>>>>    send wait_off
53132>>>>>    set dynamic_update_state to true
53133>>>>>  end_procedure
53134>>>>>  procedure select_none
53136>>>>>    integer itm# max# row#
53136>>>>>    get Row_Count to max#
53137>>>>>    for row# from 0 to (max#-1)
53143>>>>>>
53143>>>>>      set Row_Select_State Row# to false
53144>>>>>    loop
53145>>>>>>
53145>>>>>    send update_select_display
53146>>>>>    set dynamic_update_state to true
53147>>>>>  end_procedure
53148>>>>>  procedure select_invert
53150>>>>>    integer max# row# st#
53150>>>>>    get Row_Count to max#
53151>>>>>    for row# from 0 to (max#-1)
53157>>>>>>
53157>>>>>      ifnot (Row_Shadow_State(self,row#)) begin
53159>>>>>        get Row_Select_State Row# to st#
53160>>>>>        if (st# or uppercase(Row_RootName(self,row#))<>"FLEXERRS") set Row_Select_State Row# to (not(st#))
53163>>>>>      end
53163>>>>>>
53163>>>>>    loop
53164>>>>>>
53164>>>>>    send update_select_display
53165>>>>>    set dynamic_update_state to true
53166>>>>>  end_procedure
53167>>>>>
53167>>>>>  register_function sChildFiles.i integer file# returns string
53167>>>>>  register_function sParentFiles.i integer file# returns string
53167>>>>>  procedure select_parents
53169>>>>>    integer oFDX# itm# max# file#
53169>>>>>    string str#
53169>>>>>    get piFDX_Server to oFDX#
53170>>>>>    if oFDX# begin
53172>>>>>      ifnot (Row_Shadow_State(self,current_row(self))) begin
53174>>>>>        get sParentFiles.i of oFDX# (Current_File(self)) to str#
53175>>>>>        move (HowManyIntegers(str#)) to max#
53176>>>>>        for itm# from 1 to max#
53182>>>>>>
53182>>>>>          set File_Select_State (ExtractInteger(str#,itm#)) to true
53183>>>>>        loop
53184>>>>>>
53184>>>>>        set File_Select_State (Current_File(self)) to true
53185>>>>>        send update_select_display
53186>>>>>        set dynamic_update_state to true
53187>>>>>      end
53187>>>>>>
53187>>>>>    end
53187>>>>>>
53187>>>>>  end_procedure
53188>>>>>  procedure select_children
53190>>>>>    integer oFDX# itm# max# file#
53190>>>>>    string str#
53190>>>>>    get piFDX_Server to oFDX#
53191>>>>>    if oFDX# begin
53193>>>>>      ifnot (Row_Shadow_State(self,current_row(self))) begin
53195>>>>>        get sChildFiles.i of oFDX# (Current_File(self)) to str#
53196>>>>>        move (HowManyIntegers(str#)) to max#
53197>>>>>        for itm# from 1 to max#
53203>>>>>>
53203>>>>>          set File_Select_State (ExtractInteger(str#,itm#)) to true
53204>>>>>        loop
53205>>>>>>
53205>>>>>        set File_Select_State (Current_File(self)) to true
53206>>>>>        send update_select_display
53207>>>>>        set dynamic_update_state to true
53208>>>>>      end
53208>>>>>>
53208>>>>>    end
53208>>>>>>
53208>>>>>  end_procedure
53209>>>>>  procedure select_master
53211>>>>>    integer itm# max# row#
53211>>>>>    string rn# str#
53211>>>>>    get Row_Count to max#
53212>>>>>    move "" to str#
53213>>>>>    for row# from 0 to (max#-1)
53219>>>>>>
53219>>>>>      get Row_RootName row# to rn#
53220>>>>>      ifnot (uppercase(rn#)) eq "FLEXERRS" begin
53222>>>>>        ifnot (""+uppercase(rn#)+"") in str# begin
53224>>>>>          set Row_Select_State Row# to true
53225>>>>>          move (str#+uppercase(rn#)+"") to str#
53226>>>>>        end
53226>>>>>>
53226>>>>>      end
53226>>>>>>
53226>>>>>    loop
53227>>>>>>
53227>>>>>    send update_select_display
53228>>>>>    set dynamic_update_state to true
53229>>>>>  end_procedure
53230>>>>>  procedure select_bad
53232>>>>>    integer max# row# file# bad#
53232>>>>>    set dynamic_update_state to false
53233>>>>>    send wait_on
53234>>>>>    get Row_Count to max#
53235>>>>>    for row# from 0 to (max#-1)
53241>>>>>>
53241>>>>>      get Row_File row# to file#
53242>>>>>      move (not(iFileAvailable.i(self,file#))) to bad#
53243>>>>>      if bad# set Row_Select_State Row# to true
53246>>>>>    loop
53247>>>>>>
53247>>>>>    set dynamic_update_state to true
53248>>>>>    send update_select_display
53249>>>>>    send wait_off
53250>>>>>  end_procedure
53251>>>>>  procedure select_open
53253>>>>>    integer max# row# open# file#
53253>>>>>    ifnot (piFDX_Server(self)) begin
53255>>>>>      get Row_Count to max#
53256>>>>>      for row# from 0 to (max#-1)
53262>>>>>>
53262>>>>>        get Row_File row# to file#
53263>>>>>        if (DBMS_IsOpenFile(file#)) set Row_Select_State Row# to true
53266>>>>>      loop
53267>>>>>>
53267>>>>>      send update_select_display
53268>>>>>      set dynamic_update_state to true
53269>>>>>    end
53269>>>>>>
53269>>>>>  end_procedure
53270>>>>>
53270>>>>>  procedure Callback_Selected_Files integer msg# integer tmp_obj#
53272>>>>>    integer obj# max# row# open# file#
53272>>>>>    if num_arguments gt 1 move tmp_obj# to obj#
53275>>>>>    else move self to obj#
53277>>>>>    get Row_Count to max#
53278>>>>>    for row# from 0 to (max#-1)
53284>>>>>>
53284>>>>>      if (Row_Select_State(self,row#)) begin
53286>>>>>        move (Row_File(self,row#)) to file#
53287>>>>>        send msg# to obj# file# (Row_DisplayName(self,row#)) (Row_DfName(self,row#)) (Row_RootName(self,row#))
53288>>>>>      end
53288>>>>>>
53288>>>>>    loop
53289>>>>>>
53289>>>>>  end_procedure
53290>>>>>
53290>>>>>  procedure Callback_All_Files integer msg# integer tmp_obj#
53292>>>>>    integer obj# max# row# open# file#
53292>>>>>    if num_arguments gt 1 move tmp_obj# to obj#
53295>>>>>    else move self to obj#
53297>>>>>    get Row_Count to max#
53298>>>>>    for row# from 0 to (max#-1)
53304>>>>>>
53304>>>>>      move (Row_File(self,row#)) to file#
53305>>>>>      send msg# to obj# file# (Row_DisplayName(self,row#)) (Row_DfName(self,row#)) (Row_RootName(self,row#))
53306>>>>>    loop
53307>>>>>>
53307>>>>>  end_procedure
53308>>>>>
53308>>>>>  //> Procedure Callback_General are used for calling back
53308>>>>>  //>
53308>>>>>  //>  Selected# =  0 => Only files not selected are called back
53308>>>>>  //>  Selected# =  1 => Only files that are selected are called back
53308>>>>>  //>  Selected# = -1 => Files are called back whether they are selected or not
53308>>>>>  //>
53308>>>>>  //>  Shaded#   =  0 => Only files not shaded are called back
53308>>>>>  //>  Shaded#   =  1 => Only shaded files are called back
53308>>>>>  //>  Shaded#   = -1 => Files are called back whether they are shaded or not
53308>>>>>  //>
53308>>>>>  //>  Master#   =  0 => All entries fulfilling the above are called back
53308>>>>>  //>  Master#   =  1 => If more entries have identical root names they are only called back once.
53308>>>>>  procedure Callback_General integer msg# integer obj# integer selected# integer shaded# integer master_tmp#
53310>>>>>    integer row# max# file# is_selected# is_shaded# master# ok#
53310>>>>>    string check# root#
53310>>>>>    if num_arguments lt 5 move 0 to master#
53313>>>>>    else move master_tmp# to master#
53315>>>>>    move ";" to check#
53316>>>>>    get Row_Count to max#
53317>>>>>    for row# from 0 to (max#-1)
53323>>>>>>
53323>>>>>      move (Row_Select_State(self,row#)) to is_selected#
53324>>>>>      move (Row_Shadow_State(self,row#)) to is_shaded#
53325>>>>>      if ((selected#=-1 or selected#=is_selected#) and (shaded#=-1 or shaded#=is_shaded#)) begin
53327>>>>>        if master# begin
53329>>>>>          move (trim(lowercase(Row_RootName(self,row#)))) to root#
53330>>>>>          if (";"+root#+";") in check# move 0 to ok#
53333>>>>>          else begin
53334>>>>>            move (check#+root#+";") to check#
53335>>>>>            move 1 to ok#
53336>>>>>          end
53336>>>>>>
53336>>>>>        end
53336>>>>>>
53336>>>>>        else move 1 to ok#
53338>>>>>        if ok# begin
53340>>>>>          get Row_File row# to file#
53341>>>>>          send msg# to obj# file# is_selected# is_shaded#
53342>>>>>        end
53342>>>>>>
53342>>>>>      end
53342>>>>>>
53342>>>>>    loop
53343>>>>>>
53343>>>>>  end_procedure
53344>>>>>
53344>>>>>  // Returns true if the function is completed
53344>>>>>  register_function iCallback_File.iii integer file# integer get# integer obj# returns integer
53344>>>>>  function iCallback_Selected_Files_Server integer get# integer obj# returns integer
53346>>>>>    integer max# row# open# file# rval# svr#
53346>>>>>    get piFDX_Server to svr#
53347>>>>>    get Row_Count to max#
53348>>>>>    move 1 to rval#
53349>>>>>    for row# from 0 to (max#-1)
53355>>>>>>
53355>>>>>      if rval# begin
53357>>>>>        if (Row_Select_State(self,row#)) get iCallback_File.iii of svr# (Row_File(self,row#)) get# obj# to rval#
53360>>>>>      end
53360>>>>>>
53360>>>>>      else function_return 0
53362>>>>>    loop
53363>>>>>>
53363>>>>>    function_return 1
53364>>>>>  end_function
53365>>>>>  procedure load_current_selection string fn#
53367>>>>>    integer ch# row# max# file# st# fin#
53367>>>>>    string str#
53367>>>>>    get Seq_New_Channel to ch#
53368>>>>>    direct_input channel ch# fn#
53370>>>>>    if [~seqeof] begin
53372>>>>>      send wait_on
53373>>>>>      readln str#
53374>>>>>      ifnot str# eq "LFSELECT1.0" send obs "Incompatible format"
53377>>>>>      else begin
53378>>>>>        repeat
53378>>>>>>
53378>>>>>          readln file#
53379>>>>>          readln st#
53380>>>>>          move (seqeof) to fin#
53381>>>>>          ifnot fin# if st# set file_select_state file# to st#
53386>>>>>        until fin#
53388>>>>>      end
53388>>>>>>
53388>>>>>      send wait_off
53389>>>>>    end
53389>>>>>>
53389>>>>>    else send obs "File not found"
53391>>>>>    close_input channel ch#
53393>>>>>    send Seq_Release_Channel ch#
53394>>>>>    send update_select_display
53395>>>>>  end_procedure
53396>>>>>  procedure load_current_selection.browse
53398>>>>>    string fn#
53398>>>>>    move (SEQ_SelectFile("Load filelist selection","Filelist selections (*.fsl)|*.FSL")) to fn#
53399>>>>>    if fn# ne "" send load_current_selection fn#
53402>>>>>  end_procedure
53403>>>>>  procedure save_current_selection string fn#
53405>>>>>    integer ch# row# max# file# st#
53405>>>>>    send wait_on
53406>>>>>    get Seq_New_Channel to ch#
53407>>>>>    direct_output channel ch# fn#
53409>>>>>    writeln "LFSELECT1.0"
53411>>>>>    get Row_Count to max#
53412>>>>>    for row# from 0 to (max#-1)
53418>>>>>>
53418>>>>>      get Row_File row# to file#
53419>>>>>      get Row_Select_state row# to st#
53420>>>>>      writeln file#
53422>>>>>      writeln st#
53424>>>>>    loop
53425>>>>>>
53425>>>>>    close_output channel ch#
53427>>>>>    send Seq_Release_Channel ch#
53428>>>>>    send wait_off
53429>>>>>  end_procedure
53430>>>>>  procedure save_current_selection.browse
53432>>>>>    string fn#
53432>>>>>    move (SEQ_SelectOutFile("Save filelist selection","Filelist selections (*.fsl)|*.FSL")) to fn#
53433>>>>>    if fn# ne "" send save_current_selection fn#
53436>>>>>  end_procedure
53437>>>>>  procedure display_file_things
53439>>>>>    if (item_count(self)) ifnot (Row_Shadow_State(self,Current_Row(self))) send FDX_ModalDisplayFileAttributes (piFDX_Server(self)) (Current_File(self))
53444>>>>>  end_procedure
53445>>>>>  procedure display_file_location
53447>>>>>    integer fdx# file#
53447>>>>>    number ts#
53447>>>>>    string path#
53447>>>>>    ifnot (Row_Shadow_State(self,Current_Row(self))) begin
53449>>>>>      get piFDX_Server to fdx#
53450>>>>>      get Current_File to file#
53451>>>>>      get sDatPath.i of fdx# file# to path#
53452>>>>>      get nTimeStamp.i of fdx# file# to ts#
53453>>>>>      send obs "Data path:" path# "Table data last modified:" (TS_ConvertToString(ts#))
53454>>>>>    end
53454>>>>>>
53454>>>>>  end_procedure
53455>>>>>end_class // cFdxFileMultiSelector
53456>>>
53456>>>
53456>>>use aps
53456>>>object oUserModalSelectTables is a aps.ModalPanel
53458>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
53459>>>  set pMinimumSize to 180 0
53460>>>  set Locate_Mode to CENTER_ON_SCREEN
53461>>>  property integer piNeedsFilling public 1
53463>>>  property integer piResult public 0
53465>>>  on_key kCancel send close_panel
53466>>>  on_key kSave_Record send close_panel_ok
53467>>>  procedure close_panel_ok
53470>>>    set piResult to 1
53471>>>    send close_panel
53472>>>  end_procedure
53473>>>  object oCont is a aps.Container3D
53475>>>    set p_auto_column to false
53476>>>    object oLst is a cFdxFileMultiSelector
53478>>>      set size to 180 0
53479>>>      set piNo_Alias_State to true          // Exclude alias files
53480>>>      //send DriverFilter_Add DBMS_DRIVER_DATAFLEX
53480>>>      procedure re_order
53483>>>      end_procedure
53484>>>      procedure update_select_display // This is called automatically by the class
53487>>>        integer selected# total#
53487>>>        get File_Select_Count to selected#
53488>>>        get Row_Count to total#
53489>>>        send select_display selected# total#
53490>>>      end_procedure
53491>>>    end_object // oLst
53492>>>
53492>>>    object oSelectTxt is a aps.TextBox snap sl_right
53495>>>    end_object
53496>>>    set auto_size_state of (oSelectTxt(self)) to true
53497>>>    send aps_align_by_moving (oSelectTxt(self)) (oLst(self)) SL_ALIGN_BOTTOM
53498>>>    procedure select_display integer selected# integer total#
53501>>>      set value of (oSelectTxt(self)) to ("Selected: "+string(selected#))
53502>>>    end_procedure
53503>>>
53503>>>    object oBtn1 is a aps.multi_button
53505>>>      on_item t.FDX.Btn.SelectAll     send select_all_not_bad  to (oLst(self))
53506>>>    end_object
53507>>>    object oBtn2 is a aps.multi_button
53509>>>      on_item t.FDX.Btn.SelectNone    send select_none         to (oLst(self))
53510>>>    end_object
53511>>>    object oBtn3 is a aps.multi_button
53513>>>      on_item t.FDX.Btn.SelectInvert  send select_invert       to (oLst(self))
53514>>>    end_object
53515>>>    object oBtn4 is a aps.multi_button
53517>>>      on_item t.FDX.Btn.SelectPhys    send select_master       to (oLst(self))
53518>>>    end_object
53519>>>    object oBtn5 is a aps.multi_button
53521>>>      on_item t.FDX.Btn.SelectParent  send select_parents      to (oLst(self))
53522>>>    end_object
53523>>>    object oBtn6 is a aps.multi_button
53525>>>      on_item t.FDX.Btn.SelectChild   send select_children     to (oLst(self))
53526>>>    end_object
53527>>>    object oBtn7 is a aps.multi_button
53529>>>      on_item "Load selection"        send load_current_selection.browse to (oLst(self))
53530>>>    end_object
53531>>>    object oBtn8 is a aps.multi_button
53533>>>      on_item "Save selection"        send save_current_selection.browse to (oLst(self))
53534>>>    end_object
53535>>>    object oBtn9 is a aps.multi_button
53537>>>      on_item "Re-order"              send re_order            to (oLst(self))
53538>>>    end_object
53539>>>    object oBtn10 is a aps.multi_button
53541>>>      on_item "Display def."          send display_file_things to (oLst(self))
53542>>>    end_object
53543>>>    send aps_locate_multi_buttons sl_vertical
53544>>>  end_object
53545>>>  object oBtn1 is a aps.multi_button
53547>>>    on_item t.btn.ok send close_panel_ok
53548>>>  end_object
53549>>>  object oBtn2 is a aps.multi_button
53551>>>    on_item t.btn.cancel send close_panel
53552>>>  end_object
53553>>>  send aps_locate_multi_buttons
53554>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
53557>>>    send aps_resize (oLst(oCont(self))) delta_rw# 0
53558>>>    send aps_align_by_moving (oSelectTxt(oCont(self))) (oLst(oCont(self))) SL_ALIGN_BOTTOM
53559>>>    send aps_resize (oCont(self)) delta_rw# 0
53560>>>    send aps_register_multi_button (oBtn1(self))
53561>>>    send aps_register_multi_button (oBtn2(self))
53562>>>    send aps_locate_multi_buttons
53563>>>    send aps_auto_size_container
53564>>>  end_procedure
53565>>>  function iRun.s string title# returns integer
53568>>>    integer rval# lst# srv# fdx#
53568>>>    set piResult to false
53569>>>    set label to title#
53570>>>    move (oLst(oCont(self))) to lst#
53571>>>    if (piNeedsFilling(lst#)) begin
53573>>>      send fill_list_all_files to lst#
53574>>>      set piNeedsFilling of lst# to false
53575>>>    end
53575>>>>
53575>>>    set piFDX_Server of lst# to fdx#
53576>>>    set object_shadow_state of (oBtn5(oCont(self))) to (not(fdx#))
53577>>>    set object_shadow_state of (oBtn6(oCont(self))) to (not(fdx#))
53578>>>    send popup
53579>>>    function_return (piResult(self))
53580>>>  end_function
53581>>>  function iCallback_Selected_Files integer get# integer obj# returns integer
53584>>>    integer rval#
53584>>>    get iCallback_Selected_Files_Server of (oLst(self)) get# obj# to rval#
53585>>>    function_return rval#
53586>>>  end_function
53587>>>end_object // oUserModalSelectTables
53588>>>
53588>>>procedure UserModalSelectTablesSetup global ;          integer oFDX ;          integer BES_State# ;          integer No_Alias_State# ;          integer Driver_Filter_State# ;          integer Generic_Display_Name_State#
53590>>>  integer obj# fill_list#
53590>>>  move 0 to fill_list#
53591>>>  move (oLst(oCont(oUserModalSelectTables(self)))) to obj#
53592>>>  if oFDX ne (piFDX_Server(obj#)) begin
53594>>>    set piFDX_Server of obj# to oFDX
53595>>>    move 1 to fill_list#
53596>>>  end
53596>>>>
53596>>>  if BES_State# ne (piBad_Entries_State(obj#)) begin
53598>>>    set piBad_Entries_State of obj# to BES_State#
53599>>>    move 1 to fill_list#
53600>>>  end
53600>>>>
53600>>>  if No_Alias_State# ne (piNo_Alias_State(obj#)) begin
53602>>>    set piNo_Alias_State of obj# to No_Alias_State#
53603>>>    move 1 to fill_list#
53604>>>  end
53604>>>>
53604>>>  if Driver_Filter_State# ne (piDriverFilter_State(obj#)) begin
53606>>>    set piDriverFilter_State of obj# to Driver_Filter_State#
53607>>>    move 1 to fill_list#
53608>>>  end
53608>>>>
53608>>>  if Generic_Display_Name_State# ne (piGeneric_Display_Name_State(obj#)) begin
53610>>>    set piGeneric_Display_Name_State of obj# to Generic_Display_Name_State#
53611>>>    move 1 to fill_list#
53612>>>  end
53612>>>>
53612>>>  if fill_list# set piNeedsFilling of obj# to true
53615>>>end_procedure
53616>>>
53616>>>function iUserModalSelectTables.s global string title# returns integer
53618>>>  function_return (iRun.s(oUserModalSelectTables(self),title#))
53619>>>end_function
53620>>>function iUserModalSelectTables.sCallBack global integer get# integer obj# returns integer
53622>>>  function_return (iCallback_Selected_Files(oUserModalSelectTables(self),get#,obj#))
53623>>>end_function
53624>>>
53624>>>// *** TEST CODE ****************************************************************
53624>>>
53624>>>// send UserModalSelectTablesSetup 0 BAD_ENTRIES_SHADOW dfFalse dfFalse dfFalse
53624>>>// move (iUserModalSelectTables.s("Select tables, please")) to windowindex
53624>
53624>Use Version.nui
53624>
53624>Use cApplication.pkg
53624>Object oApplication is a cApplication
53626>  Set pbEnterKeyAsTabKey to DFTRUE
53627>  Set psAutoOpenWorkspace to "" // Do not attempt to open "config.ws"
53628>// Procedure OnCreate
53628>//   Send DoOpenWorkspace CURRENT$WORKSPACE
53628>// End_Procedure
53628>End_Object // oApplication
53629>
53629>// procedure SmadrHeleLortet
53629>//   runprogram background "Afreager.exe"
53629>// end_procedure
53629>// on_key key_ctrl+key_h send SmadrHeleLortet
53629>
53629>
53629>Use DFMatrix.utl //
Including file: dfmatrix.utl    (C:\Apps\VDFQuery\AppSrc\dfmatrix.utl)
53629>>>//**********************************************************************
53629>>>// Use DFMatrix.utl // DFMatrix application glue
53629>>>//
53629>>>// By Sture Andersen
53629>>>// Version: 2.0-
53629>>>//
53629>>>// Create: Wed  09-02-2000
53629>>>// Update:
53629>>>//
53629>>>//
53629>>>//**********************************************************************
53629>>>
53629>>>Use CmdLine.nui  // Simple thing for reading command line parameters
Including file: cmdline.nui    (C:\Apps\VDFQuery\AppSrc\cmdline.nui)
53629>>>>>// Use CmdLine.nui  // Simple thing for reading command line parameters
53629>>>>>
53629>>>>>use Base.nui
53629>>>>>
53629>>>>>desktop_section
53634>>>>>  object oCmdLineParameters is a cArray
53636>>>>>    send delete_data
53637>>>>>    procedure DoRead
53640>>>>>      string lsParam
53640>>>>>      repeat
53640>>>>>>
53640>>>>>        cmdline lsParam
53641>>>>>>
53641>>>>>        if lsParam ne "" set value item (item_count(self)) to lsParam
53644>>>>>      until lsParam eq ""
53646>>>>>    end_procedure
53647>>>>>    function iFindParamValue.si string lsValue integer lbUpperCase returns integer
53650>>>>>      integer liItem liMax
53650>>>>>      string lsTestValue
53650>>>>>      if lbUpperCase move (uppercase(lsValue)) to lsValue
53653>>>>>      get item_count to liMax
53654>>>>>      for liItem from 0 to liMax
53660>>>>>>
53660>>>>>        get value item liItem to lsTestValue
53661>>>>>        if lbUpperCase move (uppercase(lsTestValue)) to lsTestValue
53664>>>>>        if (lsTestValue=lsValue) function_return liItem
53667>>>>>      loop
53668>>>>>>
53668>>>>>      function_return -1 // not found
53669>>>>>    end_function
53670>>>>>  end_object // oCmdLineParameters
53671>>>>>end_desktop_section
53676>>>>>
53676>>>>>procedure DoReadCmdLine global
53678>>>>>  send DoRead to (oCmdLineParameters(self))
53679>>>>>end_procedure
53680>>>>>send DoReadCmdLine
53681>>>>>
53681>>>>>function CmdLineParamCount global returns integer
53683>>>>>  function_return (item_count(oCmdLineParameters(self)))
53684>>>>>end_function
53685>>>>>function CmdLineParamValue global integer liParam returns string
53687>>>>>  function_return (value(oCmdLineParameters(self),liParam))
53688>>>>>end_function
53689>>>>>function CmdLineFindParamValue global string lsValue integer lbUpperCase returns integer
53691>>>>>  integer liRval
53691>>>>>  get iFindParamValue.si of (oCmdLineParameters(self)) lsValue lbUpperCase to liRval
53692>>>>>  function_return liRval
53693>>>>>end_function
53694>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
53694>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
53694>>>Use Output.utl   // Basic sequential output service
Including file: output.utl    (C:\Apps\VDFQuery\AppSrc\output.utl)
53694>>>>>// Use Output.utl   // Sequential output to whatever
53694>>>>>
53694>>>>>Use Aps
53694>>>>> Use DFWinRpt
53694>>>>>
53694>>>>>
53694>>>>>Use Dates.utl    // Date manipulation for VDF
Including file: dates.utl    (C:\Apps\VDFQuery\AppSrc\dates.utl)
53694>>>>>>>// **********************************************************************
53694>>>>>>>// Use Dates.utl    // Date manipulation for VDF and DF3.2
53694>>>>>>>//
53694>>>>>>>// by Sture Andersen (sa1@vd.dk)
53694>>>>>>>//
53694>>>>>>>// The file contains a number of global functions for manipulating
53694>>>>>>>// dates. The package may be used with DataFlex 3.1 and Visual DataFlex.
53694>>>>>>>// This package is public domain.
53694>>>>>>>//
53694>>>>>>>// The package file is accompanied by a Word document (dfutil.doc)
53694>>>>>>>// listing the functions and their use.
53694>>>>>>>//
53694>>>>>>>//
53694>>>>>>>// Create: Fri  06-06-1997 - Merger of s_utl020, 021, 022, 023, 024, 025.
53694>>>>>>>// Update: Thu  26-06-1997 - Fixes for strange behavior when date4_state is set.
53694>>>>>>>//                         - Addition of popup_calendar to VDF.
53694>>>>>>>//         Sun  29-06-1997 - Character mode popup calender.
53694>>>>>>>//         Fri  04-07-1997 - Function WeekToDate added.
53694>>>>>>>//         Thu  10-07-1997 - Fixes.
53694>>>>>>>//         Mon  11-08-1997 - WeekToDate fixed.
53694>>>>>>>//         Sun  24-08-1997 - Character mode popup calender finished.
53694>>>>>>>//         Mon  15-12-1997 - Procedure Request_Popup_Calendar added.
53694>>>>>>>//         Mon  29-12-1997 - Procedures ItemYear2to4, ItemDate2to4 and
53694>>>>>>>//                           ItemSysdate added.
53694>>>>>>>//         Mon  29-12-1997 - Procedures FieldYear2to4, FieldDate2to4 and
53694>>>>>>>//                           FieldSysdate added.
53694>>>>>>>//         Sun  01-02-1998 - Functions Module_Compile_Date and
53694>>>>>>>//                           Module_Compile_Time added.
53694>>>>>>>//         Wed  25-02-1998 - Request_Popup in calendar object now only
53694>>>>>>>//                           responds if entry_state of the calling object
53694>>>>>>>//                           is true (VDF version). (No apparent effect)
53694>>>>>>>//         Sat  28-03-1998 - Added the following functions:
53694>>>>>>>//                             TS_SysTime      TS_ExtractDate
53694>>>>>>>//                             TS_ExtractTime  TS_ConvertToString
53694>>>>>>>//         Tue  26-05-1998 - Procedure TS_UI_Update added
53694>>>>>>>//         Sat  01-08-1998 - mask_date_window taken into account
53694>>>>>>>//         Mon  10-08-1998 - Functions Module_Start_Date and
53694>>>>>>>//                           Module_Start_Time added.
53694>>>>>>>//         Wed  02-09-1998 - Parameter for Module_Start_Date removed
53694>>>>>>>//         Mon  12-10-1998 - Portuguese added
53694>>>>>>>//         Wed  04-11-1998 - TS_TimeEstimator class added
53694>>>>>>>//         Tue  29-12-1998 - Function DateAsString added
53694>>>>>>>//         Wed  13-01-1999 - Function DateWeekNumber changed according to
53694>>>>>>>//                           Kjetil Johanson
53694>>>>>>>//         Mon  18-01-1999 - Function DateWeekNumber changed according to
53694>>>>>>>//                           Kjetil Johanson (again)
53694>>>>>>>//         Tue  19-01-1999 - Changed procedure names in TS_TimeEstimator
53694>>>>>>>//                           class (Continue->TS_Continue and Pause->
53694>>>>>>>//                           TS_Pause)
53694>>>>>>>//         Thu  21-01-1999 - Procedures DateFormatAsString and DateFormatName
53694>>>>>>>//                           added.
53694>>>>>>>//                         - Procedures DateCurrentSeparator and
53694>>>>>>>//                           DateCurrentFormat added.
53694>>>>>>>//         Tue  13-04-1999 - Julian constants added: Jan1st1900, Jan1st2000
53694>>>>>>>//                           Jan1st1000 and Jan1st100
53694>>>>>>>//         Mon  26-04-1999 - Changed procedure FieldYear2to4 and ItemYear2to4
53694>>>>>>>//                           to trap 3 digit years.
53694>>>>>>>//         Wed  27-04-1999 - Changed Dutch abbriviated day names (to 2 characters)
53694>>>>>>>//         Sun  02-05-1999 - Added function TS_Compose2
53694>>>>>>>//                         - Fixed error in TS_ConvertToString
53694>>>>>>>//         Tue  01-06-1999 - Added procedure popup_no_export to calendar.
53694>>>>>>>//         Thu  15-06-1999 - Fixed Date4to2 function and exporting dates
53694>>>>>>>//                           from the calendar to forms with no form_margin.
53694>>>>>>>//         Tue  07-09-1999 - Added function DateAsText
53694>>>>>>>//         Wed  27-10-1999 - Temporary fix for Module_Compile_Date function
53694>>>>>>>//                           in combination with y2k.
53694>>>>>>>//         Wed  19-12-1999 - Function StringToDate added.
53694>>>>>>>//                         - Existing function DateAsString renamed to
53694>>>>>>>//                           DateToString.
53694>>>>>>>//         Mon  03-01-2000 - Fix for VDF4. Popup calendar on empty date field
53694>>>>>>>//                           would result in seeding the calendar on year 100.
53694>>>>>>>//                           This error was caused by the fact that VDF 4
53694>>>>>>>//                           ignores SYSDATE4_STATE such that the sysdate
53694>>>>>>>//                           command returns 03-01-100
53694>>>>>>>//         Wed  01-02-2000 - Define instead of #REPLACE
53694>>>>>>>//         Wed  23-08-2000 - Function TS_Module_Compile_Time added
53694>>>>>>>//         Sat  04-08-2001 - Function StringToDate in Dates.nui fixed by Paul
53694>>>>>>>//                           Cooling
53694>>>>>>>//         Sat  30-08-2003 - Odd date thing fixed by Wil van Antwherpen. (Search: **WvA:)
53694>>>>>>>//
53694>>>>>>>// NOTE:  There is language dependent string constants in this file.
53694>>>>>>>//        Currently there are sections for dutch, english, danish, swedish,
53694>>>>>>>//        norwegian, spanish, german and portuguese
53694>>>>>>>//
53694>>>>>>>//        These sections may be identified by searching the symbol LNG_DEFAULT
53694>>>>>>>//
53694>>>>>>>// ***********************************************************************
53694>>>>>>>Use Dates.nui    // Date routines (No User Interface)
53694>>>>>>>Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface)
53694>>>>>>>
53694>>>>>>>define DATES_INCLUDE_POPUP for 1   // If set to 0 the popup calendar will not be included
53694>>>>>>>
53694>>>>>>>procedure ItemSysdate for desktop integer liItm
53696>>>>>>>  date ldDate
53696>>>>>>>  get value item liItm to ldDate
53697>>>>>>>  if ldDate eq 0 begin
53699>>>>>>>    sysdate4 ldDate
53700>>>>>>>    set changed_value item liItm to ldDate
53701>>>>>>>  end
53701>>>>>>>>
53701>>>>>>>end_procedure
53702>>>>>>>
53702>>>>>>>procedure ItemDate2to4 for desktop integer liItm
53704>>>>>>>  integer liYear
53704>>>>>>>  date ldDate ldNewDate
53704>>>>>>>  send ErrorHnd_Quiet_Activate
53705>>>>>>>  get value item liItm to ldDate
53706>>>>>>>  send ErrorHnd_Quiet_Deactivate
53707>>>>>>>
53707>>>>>>>  move (DateSegment(ldDate,DS_YEAR)) to liYear
53708>>>>>>>  if (liYear=0 and ldDate<>0) move (DateIncrement(ldDate,3,iSysYear())) to ldNewDate
53711>>>>>>>  else move ldDate to ldNewDate
53713>>>>>>>
53713>>>>>>>  move (Date2to4(ldNewDate)) to ldNewDate
53714>>>>>>>  move (DateSegment(ldNewDate,3)) to liYear
53715>>>>>>>  if (liYear>99 and liYear<1000) begin
53717>>>>>>>    error 15 // Illegal entry in this window
53718>>>>>>>>
53718>>>>>>>    procedure_return 1
53719>>>>>>>  end
53719>>>>>>>>
53719>>>>>>>  if ldNewDate ne ldDate set value item liItm to ldNewDate
53722>>>>>>>end_procedure
53723>>>>>>>
53723>>>>>>>procedure ItemYear2to4 for desktop integer liItm
53725>>>>>>>  integer liYear liNewYear
53725>>>>>>>  get value item liItm to liYear
53726>>>>>>>  if (liYear>99 and liYear<1000) begin
53728>>>>>>>    error 15 // Illegal entry in this window
53729>>>>>>>>
53729>>>>>>>    procedure_return 1
53730>>>>>>>  end
53730>>>>>>>>
53730>>>>>>>  move (Year2to4(liYear)) to liNewYear
53731>>>>>>>  if liNewYear ne liYear set value item liItm to liNewYear
53734>>>>>>>end_procedure
53735>>>>>>>
53735>>>>>>>
53735>>>>>>> register_procedure NotifyPopupCalendarChange date ldDate
53735>>>>>>> register_procedure NotifyPopupCalendarSelect date ldDate
53735>>>>>>>
53735>>>>>>>  use DFAllent
53735>>>>>>>  class calendar.textbox is a textbox
53736>>>>>>>    procedure construct_object
53738>>>>>>>      forward send construct_object
53740>>>>>>>      Set Auto_Size_State To DFFALSE
53741>>>>>>>      Set Justification_Mode To (JMODE_VCENTER+JMODE_CENTER)
53742>>>>>>>    end_procedure
53743>>>>>>>  end_class
53744>>>>>>>
53744>>>>>>>  register_object oBtn1
53744>>>>>>>  register_object oBtn6
53744>>>>>>>
53744>>>>>>>  class calendar.button is a button
53745>>>>>>>
53745>>>>>>>    procedure construct_object
53747>>>>>>>      forward send construct_object
53749>>>>>>>      set size to 15 18
53750>>>>>>>      on_key kleftarrow   send prev_day
53751>>>>>>>      on_key krightarrow  send next_day
53752>>>>>>>      on_key kuparrow     send prev_week
53753>>>>>>>      on_key kdownarrow   send next_week
53754>>>>>>>      property date pdAssignedDate public 0
53755>>>>>>>    end_procedure
53756>>>>>>>
53756>>>>>>>    procedure switch // This makes all 42 buttons act as if they are one focus
53758>>>>>>>      send activate to (oBtn1(self))
53759>>>>>>>    end_procedure
53760>>>>>>>    procedure switch_back
53762>>>>>>>      send activate to (oBtn6(self))
53763>>>>>>>    end_procedure
53764>>>>>>>
53764>>>>>>>    procedure mouse_down
53766>>>>>>>      integer lhSelf
53766>>>>>>>      forward send mouse_down
53768>>>>>>>      move self to lhSelf
53769>>>>>>>      delegate set pdCurrentDate to (pdAssignedDate(lhSelf))
53771>>>>>>>    end_procedure
53772>>>>>>>  end_class
53773>>>>>>>
53773>>>>>>>  desktop_section
53778>>>>>>>    object popup_calendar is a ModalPanel
53780>>>>>>>      set size to 160 250
53781>>>>>>>      property date    pdCurrentDate  public 0
53783>>>>>>>      property integer p_current_year  public -1
53785>>>>>>>      property integer p_current_month public -1
53787>>>>>>>      property integer pExportState    public 1
53789>>>>>>>
53789>>>>>>>      on_key key_ctrl+key_pgup send prev_year
53790>>>>>>>      on_key key_ctrl+key_pgdn send next_year
53791>>>>>>>      on_key          key_pgup send prev_month
53792>>>>>>>      on_key          key_pgdn send next_month
53793>>>>>>>      on_key key_ctrl+key_d    send go_today
53794>>>>>>>      on_key kcancel           send cancel
53795>>>>>>>
53795>>>>>>>      object oCont3d is a container3d
53797>>>>>>>        set location to 5 5
53798>>>>>>>        set size to 120 237
53799>>>>>>>        object oTextboxYear is a calendar.textbox
53801>>>>>>>          set location to 5 5
53802>>>>>>>          set size to 15 30
53803>>>>>>>          set border_style to BORDER_STATICEDGE
53804>>>>>>>          procedure display
53807>>>>>>>            set value to (p_current_year(self))
53808>>>>>>>          end_procedure
53809>>>>>>>        end_object
53810>>>>>>>        object oDaynameHeader is a container3d
53812>>>>>>>          set location to 5 39
53813>>>>>>>          set size to 15 126
53814>>>>>>>          set border_style to BORDER_STATICEDGE
53815>>>>>>>          procedure initialize
53818>>>>>>>            integer liItm
53818>>>>>>>            for liItm from 0 to 6
53824>>>>>>>>
53824>>>>>>>              object oTxt is a calendar.textbox
53826>>>>>>>                set size to 12 17
53827>>>>>>>                set location to 0 (liItm*17.6+1)
53828>>>>>>>                 set value to (left(DayName(liItm+1),3))
53829>>>>>>>              end_object
53830>>>>>>>            loop
53831>>>>>>>>
53831>>>>>>>          end_procedure
53832>>>>>>>          send initialize
53833>>>>>>>        end_object
53834>>>>>>>        object oWeekNumberHeader is a container3d
53836>>>>>>>          set location to 24 5
53837>>>>>>>          set size     to 89 30
53838>>>>>>>          set border_style to BORDER_STATICEDGE
53839>>>>>>>          object oObjIdArray is an array
53841>>>>>>>          end_object
53842>>>>>>>          procedure initialize
53845>>>>>>>            integer liItm lhObj
53845>>>>>>>            move (oObjIdArray(self)) to lhObj
53846>>>>>>>            for liItm from 0 to 5
53852>>>>>>>>
53852>>>>>>>              object oTxt is a textbox
53854>>>>>>>                set size to 15 30
53855>>>>>>>                set location to (liItm*15+1) 1
53856>>>>>>>                set value of lhObj item (item_count(lhObj)) to self
53857>>>>>>>              end_object
53858>>>>>>>            loop
53859>>>>>>>>
53859>>>>>>>          end_procedure
53860>>>>>>>          procedure display
53863>>>>>>>            integer liItm lhObj
53863>>>>>>>            date ldDate ldLastDate
53863>>>>>>>            move (oObjIdArray(self)) to lhObj
53864>>>>>>>            get pdCurrentDate to ldDate
53865>>>>>>>            move (FirstDayInMonth(ldDate)) to ldDate
53866>>>>>>>            move (LastDayInMonth(ldDate)) to ldLastDate
53867>>>>>>>            move (ldDate-DateDayNumber(ldDate)+1) to ldDate
53868>>>>>>>            for liItm from 0 to 5
53874>>>>>>>>
53874>>>>>>>              if (liItm*7+ldDate) le ldLastDate ;                set value of (integer(value(lhObj,liItm))) to (t.calendar.week*string(DateWeekNumber(liItm*7+ldDate)))
53877>>>>>>>              else set value of (integer(value(lhObj,liItm))) to ""
53879>>>>>>>            loop
53880>>>>>>>>
53880>>>>>>>          end_procedure
53881>>>>>>>          send initialize
53882>>>>>>>        end_object
53883>>>>>>>        object oDaysGrid is a container3d
53885>>>>>>>          set location to 23 39
53886>>>>>>>          set size     to 100 127
53887>>>>>>>          set border_style to BORDER_NONE
53888>>>>>>>          object oBtnArray is an array
53890>>>>>>>          end_object
53891>>>>>>>          procedure initialize
53894>>>>>>>            integer liRow liCol lhBtnArray
53894>>>>>>>            move (oBtnArray(self)) to lhBtnArray
53895>>>>>>>            for liRow from 0 to 5
53901>>>>>>>>
53901>>>>>>>              for liCol from 0 to 6
53907>>>>>>>>
53907>>>>>>>                object oBtn is a calendar.button
53909>>>>>>>                  set location to (liRow*15) (liCol*18)
53910>>>>>>>                  set value of lhBtnArray item (item_count(lhBtnArray)) to self
53911>>>>>>>                  on_item "" send move_value_out_ok
53912>>>>>>>                end_object
53913>>>>>>>              loop
53914>>>>>>>>
53914>>>>>>>            loop
53915>>>>>>>>
53915>>>>>>>          end_procedure
53916>>>>>>>          send initialize
53917>>>>>>>
53917>>>>>>>          procedure display.iii integer liItm integer liDay integer lbActivate
53920>>>>>>>            integer lhObj liCurrentDay
53920>>>>>>>            move (integer(value(oBtnArray(self),liItm))) to lhObj
53921>>>>>>>            move (DateSegment(pdCurrentDate(self),DS_DAY)) to liCurrentDay
53922>>>>>>>            if lbActivate begin
53924>>>>>>>              if liDay eq liCurrentDay send activate to lhObj
53927>>>>>>>            end
53927>>>>>>>>
53927>>>>>>>            else begin
53928>>>>>>>              if liDay begin
53930>>>>>>>                set value of lhObj to liDay
53931>>>>>>>                set visible_state of lhObj to DFTRUE
53932>>>>>>>                set pdAssignedDate of lhObj to (DateCompose(liDay,p_current_month(self),p_current_year(self)))
53933>>>>>>>              end
53933>>>>>>>>
53933>>>>>>>              else set visible_state of lhObj to DFFALSE
53935>>>>>>>            end
53935>>>>>>>>
53935>>>>>>>          end_procedure
53936>>>>>>>
53936>>>>>>>          procedure display integer lbActivate
53939>>>>>>>            integer liFirstItem liLastItem liItm liDay liDate
53939>>>>>>>            get pdCurrentDate to liDate
53940>>>>>>>            move (FirstDayInMonth(liDate)) to liDate
53941>>>>>>>            move (DateDayNumber(liDate)-1) to liFirstItem
53942>>>>>>>            // **WvA: 27-08-2003 VDF9.1 Needs the integer datevalue to be casted to
53942>>>>>>>            // a date before the expression can be evaluated.
53942>>>>>>>            move (LastDayInMonth(liDate)-date(liDate)+liFirstItem) to liLastItem
53943>>>>>>>            // **
53943>>>>>>>            ifnot lbActivate begin
53945>>>>>>>              for liItm from 0 to (liFirstItem-1)
53951>>>>>>>>
53951>>>>>>>                send display.iii liItm 0 0
53952>>>>>>>              loop
53953>>>>>>>>
53953>>>>>>>            end
53953>>>>>>>>
53953>>>>>>>            move 1 to liDay
53954>>>>>>>            for liItm from liFirstItem to liLastItem
53960>>>>>>>>
53960>>>>>>>              send display.iii liItm liDay lbActivate
53961>>>>>>>              increment liDay
53962>>>>>>>            loop
53963>>>>>>>>
53963>>>>>>>            ifnot lbActivate begin
53965>>>>>>>              for liItm from (liLastItem+1) to 41
53971>>>>>>>>
53971>>>>>>>                send display.iii liItm 0 0
53972>>>>>>>              loop
53973>>>>>>>>
53973>>>>>>>            end
53973>>>>>>>>
53973>>>>>>>          end_procedure
53974>>>>>>>        end_object
53975>>>>>>>        object oTxtMonth is a calendar.textbox
53977>>>>>>>          set size to 12 27
53978>>>>>>>          set location to 25 185
53979>>>>>>>          set value to t.calendar.month
53980>>>>>>>        end_object
53981>>>>>>>        object oBtn1 is a button
53983>>>>>>>          set size to 12 12
53984>>>>>>>          set location to 40 185
53985>>>>>>>          on_item "" send prev_month
53986>>>>>>>          set bitmap to "prev.bmp"
53987>>>>>>>          procedure switch_back
53990>>>>>>>            send display_main
53991>>>>>>>          end_procedure
53992>>>>>>>        end_object
53993>>>>>>>        object oBtn2 is a button
53995>>>>>>>          set size to 12 12
53996>>>>>>>          set location to 40 200
53997>>>>>>>          on_item "" send next_month
53998>>>>>>>          set bitmap to "next.bmp"
53999>>>>>>>        end_object
54000>>>>>>>        object oTxtYear is a calendar.textbox
54002>>>>>>>          set size to 12 27
54003>>>>>>>          set location to 70 185
54004>>>>>>>          set value to t.calendar.year
54005>>>>>>>        end_object
54006>>>>>>>        object oBtn3 is a button
54008>>>>>>>          set size to 12 12
54009>>>>>>>          set location to 85 185
54010>>>>>>>          on_item "" send prev_year
54011>>>>>>>          set bitmap to "prev.bmp"
54012>>>>>>>        end_object
54013>>>>>>>        object oBtn4 is a button
54015>>>>>>>          set size to 12 12
54016>>>>>>>          set location to 85 200
54017>>>>>>>          on_item "" send next_year
54018>>>>>>>          set bitmap to "next.bmp"
54019>>>>>>>        end_object
54020>>>>>>>      end_object
54021>>>>>>>      object oBtn5 is a button
54023>>>>>>>        set size to 14 60
54024>>>>>>>        set location to 129 115
54025>>>>>>>        on_item t.calendar.ok send move_value_out_ok
54026>>>>>>>      end_object
54027>>>>>>>      object oBtn6 is a button
54029>>>>>>>        set size to 14 60
54030>>>>>>>        set location to 129 182
54031>>>>>>>        on_item t.calendar.cancel send cancel
54032>>>>>>>        procedure switch
54035>>>>>>>          send display_main
54036>>>>>>>        end_procedure
54037>>>>>>>      end_object
54038>>>>>>>      procedure next_year
54041>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_YEAR,1))
54042>>>>>>>        send display_main
54043>>>>>>>      end_procedure
54044>>>>>>>      procedure prev_year
54047>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_YEAR,-1))
54048>>>>>>>        send display_main
54049>>>>>>>      end_procedure
54050>>>>>>>      procedure next_month
54053>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_MONTH,1))
54054>>>>>>>        send display_main
54055>>>>>>>      end_procedure
54056>>>>>>>      procedure prev_month
54059>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_MONTH,-1))
54060>>>>>>>        send display_main
54061>>>>>>>      end_procedure
54062>>>>>>>      procedure next_week
54065>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_WEEK,1))
54066>>>>>>>        send display_main
54067>>>>>>>      end_procedure
54068>>>>>>>      procedure prev_week
54071>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_WEEK,-1))
54072>>>>>>>        send display_main
54073>>>>>>>      end_procedure
54074>>>>>>>      procedure next_day
54077>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_DAY,1))
54078>>>>>>>        send display_main
54079>>>>>>>      end_procedure
54080>>>>>>>      procedure prev_day
54083>>>>>>>        set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_DAY,-1))
54084>>>>>>>        send display_main
54085>>>>>>>      end_procedure
54086>>>>>>>      procedure go_today
54089>>>>>>>        date ldDate
54089>>>>>>>        sysdate4 ldDate
54090>>>>>>>        set pdCurrentDate to ldDate
54091>>>>>>>        send display_main
54092>>>>>>>      end_procedure
54093>>>>>>>      property integer invoking_object_id public 0
54095>>>>>>>      procedure OnChange date ldDate
54098>>>>>>>        integer lhFocus lbDelegationMode
54098>>>>>>>        get invoking_object_id to lhFocus
54099>>>>>>>        if lhFocus gt desktop begin
54101>>>>>>>          get delegation_mode of lhFocus to lbDelegationMode
54102>>>>>>>          set delegation_mode of lhFocus to no_delegate_or_error
54103>>>>>>>          send NotifyPopupCalendarChange to lhFocus ldDate
54104>>>>>>>          set delegation_mode of lhFocus to lbDelegationMode
54105>>>>>>>        end
54105>>>>>>>>
54105>>>>>>>      end_procedure
54106>>>>>>>      procedure display
54109>>>>>>>        integer liDate liMonth liYear
54109>>>>>>>        get pdCurrentDate to liDate
54110>>>>>>>        send OnChange liDate
54111>>>>>>>        move (DateSegment(liDate,DS_YEAR)) to liYear
54112>>>>>>>        move (DateSegment(liDate,DS_MONTH)) to liMonth
54113>>>>>>>        if (p_current_year(self)<>liYear or p_current_month(self)<>liMonth) begin
54115>>>>>>>          set p_current_year to liYear
54116>>>>>>>          set p_current_month to liMonth
54117>>>>>>>          set value to (t.calendar.calendar_popup+", "+MonthName(liMonth))
54118>>>>>>>          send display to (oTextboxYear(oCont3d(self)))
54119>>>>>>>          send display to (oWeekNumberHeader(oCont3d(self)))
54120>>>>>>>          send display to (oDaysGrid(oCont3d(self))) 0
54121>>>>>>>        end
54121>>>>>>>>
54121>>>>>>>      end_procedure
54122>>>>>>>      procedure display_main
54125>>>>>>>        send display
54126>>>>>>>        send display to (oDaysGrid(oCont3d(self))) 1
54127>>>>>>>      end_procedure
54128>>>>>>>      procedure popup_no_export
54131>>>>>>>        set pExportState to DFFALSE
54132>>>>>>>        send popup
54133>>>>>>>        set pExportState to DFTRUE
54134>>>>>>>      end_procedure
54135>>>>>>>
54135>>>>>>>      procedure popup_group
54138>>>>>>>        integer lhFocus
54138>>>>>>>        date ldDate
54138>>>>>>>        move (focus(desktop)) to lhFocus
54139>>>>>>>        set invoking_object_id to lhFocus
54140>>>>>>>        get value of lhFocus item current to ldDate
54141>>>>>>>        ifnot (integer(ldDate)) move (dSysdate()) to ldDate
54144>>>>>>>        move (Date2to4(ldDate)) to ldDate
54145>>>>>>>        set pdCurrentDate to ldDate
54146>>>>>>>        send display
54147>>>>>>>        forward send popup_group
54149>>>>>>>        send display to (oDaysGrid(oCont3d(self))) 1
54150>>>>>>>      end_procedure
54151>>>>>>>
54151>>>>>>>      procedure move_value_out
54154>>>>>>>        integer lhFocus lbDelegationMode liMargin liDataType
54154>>>>>>>//      if (pExportState(self)) begin
54154>>>>>>>          get invoking_object_id to lhFocus
54155>>>>>>>          if lhFocus gt desktop begin
54157>>>>>>>            get delegation_mode of lhFocus to lbDelegationMode
54158>>>>>>>            set delegation_mode of lhFocus to no_delegate_or_error
54159>>>>>>>            send NotifyPopupCalendarSelect to lhFocus (pdCurrentDate(self))
54160>>>>>>>            get form_margin of lhFocus item current to liMargin
54161>>>>>>>            get form_datatype of lhFocus item current to liDataType
54162>>>>>>>            set delegation_mode of lhFocus to lbDelegationMode
54163>>>>>>>            if (pExportState(self)) begin
54165>>>>>>>              if (liMargin>=10 or liDataType=mask_date_window or liDataType=date_window) set value of lhFocus item current to (pdCurrentDate(self))
54168>>>>>>>              else             set value of lhFocus item current to (Date4to2(pdCurrentDate(self)))
54170>>>>>>>              set item_changed_state of lhFocus item current to DFTRUE
54171>>>>>>>            end
54171>>>>>>>>
54171>>>>>>>          end
54171>>>>>>>>
54171>>>>>>>//      end
54171>>>>>>>      end_procedure
54172>>>>>>>
54172>>>>>>>      procedure move_value_out_ok
54175>>>>>>>        send move_value_out
54176>>>>>>>        send deactivate
54177>>>>>>>      end_procedure
54178>>>>>>>
54178>>>>>>>      procedure request_popup
54181>>>>>>>        integer lhFocus liType lbDelegationMode
54181>>>>>>>        move (focus(desktop)) to lhFocus
54182>>>>>>>        if lhFocus gt desktop begin
54184>>>>>>>          get delegation_mode of lhFocus to lbDelegationMode
54185>>>>>>>          set delegation_mode of lhFocus to no_delegate_or_error
54186>>>>>>>          get form_datatype of lhFocus item current to liType
54187>>>>>>>          if (liType=date_window or liType=mask_date_window) send popup
54190>>>>>>>          set delegation_mode of lhFocus to lbDelegationMode
54191>>>>>>>        end
54191>>>>>>>>
54191>>>>>>>      end_procedure
54192>>>>>>>    end_object
54193>>>>>>>  end_desktop_section
54198>>>>>>>  // If the procedure below was not defined "for BaseClass" its symbolic
54198>>>>>>>  // substitute would become negative (because located on the desktop). This
54198>>>>>>>  // would result in the toolbar object not being able to handle it. Therefore:
54198>>>>>>>  procedure request_popup_calendar for BaseClass
54200>>>>>>>    send request_popup to (popup_calendar(self))
54201>>>>>>>  end_procedure
54202>>>>>>>  procedure popup_calendar_no_export
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
54204>>>>>>>    send popup_no_export to (popup_calendar(self))
54205>>>>>>>  end_procedure
54206>>>>>>>  register_procedure Add_Toolbar_Button_Bitmap string lsBmp string lsTip string lsStatusHelp integer liMsg integer lhObj
54206>>>>>>>  procedure Add_Calendar_tbButton integer lhToolButton
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
54208>>>>>>>    send Add_Toolbar_Button_Bitmap to lhToolButton "DfCalend.bmp" t.calendar.calendar_popup t.calendar.Activate msg_request_popup_calendar
54209>>>>>>>  end_procedure
54210>>>>>>> function s.calendar returns integer // Backwards compatible!!
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
54212>>>>>>>   function_return (popup_calendar(self))
54213>>>>>>> end_function
54214>>>>>>>
54214>>>>>>>// Karl,
54214>>>>>>>// Structure is as follows,
54214>>>>>>>//
54214>>>>>>>// //put this code in the top portion of the view code or in the program
54214>>>>>>>// code.
54214>>>>>>>//
54214>>>>>>>// Type SystemTime
54214>>>>>>>//   field SystemTime.iYear As Word
54214>>>>>>>//   field SystemTime.iMonth As Word
54214>>>>>>>//   field SystemTime.iDayOfWeek As Word
54214>>>>>>>//   field SystemTime.iDay As Word
54214>>>>>>>//   field SystemTime.iHour As Word
54214>>>>>>>//   field SystemTime.iMinute As Word
54214>>>>>>>//   field SystemTime.iSecond As Word
54214>>>>>>>//   field SystemTime.iMilliseconds As Word
54214>>>>>>>// End_Type
54214>>>>>>>//
54214>>>>>>>// external_function GetSystemTime "GetSystemTime" kernel32.dll Pointer lpGST Returns VOID_TYPE
54214>>>>>>>//
54214>>>>>>>// //put this code in an onClick or wherever
54214>>>>>>>// procedure onclick
54214>>>>>>>//   integer iRetVal
54214>>>>>>>//   string TimeData
54214>>>>>>>//   pointer GST
54214>>>>>>>//
54214>>>>>>>//   ZeroType SystemTime to TimeData
54214>>>>>>>//   getAddress from TimeData to GST
54214>>>>>>>//
54214>>>>>>>//   move (GetSystemTime(GST)) to iRetVal
54214>>>>>>>// end_procedure
54214>>>>>>>//
54214>>>>>>>// To extract the data from the Structure after calling the function use
54214>>>>>>>// the getbuff command as follows:
54214>>>>>>>//
54214>>>>>>>// getbuff from TimeData as SystemTime.IVAL to var
54214>>>>>>>//
54214>>>>>>>// where IVAL is one of the vars such as iYear or iDay, etc.
54214>>>>>>>//
54214>>>>>>>// OLIVER NELSON
54214>>>>>>>//
54214>>>>>>>//
54214>>>>>Use Files.utl    // Utilities for handling file related stuff
54214>>>>>Use MsgBox.utl   // obs procedure
54214>>>>>Use Seq_Chnl     // Defines global sequential device management operations (DAC)
54214>>>>>Use Language.pkg // Default language setup
54214>>>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
54214>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
54214>>>>>
54214>>>>>// ===========================================================================
54214>>>>>//          LANGUAGE DEPENDANT TEXT CONSTANTS
54214>>>>>// ===========================================================================
54214>>>>>
54214>>>>> define t.output.GoPg_Label     for "Go to page"
54214>>>>> define t.output.Find           for "Find"
54214>>>>> define t.output.Search_string  for "Search string"
54214>>>>> define t.output.Case_sensitive for "Case sensitive"
54214>>>>> define t.output.Searching      for "Searching for string..."
54214>>>>> define t.output.PressAnyKey    for "Press any key to interrupt"
54214>>>>> define t.output.CancelSearch   for "Cancel search?"
54214>>>>> define t.output.TextNotFound   for "' not found!"
54214>>>>> define t.output.NotToScreen    for "Not screen!"
54214>>>>> define t.output.Main1          for " &Exit"
54214>>>>> define t.output.Main1_1        for "&Exit\aEsc"
54214>>>>> define t.output.Main2          for " &Navigate"
54214>>>>> define t.output.Main2_1        for "&Prev. page \aPgUp"
54214>>>>> define t.output.Main2_2        for "&Next page \aPgDn"
54214>>>>> define t.output.Main2_3        for "16 lines &Up\a-"
54214>>>>> define t.output.Main2_4        for "16 lines &Down\a+"
54214>>>>> define t.output.Main2_5        for "First page \aCtrl+PgUp"
54214>>>>> define t.output.Main2_6        for "Last page \aCtrl+PgDn"
54214>>>>> define t.output.Main2_7        for "&Go to page\aAlt-G"
54214>>>>> define t.output.Main2_8        for "Line start\aHome"
54214>>>>> define t.output.Main2_9        for "Left"
54214>>>>> define t.output.Main2_10       for "Right"
54214>>>>> define t.output.Main2_11       for "Linie end\aEnd"
54214>>>>> define t.output.Main3          for " &Search"
54214>>>>> define t.output.Main3_1        for "&Search\aF2"
54214>>>>> define t.output.Main3_2        for "&Find next\aSF2"
54214>>>>> define t.output.Main4          for " &Print"
54214>>>>> define t.output.Main4_1        for "&Print report"
54214>>>>>
54214>>>>>// ===========================================================================
54214>>>>>//          CONSTANTS DECLARATIONS
54214>>>>>// ===========================================================================
54214>>>>>
54214>>>>>define DEST_NONE    for 0
54214>>>>>define DEST_PRINTER for 1
54214>>>>>define DEST_SCREEN  for 2
54214>>>>>define DEST_FILE    for 3
54214>>>>>define DEST_HTML    for 4
54214>>>>>define DEST_EDITOR  for 5
54214>>>>>define DEST_EMAIL   for 6
54214>>>>>
54214>>>>>define FILEEXISTS_CANCEL    for 0
54214>>>>>define FILEEXISTS_APPEND    for 1
54214>>>>>define FILEEXISTS_OVERWRITE for 2
54214>>>>>define FILEEXISTS_PROMPT    for 3 // Ask the operator
54214>>>>>
54214>>>>>// ===========================================================================
54214>>>>>//          BASIC OUTPUT CLASS
54214>>>>>// ===========================================================================
54214>>>>>
54214>>>>>indicator output$move_up?
54214>>>>>string    output$code
54214>>>>>string    output$symbollist 255
54214>>>>>integer   output$idx
54214>>>>>integer   seq.object#
54214>>>>>
54214>>>>>
54214>>>>>goto output$skip_definition
54215>>>>>>
54215>>>>>output$code_move:
54215>>>>>  Enumeration_List
54215>>>>>    output.define_code _nop             ""
54221>>>>>    output.define_code _initialize      ""
54227>>>>>    output.define_code _reset           ""
54233>>>>>    output.define_code _bold_on         ""
54239>>>>>    output.define_code _bold_off        ""
54245>>>>>    output.define_code _italics_on      ""
54251>>>>>    output.define_code _italics_off     ""
54257>>>>>    output.define_code _underline_on    ""
54263>>>>>    output.define_code _underline_off   ""
54269>>>>>    output.define_code _user_on         ""
54275>>>>>    output.define_code _user_off        ""
54281>>>>>    output.define_code _cpi10           ""
54287>>>>>    output.define_code _cpi12           ""
54293>>>>>    output.define_code _cpi17           ""
54299>>>>>    output.define_code _lpi03           ""
54305>>>>>    output.define_code _lpi06           ""
54311>>>>>    output.define_code _lpi08           ""
54317>>>>>    output.define_code _lpi12           ""
54323>>>>>    output.define_code _lpi72           ""
54329>>>>>    output.define_code _macro_def_pre   ""
54335>>>>>    output.define_code _macro_def_post  ""
54341>>>>>    output.define_code _macro_call_pre  ""
54347>>>>>    output.define_code _macro_call_post ""
54353>>>>>    output.define_code _macro_kill_pre  ""
54359>>>>>    output.define_code _macro_kill_post ""
54365>>>>>    output.define_code _paper_tray_1    ""
54371>>>>>    output.define_code _paper_tray_2    ""
54377>>>>>    output.define_code _paper_tray_3    ""
54383>>>>>    output.define_code _paper_tray_4    ""
54389>>>>>    output.define_code _pos_push        ""
54395>>>>>    output.define_code _pos_pop         ""
54401>>>>>  End_Enumeration_List
54401>>>>>return
54402>>>>>output$skip_definition:
54402>>>>>
54402>>>>>
54402>>>>>move "" to OUTPUT$SYMBOLLIST
54403>>>>>BUILD_CODE_SYMBOLS
54434>>>>>
54434>>>>>procedure output.get_code integer code#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
54436>>>>>  indicate output$move_up? true
54437>>>>>  move code# to output$idx
54438>>>>>  gosub output$code_move
54439>>>>>>
54439>>>>>end_procedure
54440>>>>>procedure output.set_code integer code#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
54442>>>>>  indicate output$move_up? false
54443>>>>>  move code# to output$idx
54444>>>>>  gosub output$code_move
54445>>>>>>
54445>>>>>end_procedure
54446>>>>>procedure output.zero_codes
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
54448>>>>>  integer code#
54448>>>>>  move "" to output$code
54449>>>>>  for code# from 0 to output$max_code
54455>>>>>>
54455>>>>>    send output.set_code code#
54456>>>>>  loop
54457>>>>>>
54457>>>>>end_procedure
54458>>>>>send output.zero_codes
54459>>>>>function output.replace_codes global string str# returns string
54461>>>>>  integer code#
54461>>>>>  string symb#
54461>>>>>  if "<" in str# begin
54463>>>>>    for code# from 0 to output$max_code
54469>>>>>>
54469>>>>>      send output.get_code code#
54470>>>>>      move (replaces(mid(output$symbollist,5,code#*5+1),str#,output$code)) to str#
54471>>>>>    loop
54472>>>>>>
54472>>>>>  end
54472>>>>>>
54472>>>>>  function_return str#
54473>>>>>end_function
54474>>>>>function output.remove_codes global string str# returns string
54476>>>>>  integer code#
54476>>>>>  string symb#
54476>>>>>  if "<" in str# begin
54478>>>>>    for code# from 0 to output$max_code
54484>>>>>>
54484>>>>>      move (replaces(mid(output$symbollist,5,code#*5+1),str#,"")) to str#
54485>>>>>    loop
54486>>>>>>
54486>>>>>  end
54486>>>>>>
54486>>>>>  function_return str#
54487>>>>>end_function
54488>>>>>
54488>>>>>class cBasicSequentialOutputEMailRecipients is a cArray
54489>>>>>  item_property_list
54489>>>>>    item_property string psName.i
54489>>>>>    item_property string psAddress.i
54489>>>>>  end_item_property_list cBasicSequentialOutputEMailRecipients
#REM 54521 DEFINE FUNCTION PSADDRESS.I INTEGER LIROW RETURNS STRING
#REM 54525 DEFINE PROCEDURE SET PSADDRESS.I INTEGER LIROW STRING VALUE
#REM 54529 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 54533 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
54538>>>>>  procedure add_recipient string lsName string lsAddress
54540>>>>>    integer liRow
54540>>>>>    get row_count to liRow
54541>>>>>    set psName.i    liRow to lsName
54542>>>>>    set psAddress.i liRow to lsAddress
54543>>>>>  end_procedure
54544>>>>>end_class // cBasicSequentialOutputEMailRecipients
54545>>>>>
54545>>>>>class cBasicSequentialOutput is a cArray
54546>>>>>  procedure construct_object integer img#
54548>>>>>    forward send construct_object img#
54550>>>>>    set delegation_mode to delegate_to_parent
54551>>>>>    move self to seq.object#
54552>>>>>    property string  pTitle            public "Un-titled"
54553>>>>>    property date    pInitDate         public 0
54554>>>>>    property string  pInitTime         public ""
54555>>>>>    property integer pDestination      public DEST_SCREEN
54556>>>>>
54556>>>>>    property integer pOutputChannel    public -1
54557>>>>>
54557>>>>>     property string  pPrinterPort     public "LPT1:"
54558>>>>>    property string  pOutFileName      public "dataflex.txt"
54559>>>>>    property string  pScreenTmpFile    public "" // Used when printing to screen AND *email*
54560>>>>>    property integer pFileExistsAction public FILEEXISTS_OVERWRITE // If set to FILEEXISTS_CANCEL the report will refuse to print to an existing file!
54561>>>>>    property integer pOmitFormFeed     public 0
54562>>>>>
54562>>>>>    property integer pLineCount        public 0
54563>>>>>    property integer pPageCount        public 0
54564>>>>>    property integer pPageLength       public 50 // 0 means continous
54565>>>>>    property integer pBytesWritten     public 0
54566>>>>>
54566>>>>>    property integer phMsg_Object      public 0
54567>>>>>
54567>>>>>    property integer pHeader_image     public 0
54568>>>>>    property integer pHeader_height    public 0 // number of lines in header.
54569>>>>>    property integer pHeader_msg       public 0
54570>>>>>
54570>>>>>    property integer pSubHeader_image  public 0
54571>>>>>    property integer pSubHeader_height public 0 // number of lines in subheader.
54572>>>>>    property integer pSubHeader_msg    public 0
54573>>>>>
54573>>>>>    property integer pFooter_image     public 0
54574>>>>>    property integer pFooter_height    public 0 // number of lines in footer.
54575>>>>>    property integer pFooter_msg       public 0
54576>>>>>    property integer pFooterFill_image public 0
54577>>>>>
54577>>>>>    property integer pOnceOnly_image   public 0
54578>>>>>    property integer pOnceOnly_height  public 0
54579>>>>>    property integer pOnceOnly_msg     public 0
54580>>>>>
54580>>>>>    property integer pInUseState       public false
54581>>>>>    property integer pWidth            public 77
54582>>>>>    property integer pbOemToAnsi       public 0
54583>>>>>
54583>>>>>    object oPageOffSets is an array no_image
54585>>>>>    end_object
54586>>>>>    object oChannelAdmin is a cChannelAdmin no_image
54588>>>>>    end_object
54589>>>>>    object oEmailRecipients is a cBasicSequentialOutputEMailRecipients
54591>>>>>    end_object
54592>>>>>    // ". /dfds01/appl/scripts/sendfile #F# #A#"
54592>>>>>    property string psSendMailProgramPath public ""
54593>>>>>  end_procedure
54594>>>>>
54594>>>>>  procedure add_recipient string lsName string lsAddress
54596>>>>>    send add_recipient to (oEmailRecipients(self)) lsName lsAddress
54597>>>>>  end_procedure
54598>>>>>
54598>>>>>  procedure reset_recipients
54600>>>>>    send delete_data to (oEmailRecipients(self))
54601>>>>>  end_procedure
54602>>>>>
54602>>>>>  function iUseSequentialChannel returns integer
54604>>>>>    integer destination#
54604>>>>>    get pDestination to destination#
54605>>>>>    function_return (destination#=DEST_FILE or destination#=DEST_HTML or destination#=DEST_EDITOR)
54606>>>>>  end_function // iUseSequentialChannel
54607>>>>>
54607>>>>>  function iPageBreakNeeded integer lines# returns integer
54609>>>>>    integer pageend#
54609>>>>>    get pPageLength to pageend#
54610>>>>>    if pageend# eq 0 function_return 0
54613>>>>>    function_return (lines#>(pageend#-pLineCount(self)-pFooter_height(self)))
54614>>>>>  end_function
54615>>>>>
54615>>>>>  function iAvailablePageLength returns integer
54617>>>>>    integer pageend# headerlines# subheaderlines# footerlines#
54617>>>>>    get pPageLength to pageend#
54618>>>>>    get pHeader_height to headerlines#
54619>>>>>    get pSubHeader_height to subheaderlines#
54620>>>>>    get pFooter_height to footerlines#
54621>>>>>    function_return (pageend#-headerlines#-subheaderlines#-footerlines#)
54622>>>>>  end_function
54623>>>>>
54623>>>>>  function Remaining_Lines returns integer
54625>>>>>    integer pageend# linecount# footerlines#
54625>>>>>    get pPageLength to pageend#
54626>>>>>    get pLineCount to linecount#
54627>>>>>    get pFooter_height to footerlines#
54628>>>>>    function_return (pageend#-linecount#-footerlines#)
54629>>>>>  end_function
54630>>>>>
54630>>>>>  function iResource_Reserve returns integer
54632>>>>>    integer ch1# ch2# rval# UseSequentialChannel#
54632>>>>>    get iUseSequentialChannel to UseSequentialChannel# // Do we need a channel?
54633>>>>>    if UseSequentialChannel# get Seq_New_Channel to ch1#
54636>>>>>    else move 0 to ch1#
54638>>>>>    get Seq_New_Channel to ch2#
54639>>>>>    move (ch1#>=0 and ch2#>=0) to rval#
54640>>>>>    if rval# begin
54642>>>>>      if UseSequentialChannel# set pOutputChannel to ch1#
54645>>>>>      set pChannel of (oChannelAdmin(self)) to ch2#
54646>>>>>    end
54646>>>>>>
54646>>>>>    else begin
54647>>>>>      if UseSequentialChannel# if ch1# ge 0 send Seq_Release_Channel ch1#
54652>>>>>      if ch2# ge 0 send Seq_Release_Channel ch2#
54655>>>>>    end
54655>>>>>>
54655>>>>>    function_return rval#
54656>>>>>  end_function
54657>>>>>
54657>>>>>  procedure Resource_Release
54659>>>>>    if (iUseSequentialChannel(self)) ;        send Seq_Release_Channel (pOutputChannel(self))
54662>>>>>    send Seq_Release_Channel (pChannel(oChannelAdmin(self)))
54663>>>>>  end_procedure
54664>>>>>
54664>>>>>  procedure Page_Eject_No_Footer.i integer ff#
54666>>>>>    integer obj# ch# Destination#
54666>>>>>    integer pos# UseSequentialChannel#
54666>>>>>    if (pLineCount(self)) begin
54668>>>>>      get iUseSequentialChannel to UseSequentialChannel#
54669>>>>>      if UseSequentialChannel# begin
54671>>>>>        get pOutputChannel to ch#
54672>>>>>        get_channel_position ch# to pos#
54673>>>>>>
54673>>>>>        set pBytesWritten to pos#
54674>>>>>      end
54674>>>>>>
54674>>>>>      get pDestination to Destination#
54675>>>>>      if Destination# eq DEST_SCREEN begin //screen
54677>>>>>//        winprint, newpage
54677>>>>>      end
54677>>>>>>
54677>>>>>      else begin
54678>>>>>        if UseSequentialChannel# begin
54680>>>>>          if ff# begin
54682>>>>>            if Destination# eq DEST_HTML write channel ch# (replace("#",'

',string(pPageCount(self))))
54686>>>>>            else write channel ch# (character(12))
54689>>>>>          end
54689>>>>>>
54689>>>>>        end
54689>>>>>>
54689>>>>>      end
54689>>>>>>
54689>>>>>      set pPageCount to (pPageCount(self)+1)
54690>>>>>      set pLineCount to 0
54691>>>>>      move 0 to linecount
54692>>>>>    end
54692>>>>>>
54692>>>>>  end_procedure
54693>>>>>
54693>>>>>  procedure page_eject.i integer ff#
54695>>>>>    integer line# linecount# pageend# footerlines# footer_img# footerfill_img#
54695>>>>>    get pLineCount to linecount#
54696>>>>>    if linecount# begin // only if something has been written
54698>>>>>      get pFooter_image to footer_img#
54699>>>>>      if footer_img# begin // If 'footer' has been set
54701>>>>>        get pPageLength to pageend#
54702>>>>>        get pFooter_height to footerlines#
54703>>>>>        get pFooterFill_image to footerfill_img#
54704>>>>>        for line# from linecount# to (pageend#-1-footerlines#)
54710>>>>>>
54710>>>>>          if footerfill_img# send output_image_aux footerfill_img#
54713>>>>>          else send writeln_no_headers ""
54715>>>>>        loop
54716>>>>>>
54716>>>>>        send message.i (pFooter_msg(self))
54717>>>>>        send output_image_aux footer_img#
54718>>>>>      end
54718>>>>>>
54718>>>>>      send page_eject_no_footer.i ff#
54719>>>>>    end
54719>>>>>>
54719>>>>>  end_procedure
54720>>>>>
54720>>>>>  procedure new_page
54722>>>>>    send page_eject.i 1
54723>>>>>  end_procedure
54724>>>>>
54724>>>>>  procedure cmdline_start
54726>>>>>  end_procedure
54727>>>>>  procedure cmdline_stop
54729>>>>>  end_procedure
54730>>>>>
54730>>>>>  function iPreconditions_Direct_Output returns integer
54732>>>>>    integer rval#
54732>>>>>    get iResource_Reserve to rval#
54733>>>>>    function_return rval#
54734>>>>>  end_function
54735>>>>>
54735>>>>>  function iDirect_Output returns integer
54737>>>>>    integer rval# dest# exists_action#
54737>>>>>    string tmp_fn# fn#
54737>>>>>    move 1 to rval#
54738>>>>>    if (iPreconditions_Direct_Output(self)) begin
54740>>>>>      get pDestination to dest#
54741>>>>>      set pInitDate to (dSysDate())
54742>>>>>      set pInitTime to (sSysTime())
54743>>>>>      if dest# eq DEST_PRINTER begin // Printer
54745>>>>>         set pOmitFormFeed to true
54746>>>>>      end
54746>>>>>>
54746>>>>>      if dest# eq DEST_SCREEN begin // Screen
54748>>>>>         set pOmitFormFeed to true
54749>>>>>      end
54749>>>>>>
54749>>>>>      if dest# eq DEST_FILE begin // File
54751>>>>>        get pOutFileName to fn#
54752>>>>>        move 2 to exists_action# // 0=cancel 1=append, 2=overwrite
54753>>>>>        if (SEQ_FileExists(fn#)) begin
54755>>>>>          get pFileExistsAction to exists_action#
54756>>>>>          // if exists_action# eq FILEEXISTS_PROMPT move (SEQ_FileExistsAction(fn#,1)) to exists_action#
54756>>>>>        end
54756>>>>>>
54756>>>>>        if exists_action# begin
54758>>>>>          if exists_action# eq 1 append_output channel (pOutputChannel(self)) ("cr: 13 eol: 10 "+fn#) //append
54762>>>>>          if exists_action# eq 2 direct_output channel (pOutputChannel(self)) ("cr: 13 eol: 10 "+fn#) //overwrite
54766>>>>>        end
54766>>>>>>
54766>>>>>        else move 0 to rval#
54768>>>>>      end
54768>>>>>>
54768>>>>>      if dest# eq DEST_EMAIL begin // EMAIL
54770>>>>>
54770>>>>>//        get SEQ_UniqueFileName "mail" to fn#
54770>>>>>        get SEQ_UniqueFileNamePathAndExt "" "mail" "txt" to fn#
54771>>>>>        if fn# ne "" begin
54773>>>>>          set pScreenTmpFile to fn#
54774>>>>>          if (API_OtherAttr_Value(OA_OS_SHORT_NAME)="WIN32CM") begin
54776>>>>>            direct_output channel (pOutputChannel(self)) fn#
54778>>>>>          end
54778>>>>>>
54778>>>>>          else begin
54779>>>>>            direct_output channel (pOutputChannel(self)) ("pc-text: "+fn#)
54781>>>>>          end
54781>>>>>>
54781>>>>>        end
54781>>>>>>
54781>>>>>        else begin
54782>>>>>          send obs "Outfile failure (source: output.utl)" "(E-mail)"
54783>>>>>          move 0 to rval#
54784>>>>>        end
54784>>>>>>
54784>>>>>      end
54784>>>>>>
54784>>>>>      if dest# eq DEST_HTML begin // HTML
54786>>>>>      end
54786>>>>>>
54786>>>>>      set pPageCount    to 0
54787>>>>>      set pBytesWritten to 0
54788>>>>>      set pLineCount    to 0
54789>>>>>    end
54789>>>>>>
54789>>>>>    else move 0 to rval#
54791>>>>>    if rval# begin
54793>>>>>      set pInUseState to true
54794>>>>>      send Report_Wait_On
54795>>>>>      send Initialize_Output
54796>>>>>    end
54796>>>>>>
54796>>>>>    else begin
54797>>>>>      set pInUseState to false
54798>>>>>      send Resource_Release
54799>>>>>    end
54799>>>>>>
54799>>>>>    function_return rval#
54800>>>>>  end_function
54801>>>>>  function iDirect_Output_Title string title# returns integer
54803>>>>>    integer rval#
54803>>>>>    set pTitle to title#
54804>>>>>    get iDirect_Output to rval#
54805>>>>>    if rval# begin
54807>>>>>      set pHeader_image to 0
54808>>>>>      set pHeader_height to 0
54809>>>>>      set pHeader_msg to 0
54810>>>>>      set pSubHeader_image to 0
54811>>>>>      set pSubHeader_height to 0
54812>>>>>      set pSubHeader_msg to 0
54813>>>>>      set pFooter_image to 0
54814>>>>>      set pFooter_height to 0
54815>>>>>      set pFooter_msg to 0
54816>>>>>      set pFooterFill_image to 0
54817>>>>>      set pOnceOnly_image to 0
54818>>>>>      set pOnceOnly_height to 0
54819>>>>>      set pOnceOnly_msg to 0
54820>>>>>    end
54820>>>>>>
54820>>>>>    function_return rval#
54821>>>>>  end_function
54822>>>>>  procedure Initialize_Output
54824>>>>>  end_procedure
54825>>>>>
54825>>>>>            procedure DoSendEmails string lsFile
54827>>>>>              integer lhEmailRecipients liMax liRow
54827>>>>>              string lsName lsAddress lsSendMailProgramPath
54827>>>>>
54827>>>>>              get psSendMailProgramPath to lsSendMailProgramPath
54828>>>>>              if (lsSendMailProgramPath<>"") begin
54830>>>>>
54830>>>>>                move (oEmailRecipients(self)) to lhEmailRecipients
54831>>>>>                get row_count of lhEmailRecipients to liMax
54832>>>>>                decrement liMax
54833>>>>>                for liRow from 0 to liMax
54839>>>>>>
54839>>>>>                  get psSendMailProgramPath to lsSendMailProgramPath
54840>>>>>                  move (replace("#A#",lsSendMailProgramPath,psAddress.i(lhEmailRecipients,liRow))) to lsSendMailProgramPath
54841>>>>>                  move (replace("#F#",lsSendMailProgramPath,lsFile)) to lsSendMailProgramPath
54842>>>>>                  //send obs lsSendMailProgramPath
54842>>>>>                  runprogram wait lsSendMailProgramPath
54843>>>>>                loop
54844>>>>>>
54844>>>>>              end
54844>>>>>>
54844>>>>>              else send obs "E-mail program path not specified."
54846>>>>>            end_procedure
54847>>>>>
54847>>>>>  procedure Close_Output
54849>>>>>    integer ch# dest# pos#
54849>>>>>    string lsFileName
54849>>>>>    if (pInUseState(self)) begin
54851>>>>>      if (pLineCount(self)) send page_eject.i (not(pOmitFormFeed(self)))
54854>>>>>
54854>>>>>      if (iUseSequentialChannel(self)) begin
54856>>>>>        send write_no_headers ""
54857>>>>>        get pOutputChannel to ch#
54858>>>>>        get_channel_position ch# to pos#
54859>>>>>>
54859>>>>>        set pBytesWritten to pos#
54860>>>>>        despool
54861>>>>>>
54861>>>>>        close_output channel ch#
54863>>>>>      end
54863>>>>>>
54863>>>>>
54863>>>>>      get pDestination to dest#
54864>>>>>      if dest# eq DEST_PRINTER begin
54866>>>>>        send cmdline_stop
54867>>>>>//        WinPrint, print doc
54867>>>>>      end
54867>>>>>>
54867>>>>>      if dest# eq DEST_EMAIL begin
54869>>>>>        //send obs "Haps, min fine ven"
54869>>>>>        send report_wait_update "Sending e-mails..."
54870>>>>>        get pScreenTmpFile to lsFileName
54871>>>>>        get SEQ_ConvertToAbsoluteFileName lsFileName to lsFileName
54872>>>>>        send DoSendEmails lsFileName
54873>>>>>        erasefile lsFileName
54874>>>>>>
54874>>>>>      end
54874>>>>>>
54874>>>>>      send report_wait_off
54875>>>>>      if dest# eq DEST_SCREEN begin
54877>>>>>//        WinPrint, print doc
54877>>>>>      end
54877>>>>>>
54877>>>>>      else send report_done
54879>>>>>      set pInUseState to false
54880>>>>>      send Resource_Release
54881>>>>>    end
54881>>>>>>
54881>>>>>
54881>>>>>  end_procedure
54882>>>>>
54882>>>>>  procedure message.i integer msg#
54884>>>>>    integer lhObj
54884>>>>>    if msg# begin
54886>>>>>      get phMsg_Object to lhObj
54887>>>>>      if lhObj send msg# to lhObj
54890>>>>>      else send msg#
54892>>>>>    end
54892>>>>>>
54892>>>>>  end_procedure
54893>>>>>
54893>>>>>  function replace_header_codes string str# returns string
54895>>>>>    integer pagecount#
54895>>>>>    date date#
54895>>>>>    string page#
54895>>>>>    get pInitDate to date#
54896>>>>>    move (pPageCount(self)+1) to pagecount#
54897>>>>>    move (replaces("",str#,string(date#))) to str#
54898>>>>>    move (replaces("",str#,pInitTime(self))) to str# //time
54899>>>>>    if "" in str# begin // page number
54901>>>>>      move pagecount# to page#
54902>>>>>      if pagecount# le 999 insert " " in page# at 1
54906>>>>>      pad page# to page# 4
54908>>>>>>
54908>>>>>      move (replaces("",str#,page#)) to str# //time
54909>>>>>    end
54909>>>>>>
54909>>>>>    if "
" in str# begin // page number
54911>>>>>      move pagecount# to page#
54912>>>>>      if pagecount# le 99 insert " " in page# at 1
54916>>>>>      if pagecount# le  9 insert " " in page# at 1
54920>>>>>      move (replaces("
",str#,page#)) to str#
54921>>>>>    end
54921>>>>>>
54921>>>>>    function_return str#
54922>>>>>  end_function
54923>>>>>
54923>>>>>  function replace_codes string str# returns string
54925>>>>>    // If e-mail remove codes, else insert code values
54925>>>>>    if (pDestination(self)=DEST_EMAIL) function_return (output.replace_codes(str#))
54928>>>>>    function_return (output.remove_codes(str#))
54929>>>>>  end_function
54930>>>>>
54930>>>>>  procedure output_image_help integer img# integer header_codes#
54932>>>>>    integer seqeof# obj# ch#
54932>>>>>    string str#
54932>>>>>    move (seqeof) to seqeof#
54933>>>>>    move (oChannelAdmin(self)) to obj#
54934>>>>>    get pChannel of obj# to ch#
54935>>>>>    send direct_xput to obj# 1 ("image: "+string(img#))
54936>>>>>    repeat
54936>>>>>>
54936>>>>>      readln channel ch# str#
54938>>>>>      [~seqeof] begin
54940>>>>>>
54940>>>>>        if header_codes# send writeln_no_headers (replace_header_codes(self,str#))
54943>>>>>        else send writeln str#
54945>>>>>      end
54945>>>>>>
54945>>>>>    [~seqeof] loop
54946>>>>>>
54946>>>>>    send close_xput to obj#
54947>>>>>    indicate seqeof as seqeof#
54948>>>>>  end_procedure
54949>>>>>
54949>>>>>  procedure output_image_aux integer img#
54951>>>>>    send output_image_help img# 1
54952>>>>>  end_procedure
54953>>>>>
54953>>>>>  procedure output_image integer img# integer check_space_tmp#
54955>>>>>    integer check_space#
54955>>>>>    if num_arguments gt 1 move check_space_tmp# to check_space#
54958>>>>>    else move 0 to check_space#
54960>>>>>    if (iPageBreakNeeded(self,check_space#)) send page_eject.i 0
54963>>>>>    send output_image_help img# 0
54964>>>>>  end_procedure
54965>>>>>
54965>>>>>  procedure output_image_wrap integer img# // Won't work! (BLANKFORM img#)
54967>>>>>    send output_image_help img# 0
54969>>>>>    indicate copy_122 as [ |122]
54970>>>>>    send output_image img#
54973>>>>>    indicate copy_122 as [ |122]
54974>>>>>    [not copy_122] repeat
54976>>>>>>
54976>>>>>      send output_image img#
54978>>>>>      indicate copy_122 as [ |122]
54979>>>>>    [not copy_122] loop
54980>>>>>>
54980>>>>>  end_procedure
54981>>>>>
54981>>>>>  procedure write.i string str# integer do_headers#
54983>>>>>    integer header_img# subheader_img# onceonly_img# pagecount# pageend#
54983>>>>>    string page_init#
54983>>>>>    if do_headers# begin
54985>>>>>      get pHeader_image    to header_img#
54986>>>>>      get pSubHeader_image to subheader_img#
54987>>>>>      get pOnceOnly_image  to onceonly_img#
54988>>>>>      get pPageCount       to pagecount#
54989>>>>>      get pPageLength      to pageend#
54990>>>>>
54990>>>>>      if (iPageBreakNeeded(self,1)) send page_eject.i 0
54993>>>>>
54993>>>>>      // if we are at the top of a new page print header and subheader:
54993>>>>>      if (pLineCount(self)) eq 0 begin
54995>>>>>
54995>>>>>        send message.i (pHeader_msg(self))
54996>>>>>        if header_img# send output_image_aux header_img#
54999>>>>>
54999>>>>>        send message.i (pSubHeader_msg(self))
55000>>>>>        if subheader_img# send output_image_aux subheader_img#
55003>>>>>      end
55003>>>>>>
55003>>>>>      if onceonly_img# begin
55005>>>>>        send message.i (pOnceOnly_msg(self))
55006>>>>>        set pOnceOnly_image to 0
55007>>>>>        send output_image onceonly_img#
55008>>>>>      end
55008>>>>>>
55008>>>>>    end
55008>>>>>>
55008>>>>>    move (replace_codes(self,str#)) to str#
55009>>>>>    if (iUseSequentialChannel(self)) write channel (pOutputChannel(self)) str#
55013>>>>>    else begin
55014>>>>>    end
55014>>>>>>
55014>>>>>  end_procedure
55015>>>>>
55015>>>>>  procedure write_no_headers string str#
55017>>>>>    send write.i str# 0
55018>>>>>  end_procedure
55019>>>>>
55019>>>>>  procedure write string str#
55021>>>>>    send write.i str# 1
55022>>>>>  end_procedure
55023>>>>>
55023>>>>>  procedure writeln string str#
55025>>>>>    send write.i str# 1
55026>>>>>    if (iUseSequentialChannel(self)) writeln channel (pOutputChannel(self)) (if(pDestination(self)=DEST_HTML,"
",""))
55031>>>>>    else begin
55032>>>>>    end
55032>>>>>>
55032>>>>>    set pLineCount to (pLineCount(self)+1)
55033>>>>>  end_procedure
55034>>>>>
55034>>>>>  procedure writeln_no_headers string str#
55036>>>>>    send write.i str# 0
55037>>>>>    writeln channel (pOutputChannel(self))
55039>>>>>    set pLineCount to (pLineCount(self)+1)
55040>>>>>  end_procedure
55041>>>>>
55041>>>>>  procedure make_horizontal_line
55043>>>>>    integer destination#
55043>>>>>    get pDestination to Destination#
55044>>>>>
55044>>>>>//    if (destination#=DEST_PRINTER or destination#=DEST_SCREEN)  winprint, draw line
55044>>>>>    else begin
55045>>>>>      if destination# eq DEST_HTML send writeln "
" // Horizontal ruler
55048>>>>>      else send writeln (repeat(" ",pWidth(self)))
55050>>>>>    end
55050>>>>>>
55050>>>>>  end_procedure
55051>>>>>
55051>>>>>  procedure call_viewer
55053>>>>>    integer self#
55053>>>>>    move self to self#
55054>>>>>    send output.CallViewer (pScreenTmpFile(self)) self#
55055>>>>>  end_procedure
55056>>>>>
55056>>>>>  procedure Report_Wait_On
55058>>>>>  end_procedure
55059>>>>>  procedure Report_Wait_Off
55061>>>>>  end_procedure
55062>>>>>  procedure Report_Wait_Update string str#
55064>>>>>  end_procedure
55065>>>>>  procedure Report_Wait_Update2 string str#
55067>>>>>  end_procedure
55068>>>>>  function iReport_Cancel returns integer
55070>>>>>  end_function
55071>>>>>  procedure Report_Done
55073>>>>>    send obs "Done"
55074>>>>>  end_procedure
55075>>>>>end_class // cBasicSequentialOutput
55076>>>>>
55076>>>>>object oBasicSequentialOutput is a cBasicSequentialOutput NO_IMAGE
55078>>>>>end_object
55079>>>>>
55079>>>>>
55079>>>>>// seq.output  [lines]
55079>>>>>
55079>>>>>
55079>>>>>
55079>>>>>
55079>>>>>
55079>>>>>
55079>>>>>
55079>>>>>// ===========================================================================
55079>>>>>//  ********************* CHARACTER MODE PREVIEW OBJECT *********************
55079>>>>>// ===========================================================================
55079>>>>>
55079>>>>>use Aps      // Auto Position and Sizing classes for Visual DataFlex 4.0
55079>>>>>use file_dlg // OpenDialog class
55079>>>>>register_abstract_field_type aft_AppLinkPath50 50 ascii_window
55081>>>>>
55081>>>>>object WordPadLinkSetup is a aps.ModalPanel label "WordPad kommunikation"
55084>>>>>  object FlDlg is a OpenDialog
55086>>>>>    set NoChangeDir_State to true
55087>>>>>  end_object
55088>>>>>  object cont is a aps.container3D
55090>>>>>    object frm1 is a aps.Form label "WordPadPath:" abstract aft_AppLinkPath50
55094>>>>>      set p_extra_internal_width to -100
55095>>>>>      set form_button item 0 to 1
55096>>>>>      set form_button_value item 0 to "..."
55097>>>>>      procedure form_button_notification integer itm#
55100>>>>>        integer obj#
55100>>>>>        move (FlDlg(self)) to obj#
55101>>>>>        set Dialog_Caption of obj# to "Locate WORDPAD.EXE"
55102>>>>>        Set Filter_String  of obj# to ;         "Standard (WORDPAD.EXE)|WORDPAD.EXE|EXE files|*.exe|All files|*.*"
55103>>>>>        if (Show_Dialog(obj#)) set value item 0 to (File_Name(obj#))
55106>>>>>      end_procedure
55107>>>>>    end_object
55108>>>>>  end_object
55109>>>>>  procedure activate
55112>>>>>    ifnot (active_state(self)) send retrieve_values
55115>>>>>    forward send activate
55117>>>>>  end_procedure
55118>>>>>  procedure retrieve_values
55121>>>>>    string str#
55121>>>>>    get_profile_string "APPLICATION_LINKS" "WordPadPath"  to str#
55124>>>>>    set value of (frm1(cont(self))) item 0 to str#
55125>>>>>  end_procedure
55126>>>>>  procedure store_values
55129>>>>>    set_profile_string "APPLICATION_LINKS" "WordPadPath"  to (value(frm1(cont(self)),0))
55132>>>>>    send close_panel
55133>>>>>  end_procedure
55134>>>>>  object btn1 is a aps.multi_button
55136>>>>>    on_item "OK" send store_values
55137>>>>>  end_object
55138>>>>>  object btn2 is a aps.multi_button
55140>>>>>    on_item "Cancel" send close_panel
55141>>>>>  end_object
55142>>>>>  send aps_locate_multi_buttons
55143>>>>>end_object
55144>>>>>procedure activate_wordpad_setup
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
55146>>>>>  send popup to (WordPadLinkSetup(self))
55147>>>>>end_procedure
55148>>>>>
55148>>>>>procedure output.CallViewer global string fn# integer obj#
55150>>>>>   string str#
55150>>>>>   get_profile_string "APPLICATION_LINKS" "WordPadPath" to str#
55153>>>>>   move (str#*fn#) to str#
55154>>>>>   runprogram wait str#
55155>>>>>end_procedure
55156>>>>>
55156>>>>>procedure output.display_file global string fn#
55158>>>>>  integer ch# fin# liPos
55158>>>>>  integer liSearchPrnLine // Find this line (in .PRN file)
55158>>>>>  integer liFileLine      // Line number currently being loaded
55158>>>>>  integer liResultLine    // desired item found in this line in the file
55158>>>>>  string  lsTmpPrnLine    //
55158>>>>>  string str# dir#
55158>>>>>  get Seq_New_Channel to ch#
55159>>>>>  direct_input channel ch# fn#
55161>>>>>  if [seqeof] send obs ("File not found ("+fn#+")")
55164>>>>>  else begin
55165>>>>>    get SEQ_ExtractPathFromFileName fn# to dir#
55166>>>>>    if (dir#="") move (SEQ_FindFileAlongDFPath(fn#)) to dir#
55169>>>>>    if (dir#=".") get_current_directory to dir#
55172>>>>>    set pDestination of seq.object# to DEST_SCREEN
55173>>>>>    if (iDirect_Output_Title(seq.object#,fn#+" "+"("+dir#+")")) begin
55175>>>>>      move 0 to fin#
55176>>>>>      move 0 to liFileLine
55177>>>>>      move 0 to liResultLine
55178>>>>>      repeat
55178>>>>>>
55178>>>>>        readln channel ch# str#
55180>>>>>        move (seqeof) to fin#
55181>>>>>        ifnot fin# begin
55183>>>>>
55183>>>>>          increment liFileLine
55184>>>>>
55184>>>>>          // *** PRN file search ***
55184>>>>>          if liSearchPrnLine begin // If we're searching for a PRN line
55186>>>>>            ifnot liResultLine begin // If we didn't find it yet
55188>>>>>              if ("0123456789" contains left(str#,1)) begin
55190>>>>>                move (pos(">",str#)) to liPos
55191>>>>>                if (liPos>0 and liPos<8) begin
55193>>>>>                  move (left(str#,liPos-1)) to lsTmpPrnLine
55194>>>>>                  if (StringIsInteger(lsTmpPrnLine) and integer(lsTmpPrnLine)>=liSearchPrnLine) begin
55196>>>>>                    move liFileLine to liResultLine
55197>>>>>                    move 0 to liSearchPrnLine
55198>>>>>                  end
55198>>>>>>
55198>>>>>                end
55198>>>>>>
55198>>>>>              end
55198>>>>>>
55198>>>>>            end
55198>>>>>>
55198>>>>>          end
55198>>>>>>
55198>>>>>
55198>>>>>          seq.writeln str#
55200>>>>>        end
55200>>>>>>
55200>>>>>      until fin#
55202>>>>>      seq.close_output
55203>>>>>    end
55203>>>>>>
55203>>>>>  end
55203>>>>>>
55203>>>>>  send Seq_Release_Channel ch#
55204>>>>>end_procedure
55205>>>>>
55205>>>>>procedure output.run_dfindex_all global
55207>>>>>  send output.display_file "dfsort.log"
55208>>>>>end_procedure
55209>>>//Use DataScan.utl // Data scan classes
55209>>>Use FDX.nui      // cFDX class
55209>>>Use Fdx1.utl     // FDX aware display global attributes (FDX_DisplayGlobalAttributes procedure)
55209>>>Use Fdx2.utl     // FDX aware object for displaying a table definiton
55209>>>Use Fdx4.utl     // FDX aware cFileList_List selector object
55209>>>Use Fdx5.utl     // Basic adiministration of FDX objects
Including file: fdx5.utl    (C:\Apps\VDFQuery\AppSrc\fdx5.utl)
55209>>>>>//**********************************************************************
55209>>>>>// Use Fdx5.utl     // Basic administration of FDX objects
55209>>>>>//
55209>>>>>// By Sture Andersen
55209>>>>>//
55209>>>>>// Create: Sun  16-01-2000
55209>>>>>// Update:
55209>>>>>//
55209>>>>>//**********************************************************************
55209>>>>>
55209>>>>>Use FDX.nui      // cFDX class
55209>>>>>Use Fdx4.utl     // FDX aware cFileList_List selector object
55209>>>>>Use Files.utl    // Utilities for handling file related stuff
55209>>>>>Use Macros.utl   // Various macros (FOR_EX...)
55209>>>>>Use MsgBox.utl   // obs procedure
55209>>>>>Use Wait.utl     // Something to put on screen while batching.
55209>>>>>Use SetFiles.utl // SetOfFiles class
Including file: setfiles.utl    (C:\Apps\VDFQuery\AppSrc\setfiles.utl)
55209>>>>>>>// Use SetFiles.utl // SetOfFiles class (for disk files)
55209>>>>>>>
55209>>>>>>>//> The cSetOfFiles is used to sort a set of files possibly spanning more
55209>>>>>>>//> directories.
55209>>>>>>>//> Files may be added one at a time to this set or by the directory. There
55209>>>>>>>//> even is a message that will add all files in a directory and in all
55209>>>>>>>//> child directories thereof.
55209>>>>>>>
55209>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
55209>>>>>>>Use Strings.nui  // String manipulation for VDF
55209>>>>>>>Use Files.utl    // Utilities for handling file related stuff
55209>>>>>>>Use WildCard.nui // WildCardMatch function
Including file: wildcard.nui    (C:\Apps\VDFQuery\AppSrc\wildcard.nui)
55209>>>>>>>>>// Use WildCard.nui // WildCardMatch function
55209>>>>>>>>>//
55209>>>>>>>>>// This package may be used when checking strings containing wildcard
55209>>>>>>>>>// characters "*" and "?" against strings. I would not bet my life that
55209>>>>>>>>>// this is not exactly the same as undocumentet operator "matches" does.
55209>>>>>>>>>//
55209>>>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
55209>>>>>>>>>Use Strings.nui  // String manipulation for VDF
55209>>>>>>>>>
55209>>>>>>>>>// The public interface of this package is WildCardMatchPrepare and
55209>>>>>>>>>// WildCardMatch messages.
55209>>>>>>>>>//
55209>>>>>>>>>//   Use like this:
55209>>>>>>>>>//
55209>>>>>>>>>//      send WildCardMatchPrepare "*.nui"
55209>>>>>>>>>//      if (WildCardMatch("WildCard.nui")) showln "Matches"
55209>>>>>>>>>//      else showln "No Match"
55209>>>>>>>>>
55209>>>>>>>>>enumeration_list
55209>>>>>>>>>  define WCAS_THE_HARD_WAY         //
55209>>>>>>>>>  define WCAS_ALWAYS_TRUE          // *
55209>>>>>>>>>  define WCAS_EQUAL                // Sture
55209>>>>>>>>>  define WCAS_LEFT_MATCH           // Sture*
55209>>>>>>>>>  define WCAS_RIGHT_MATCH          // *Andersen
55209>>>>>>>>>  define WCAS_LEFT_AND_RIGHT_MATCH // Sture*Andersen
55209>>>>>>>>>  define WCAS_CONTAINS             // *B*
55209>>>>>>>>>end_enumeration_list
55209>>>>>>>>>enumeration_list
55209>>>>>>>>>  define WCAS_CONSTANT
55209>>>>>>>>>  define WCAS_QUESTIONMARK
55209>>>>>>>>>  define WCAS_ASTERISK
55209>>>>>>>>>end_enumeration_list
55209>>>>>>>>>
55209>>>>>>>>>class cWildCardMatcher is a cArray
55210>>>>>>>>>  procedure construct_object integer liImage
55212>>>>>>>>>    forward send construct_object liImage
55214>>>>>>>>>    // The properties defined here are used only to try to optimise
55214>>>>>>>>>    // the evaluation of lsTestValues.
55214>>>>>>>>>    property integer piAltStrategy           public WCAS_THE_HARD_WAY
55215>>>>>>>>>    // If an alternative strategy is active can we use it to accept a
55215>>>>>>>>>    // value (piAltStrategyRejectOnly=TRUE) or must we run it the hard
55215>>>>>>>>>    // way afterwards (piAltStrategyRejectOnly=FALSE)?
55215>>>>>>>>>    property integer piAltStrategyRejectOnly public DFFALSE
55216>>>>>>>>>    property string  psAltStrategyLeftValue  public ""
55217>>>>>>>>>    property string  psAltStrategyRightValue public ""
55218>>>>>>>>>  end_procedure
55219>>>>>>>>>  item_property_list
55219>>>>>>>>>    item_property integer piType.i  // 0=constant 1=? 2=*
55219>>>>>>>>>    item_property string  psValue.i // Only relevant when piType.i is 0
55219>>>>>>>>>  end_item_property_list cWildCardMatcher
#REM 55251 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 55255 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 55259 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 55263 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
55268>>>>>>>>>
55268>>>>>>>>>  procedure add_row integer liType string lsValue
55270>>>>>>>>>    integer liRow
55270>>>>>>>>>    get row_count to liRow
55271>>>>>>>>>    set piType.i  liRow to liType
55272>>>>>>>>>    set psValue.i liRow to lsValue
55273>>>>>>>>>  end_procedure
55274>>>>>>>>>
55274>>>>>>>>>  procedure DoReset
55276>>>>>>>>>    send delete_data
55277>>>>>>>>>    set piAltStrategy to WCAS_THE_HARD_WAY
55278>>>>>>>>>  end_procedure
55279>>>>>>>>>
55279>>>>>>>>>  // This procedure tries to find a optimized way to evaluate the expression
55279>>>>>>>>>  procedure DoFindShortCuts
55281>>>>>>>>>    integer liRows
55281>>>>>>>>>    get row_count to liRows
55282>>>>>>>>>    set piAltStrategy to WCAS_THE_HARD_WAY
55283>>>>>>>>>    set piAltStrategyRejectOnly to DFFALSE
55284>>>>>>>>>    if (liRows=1) begin
55286>>>>>>>>>      if (piType.i(self,0)=WCAS_ASTERISK) set piAltStrategy to WCAS_ALWAYS_TRUE
55289>>>>>>>>>      if (piType.i(self,0)=WCAS_CONSTANT) begin
55291>>>>>>>>>        set piAltStrategy to WCAS_EQUAL
55292>>>>>>>>>        set psAltStrategyLeftValue to (psValue.i(self,0))
55293>>>>>>>>>      end
55293>>>>>>>>>>
55293>>>>>>>>>    end
55293>>>>>>>>>>
55293>>>>>>>>>    else begin
55294>>>>>>>>>      if (piType.i(self,0)=WCAS_CONSTANT) begin // If leftmost is a constant
55296>>>>>>>>>        if (piType.i(self,liRows-1)=WCAS_CONSTANT) begin // if rightmost is also a constant
55298>>>>>>>>>          if (liRows=3 and piType.i(self,1)=WCAS_ASTERISK) begin
55300>>>>>>>>>            set piAltStrategy to WCAS_LEFT_AND_RIGHT_MATCH
55301>>>>>>>>>            set psAltStrategyLeftValue to (psValue.i(self,0))
55302>>>>>>>>>            set psAltStrategyRightValue to (psValue.i(self,liRows-1))
55303>>>>>>>>>          end
55303>>>>>>>>>>
55303>>>>>>>>>          else begin
55304>>>>>>>>>            set piAltStrategy to WCAS_LEFT_AND_RIGHT_MATCH
55305>>>>>>>>>            set psAltStrategyLeftValue to (psValue.i(self,0))
55306>>>>>>>>>            set psAltStrategyRightValue to (psValue.i(self,liRows-1))
55307>>>>>>>>>            set piAltStrategyRejectOnly to DFTRUE
55308>>>>>>>>>          end
55308>>>>>>>>>>
55308>>>>>>>>>        end
55308>>>>>>>>>>
55308>>>>>>>>>        else begin
55309>>>>>>>>>          if (liRows=2 and piType.i(self,1)=WCAS_ASTERISK) begin
55311>>>>>>>>>            set piAltStrategy to WCAS_LEFT_MATCH
55312>>>>>>>>>            set psAltStrategyLeftValue to (psValue.i(self,0))
55313>>>>>>>>>          end
55313>>>>>>>>>>
55313>>>>>>>>>          else begin
55314>>>>>>>>>            set piAltStrategy to WCAS_LEFT_MATCH
55315>>>>>>>>>            set psAltStrategyLeftValue to (psValue.i(self,0))
55316>>>>>>>>>            set piAltStrategyRejectOnly to DFTRUE
55317>>>>>>>>>          end
55317>>>>>>>>>>
55317>>>>>>>>>        end
55317>>>>>>>>>>
55317>>>>>>>>>      end
55317>>>>>>>>>>
55317>>>>>>>>>      else begin
55318>>>>>>>>>        if (piType.i(self,liRows-1)=WCAS_CONSTANT) begin // If rightmost is a constant
55320>>>>>>>>>          if (liRows=2 and piType.i(self,0)=WCAS_ASTERISK) begin
55322>>>>>>>>>            set piAltStrategy to WCAS_RIGHT_MATCH
55323>>>>>>>>>            set psAltStrategyRightValue to (psValue.i(self,liRows-1))
55324>>>>>>>>>          end
55324>>>>>>>>>>
55324>>>>>>>>>          else begin
55325>>>>>>>>>            set piAltStrategy to WCAS_RIGHT_MATCH
55326>>>>>>>>>            set psAltStrategyRightValue to (psValue.i(self,liRows-1))
55327>>>>>>>>>            set piAltStrategyRejectOnly to DFTRUE
55328>>>>>>>>>          end
55328>>>>>>>>>>
55328>>>>>>>>>        end
55328>>>>>>>>>>
55328>>>>>>>>>        else begin // Now we check if first and last are asterisks
55329>>>>>>>>>          if (liRows=3 and piType.i(self,0)=WCAS_ASTERISK and piType.i(self,1)=WCAS_CONSTANT and piType.i(self,2)=WCAS_ASTERISK) begin
55331>>>>>>>>>            set piAltStrategy to WCAS_CONTAINS
55332>>>>>>>>>            set psAltStrategyLeftValue to (psValue.i(self,1))
55333>>>>>>>>>          end
55333>>>>>>>>>>
55333>>>>>>>>>        end
55333>>>>>>>>>>
55333>>>>>>>>>      end
55333>>>>>>>>>>
55333>>>>>>>>>    end
55333>>>>>>>>>>
55333>>>>>>>>>  end_procedure
55334>>>>>>>>>
55334>>>>>>>>>  procedure BreakDownMask string lsMask
55336>>>>>>>>>    integer liPos liLen liType
55336>>>>>>>>>    string lsChar lsItem
55336>>>>>>>>>    send DoReset
55337>>>>>>>>>    move (replaces("**",lsMask,"*")) to lsMask // Simple reduction
55338>>>>>>>>>    move (length(lsMask)) to liLen
55339>>>>>>>>>    move "" to lsItem
55340>>>>>>>>>    for liPos from 1 to liLen
55346>>>>>>>>>>
55346>>>>>>>>>      move (mid(lsMask,1,liPos)) to lsChar
55347>>>>>>>>>      if lsChar eq "*" begin
55349>>>>>>>>>        if lsItem ne "" begin
55351>>>>>>>>>          send add_row WCAS_CONSTANT lsItem
55352>>>>>>>>>          move "" to lsItem
55353>>>>>>>>>        end
55353>>>>>>>>>>
55353>>>>>>>>>        send add_row WCAS_ASTERISK ""
55354>>>>>>>>>      end
55354>>>>>>>>>>
55354>>>>>>>>>      else if lsChar eq "?" begin
55357>>>>>>>>>        if lsItem ne "" begin
55359>>>>>>>>>          send add_row WCAS_CONSTANT lsItem
55360>>>>>>>>>          move "" to lsItem
55361>>>>>>>>>        end
55361>>>>>>>>>>
55361>>>>>>>>>        send add_row WCAS_QUESTIONMARK ""
55362>>>>>>>>>      end
55362>>>>>>>>>>
55362>>>>>>>>>      else move (lsItem+lsChar) to lsItem
55364>>>>>>>>>    loop
55365>>>>>>>>>>
55365>>>>>>>>>    if lsItem ne "" send add_row WCAS_CONSTANT lsItem
55368>>>>>>>>>    send DoFindShortCuts
55369>>>>>>>>>  end_procedure
55370>>>>>>>>>  function iMatch.is integer liRow string lsTestValue returns integer
55372>>>>>>>>>    integer lsMax liType liLen liPos
55372>>>>>>>>>    string lsItem
55372>>>>>>>>>    get row_count to lsMax
55373>>>>>>>>>    if liRow ge lsMax begin
55375>>>>>>>>>      if (lsTestValue="") function_return 1
55378>>>>>>>>>      function_return 0
55379>>>>>>>>>    end
55379>>>>>>>>>>
55379>>>>>>>>>    get piType.i liRow to liType
55380>>>>>>>>>    if liType eq WCAS_CONSTANT begin // constant
55382>>>>>>>>>      if (length(lsTestValue)) eq 0 function_return 0
55385>>>>>>>>>      get psValue.i liRow to lsItem
55386>>>>>>>>>      move (length(lsItem)) to liLen
55387>>>>>>>>>      if lsItem eq (left(lsTestValue,liLen)) function_return (iMatch.is(self,liRow+1,StringRightBut(lsTestValue,liLen)))
55390>>>>>>>>>      function_return 0
55391>>>>>>>>>    end
55391>>>>>>>>>>
55391>>>>>>>>>    if liType eq WCAS_QUESTIONMARK begin // ?
55393>>>>>>>>>      if (length(lsTestValue)) eq 0 function_return 0
55396>>>>>>>>>      function_return (iMatch.is(self,liRow+1,StringRightBut(lsTestValue,1)))
55397>>>>>>>>>    end
55397>>>>>>>>>>
55397>>>>>>>>>    if liType eq WCAS_ASTERISK begin // *
55399>>>>>>>>>      if liRow eq (lsMax-1) function_return 1
55402>>>>>>>>>      move (length(lsTestValue)) to liLen
55403>>>>>>>>>      for liPos from 0 to liLen
55409>>>>>>>>>>
55409>>>>>>>>>        if (iMatch.is(self,liRow+1,StringRightBut(lsTestValue,liPos))) function_return 1
55412>>>>>>>>>      loop
55413>>>>>>>>>>
55413>>>>>>>>>    end
55413>>>>>>>>>>
55413>>>>>>>>>    //function_return 0
55413>>>>>>>>>  end_function
55414>>>>>>>>>  function iMatch.s string lsTestValue returns integer
55416>>>>>>>>>    integer liAltStrategy liAltStrategyRejectOnly
55416>>>>>>>>>    get piAltStrategy to liAltStrategy
55417>>>>>>>>>    get piAltStrategyRejectOnly to liAltStrategyRejectOnly
55418>>>>>>>>>    if liAltStrategy eq WCAS_ALWAYS_TRUE function_return DFTRUE
55421>>>>>>>>>    if liAltStrategy eq WCAS_EQUAL       function_return (lsTestValue=psAltStrategyLeftValue(self))
55424>>>>>>>>>    if liAltStrategy eq WCAS_LEFT_MATCH begin
55426>>>>>>>>>      if liAltStrategyRejectOnly begin
55428>>>>>>>>>        ifnot (StringBeginsWith(lsTestValue,psAltStrategyLeftValue(self))) function_return DFFALSE
55431>>>>>>>>>      end
55431>>>>>>>>>>
55431>>>>>>>>>      else function_return (StringBeginsWith(lsTestValue,psAltStrategyLeftValue(self)))
55433>>>>>>>>>    end
55433>>>>>>>>>>
55433>>>>>>>>>    if liAltStrategy eq WCAS_RIGHT_MATCH begin
55435>>>>>>>>>      if liAltStrategyRejectOnly begin
55437>>>>>>>>>        ifnot (StringEndsWith(lsTestValue,psAltStrategyRightValue(self))) function_return DFFALSE
55440>>>>>>>>>      end
55440>>>>>>>>>>
55440>>>>>>>>>      else function_return (StringEndsWith(lsTestValue,psAltStrategyRightValue(self)))
55442>>>>>>>>>    end
55442>>>>>>>>>>
55442>>>>>>>>>    if liAltStrategy eq WCAS_LEFT_AND_RIGHT_MATCH begin
55444>>>>>>>>>      if liAltStrategyRejectOnly begin
55446>>>>>>>>>        ifnot (StringBeginsWith(lsTestValue,psAltStrategyLeftValue(self)) and StringEndsWith(lsTestValue,psAltStrategyRightValue(self))) function_return DFFALSE
55449>>>>>>>>>      end
55449>>>>>>>>>>
55449>>>>>>>>>      else function_return (StringBeginsWith(lsTestValue,psAltStrategyLeftValue(self)) and StringEndsWith(lsTestValue,psAltStrategyRightValue(self)))
55451>>>>>>>>>    end
55451>>>>>>>>>>
55451>>>>>>>>>    if liAltStrategy eq WCAS_CONTAINS begin
55453>>>>>>>>>      function_return (lsTestValue contains psAltStrategyLeftValue(self))
55454>>>>>>>>>    end
55454>>>>>>>>>>
55454>>>>>>>>>    function_return (iMatch.is(self,0,lsTestValue))
55455>>>>>>>>>  end_function
55456>>>>>>>>>  function iAnyWildCards returns integer
55458>>>>>>>>>    if (row_count(self)>1) function_return DFTRUE
55461>>>>>>>>>    function_return (piType.i(self,0)<>WCAS_CONSTANT)
55462>>>>>>>>>  end_function
55463>>>>>>>>>end_class // cWildCardMatcher
55464>>>>>>>>>
55464>>>>>>>>>desktop_section
55469>>>>>>>>>  object oPrivateWildCardMatch is a cWildCardMatcher NO_IMAGE
55471>>>>>>>>>  end_object // oPrivateWildCardMatch
55472>>>>>>>>>end_desktop_section
55477>>>>>>>>>
55477>>>>>>>>>procedure WildCardMatchPrepare global string lsMask
55479>>>>>>>>>  send BreakDownMask to (oPrivateWildCardMatch(self)) lsMask
55480>>>>>>>>>end_procedure
55481>>>>>>>>>
55481>>>>>>>>>function WildCardMatch global string lsTestValue returns integer
55483>>>>>>>>>  function_return (iMatch.s(oPrivateWildCardMatch(self),lsTestValue))
55484>>>>>>>>>end_function
55485>>>>>>>>>
55485>>>>>>>>>// This may be used to check if the test value was broken down into
55485>>>>>>>>>// more items indicating whether a wildcard character was actually
55485>>>>>>>>>// part of it.
55485>>>>>>>>>function WildCardBreakDownItems global returns integer
55487>>>>>>>>>  function_return (iAnyWildCards(oPrivateWildCardMatch(self)))
55488>>>>>>>>>end_function
55489>>>>>>>>>// Test source for DF 3.x (not at all object oriented)
55489>>>>>>>>>//
55489>>>>>>>>>// /Test
55489>>>>>>>>>//   Mask......: _________________
55489>>>>>>>>>//   Test value: _________________
55489>>>>>>>>>//   Result....: _________________
55489>>>>>>>>>// /*
55489>>>>>>>>>//
55489>>>>>>>>>// repeat
55489>>>>>>>>>//   accept test.1
55489>>>>>>>>>//   accept test.2
55489>>>>>>>>>//   send WildCardMatchPrepare (trim(Test.1))
55489>>>>>>>>>//   if (WildCardMatch(trim(Test.2))) move "Match!" to Test.3
55489>>>>>>>>>//   else move "No match!" to Test.3
55489>>>>>>>>>// [~key.escape] loop
55489>>>>>>>>>// abort
55489>>>>>>>>>
55489>>>>>>>>>class cSetOfMasks is a cArray
55490>>>>>>>>>  procedure construct_object integer liImage
55492>>>>>>>>>    forward send construct_object liImage
55494>>>>>>>>>    property string psName public ""
55495>>>>>>>>>  end_procedure
55496>>>>>>>>>  item_property_list
55496>>>>>>>>>    item_property string psMask.i
55496>>>>>>>>>    item_property string psDecription.i
55496>>>>>>>>>  end_item_property_list cSetOfMasks
#REM 55528 DEFINE FUNCTION PSDECRIPTION.I INTEGER LIROW RETURNS STRING
#REM 55532 DEFINE PROCEDURE SET PSDECRIPTION.I INTEGER LIROW STRING VALUE
#REM 55536 DEFINE FUNCTION PSMASK.I INTEGER LIROW RETURNS STRING
#REM 55540 DEFINE PROCEDURE SET PSMASK.I INTEGER LIROW STRING VALUE
55545>>>>>>>>>  procedure DoReset
55547>>>>>>>>>    send delete_data
55548>>>>>>>>>  end_procedure
55549>>>>>>>>>
55549>>>>>>>>>  function iFindMask.s string lsMask returns integer
55551>>>>>>>>>    integer liRow liMax
55551>>>>>>>>>    get row_count to liMax
55552>>>>>>>>>    decrement liMax
55553>>>>>>>>>    for liRow from 0 to liMax
55559>>>>>>>>>>
55559>>>>>>>>>      if (lsMask=psMask.i(self,liRow)) function_return liRow
55562>>>>>>>>>    loop
55563>>>>>>>>>>
55563>>>>>>>>>    function_return -1
55564>>>>>>>>>  end_function
55565>>>>>>>>>
55565>>>>>>>>>  procedure DoAddMask string lsMask string lsDecription
55567>>>>>>>>>    integer liRow
55567>>>>>>>>>    if (lsMask<>"" and iFindMask.s(self,lsMask)=-1) begin
55569>>>>>>>>>      get row_count to liRow
55570>>>>>>>>>      set psMask.i       liRow to lsMask
55571>>>>>>>>>      set psDecription.i liRow to lsDecription
55572>>>>>>>>>    end
55572>>>>>>>>>>
55572>>>>>>>>>  end_procedure
55573>>>>>>>>>  // This may be used for merging with another cSetOfMasks:
55573>>>>>>>>>  procedure DoImport integer lhSetOfMasks
55575>>>>>>>>>    integer liRow liMax
55575>>>>>>>>>    get row_count of lhSetOfMasks to liMax
55576>>>>>>>>>    decrement liMax
55577>>>>>>>>>    for liRow from 0 to liMax
55583>>>>>>>>>>
55583>>>>>>>>>      send DoAddMask (psMask.i(lhSetOfMasks,liRow)) (psDecription.i(lhSetOfMasks,liRow))
55584>>>>>>>>>    loop
55585>>>>>>>>>>
55585>>>>>>>>>  end_procedure
55586>>>>>>>>>  function sMasksAsString string lsSeparator returns string
55588>>>>>>>>>    integer liRow liMax
55588>>>>>>>>>    string lsRval
55588>>>>>>>>>    move "" to lsRval
55589>>>>>>>>>    get row_count to liMax
55590>>>>>>>>>    decrement liMax
55591>>>>>>>>>    for liRow from 0 to liMax
55597>>>>>>>>>>
55597>>>>>>>>>      move (lsRval+psMask.i(self,liRow)) to lsRval
55598>>>>>>>>>      if (liRow<>liMax) move (lsRval+lsSeparator) to lsRval
55601>>>>>>>>>    loop
55602>>>>>>>>>>
55602>>>>>>>>>    function_return lsRval
55603>>>>>>>>>  end_function
55604>>>>>>>>>  procedure DoCallBack integer liMsg integer lhObj
55606>>>>>>>>>    integer liRow liMax
55606>>>>>>>>>    get row_count to liMax
55607>>>>>>>>>    decrement liMax
55608>>>>>>>>>    for liRow from 0 to liMax
55614>>>>>>>>>>
55614>>>>>>>>>      send liMsg to lhObj (psMask.i(self,liRow)) (psDecription.i(self,liRow))
55615>>>>>>>>>    loop
55616>>>>>>>>>>
55616>>>>>>>>>  end_procedure
55617>>>>>>>>>end_class // cSetOfMasks
55618>>>>>>>>>
55618>>>>>>>>>class cWildCardMatcherArray is a cArray
55619>>>>>>>>>  procedure DoReset
55621>>>>>>>>>    integer liMax liItm
55621>>>>>>>>>    get item_count to liMax
55622>>>>>>>>>    decrement liMax
55623>>>>>>>>>    for liItm from 0 to liMax
55629>>>>>>>>>>
55629>>>>>>>>>      send request_destroy_object to (integer(value(self,liItm)))
55630>>>>>>>>>    loop
55631>>>>>>>>>>
55631>>>>>>>>>    send delete_data
55632>>>>>>>>>  end_procedure
55633>>>>>>>>>            procedure BreakDownMask string lsMask
55635>>>>>>>>>              integer liObj
55635>>>>>>>>>              object oWildCardMatcher is a cWildCardMatcher NO_IMAGE
55637>>>>>>>>>                send BreakDownMask lsMask
55638>>>>>>>>>                move self to liObj
55639>>>>>>>>>              end_object
55640>>>>>>>>>              set value item (item_count(self)) to liObj
55641>>>>>>>>>            end_procedure
55642>>>>>>>>>  procedure BreakDownSetOfMasks integer lhObj // An object of the cSetOfMasks class
55644>>>>>>>>>    integer liRow liMax
55644>>>>>>>>>    get row_count of lhObj to liMax
55645>>>>>>>>>    decrement liMax
55646>>>>>>>>>    for liRow from 0 to liMax
55652>>>>>>>>>>
55652>>>>>>>>>      send BreakDownMask (psMask.i(lhObj,liRow))
55653>>>>>>>>>    loop
55654>>>>>>>>>>
55654>>>>>>>>>  end_procedure
55655>>>>>>>>>  function iMatch.s string lsTestValue returns integer
55657>>>>>>>>>    integer liMax liItm
55657>>>>>>>>>    get item_count to liMax
55658>>>>>>>>>    decrement liMax
55659>>>>>>>>>    for liItm from 0 to liMax
55665>>>>>>>>>>
55665>>>>>>>>>      if (iMatch.s(integer(value(self,liItm)),lsTestValue)) function_return (liItm+1)
55668>>>>>>>>>    loop
55669>>>>>>>>>>
55669>>>>>>>>>    function_return 0
55670>>>>>>>>>  end_function
55671>>>>>>>>>  // Returns the number of items the last added mask was broken into.
55671>>>>>>>>>  function iAnyWildCards returns integer
55673>>>>>>>>>    integer liObj
55673>>>>>>>>>    get value item (item_count(self)-1) to liObj
55674>>>>>>>>>    function_return (iAnyWildCards(liObj))
55675>>>>>>>>>  end_function
55676>>>>>>>>>end_class // cWildCardMatchArray
55677>>>>>>>
55677>>>>>>>enumeration_list
55677>>>>>>>  define LF_ORDERING_NAME
55677>>>>>>>  define LF_ORDERING_TYPE
55677>>>>>>>  define LF_ORDERING_PATH
55677>>>>>>>  define LF_ORDERING_SIZE
55677>>>>>>>  define LF_ORDERING_TIME
55677>>>>>>>end_enumeration_list
55677>>>>>>>
55677>>>>>>>class cSetOfFiles is a cArray
55678>>>>>>>  item_property_list
55678>>>>>>>    item_property string  psFileName.i // File name
55678>>>>>>>    item_property string  psFileType.i // File extention
55678>>>>>>>    item_property string  psFilePath.i // Path to file
55678>>>>>>>    item_property integer piFileSize.i // File size
55678>>>>>>>    item_property number  pnFileTime.i // Time stamp
55678>>>>>>>  end_item_property_list cSetOfFiles
#REM 55719 DEFINE FUNCTION PNFILETIME.I INTEGER LIROW RETURNS NUMBER
#REM 55723 DEFINE PROCEDURE SET PNFILETIME.I INTEGER LIROW NUMBER VALUE
#REM 55727 DEFINE FUNCTION PIFILESIZE.I INTEGER LIROW RETURNS INTEGER
#REM 55731 DEFINE PROCEDURE SET PIFILESIZE.I INTEGER LIROW INTEGER VALUE
#REM 55735 DEFINE FUNCTION PSFILEPATH.I INTEGER LIROW RETURNS STRING
#REM 55739 DEFINE PROCEDURE SET PSFILEPATH.I INTEGER LIROW STRING VALUE
#REM 55743 DEFINE FUNCTION PSFILETYPE.I INTEGER LIROW RETURNS STRING
#REM 55747 DEFINE PROCEDURE SET PSFILETYPE.I INTEGER LIROW STRING VALUE
#REM 55751 DEFINE FUNCTION PSFILENAME.I INTEGER LIROW RETURNS STRING
#REM 55755 DEFINE PROCEDURE SET PSFILENAME.I INTEGER LIROW STRING VALUE
55760>>>>>>>  procedure construct_object integer img#
55762>>>>>>>    forward send construct_object img#
55764>>>>>>>    object oPaths is a cSet NO_IMAGE
55766>>>>>>>    end_object
55767>>>>>>>    object oIndex is a cArray NO_IMAGE
55769>>>>>>>    end_object
55770>>>>>>>    property integer private.piOrdering public 0
55771>>>>>>>    //> piBuildFromPaths is true if the contents of the array
55771>>>>>>>    //> was build with the SnapShot_Build message. It is meant
55771>>>>>>>    //> as a signal to a displaying object that it should or
55771>>>>>>>    //> should not also display which directories the content
55771>>>>>>>    //> was build from.
55771>>>>>>>    property integer piBuildFromPaths   public DFFalse
55772>>>>>>>    property string  psTitle            public ""
55773>>>>>>>
55773>>>>>>>    object oDirStack is a cStack NO_IMAGE
55775>>>>>>>      // This object is used by the AddSubDirectories procedure
55775>>>>>>>    end_object
55776>>>>>>>  end_procedure
55777>>>>>>>  //> Returns the total size of all the files currently added to the array
55777>>>>>>>  function iTotalSize returns integer
55779>>>>>>>    integer rval# max# row#
55779>>>>>>>    move 0 to rval#
55780>>>>>>>    get row_count to rval#
55781>>>>>>>    for row# from 0 to (max#-1)
55787>>>>>>>>
55787>>>>>>>      move (rval#+piFileSize.i(self,row#)) to rval#
55788>>>>>>>    loop
55789>>>>>>>>
55789>>>>>>>    function_return rval#
55790>>>>>>>  end_function
55791>>>>>>>  function sFileName.i integer iItm returns string
55793>>>>>>>    string sName sExt
55793>>>>>>>    get psFileName.i iItm to sName
55794>>>>>>>    get psFileType.i iItm to sExt
55795>>>>>>>    if sExt eq "" function_return sName
55798>>>>>>>    function_return (sName+"."+sExt)
55799>>>>>>>  end_function
55800>>>>>>>  function sFileNameIncPath.i integer iItm returns string
55802>>>>>>>    string sFile sDir
55802>>>>>>>    get sFileName.i iItm to sFile
55803>>>>>>>    get psFilePath.i iItm to sDir
55804>>>>>>>    function_return (SEQ_ComposeAbsoluteFileName(sDir,sFile))
55805>>>>>>>  end_function
55806>>>>>>>  function iPath_Count returns integer
55808>>>>>>>    function_return (item_count(oPaths(self)))
55809>>>>>>>  end_function
55810>>>>>>>  function sPath.i integer itm# returns string
55812>>>>>>>    function_return (value(oPaths(self),itm#))
55813>>>>>>>  end_function
55814>>>>>>>  function iFile_Count returns integer
55816>>>>>>>    function_return (item_count(oIndex(self)))
55817>>>>>>>  end_function
55818>>>>>>>  function iFile_Row.i integer itm# returns integer
55820>>>>>>>    function_return (right(value(oIndex(self),itm#),6))
55821>>>>>>>  end_function
55822>>>>>>>  procedure Wait_SetText string str#
55824>>>>>>>  end_procedure
55825>>>>>>>  procedure Wait_SetText2 string str#
55827>>>>>>>  end_procedure
55828>>>>>>>  function piOrdering returns integer
55830>>>>>>>    function_return (private.piOrdering(self))
55831>>>>>>>  end_function
55832>>>>>>>  procedure set piOrdering integer idx#
55834>>>>>>>    integer obj# max#
55834>>>>>>>    integer row#
55834>>>>>>>    string str#
55834>>>>>>>    if idx# ne (piOrdering(self)) begin
55836>>>>>>>      set private.piOrdering to idx#
55837>>>>>>>      move (oIndex(self)) to obj#
55838>>>>>>>      send delete_data to obj#
55839>>>>>>>      get row_count to max#
55840>>>>>>>      if idx# eq LF_ORDERING_NAME begin // psFileName.i
55842>>>>>>>        for row# from 0 to (max#-1)
55848>>>>>>>>
55848>>>>>>>          set value of obj# item row# to (uppercase(sFileName.i(self,row#))+pad(row#,6))
55849>>>>>>>        loop
55850>>>>>>>>
55850>>>>>>>      end
55850>>>>>>>>
55850>>>>>>>      if idx# eq LF_ORDERING_TYPE begin // psFileType.i
55852>>>>>>>        for row# from 0 to (max#-1)
55858>>>>>>>>
55858>>>>>>>          set value of obj# item row# to (psFileType.i(self,row#)+pad(row#,6))
55859>>>>>>>        loop
55860>>>>>>>>
55860>>>>>>>      end
55860>>>>>>>>
55860>>>>>>>      if idx# eq LF_ORDERING_PATH begin // psFilePath.i
55862>>>>>>>        for row# from 0 to (max#-1)
55868>>>>>>>>
55868>>>>>>>          set value of obj# item row# to (psFilePath.i(self,row#)+pad(row#,6))
55869>>>>>>>        loop
55870>>>>>>>>
55870>>>>>>>      end
55870>>>>>>>>
55870>>>>>>>      if idx# eq LF_ORDERING_SIZE begin // piFileSize.i
55872>>>>>>>        for row# from 0 to (max#-1)
55878>>>>>>>>
55878>>>>>>>          set value of obj# item row# to (RightShift(piFileSize.i(self,row#),12)+pad(row#,6))
55879>>>>>>>        loop
55880>>>>>>>>
55880>>>>>>>      end
55880>>>>>>>>
55880>>>>>>>      if idx# eq LF_ORDERING_TIME begin // pnFileTime.i
55882>>>>>>>        for row# from 0 to (max#-1)
55888>>>>>>>>
55888>>>>>>>          set value of obj# item row# to (RightShift(pnFileTime.i(self,row#),15)+pad(row#,6))
55889>>>>>>>        loop
55890>>>>>>>>
55890>>>>>>>      end
55890>>>>>>>>
55890>>>>>>>      send sort_items to obj#
55891>>>>>>>    end
55891>>>>>>>>
55891>>>>>>>  end_procedure
55892>>>>>>>  procedure AddDir string dir#
55894>>>>>>>    string tmp#
55894>>>>>>>    move (lowercase(SEQ_TranslatePathToAbsolute(dir#))) to dir#
55895>>>>>>>    send element_add to (oPaths(self)) dir#
55896>>>>>>>  end_procedure
55897>>>>>>>  procedure AddSearchPath_Help string dir#
55899>>>>>>>    send AddDir dir#
55900>>>>>>>  end_procedure
55901>>>>>>>  procedure AddSearchPath string path#
55903>>>>>>>    send SEQ_CallBack_DirsInPath path# msg_AddSearchPath_Help self
55904>>>>>>>  end_procedure
55905>>>>>>>  procedure AddDFPath
55907>>>>>>>    send AddSearchPath (SEQ_DfPath())
55908>>>>>>>  end_procedure
55909>>>>>>>
55909>>>>>>>  procedure AddSubDirectories_Help string fn# string path#
55911>>>>>>>    if (fn#<>"[.]" and fn#<>"[..]") begin
55913>>>>>>>      replace "[" in fn# with ""
55915>>>>>>>      replace "]" in fn# with ""
55917>>>>>>>      move (SEQ_ComposeAbsoluteFileName(path#,fn#)) to path#
55918>>>>>>>      send push.s to (oDirStack(self)) path#
55919>>>>>>>      send AddDir path#
55920>>>>>>>    end
55920>>>>>>>>
55920>>>>>>>  end_procedure
55921>>>>>>>
55921>>>>>>>  procedure AddSubDirectories string path#
55923>>>>>>>    integer oDirStack# itm_start# itm_stop# itm#
55923>>>>>>>    move (oDirStack(self)) to oDirStack#
55924>>>>>>>    get item_count of oDirStack# to itm_start#
55925>>>>>>>    send SEQ_Load_ItemsInDir path#
55926>>>>>>>    send SEQ_CallBack_ItemsInDir SEQCB_DIRS_ONLY msg_AddSubDirectories_Help self
55927>>>>>>>    get item_count of oDirStack# to itm_stop#
55928>>>>>>>    for itm# from itm_start# to (itm_stop#-1)
55934>>>>>>>>
55934>>>>>>>      send AddSubDirectories (sPop(oDirStack#))
55935>>>>>>>    loop
55936>>>>>>>>
55936>>>>>>>  end_procedure
55937>>>>>>>
55937>>>>>>>  procedure add_file string fn# string path#
55939>>>>>>>    integer row#
55939>>>>>>>    string file_first_name#
55939>>>>>>>    get row_count to row#
55940>>>>>>>    if "." in fn# move (StripFromLastOccurance(fn#,".")) to file_first_name#
55943>>>>>>>    else move fn# to file_first_name#
55945>>>>>>>    set psFileName.i row# to file_first_name#
55946>>>>>>>    set psFilePath.i row# to path#
55947>>>>>>>    set psFileType.i row# to (replace(".",replace(file_first_name#,fn#,""),""))
55948>>>>>>>    move (SEQ_ComposeAbsoluteFileName(path#,fn#)) to fn#
55949>>>>>>>    set piFileSize.i row# to (SEQ_FileSize(fn#))
55950>>>>>>>    set pnFileTime.i row# to (SEQ_FileModTime(fn#))
55951>>>>>>>  end_procedure
55952>>>>>>>
55952>>>>>>>  //> This procedure adds all files present in the directories previously
55952>>>>>>>  //> specified using the AddDir, AddSearchPath and AddDFPath messages.
55952>>>>>>>  procedure SnapShot_Build
55954>>>>>>>    integer oPaths# max# itm#
55954>>>>>>>    string str# path#
55954>>>>>>>    send Wait_SetText "Reading directory contents"
55955>>>>>>>    send SnapShot_Reset 0
55956>>>>>>>    move (oPaths(self)) to oPaths#
55957>>>>>>>    get item_count of oPaths# to max#
55958>>>>>>>    for itm# from 0 to (max#-1)
55964>>>>>>>>
55964>>>>>>>      get value of oPaths# item itm# to path#
55965>>>>>>>      send Wait_SetText2 path#
55966>>>>>>>      send SEQ_Load_ItemsInDir path#
55967>>>>>>>      send SEQ_CallBack_ItemsInDir SEQCB_FILES_ONLY msg_add_file self
55968>>>>>>>    loop
55969>>>>>>>>
55969>>>>>>>    set piOrdering to LF_ORDERING_NAME
55970>>>>>>>    set piBuildFromPaths to DFTrue
55971>>>>>>>  end_procedure
55972>>>>>>>  procedure SnapShot_Reset integer reset_all#
55974>>>>>>>    send delete_data
55975>>>>>>>    if reset_all# send delete_data to (oPaths(self))
55978>>>>>>>    send delete_data to (oIndex(self))
55979>>>>>>>    set piOrdering to -1
55980>>>>>>>  end_procedure
55981>>>>>>>  procedure Reset
55983>>>>>>>    send SnapShot_Reset 1
55984>>>>>>>  end_procedure
55985>>>>>>>  procedure SnapShot_Write integer ch#
55987>>>>>>>    send Wait_SetText "Writing directory contents"
55988>>>>>>>    send Wait_SetText2 ""
55989>>>>>>>    send SEQ_WriteArrayItems ch# self
55990>>>>>>>    send SEQ_WriteArrayItems ch# (oPaths(self))
55991>>>>>>>  end_procedure
55992>>>>>>>  procedure SnapShot_Read integer ch#
55994>>>>>>>    send Wait_SetText "Importing directory contents"
55995>>>>>>>    send Wait_SetText2 ""
55996>>>>>>>    send SEQ_ReadArrayItems ch# self
55997>>>>>>>    send SEQ_ReadArrayItems ch# (oPaths(self))
55998>>>>>>>  end_procedure
55999>>>>>>>  procedure Seq_Write integer ch#
56001>>>>>>>    writeln channel ch# "DIRCONT1.0"
56004>>>>>>>    send SnapShot_Write ch#
56005>>>>>>>  end_procedure
56006>>>>>>>  procedure Seq_Read integer ch#
56008>>>>>>>    string str#
56008>>>>>>>    readln channel ch# str#
56010>>>>>>>    send Reset
56011>>>>>>>    send SnapShot_Read ch#
56012>>>>>>>    set piOrdering to LF_ORDERING_NAME
56013>>>>>>>  end_procedure
56014>>>>>>>  procedure SnapShot_Save string fn#
56016>>>>>>>    integer ch#
56016>>>>>>>    move (SEQ_DirectOutput(fn#)) to ch#
56017>>>>>>>    if ch# ge 0 begin
56019>>>>>>>      send Seq_Write ch#
56020>>>>>>>      send SEQ_CloseOutput ch#
56021>>>>>>>    end
56021>>>>>>>>
56021>>>>>>>  end_procedure
56022>>>>>>>  procedure SnapShot_Load string fn#
56024>>>>>>>    integer ch#
56024>>>>>>>    move (SEQ_DirectInput(fn#)) to ch#
56025>>>>>>>    if ch# ge 0 begin
56027>>>>>>>      send Seq_Read ch#
56028>>>>>>>      send SEQ_CloseInput ch#
56029>>>>>>>    end
56029>>>>>>>>
56029>>>>>>>  end_procedure
56030>>>>>>>  procedure CopyFilesFromObject string sMask integer iSourceObject
56032>>>>>>>    integer iRow iMax
56032>>>>>>>    string sFile
56032>>>>>>>    move (uppercase(sMask)) to sMask
56033>>>>>>>    send WildCardMatchPrepare sMask
56034>>>>>>>    get row_count of iSourceObject to iMax
56035>>>>>>>    decrement iMax
56036>>>>>>>    for iRow from 0 to iMax
56042>>>>>>>>
56042>>>>>>>      get sFileName.i of iSourceObject iRow to sFile
56043>>>>>>>      if (WildCardMatch(uppercase(sFile))) send add_file sFile (psFilePath.i(iSourceObject,iRow))
56046>>>>>>>    loop
56047>>>>>>>>
56047>>>>>>>  end_procedure
56048>>>>>>>  // Procedure AddFirstOccuranceOfFile looks for the filename passed
56048>>>>>>>  // in the paths of the oPaths (embedded) object and adds the first
56048>>>>>>>  // occurance to the set (if any)
56048>>>>>>>  procedure AddFirstOccuranceOfFile string lsFileNameNoPath
56050>>>>>>>    integer liMax liItem
56050>>>>>>>    string lsPath lsFileName
56050>>>>>>>    get iPath_Count to liMax
56051>>>>>>>    decrement liMax
56052>>>>>>>    for liItem from 0 to liMax
56058>>>>>>>>
56058>>>>>>>      get sPath.i liItem to lsPath
56059>>>>>>>      move (SEQ_ComposeAbsoluteFileName(lsPath,lsFileNameNoPath)) to lsFileName
56060>>>>>>>      if (SEQ_FileExists(lsFileName)=SEQIT_FILE) begin
56062>>>>>>>        send add_file lsFileNameNoPath lsPath
56063>>>>>>>        procedure_return
56064>>>>>>>      end
56064>>>>>>>>
56064>>>>>>>    loop
56065>>>>>>>>
56065>>>>>>>  end_procedure
56066>>>>>>>  // Procedure DoScanCompilerListingFile goes through a PRN file and
56066>>>>>>>  // adds all files included in that file to the set.
56066>>>>>>>  procedure DoScanCompilerListingFile string lsPrnFile
56068>>>>>>>    integer liChannel liSeqEof
56068>>>>>>>    string lsLine
56068>>>>>>>    get SEQ_DirectInput lsPrnFile to liChannel
56069>>>>>>>    if liChannel ge 0 begin
56071>>>>>>>      repeat
56071>>>>>>>>
56071>>>>>>>        readln channel liChannel lsLine
56073>>>>>>>        move (SeqEof) to liSeqEof
56074>>>>>>>        ifnot liSeqEof begin
56076>>>>>>>          if (StringBeginsWith(lsLine,"INCLUDING FILE: ")) begin
56078>>>>>>>            replace "INCLUDING FILE: " in lsLine with ""
56080>>>>>>>            ifnot ".PKI" in lsLine send AddFirstOccuranceOfFile lsLine
56083>>>>>>>          end
56083>>>>>>>>
56083>>>>>>>        end
56083>>>>>>>>
56083>>>>>>>      until liSeqEof
56085>>>>>>>      send SEQ_CloseInput liChannel
56086>>>>>>>    end
56086>>>>>>>>
56086>>>>>>>  end_procedure
56087>>>>>>>  procedure DoCopyFiles string lsDestinationDir
56089>>>>>>>    integer liMax liRow liOk
56089>>>>>>>    string lsFileName lsTargetFile lsSourceFile
56089>>>>>>>    if (SEQ_FileExists(lsDestinationDir)=SEQIT_DIRECTORY) begin
56091>>>>>>>      get row_count to liMax
56092>>>>>>>      decrement liMax
56093>>>>>>>      for liRow from 0 to liMax
56099>>>>>>>>
56099>>>>>>>        get sFileName.i liRow to lsFileName
56100>>>>>>>        get sFileNameIncPath.i liRow to lsSourceFile
56101>>>>>>>        get SEQ_ComposeAbsoluteFileName lsDestinationDir lsFileName to lsTargetFile
56102>>>>>>>        get SEQ_CopyFile lsSourceFile lsTargetFile to liOk
56103>>>>>>>      loop
56104>>>>>>>>
56104>>>>>>>    end
56104>>>>>>>>
56104>>>>>>>  end_procedure
56105>>>>>>>end_class // cSetOfFiles
56106>>>>>>>
56106>>>>>>>//object oSetOfFiles is a cSetOfFiles NO_IMAGE
56106>>>>>>>//  send AddDFPath
56106>>>>>>>//  send SnapShot_Build
56106>>>>>>>//  send SnapShot_Save "c:\x.x"
56106>>>>>>>//end_object
56106>>>>>Use FdxSet.nui   // cFdxSetOfFiles, cFdxSetOfFields, cFdxSetOfIndices
Including file: fdxset.nui    (C:\Apps\VDFQuery\AppSrc\fdxset.nui)
56106>>>>>>>// Use FdxSet.nui   // cFdxSetOfTables, cFdxSetOfFields, cFdxSetOfIndices
56106>>>>>>>
56106>>>>>>>Use FDX.nui      // cFDX class
56106>>>>>>>Use FDX_Attr.nui // FDX compatible attribute functions
56106>>>>>>>Use Strings.nui  // String manipulation for VDF
56106>>>>>>>Use WildCard.nui // WildCardMatch function
56106>>>>>>>
56106>>>>>>>enumeration_list
56106>>>>>>>  define FDXSET_NONE
56106>>>>>>>  define FDXSET_EQ
56106>>>>>>>  define FDXSET_NE
56106>>>>>>>  define FDXSET_LT
56106>>>>>>>  define FDXSET_LE
56106>>>>>>>  define FDXSET_GE
56106>>>>>>>  define FDXSET_GT
56106>>>>>>>  define FDXSET_END // Must be the higher number defined
56106>>>>>>>end_enumeration_list
56106>>>>>>>
56106>>>>>>>function sFdxSet_CompText global integer comp# returns string
56108>>>>>>>  if comp# eq FDXSET_NONE function_return ""
56111>>>>>>>  if comp# eq FDXSET_LT   function_return "LT"
56114>>>>>>>  if comp# eq FDXSET_LE   function_return "LE"
56117>>>>>>>  if comp# eq FDXSET_EQ   function_return "EQ"
56120>>>>>>>  if comp# eq FDXSET_GE   function_return "GE"
56123>>>>>>>  if comp# eq FDXSET_GT   function_return "GT"
56126>>>>>>>  if comp# eq FDXSET_NE   function_return "NE"
56129>>>>>>>end_function
56130>>>>>>>
56130>>>>>>>//> Call back all legal comparison modes when attribute is attr#
56130>>>>>>>procedure FdxSet_Comp_CallBack global integer attr# integer msg# integer obj#
56132>>>>>>>  integer comp# type#
56132>>>>>>>  if (API_AttrDiscreteValues(attr#)) begin // Is the attribute represented by a set of (symbolic) discrete values?
56134>>>>>>>    send msg# to obj# FDXSET_EQ (sFdxSet_CompText(FDXSET_EQ))
56135>>>>>>>    send msg# to obj# FDXSET_NE (sFdxSet_CompText(FDXSET_NE))
56136>>>>>>>  end
56136>>>>>>>>
56136>>>>>>>  else begin
56137>>>>>>>    if (API_AttrType(attr#)=ATTRTYPE_IDXSEG) send msg# to obj# FDXSET_EQ (sFdxSet_CompText(FDXSET_EQ))
56140>>>>>>>    else begin
56141>>>>>>>      if (API_AttrValueType(attr#)) eq DF_BCD begin
56143>>>>>>>        for comp# from 1 to (FDXSET_END-1)
56149>>>>>>>>
56149>>>>>>>          send msg# to obj# comp# (sFdxSet_CompText(comp#))
56150>>>>>>>        loop
56151>>>>>>>>
56151>>>>>>>      end
56151>>>>>>>>
56151>>>>>>>      else begin // DF_ASCII
56152>>>>>>>        send msg# to obj# FDXSET_EQ (sFdxSet_CompText(FDXSET_EQ))
56153>>>>>>>        send msg# to obj# FDXSET_NE (sFdxSet_CompText(FDXSET_NE))
56154>>>>>>>      end
56154>>>>>>>>
56154>>>>>>>    end
56154>>>>>>>>
56154>>>>>>>  end
56154>>>>>>>>
56154>>>>>>>end_procedure
56155>>>>>>>
56155>>>>>>>class cFdxSet is a cArray
56156>>>>>>>  procedure construct_object integer img#
56158>>>>>>>    forward send construct_object img#
56160>>>>>>>    property string psTitle public ""
56161>>>>>>>    property integer piFDX_Server public 0
56162>>>>>>>    object oAuxArray is a cArray no_image
56164>>>>>>>    end_object
56165>>>>>>>    property integer piTestAttribute  public 0
56166>>>>>>>    property integer piTestCompMode   public FDXSET_NONE
56167>>>>>>>    property string  psTestValue      public ""
56168>>>>>>>  end_procedure
56169>>>>>>>  procedure display_criterion
56171>>>>>>>    send obs (API_Attr_Name(piTestAttribute(self))) (sFdxSet_CompText(piTestCompMode(self))) (psTestValue(self))
56172>>>>>>>  end_procedure
56173>>>>>>>  item_property_list
56173>>>>>>>    item_property integer piFile.i
56173>>>>>>>    item_property integer piItem.i
56173>>>>>>>  end_item_property_list cFdxSet
#REM 56205 DEFINE FUNCTION PIITEM.I INTEGER LIROW RETURNS INTEGER
#REM 56209 DEFINE PROCEDURE SET PIITEM.I INTEGER LIROW INTEGER VALUE
#REM 56213 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 56217 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
56222>>>>>>>  //***** PRIVATE ***************************************************
56222>>>>>>>  procedure AddItem integer file# integer item#
56224>>>>>>>    integer row#
56224>>>>>>>    get row_count to row#
56225>>>>>>>    set piFile.i  row# to file#
56226>>>>>>>    set piItem.i row# to item#
56227>>>>>>>  end_procedure
56228>>>>>>>  function iFindItem.ii integer file# integer item# returns integer
56230>>>>>>>    integer max# row#
56230>>>>>>>    get row_count to max#
56231>>>>>>>    for row# from 0 to (max#-1)
56237>>>>>>>>
56237>>>>>>>      if (piFile.i(self,row#)=file# and piItem.i(self,row#)=item#) function_return row#
56240>>>>>>>    loop
56241>>>>>>>>
56241>>>>>>>    function_return -1
56242>>>>>>>  end_function
56243>>>>>>>  function iAddItem integer file# integer item# returns integer
56245>>>>>>>    if (iFindItem.ii(self,file#,item#)) eq -1 begin
56247>>>>>>>      send AddItem file# item#
56248>>>>>>>      function_return 1
56249>>>>>>>    end
56249>>>>>>>>
56249>>>>>>>    //function_return 0
56249>>>>>>>  end_function
56250>>>>>>>  procedure AddItemIfNotAlready integer file# integer item#
56252>>>>>>>    integer grb#
56252>>>>>>>    get iAddItem file# item# to grb#
56253>>>>>>>  end_procedure
56254>>>>>>>
56254>>>>>>>                          procedure private.add_to_help_array integer file# integer item#
56256>>>>>>>                            integer itm# arr#
56256>>>>>>>                            move (oAuxArray(self)) to arr#
56257>>>>>>>                            set value of arr# item (item_count(arr#)) to (IntToStrR(file#,4)+IntToStrR(item#,4))
56258>>>>>>>                          end_procedure
56259>>>>>>>                          procedure private.CopyDownFromHelpArray
56261>>>>>>>                            integer arr# max# itm#
56261>>>>>>>                            string str#
56261>>>>>>>                            move (oAuxArray(self)) to arr#
56262>>>>>>>                            send sort_items to arr# ASCENDING
56263>>>>>>>                            send reset
56264>>>>>>>                            get item_count of arr# to max#
56265>>>>>>>                            for itm# from 0 to (max#-1)
56271>>>>>>>>
56271>>>>>>>                              get value of arr# item itm# to str#
56272>>>>>>>                              send AddItem (left(str#,4)) (right(str#,4))
56273>>>>>>>                            loop
56274>>>>>>>>
56274>>>>>>>                            send delete_data to arr#
56275>>>>>>>                          end_procedure // Introduction to algorithms, MIT Press  0-262-03141-8
56276>>>>>>>
56276>>>>>>>  //***** PUBLIC ****************************************************
56276>>>>>>>  function iValidate.iiss integer type# integer comp# ;                      string scurrentvalue# string stestvalue# returns integer
56278>>>>>>>    number ncurrentvalue# ntestvalue#
56278>>>>>>>    if type# eq DF_BCD begin
56280>>>>>>>      move scurrentvalue# to ncurrentvalue#
56281>>>>>>>      move stestvalue#    to ntestvalue#
56282>>>>>>>      if comp# eq FDXSET_LT function_return (ncurrentvalue#>>>>>>      if comp# eq FDXSET_LE function_return (ncurrentvalue#<=ntestvalue#)
56288>>>>>>>      if comp# eq FDXSET_EQ function_return (ncurrentvalue#=ntestvalue#)
56291>>>>>>>      if comp# eq FDXSET_GE function_return (ncurrentvalue#>=ntestvalue#)
56294>>>>>>>      if comp# eq FDXSET_GT function_return (ncurrentvalue#>ntestvalue#)
56297>>>>>>>      if comp# eq FDXSET_NE function_return (ncurrentvalue#<>ntestvalue#)
56300>>>>>>>    end
56300>>>>>>>>
56300>>>>>>>    else begin // Then it's DF_ASCII
56301>>>>>>>      uppercase scurrentvalue#
56302>>>>>>>>
56302>>>>>>>      uppercase stestvalue#
56303>>>>>>>>
56303>>>>>>>      if comp# eq FDXSET_LT function_return (scurrentvalue#>>>>>>      if comp# eq FDXSET_LE function_return (scurrentvalue#<=stestvalue#)
56309>>>>>>>      if comp# eq FDXSET_EQ function_return (WildCardMatch(scurrentvalue#))
56312>>>>>>>      if comp# eq FDXSET_GE function_return (scurrentvalue#>=stestvalue#)
56315>>>>>>>      if comp# eq FDXSET_GT function_return (scurrentvalue#>stestvalue#)
56318>>>>>>>      if comp# eq FDXSET_NE function_return (scurrentvalue#<>stestvalue#)
56321>>>>>>>    end
56321>>>>>>>>
56321>>>>>>>    function_return 1
56322>>>>>>>  end_function
56323>>>>>>>
56323>>>>>>>  procedure reset
56325>>>>>>>    send delete_data
56326>>>>>>>  end_procedure
56327>>>>>>>
56327>>>>>>>  procedure sort_rows
56329>>>>>>>    integer max# row#
56329>>>>>>>    send delete_data to (oAuxArray(self))
56330>>>>>>>    get row_count to max#
56331>>>>>>>    for row# from 0 to (max#-1)
56337>>>>>>>>
56337>>>>>>>      send private.add_to_help_array (piFile.i(self,row#)) (piItem.i(self,row#))
56338>>>>>>>    loop
56339>>>>>>>>
56339>>>>>>>    send private.CopyDownFromHelpArray
56340>>>>>>>  end_procedure
56341>>>>>>>
56341>>>>>>>  function iValidate_Item.ii integer file# integer item# returns integer
56343>>>>>>>  end_function
56344>>>>>>>
56344>>>>>>>  //> Function iNumberOfFiles returns the number of different tables
56344>>>>>>>  //> represented by fields currently in the set.
56344>>>>>>>  function iNumberOfFiles returns integer
56346>>>>>>>    integer max# file# row#
56346>>>>>>>    string str#
56346>>>>>>>    move "" to str#
56347>>>>>>>    get row_count to max#
56348>>>>>>>    for row# from 0 to (max#-1)
56354>>>>>>>>
56354>>>>>>>      get piFile.i row# to file#
56355>>>>>>>      move (overstrike("1",str#,file#)) to str#
56356>>>>>>>    loop
56357>>>>>>>>
56357>>>>>>>    move (replaces(" ",str#,"")) to str#
56358>>>>>>>    function_return (length(str#)) // Clever!
56359>>>>>>>  end_function
56360>>>>>>>
56360>>>>>>>  //***** SET OPERATIONS ********************************************
56360>>>>>>>  procedure DoUnion.i integer oFdxSetOfItems
56362>>>>>>>    integer row# max#
56362>>>>>>>    get row_count of oFdxSetOfItems to max#
56363>>>>>>>    for row# from 0 to (max#-1)
56369>>>>>>>>
56369>>>>>>>      send AddItemIfNotAlready (piFile.i(oFdxSetOfItems,row#)) (piItem.i(oFdxSetOfItems,row#))
56370>>>>>>>    loop
56371>>>>>>>>
56371>>>>>>>    send sort_rows
56372>>>>>>>  end_procedure
56373>>>>>>>  procedure DoInterSection.i integer oFdxSetOfItems
56375>>>>>>>    integer max# row# file# item#
56375>>>>>>>    send delete_data to (oAuxArray(self))
56376>>>>>>>    get row_count to max#
56377>>>>>>>    for row# from 0 to (max#-1)
56383>>>>>>>>
56383>>>>>>>      get piFile.i row# to file#
56384>>>>>>>      get piItem.i row# to item#
56385>>>>>>>      if (iFindItem.ii(oFdxSetOfItems,file#,item#)) ne -1 send private.add_to_help_array file# item#
56388>>>>>>>    loop
56389>>>>>>>>
56389>>>>>>>    send private.CopyDownFromHelpArray
56390>>>>>>>  end_procedure
56391>>>>>>>  procedure DoComplement.i integer oFdxSetOfItems // Remove all fields that are also in oFdxSetOfItems
56393>>>>>>>    integer row# max# found_row#
56393>>>>>>>    get row_count of oFdxSetOfItems to max#
56394>>>>>>>    for row# from 0 to (max#-1)
56400>>>>>>>>
56400>>>>>>>      get iFindItem.ii (piFile.i(oFdxSetOfItems,row#)) (piItem.i(oFdxSetOfItems,row#)) to found_row#
56401>>>>>>>      if found_row# ne -1 send delete_row found_row#
56404>>>>>>>    loop
56405>>>>>>>>
56405>>>>>>>  end_procedure
56406>>>>>>>  procedure DoRemoveFile.i integer liFile
56408>>>>>>>    integer liMax liRow
56408>>>>>>>    get row_count to liMax
56409>>>>>>>    decrement liMax
56410>>>>>>>    for liRow from 0 to liMax
56416>>>>>>>>
56416>>>>>>>      if (piFile.i(self,liRow)=liFile) begin
56418>>>>>>>        send delete_row liRow
56419>>>>>>>        decrement liRow
56420>>>>>>>        decrement liMax
56421>>>>>>>      end
56421>>>>>>>>
56421>>>>>>>    loop
56422>>>>>>>>
56422>>>>>>>  end_procedure
56423>>>>>>>end_class // cFdxSet
56424>>>>>>>
56424>>>>>>>class cFdxSetOfTables is a cFdxSet
56425>>>>>>>  function iValidate_Item.ii integer file# integer item# returns integer
56427>>>>>>>    integer attr# oFDX# type# comp#
56427>>>>>>>    string scurrentvalue# stestvalue#
56427>>>>>>>    get piFDX_Server to oFDX#
56428>>>>>>>    get piTestAttribute to attr#
56429>>>>>>>    get piTestCompMode to comp#
56430>>>>>>>    if (attr# and comp#) begin
56432>>>>>>>      get psTestValue to stestvalue#
56433>>>>>>>      get API_AttrValueType attr# to type#
56434>>>>>>>      get FDX_AttrValue_FILE oFDX# attr# file# to scurrentvalue#
56435>>>>>>>      function_return (iValidate.iiss(self,type#,comp#,scurrentvalue#,stestvalue#))
56436>>>>>>>    end
56436>>>>>>>>
56436>>>>>>>    function_return 0
56437>>>>>>>  end_function
56438>>>>>>>
56438>>>>>>>  procedure Traverse_All      //> Go through all files in the world
56440>>>>>>>    integer oFDX# file#
56440>>>>>>>    //send display_criterion
56440>>>>>>>    send delete_data
56441>>>>>>>    if (piTestCompMode(self)=FDXSET_EQ and API_AttrValueType(piTestAttribute(self))=DF_ASCII) send WildCardMatchPrepare (uppercase(psTestValue(self)))
56444>>>>>>>    get piFDX_Server to oFDX#
56445>>>>>>>    move 0 to file#
56446>>>>>>>    repeat
56446>>>>>>>>
56446>>>>>>>      get iNextFileThatCanOpen of oFDX# file# to file#
56447>>>>>>>      if (file# and iValidate_Item.ii(self,file#,0)) send AddItem file# 0
56450>>>>>>>    until file# eq 0
56452>>>>>>>  end_procedure
56453>>>>>>>  procedure make_set_of_files integer obj#
56455>>>>>>>    integer max# row# file#
56455>>>>>>>    send reset to obj#
56456>>>>>>>    get row_count to max#
56457>>>>>>>    for row# from 0 to (max#-1)
56463>>>>>>>>
56463>>>>>>>      send AddItemIfNotAlready to obj# (piFile.i(self,row#)) 0
56464>>>>>>>    loop
56465>>>>>>>>
56465>>>>>>>  end_procedure
56466>>>>>>>end_class // cFdxSetOfTables
56467>>>>>>>
56467>>>>>>>//> A set of fields is a set of (file,field). The cFdxSetOfFields class
56467>>>>>>>//> is able to contain such a set and it's able to search a FDX object
56467>>>>>>>//> for fields
56467>>>>>>>
56467>>>>>>>class cFdxSetOfFields is a cFdxSet
56468>>>>>>>  function iValidate_Item.ii integer file# integer field# returns integer
56470>>>>>>>    integer attr# oFDX# type# comp#
56470>>>>>>>    string scurrentvalue# stestvalue#
56470>>>>>>>    get piFDX_Server to oFDX#
56471>>>>>>>    get piTestAttribute to attr#
56472>>>>>>>    get piTestCompMode to comp#
56473>>>>>>>    if (attr# and comp#) begin
56475>>>>>>>      get psTestValue to stestvalue#
56476>>>>>>>      get API_AttrValueType attr# to type#
56477>>>>>>>      get FDX_AttrValue_FIELD oFDX# attr# file# field# to scurrentvalue#
56478>>>>>>>      function_return (iValidate.iiss(self,type#,comp#,scurrentvalue#,stestvalue#))
56479>>>>>>>    end
56479>>>>>>>>
56479>>>>>>>    function_return 0
56480>>>>>>>  end_function
56481>>>>>>>
56481>>>>>>>  procedure Traverse_All      //> Go through all fields in the world
56483>>>>>>>    integer oFDX# file# item# max# type# attr#
56483>>>>>>>    send reset
56484>>>>>>>    //send display_criterion
56484>>>>>>>    get piFDX_Server to oFDX#
56485>>>>>>>    get piTestAttribute to attr#
56486>>>>>>>    if (API_AttrValueType(attr#)=DF_ASCII and piTestCompMode(self)=FDXSET_EQ) send WildCardMatchPrepare (uppercase(psTestValue(self)))
56489>>>>>>>    move 0 to file#
56490>>>>>>>    repeat
56490>>>>>>>>
56490>>>>>>>      get iNextFileThatCanOpen of oFDX# file# to file#
56491>>>>>>>      if file# begin
56493>>>>>>>        move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,file#)) to max#
56494>>>>>>>        for item# from 1 to max#
56500>>>>>>>>
56500>>>>>>>          if (iValidate_Item.ii(self,file#,item#)) send AddItem file# item#
56503>>>>>>>        loop
56504>>>>>>>>
56504>>>>>>>      end
56504>>>>>>>>
56504>>>>>>>    until file# eq 0
56506>>>>>>>  end_procedure
56507>>>>>>>
56507>>>>>>>  function private.iFindFieldWithOffset.ii integer file# integer offset# returns integer
56509>>>>>>>    integer oFDX# item# max_item#
56509>>>>>>>    get piFDX_Server to oFDX#
56510>>>>>>>    move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,file#)) to max_item#
56511>>>>>>>    for item# from 1 to max_item#
56517>>>>>>>>
56517>>>>>>>      if (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,file#,item#)) eq offset# function_return item#
56520>>>>>>>    loop
56521>>>>>>>>
56521>>>>>>>    //function_return 0
56521>>>>>>>  end_function
56522>>>>>>>
56522>>>>>>>  procedure private.Traverse_Relating_Help integer Parent_File# integer Parent_Field# string Child_Files#
56524>>>>>>>    integer file# item# itm# max# oFDX# max_item# Rel_File# Rel_Field# Rootitem#
56524>>>>>>>    integer Parent_Offset# Parent_OverlapOffset#
56524>>>>>>>    integer Child_Offset# Child_OverlapOffset#
56524>>>>>>>    get piFDX_Server to oFDX#
56525>>>>>>>    move (HowManyIntegers(Child_Files#)) to max#
56526>>>>>>>    move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,parent_file#,Parent_Field#)) to Parent_Offset#
56527>>>>>>>    for itm# from 1 to max#
56533>>>>>>>>
56533>>>>>>>      move (ExtractInteger(Child_Files#,itm#)) to file#
56534>>>>>>>      move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,File#)) to max_item#
56535>>>>>>>      for item# from 1 to max_item#
56541>>>>>>>>
56541>>>>>>>        move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FILE,file#,item#)) to Rel_File#
56542>>>>>>>        if Rel_File# eq Parent_File# begin
56544>>>>>>>          move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FIELD,file#,item#)) to Rel_Field#
56545>>>>>>>          if Rel_Field# eq Parent_Field# send private.Traverse_Related_Help file# item#
56548>>>>>>>          else begin
56549>>>>>>>            if (integer(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,file#,item#))) eq DF_OVERLAP begin
56551>>>>>>>              // Does it overlap our RootField?
56551>>>>>>>              if (integer(FDX_AttrValue_SPECIAL1(oFDX#,DF_FIELD_OVERLAP,Rel_File#,Rel_Field#,Parent_Field#))) begin
56553>>>>>>>
56553>>>>>>>                // OK! We know that they overlap. Now we have to figure out
56553>>>>>>>                // which field in the child file corresponds
56553>>>>>>>                // to Parent_file.Parent_Field#:
56553>>>>>>>                move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,Rel_File#,Rel_Field#)) to Parent_OverlapOffset#
56554>>>>>>>
56554>>>>>>>                move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,file#,item#)) to Child_OverlapOffset#
56555>>>>>>>                move (Child_OverlapOffset#+Parent_Offset#-Parent_OverlapOffset#) to Child_Offset#
56556>>>>>>>
56556>>>>>>>                get private.iFindFieldWithOffset.ii file# Child_Offset# to Rootitem#
56557>>>>>>>                if Rootitem# send private.Traverse_Related_Help file# Rootitem#
56560>>>>>>>                else send obs "Overlap structure mismatch (2)"
56562>>>>>>>                //send private.Traverse_Related_Help file# item#
56562>>>>>>>              end
56562>>>>>>>>
56562>>>>>>>            end
56562>>>>>>>>
56562>>>>>>>          end
56562>>>>>>>>
56562>>>>>>>        end
56562>>>>>>>>
56562>>>>>>>      loop
56563>>>>>>>>
56563>>>>>>>    loop
56564>>>>>>>>
56564>>>>>>>  end_procedure
56565>>>>>>>
56565>>>>>>>  procedure private.Traverse_Related_Help integer File# integer Rootitem#
56567>>>>>>>    integer oFDX# item# max_item# rel_file# rel_item# self#
56567>>>>>>>    integer RootField_Offset# field_offset# rel_file_offset#
56567>>>>>>>    integer liAliasFile liMaxAliasFile liPos
56567>>>>>>>    string ChildFiles# lsAliasFiles
56567>>>>>>>    get piFDX_Server to oFDX#
56568>>>>>>>    // Just in case we need it:
56568>>>>>>>    move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,file#,Rootitem#)) to RootField_Offset#
56569>>>>>>>    if (iFindItem.ii(self,file#,Rootitem#)) eq -1 begin
56571>>>>>>>      send AddItem file# Rootitem#
56572>>>>>>>      move self to self#
56573>>>>>>>      move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,File#)) to max_item#
56574>>>>>>>      for item# from 1 to max_item#
56580>>>>>>>>
56580>>>>>>>        // Does it relate?
56580>>>>>>>        move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FILE,file#,item#)) to rel_file#
56581>>>>>>>        if rel_file# begin // OK! We relate
56583>>>>>>>          move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FIELD,file#,item#)) to rel_item#
56584>>>>>>>          if item# eq Rootitem# begin // Is it the field, we are specifically querying?
56586>>>>>>>            send private.Traverse_Related_Help rel_file# rel_item#
56587>>>>>>>          end
56587>>>>>>>>
56587>>>>>>>          else begin
56588>>>>>>>            // Is it an overlap? Otherwise we are not interested.
56588>>>>>>>            if (integer(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,file#,item#))) eq DF_OVERLAP begin
56590>>>>>>>              // Does it overlap our RootField?
56590>>>>>>>              if (integer(FDX_AttrValue_SPECIAL1(oFDX#,DF_FIELD_OVERLAP,file#,Rootitem#,item#))) begin
56592>>>>>>>                // OK! We know that they overlap. Now we have to figure out
56592>>>>>>>                // which field in the related file corresponds to our RootField:
56592>>>>>>>                move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,file#,item#)) to field_offset#
56593>>>>>>>                move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,rel_file#,rel_item#)) to rel_file_offset#
56594>>>>>>>                // This is the offset of our root field be in the related file:
56594>>>>>>>                move (rel_file_offset#-field_offset#+RootField_Offset#) to rel_file_offset#
56595>>>>>>>                get private.iFindFieldWithOffset.ii rel_file# rel_file_offset# to rel_item# // overload
56596>>>>>>>                if rel_item# send private.Traverse_Related_Help rel_file# rel_item#
56599>>>>>>>                else send obs "Overlap structure mismatch (1)"
56601>>>>>>>              end
56601>>>>>>>>
56601>>>>>>>            end
56601>>>>>>>>
56601>>>>>>>          end
56601>>>>>>>>
56601>>>>>>>        end
56601>>>>>>>>
56601>>>>>>>      loop
56602>>>>>>>>
56602>>>>>>>      // Does anybody relate to it?
56602>>>>>>>      get sChildFiles.i of oFDX# file# to ChildFiles#
56603>>>>>>>      send private.Traverse_Relating_Help File# Rootitem# ChildFiles#
56604>>>>>>>      // Are there any alias files that we have to go through?
56604>>>>>>>      get sAliasFiles.i of oFDX# File# to lsAliasFiles
56605>>>>>>>      get HowManyIntegers lsAliasFiles to liMaxAliasFile
56606>>>>>>>      for liPos from 1 to liMaxAliasFile
56612>>>>>>>>
56612>>>>>>>        get ExtractInteger lsAliasFiles liPos to liAliasFile
56613>>>>>>>        send private.Traverse_Related_Help liAliasFile Rootitem#
56614>>>>>>>      loop
56615>>>>>>>>
56615>>>>>>>    end
56615>>>>>>>>
56615>>>>>>>  end_procedure
56616>>>>>>>
56616>>>>>>>  procedure Traverse_ConnectedFields integer file# integer field#
56618>>>>>>>    send reset
56619>>>>>>>    send private.Traverse_Related_Help file# field#
56620>>>>>>>  end_procedure
56621>>>>>>>
56621>>>>>>>  procedure make_set_of_files integer obj#
56623>>>>>>>    integer max# row# file#
56623>>>>>>>    send reset to obj#
56624>>>>>>>    get row_count to max#
56625>>>>>>>    for row# from 0 to (max#-1)
56631>>>>>>>>
56631>>>>>>>      send AddItemIfNotAlready to obj# (piFile.i(self,row#)) 0
56632>>>>>>>    loop
56633>>>>>>>>
56633>>>>>>>  end_procedure
56634>>>>>>>end_class // cFdxSetOfFields
56635>>>>>>>
56635>>>>>>>class cFdxSetOfIndices is a cFdxSet
56636>>>>>>>  function iValidate_Item.ii integer file# integer index# returns integer
56638>>>>>>>    integer attr# oFDX# type# comp# attrtype# seg# max_seg#
56638>>>>>>>    string scurrentvalue# stestvalue#
56638>>>>>>>    get piFDX_Server to oFDX#
56639>>>>>>>    get piTestAttribute to attr#
56640>>>>>>>    get piTestCompMode to comp#
56641>>>>>>>    if (attr# and comp#) begin
56643>>>>>>>      get API_AttrType attr# to attrtype#
56644>>>>>>>      get psTestValue to stestvalue#
56645>>>>>>>      get API_AttrValueType attr# to type#
56646>>>>>>>      if attrtype# eq ATTRTYPE_INDEX begin
56648>>>>>>>        get FDX_AttrValue_INDEX oFDX# attr# file# index# to scurrentvalue#
56649>>>>>>>        function_return (iValidate.iiss(self,type#,comp#,scurrentvalue#,stestvalue#))
56650>>>>>>>      end
56650>>>>>>>>
56650>>>>>>>      if attrtype# eq ATTRTYPE_IDXSEG begin
56652>>>>>>>        // If we get to this point we can be sure that the comperator is EQ
56652>>>>>>>        get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index# to max_seg#
56653>>>>>>>        for seg# from 1 to max_seg#
56659>>>>>>>>
56659>>>>>>>          get FDX_AttrValue_IDXSEG oFDX# attr# file# index# seg# to scurrentvalue#
56660>>>>>>>          if (iValidate.iiss(self,type#,comp#,scurrentvalue#,stestvalue#)) function_return 1
56663>>>>>>>        loop
56664>>>>>>>>
56664>>>>>>>      end
56664>>>>>>>>
56664>>>>>>>    end
56664>>>>>>>>
56664>>>>>>>    function_return 0
56665>>>>>>>  end_function
56666>>>>>>>
56666>>>>>>>  procedure Traverse_All      //> Go through all indices in the world
56668>>>>>>>    integer oFDX# file# Index# max# type# segments# attr#
56668>>>>>>>    send reset
56669>>>>>>>    //send display_criterion
56669>>>>>>>    get piFDX_Server to oFDX#
56670>>>>>>>    get piTestAttribute to attr#
56671>>>>>>>    if (API_AttrValueType(attr#)=DF_ASCII and piTestCompMode(self)=FDXSET_EQ) send WildCardMatchPrepare (uppercase(psTestValue(self)))
56674>>>>>>>    move 0 to file#
56675>>>>>>>    repeat
56675>>>>>>>>
56675>>>>>>>      get iNextFileThatCanOpen of oFDX# file# to file#
56676>>>>>>>      if file# begin
56678>>>>>>>        for Index# from 1 to 16
56684>>>>>>>>
56684>>>>>>>          get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index# to segments#
56685>>>>>>>          if segments# if (iValidate_Item.ii(self,file#,Index#)) send AddItem file# Index#
56690>>>>>>>        loop
56691>>>>>>>>
56691>>>>>>>      end
56691>>>>>>>>
56691>>>>>>>    until file# eq 0
56693>>>>>>>  end_procedure
56694>>>>>>>
56694>>>>>>>  procedure make_set_of_files integer obj#
56696>>>>>>>    integer max# row# file#
56696>>>>>>>    send reset to obj#
56697>>>>>>>    get row_count to max#
56698>>>>>>>    for row# from 0 to (max#-1)
56704>>>>>>>>
56704>>>>>>>      send AddItemIfNotAlready to obj# (piFile.i(self,row#)) 0
56705>>>>>>>    loop
56706>>>>>>>>
56706>>>>>>>  end_procedure
56707>>>>>>>
56707>>>>>>>  procedure make_set_of_fields integer obj#
56709>>>>>>>    integer max# row# file# index# seg# segments# oFDX# field#
56709>>>>>>>    send reset to obj#
56710>>>>>>>    get piFDX_Server to oFDX#
56711>>>>>>>    get row_count to max#
56712>>>>>>>    for row# from 0 to (max#-1)
56718>>>>>>>>
56718>>>>>>>      get piFile.i row# to file#
56719>>>>>>>      get piItem.i row# to index#
56720>>>>>>>      get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index# to segments#
56721>>>>>>>      for seg# from 1 to segments#
56727>>>>>>>>
56727>>>>>>>        move (FDX_AttrValue_IDXSEG(oFDX#,DF_INDEX_SEGMENT_FIELD,file#,index#,seg#)) to field#
56728>>>>>>>        if field# send AddItemIfNotAlready to obj# file# field#
56731>>>>>>>      loop
56732>>>>>>>>
56732>>>>>>>    loop
56733>>>>>>>>
56733>>>>>>>  end_procedure
56734>>>>>>>
56734>>>>>>>end_class // cFdxSetOfIndices
56735>>>>>
56735>>>>>object oSentinelAbstraction is a cBatchCompanion no_image
56737>>>>>  set Allow_Cancel_State to false
56738>>>>>  procedure Wait_On
56741>>>>>    //send cursor_wait to (cursor_control(self))
56741>>>>>    send batch_on "DFMatrix batch process"
56742>>>>>  end_procedure
56743>>>>>  procedure Wait_Off
56746>>>>>    //send cursor_ready to (cursor_control(self))
56746>>>>>    send batch_off
56747>>>>>  end_procedure
56748>>>>>  procedure Wait_Text1 string str#
56751>>>>>    send batch_update str#
56752>>>>>  end_procedure
56753>>>>>  procedure Wait_Text2 string str#
56756>>>>>    send batch_update2 str#
56757>>>>>  end_procedure
56758>>>>>end_object
56759>>>>>
56759>>>>>class cDFM_ListDir_SnapShot is a cSetOfFiles
56760>>>>>  procedure Wait_SetText string str#
56762>>>>>    delegate send Wait_SetText str#
56764>>>>>  end_procedure
56765>>>>>  procedure Wait_SetText2 string str#
56767>>>>>    delegate send Wait_SetText2 str#
56769>>>>>  end_procedure
56770>>>>>end_class // cDFM_ListFile_SnapShot
56771>>>>>
56771>>>>>procedure fdx.wait.on global
56773>>>>>  send wait_on to (oSentinelAbstraction(self))
56774>>>>>end_procedure
56775>>>>>procedure fdx.wait.off global
56777>>>>>  send wait_off to (oSentinelAbstraction(self))
56778>>>>>end_procedure
56779>>>>>procedure fdx.wait.text1 global string str#
56781>>>>>  send wait_text1 to (oSentinelAbstraction(self)) str#
56782>>>>>end_procedure
56783>>>>>procedure fdx.wait.text2 global string str#
56785>>>>>  send wait_text2 to (oSentinelAbstraction(self)) str#
56786>>>>>end_procedure
56787>>>>>
56787>>>>>class cDFM_Fdx is a cFDX
56788>>>>>  procedure construct_object integer img#
56790>>>>>    forward send construct_object img#
56792>>>>>    property integer piDirsPresentInFile public 0 //> Is dir information present in most currently read file?
56793>>>>>    property integer piDirsLoaded        public 0 //> Have the dir information already been loaded?
56794>>>>>    property integer piDirsOffSet        public 0 //> Offset where dir information begins
56795>>>>>    object oListDir_SnapShot is a cDFM_ListDir_SnapShot no_image
56797>>>>>    end_object
56798>>>>>  end_procedure
56799>>>>>  procedure Reset
56801>>>>>    forward send Reset
56803>>>>>    set piDirsLoaded to false
56804>>>>>    set piDirsPresentInFile to false
56805>>>>>    send reset to (oListDir_SnapShot(self))
56806>>>>>  end_procedure
56807>>>>>  procedure Read_Directory_Contents_From_File
56809>>>>>    integer ch#
56809>>>>>    string fn#
56809>>>>>    if (piDataOrigin(self)) eq FDX_READ_FROM_FILE begin
56811>>>>>      if (piDirsPresentInFile(self)) begin
56813>>>>>        get psFileName to fn#
56814>>>>>        if fn# ne "" begin
56816>>>>>          move (SEQ_DirectInput(fn#)) to ch#
56817>>>>>          if ch# ge 0 begin
56819>>>>>            set_channel_position ch# to (piDirsOffSet(self))
56820>>>>>>
56820>>>>>            send Seq_Read to (oListDir_SnapShot(self)) ch#
56821>>>>>            set piDirsLoaded to true
56822>>>>>            send SEQ_CloseInput ch#
56823>>>>>          end
56823>>>>>>
56823>>>>>          else begin
56824>>>>>            send fdx.wait.off
56825>>>>>            send obs "File name" fn# "not found on disk"
56826>>>>>          end
56826>>>>>>
56826>>>>>        end
56826>>>>>>
56826>>>>>        else begin
56827>>>>>          send fdx.wait.off
56828>>>>>          send obs "File name of previously read file is unknown"
56829>>>>>        end
56829>>>>>>
56829>>>>>      end
56829>>>>>>
56829>>>>>      else begin
56830>>>>>        send fdx.wait.off
56831>>>>>        send obs "Directory contents not present in previously read file"
56832>>>>>      end
56832>>>>>>
56832>>>>>    end
56832>>>>>>
56832>>>>>    else begin
56833>>>>>      send fdx.wait.off
56834>>>>>      send obs "Contents not previously read from file"
56835>>>>>    end
56835>>>>>>
56835>>>>>  end_procedure
56836>>>>>  procedure Read_Directory_Contents
56838>>>>>    integer obj#
56838>>>>>    move (oListDir_SnapShot(self)) to obj#
56839>>>>>    send AddDFPath to obj#
56840>>>>>    send SnapShot_Build to obj#
56841>>>>>    set piDirsLoaded to true
56842>>>>>  end_procedure
56843>>>>>  procedure Wait_SetText string str#
56845>>>>>    send fdx.wait.text1 str#
56846>>>>>  end_procedure
56847>>>>>  procedure Wait_SetText2 string str#
56849>>>>>    send fdx.wait.text2 str#
56850>>>>>  end_procedure
56851>>>>>  procedure Seq_Write integer ch#
56853>>>>>    forward send Seq_Write ch#
56855>>>>>    if (piDirsLoaded(self)) send Seq_Write to (oListDir_SnapShot(self)) ch#
56858>>>>>  end_procedure
56859>>>>>  procedure Seq_Read integer ch#
56861>>>>>    integer ch_pos#
56861>>>>>    string str#
56861>>>>>    forward send Seq_Read ch#
56863>>>>>    get_channel_position ch# to ch_pos#
56864>>>>>>
56864>>>>>    readln channel ch# str#
56866>>>>>    if str# eq "DIRCONT1.0" begin
56868>>>>>      set piDirsPresentInFile to 1
56869>>>>>      set piDirsLoaded        to 0
56870>>>>>      set piDirsOffSet        to ch_pos#
56871>>>>>    end
56871>>>>>>
56871>>>>>    else begin
56872>>>>>      set piDirsPresentInFile to 0
56873>>>>>      set piDirsLoaded        to 0
56874>>>>>      set piDirsOffSet        to 0
56875>>>>>    end
56875>>>>>>
56875>>>>>  end_procedure
56876>>>>>end_class // cDFM_Fdx
56877>>>>>
56877>>>>>//function iFdxIsEncapsulated for cDFM_Fdx returns integer
56877>>>>>//  function_return DFTRUE
56877>>>>>//end_function
56877>>>>>
56877>>>>>desktop_section
56882>>>>>  object oFdxObjectList is a cArray no_image
56884>>>>>    //> Creates a new FDX object and returns its object ID
56884>>>>>    function iCreateFdxObject returns integer
56887>>>>>      integer rval#
56887>>>>>      object oFdx is a cDFM_Fdx no_image
56889>>>>>        move self to rval#
56890>>>>>      end_object
56891>>>>>      function_return rval#
56892>>>>>    end_function
56893>>>>>    function iFdxObjectID.i integer itm# returns integer
56896>>>>>      integer rval#
56896>>>>>      get value item itm# to rval#
56897>>>>>      ifnot rval# begin
56899>>>>>        get iCreateFdxObject to rval#
56900>>>>>        set value item itm# to rval#
56901>>>>>      end
56901>>>>>>
56901>>>>>      function_return rval#
56902>>>>>    end_function
56903>>>>>    //> Delete all FDX objects and reset the array
56903>>>>>    procedure reset
56906>>>>>      integer itm# max# obj#
56906>>>>>      get item_count to max#
56907>>>>>      for itm# from 0 to (max#-1)
56913>>>>>>
56913>>>>>        send entry_delete itm#
56914>>>>>      loop
56915>>>>>>
56915>>>>>      send delete_data
56916>>>>>    end_procedure
56917>>>>>    //> Deletes an FDX object specified by its entry number.
56917>>>>>    procedure entry_delete integer itm#
56920>>>>>      integer obj#
56920>>>>>      get value item itm# to obj#
56921>>>>>      if obj# begin
56923>>>>>        send request_destroy_object to obj#
56924>>>>>      end
56924>>>>>>
56924>>>>>      set value item itm# to 0
56925>>>>>    end_procedure
56926>>>>>    //> Save an FDX object to a sequential file.
56926>>>>>    procedure entry_save integer itm# string fn#
56929>>>>>      integer fdx# ch#
56929>>>>>      get value item itm# to fdx#
56930>>>>>      if fdx# begin
56932>>>>>        move (SEQ_DirectOutput(fn#)) to ch#
56933>>>>>        set psFileName of fdx# to fn#
56934>>>>>        send Seq_Write to fdx# ch#
56935>>>>>        send SEQ_CloseOutput ch#
56936>>>>>      end
56936>>>>>>
56936>>>>>      else send obs ("No FDX entry in slot "+string(itm#)+" to save")
56938>>>>>    end_procedure
56939>>>>>    //> Save an FDX object to a sequential file. File name prompted by the user.
56939>>>>>    procedure entry_save_as integer itm#
56942>>>>>      integer fdx#
56942>>>>>      string fn#
56942>>>>>      move (SEQ_SelectOutFile("Save table definitions as","Extended file definition (*.fdx)|*.FDX")) to fn#
56943>>>>>      if fn# ne "" begin
56945>>>>>        send fdx.wait.on
56946>>>>>        get value item itm# to fdx#
56947>>>>>        set psFileName of fdx# to fn#
56948>>>>>        send entry_save itm# fn#
56949>>>>>        send fdx.wait.off
56950>>>>>      end
56950>>>>>>
56950>>>>>    end_procedure
56951>>>>>    function entry_read_file integer itm# string fn# returns integer
56954>>>>>      integer rval# fdx# ch#
56954>>>>>      move -1 to rval#
56955>>>>>      if (SEQ_FileExists(fn#)) begin
56957>>>>>        send fdx.wait.on
56958>>>>>        get iFdxObjectID.i itm# to fdx#
56959>>>>>        move (SEQ_DirectInput(fn#)) to ch#
56960>>>>>        send Seq_Read to fdx# ch#
56961>>>>>        send SEQ_CloseInput ch#
56962>>>>>        set psFileName of fdx# to fn#
56963>>>>>        send fdx.wait.off
56964>>>>>        function_return (piReadResult(fdx#))
56965>>>>>      end
56965>>>>>>
56965>>>>>      else begin
56966>>>>>        send obs "File not found!" ("("+fn#+")")
56967>>>>>        function_return 0
56968>>>>>      end
56968>>>>>>
56968>>>>>    end_function
56969>>>>>    procedure entry_create_empty integer itm#
56972>>>>>      integer fdx#
56972>>>>>      get iFdxObjectID.i itm# to fdx#
56973>>>>>    end_procedure
56974>>>>>    procedure entry_read_current integer itm#
56977>>>>>      integer fdx#
56977>>>>>      get iFdxObjectID.i itm# to fdx#
56978>>>>>      send fdx.wait.on
56979>>>>>      send Read_Current_Filelist to fdx# FDX_ALL_FILES
56980>>>>>      send fdx.wait.off
56981>>>>>    end_procedure
56982>>>>>  end_object
56983>>>>>
56983>>>>>  // These three objects are used to store the current sets
56983>>>>>  // of tables, fields and indices
56983>>>>>  object oFdxSetOfTables is a cFdxSetOfTables no_image
56985>>>>>  end_object
56986>>>>>  object oFdxSetOfFields is a cFdxSetOfFields no_image
56988>>>>>  end_object
56989>>>>>  object oFdxSetOfIndices is a cFdxSetOfIndices no_image
56991>>>>>  end_object
56992>>>>>
56992>>>>>  // These three objects are used temorarily when exporting
56992>>>>>  // on type of set to another
56992>>>>>  object oAuxFdxSetOfTables is a cFdxSetOfTables no_image
56994>>>>>    procedure DoTableSelector_Union
56997>>>>>      integer max# row# table_selector#
56997>>>>>      get row_count to max#
56998>>>>>      get DFMatrix_SelectorObject to table_selector#
56999>>>>>      for row# from 0 to (max#-1)
57005>>>>>>
57005>>>>>        set File_Select_State of table_selector# (piFile.i(self,row#)) to true
57006>>>>>      loop
57007>>>>>>
57007>>>>>      send update_select_display to table_selector#
57008>>>>>    end_procedure
57009>>>>>    procedure DoTableSelector_Intersection
57012>>>>>      integer max# row# table_selector# file#
57012>>>>>      get DFMatrix_SelectorObject to table_selector#
57013>>>>>      get row_count of table_selector# to max#
57014>>>>>      for row# from 0 to (max#-1)
57020>>>>>>
57020>>>>>        if (Row_Select_State(table_selector#,row#)) begin
57022>>>>>          get Row_File of table_selector# row# to file#
57023>>>>>          if (iFindItem.ii(self,file#,0)) eq -1 set Row_Select_State of table_selector# row# to false
57026>>>>>        end
57026>>>>>>
57026>>>>>      loop
57027>>>>>>
57027>>>>>    end_procedure
57028>>>>>  end_object
57029>>>>>  object oAuxFdxSetOfFields is a cFdxSetOfFields no_image
57031>>>>>  end_object
57032>>>>>  object oAuxFdxSetOfIndices is a cFdxSetOfIndices no_image
57034>>>>>  end_object
57035>>>>>end_desktop_section
57040>>>>>
57040>>>>>//> Destroy all FDX objects and reset the array.
57040>>>>>procedure fdx.reset_all global
57042>>>>>  send reset to (oFdxObjectList(self))
57043>>>>>end_procedure
57044>>>>>
57044>>>>>//> Returns the object ID of fdx object associated with entry number itm#
57044>>>>>function fdx.object_id global integer itm# returns integer
57046>>>>>  function_return (value(oFdxObjectList(self),itm#))
57047>>>>>end_function
57048>>>>>
57048>>>>>//> Let's the user browse for a FDX file for loading. If a file is indeed
57048>>>>>//> opened fdx.open_browse will returns the number of the row (not -1)
57048>>>>>//> in which the object is placed.
57048>>>>>function fdx.open_file_browse global integer itm# returns integer
57050>>>>>  integer rval#
57050>>>>>  string fn#
57050>>>>>  move (SEQ_SelectFile("Select FDX-definition file (*.fdx)","Extended file definition|*.FDX")) to fn#
57051>>>>>  if fn# ne "" begin
57053>>>>>    get entry_read_file of (oFdxObjectList(self)) itm# fn# to rval#
57054>>>>>    function_return rval#
57055>>>>>  end
57055>>>>>>
57055>>>>>  function_return 0
57056>>>>>end_function
57057>>>>>
57057>>>>>procedure fdx.open_file global integer itm# string fn#
57059>>>>>  integer rval#
57059>>>>>  get entry_read_file of (oFdxObjectList(self)) itm# fn# to rval#
57060>>>>>end_procedure
57061>>>>>
57061>>>>>procedure fdx.entry_create_empty global integer itm# returns integer
57063>>>>>  send entry_create_empty to (oFdxObjectList(self)) itm#
57064>>>>>end_procedure
57065>>>>>
57065>>>>>//> Reads the current data definitions into a new FDX object and returns
57065>>>>>//> the entry in which it was placed.
57065>>>>>procedure fdx.entry_read_current global integer itm#
57067>>>>>  send entry_read_current to (oFdxObjectList(self)) itm#
57068>>>>>end_procedure
57069>>>>>
57069>>>>>
57069>>>>>//> Destroy FDX object associated with entry number itm#
57069>>>>>procedure fdx.entry_reset global integer itm#
57071>>>>>  send entry_delete to (oFdxObjectList(self)) itm#
57072>>>>>end_procedure
57073>>>>>
57073>>>>>//> Saves FDX object number itm# in file name fn#.
57073>>>>>procedure fdx.entry_save global integer itm# string fn#
57075>>>>>  send entry_save to (oFdxObjectList(self)) itm# fn#
57076>>>>>end_procedure
57077>>>>>
57077>>>>>//> Saves FDX object number itm# in a file name supplied by the
57077>>>>>//> operator.
57077>>>>>procedure fdx.entry_save_as global integer itm#
57079>>>>>  send entry_save_as to (oFdxObjectList(self)) itm#
57080>>>>>end_procedure
57081>>>Use ObjGroup.utl // Defining groups of objects
Including file: objgroup.utl    (C:\Apps\VDFQuery\AppSrc\objgroup.utl)
57081>>>>>//**********************************************************************
57081>>>>>// Use ObjGroup.utl // Defining groups of objects
57081>>>>>//
57081>>>>>// Author:  Sture B. Andersen
57081>>>>>//
57081>>>>>// Create:  Fri  18-07-1997
57081>>>>>// Update:  Mon  17-11-1997 - Deferred_Request_Destroy_Object added
57081>>>>>//          Wed  28-01-1998 - Procedure Deferred_Message added
57081>>>>>//          Tue  11-08-1998 - Deferred_Message now implemented for use
57081>>>>>//                            with character mode as well. Beware though,
57081>>>>>//                            a lot of things will make it fail (inkey$
57081>>>>>//                            commands etc...)
57081>>>>>//                          - Non-use of K$ removed.
57081>>>>>//          Mon  18-01-1999 - Global integer NotExitingApplication
57081>>>>>//                            introduced.
57081>>>>>//                          - A lot of comments added.
57081>>>>>//          Sun  25-04-1999 - Fixed NotExitingApplication
57081>>>>>//          Tue  31-07-2001 - Added Exit_Application_Check (Fixed
57081>>>>>//                            NotExitingApplication for CM)
57081>>>>>//          Thu  08-08-2002 - Changed timer create/destroy strategy for
57081>>>>>//                            character mode DataFlex
57081>>>>>//
57081>>>>>// Purpose: 1: To provide a global mechanism for defining groups of objects
57081>>>>>//             that may be instatiated in different parts of the application
57081>>>>>//             object tree (determined at runtime).
57081>>>>>//
57081>>>>>//          2: To provide a method for adding a message to the back of the
57081>>>>>//             DataFlex message queue.
57081>>>>>//
57081>>>>>//          It's an odd couple of features to present in one and the same
57081>>>>>//          package but they really are depending upon its other services.
57081>>>>>//          Nice and tight...
57081>>>>>//
57081>>>>>// Blabla:  It may also be used as an easy method for creating multiple views
57081>>>>>//          at runtime from the same object definition. That would be done
57081>>>>>//          like this:
57081>>>>>//
57081>>>>>//           use objgroup.utl
57081>>>>>//          
57081>>>>>//           DEFINE_OBJECT_GROUP OG_Modules
57081>>>>>//             object Modules_vw is a aps.dbview label (og_param(0))
57081>>>>>//               object dd is a Modules_dd
57081>>>>>//               end_object
57081>>>>>//               set main_dd to (dd(self))
57081>>>>>//               set server to (dd(self))
57081>>>>>//               object cont is a aps.dbcontainer3d
57081>>>>>//                 set p_auto_column to false
57081>>>>>//                 object grd is a aps.dbGrid
57081>>>>>//                   begin_row
57081>>>>>//                     entry_item Modules.Code
57081>>>>>//                     entry_item Modules.Name
57081>>>>>//                   end_row
57081>>>>>//                 end_object
57081>>>>>//               end_object
57081>>>>>//               Procedure Close_Panel // Release when closed!
57081>>>>>//                 Forward Send Close_Panel
57081>>>>>//                 send Deferred_Request_Destroy_Object
57081>>>>>//               End_Procedure
57081>>>>>//               move self to OG_Current_Object# // global integer
57081>>>>>//               // The previous line makes sure we know the object-ID of
57081>>>>>//               // the view we just created.
57081>>>>>//             end_object
57081>>>>>//           END_DEFINE_OBJECT_GROUP
57081>>>>>//          
57081>>>>>//           procedure OpenNewModuleVw // Access method
57081>>>>>//             CREATE_OBJECT_GROUP OG_Modules "Yet another view"
57081>>>>>//             send popup to OG_Current_Object#
57081>>>>>//           end_procedure
57081>>>>>//
57081>>>>>//          This method does not require that the view is coded with
57081>>>>>//          APS objects.
57081>>>>>//
57081>>>>>//
57081>>>>>//          The Deferred_Message procedure
57081>>>>>//          ------------------------------
57081>>>>>//
57081>>>>>//          The package provides a third feature which is the Deferred_Message
57081>>>>>//          method. This is a way to tell DataFlex that you want a procedure
57081>>>>>//          to execute - not now - but when everything else is finished. In
57081>>>>>//          effect you can now send a message by adding it to the very end of
57081>>>>>//          the message queue.
57081>>>>>//
57081>>>>>//          Why would one want to do that? Well, I invented it to get around
57081>>>>>//          the problem of destroying panels, when they are closed. You may
57081>>>>>//          create a procedure like this:
57081>>>>>//
57081>>>>>//                      Procedure Close_Panel
57081>>>>>//                        forward send Close_Panel
57081>>>>>//                        send Request_Destroy_Object // Destroy when closed
57081>>>>>//                      End_Procedure
57081>>>>>//
57081>>>>>//          Because the runtime is still executing a procedure in the object
57081>>>>>//          you are destroying, you will get problems. Since this goes for
57081>>>>>//          all procedures within an object you simply cannot make an
57081>>>>>//          object destroy itself, when it is closed.
57081>>>>>//
57081>>>>>//          UNLESS you can find a way to put a message in the far back of
57081>>>>>//          the message queue. That would make sure that everything in
57081>>>>>//          connection with closing the panel had already happened before
57081>>>>>//          object destruction. And that is what the Deferred_Message
57081>>>>>//          procedure can do. Therefore you may instead write:
57081>>>>>//
57081>>>>>//                      Procedure Close_Panel
57081>>>>>//                        forward send Close_Panel
57081>>>>>//                        send Deferred_Message msg_Request_Destroy_Object
57081>>>>>//                      End_Procedure
57081>>>>>//
57081>>>>>//          Somewhere along the VDF versions (6 or 7) DAW fixed this
57081>>>>>//          particular problem so that now it is OK to destroy an object
57081>>>>>//          while executing one of its methods.
57081>>>>>//
57081>>>>>//
57081>>>>>//          This technique is also viable if you want to make more
57081>>>>>//          independant DDO structures perform something in one go. It
57081>>>>>//          is a fact that when a DDO object is doing something (saving
57081>>>>>//          or finding or the like) you cannot make another (un-connected)
57081>>>>>//          DDO structure do anything. It appears to be dead. The reason is
57081>>>>>//          that while a DDO is performing one of those DDO things it sets
57081>>>>>//          global integers OPERATION_MODE and OPERATION_ORIGIN to whatever
57081>>>>>//          thereby blocking other DDO's from doing anything. If you
57081>>>>>//          keep your tongue straight, you may use the Deferred_Message
57081>>>>>//          procedure to get around this limitation.
57081>>>>>//
57081>>>>>//          However, when using this technique, there is a couple of
57081>>>>>//          (hundred) pitfalls.
57081>>>>>//
57081>>>>>//          The technique I use to do this involves a timer object. The
57081>>>>>//          first time you send a deferred message this timer object
57081>>>>>//          will be created (and not before).
57081>>>>>//
57081>>>>>//          As I understand it, a timer in Windows simply must have a
57081>>>>>//          window handle (a Windows administrative thing that relates
57081>>>>>//          to a window you can see on screen) in order to function. A
57081>>>>>//          DataFlex application can have a lot of windows and it is
57081>>>>>//          important that this window is the ClientArea object of your
57081>>>>>//          application. Placing it anywhere else will give you problems.
57081>>>>>//
57081>>>>>//          If you get an error 'DFTimerManager doesn't have Window_Handle!'
57081>>>>>//          when you close your application, the timer object has been
57081>>>>>//          created in the wrong place. You can get around this by inserting
57081>>>>>//          this line in the beginning of the ClientArea object:
57081>>>>>//
57081>>>>>//                  Object Main_Client is a ClientArea
57081>>>>>//                    send Deferred_Message msg_none
57081>>>>>//                    ...
57081>>>>>//
57081>>>>>//          Another error situation arises if there is any deferred
57081>>>>>//          messages waiting to be executed when you close your
57081>>>>>//          application. This may happen for example if you hook up
57081>>>>>//          to the New_Current_Record method in a DD object.
57081>>>>>//
57081>>>>>//            Procedure New_Current_Record integer old_rec# integer new_rec#
57081>>>>>//              forward send New_Current_Record old_rec# new_rec#
57081>>>>>//              send Deferred_Message msg_Update_Other_DD_Structures
57081>>>>>//            End_Procedure
57081>>>>>//
57081>>>>>//          For reasons un-known to man kind, a DD object fires a
57081>>>>>//          New_Current_Record message when the object is destroyed (most
57081>>>>>//          likely at the time of exiting the application). Do you see the
57081>>>>>//          problem? A message is put in the message queue, when in fact
57081>>>>>//          control never returns to the program. Timers don't like
57081>>>>>//          that sort of thing. You will receive an "Can't kill timer!
57081>>>>>//          Windows error #" error.
57081>>>>>//
57081>>>>>//          If you get into this sort of trouble you may need to check
57081>>>>>//          the value of global integer NotExitingApplication (defined
57081>>>>>//          in this package) before you send a deferred message. The
57081>>>>>//          procedure above would now look like this:
57081>>>>>//
57081>>>>>//            Procedure New_Current_Record integer old_rec# integer new_rec#
57081>>>>>//              forward send New_Current_Record old_rec# new_rec#
57081>>>>>//              if NotExitingApplication ;
57081>>>>>//                 send Deferred_Message msg_Update_Other_DD_Structures
57081>>>>>//            End_Procedure
57081>>>>>//
57081>>>>>//
57081>>>>>//**********************************************************************
57081>>>>>
57081>>>>>Use UI
57081>>>>>Use Macros.utl   // Various macros (DESKTOP_SECTION)
57081>>>>>Use Set.utl      // cArray, cSet and cStack classes
57081>>>>>Use Base.nui
57081>>>>>                         // when deferred_request_destroy_object is called
57081>>>>>desktop_section
57086>>>>>  integer NotExitingApplication
57086>>>>>  move 1 to NotExitingApplication
57087>>>>>  object OG_Current_Object_stack is an cStack
57089>>>>>    procedure Notify_Exit_Application
57092>>>>>      move 0 to NotExitingApplication
57093>>>>>    end_procedure
57094>>>>>    procedure Broadcast_Notify_Exit_Application
57097>>>>>      move 0 to NotExitingApplication
57098>>>>>    end_procedure
57099>>>>>    function Exit_Application_Check returns integer // CM check
57102>>>>>      move 0 to NotExitingApplication
57103>>>>>      function_return 0 // No changes
57104>>>>>    end_function
57105>>>>>  end_object
57106>>>>>
57106>>>>>  // This object holds all parameters for Object Group instantiations. The
57106>>>>>  // object is a stack and the last item holds the number of items for the
57106>>>>>  // current object group instantiation.
57106>>>>>  //   The global integer ObjectGroupCurrentOffset# points to the first
57106>>>>>  // parameter in the current object group instantiation.
57106>>>>>
57106>>>>>  integer OG_ParameterArray# // Object ID for OG_ParameterArray
57106>>>>>  object OG_ParameterArray is an array
57108>>>>>    move self to OG_ParameterArray#
57109>>>>>  end_object
57110>>>>>end_desktop_section
57115>>>>>
57115>>>>>integer OG_CurrentOffset#  //
57115>>>>>move 0 to OG_CurrentOffset#
57116>>>>>
57116>>>>>integer OG_Current_Object# //
57116>>>>>integer OG_Tmp# //
57116>>>>>
57116>>>>>// The prefix "og" stands for object group.
57116>>>>>procedure og_set_param global integer itm# string value#
57118>>>>>  set value of OG_ParameterArray# item (OG_CurrentOffset#+itm#) to value#
57119>>>>>end_procedure
57120>>>>>function og_param global integer itm# returns string
57122>>>>>  function_return (value(OG_ParameterArray#,OG_CurrentOffset#+itm#))
57123>>>>>end_function
57124>>>>>procedure og_allocate_param_space global integer itm#
57126>>>>>  integer item_count#
57126>>>>>  get item_count of OG_ParameterArray# to item_count#
57127>>>>>  set value of OG_ParameterArray# item (item_count#+itm#) to itm#
57128>>>>>  move item_count# to OG_CurrentOffset#
57129>>>>>end_procedure
57130>>>>>procedure og_add_param global string value#
57132>>>>>  integer item_count# max#
57132>>>>>  get item_count of OG_ParameterArray# to item_count#
57133>>>>>  get integer_value of OG_ParameterArray# item (item_count#-1) to max#
57134>>>>>  send delete_item to OG_ParameterArray# (item_count#-1)
57135>>>>>  set value of OG_ParameterArray# item (item_count#-1) to value#
57136>>>>>  set value of OG_ParameterArray# item item_count# to (max#+1)
57137>>>>>end_procedure
57138>>>>>procedure og_drop_params global // Delete all parameters from last OG instantiation
57140>>>>>  integer max# itm# item_count#
57140>>>>>  get item_count of OG_ParameterArray# to item_count#
57141>>>>>  get value of OG_ParameterArray# item (item_count#-1) to max#
57142>>>>>  for itm# from 0 to max#
57148>>>>>>
57148>>>>>    send delete_item to OG_ParameterArray# (item_count#-1-itm#)
57149>>>>>  loop
57150>>>>>>
57150>>>>>  get item_count of OG_ParameterArray# to item_count#
57151>>>>>  if item_count# ; // Only if not empty    move (item_count#-integer_value(OG_ParameterArray#,item_count#-1)-1) to OG_CurrentOffset#
57154>>>>>  else move 0 to OG_CurrentOffset#
57156>>>>>end_procedure
57157>>>>>
57157>>>>>// The above set of messages enables two different strategies for setting
57157>>>>>// up parameters for an OG instantiation:
57157>>>>>//
57157>>>>>//      1) sending og_allocate_param_space to allocate the necessary number
57157>>>>>//         of array items at one time. Afterwards the values are set using
57157>>>>>//         the og_set_param message
57157>>>>>//
57157>>>>>//      2) sending og_allocate_param_space with parameter 0 simply to
57157>>>>>//         indicate that a new parameter set is about to be specified.
57157>>>>>//         Parameter values are hereafter set by using the og_add_param
57157>>>>>//         message.
57157>>>>>//
57157>>>>>// Strategy 2 is somewhat slower than 1 but may be more convenient in
57157>>>>>// most instances.
57157>>>>>//
57157>>>>>// In any case message og_drop_params will drop the current parameters
57157>>>>>// by deleting them from the stack.
57157>>>>>
57157>>>>>
57157>>>>>
57157>>>>>
57157>>>>>// The rest of this file is dedicated to supplying a method to be used when
57157>>>>>// destroying objects. The method Deferred_Request_Destroy_Object is understood
57157>>>>>// by all objects but should only be sent to panels (View's and ModalPanel's)
57157>>>>>//
57157>>>>>// The next couple of hundred lines is a duplicate of the standard VDF timer
57157>>>>>// package except that class names has been changed ("0" has been added). This
57157>>>>>// is needed because I do not want to rely on the DfTimer.pkg package. Why not?
57157>>>>>// Because that has to be USE'd from within the (App)ClientArea to avoid focus
57157>>>>>// loss at application start up. This package (ObjGroup.utl) may be used
57157>>>>>// anywhere and still work (as far as I know).
57157>>>>>
57157>>>>>Use Windows // Standard DAC packages
57157>>>>>Use WinUser //
57157>>>>>
57157>>>>>External_Function SetTimer0 "SetTimer" User32.DLL Integer hWnd Integer idTimer Integer idTimeout Pointer tmprc Returns Integer
57158>>>>>External_Function KillTimer0 "KillTimer" User32.DLL Integer hWnd Integer idTimer Returns Integer
57159>>>>>External_Function GetLastError0 "GetLastError" Kernel32.DLL Returns DWORD
57160>>>>>
57160>>>>>Integer giTimerManager#
57160>>>>>
57160>>>>>Class TimersArray0 is an Array
57161>>>>>    Function Find_Object Integer iObj Returns Integer
57163>>>>>        integer iMax
57163>>>>>        integer iItem
57163>>>>>        integer iValue
57163>>>>>        Get Item_count to iMax
57164>>>>>        Decrement iMax
57165>>>>>        For iItem from 1 to iMax
57171>>>>>>
57171>>>>>            Get Integer_Value item iItem to iValue
57172>>>>>            If iValue EQ iObj Function_Return iItem
57175>>>>>        Loop
57176>>>>>>
57176>>>>>        Function_Return -1
57177>>>>>    End_Function
57178>>>>>
57178>>>>>    Procedure Add_Object Integer iObj Returns Integer
57180>>>>>        integer iItem
57180>>>>>        Get Find_Object iObj to iItem
57181>>>>>        If iItem LT 0 Begin
57183>>>>>            Get Find_Object 0 to iItem
57184>>>>>            If iItem LT 0 Get Item_Count to iItem
57187>>>>>        End
57187>>>>>>
57187>>>>>        Set Array_Value item iItem to iObj
57188>>>>>        Procedure_Return iItem
57189>>>>>    End_Procedure
57190>>>>>
57190>>>>>    Procedure Remove_Object Integer iObj
57192>>>>>        integer iItem
57192>>>>>        Get Find_Object iObj to iItem
57193>>>>>        If iItem GT 0 Set Array_Value item iItem to 0
57196>>>>>    End_Procedure
57197>>>>>    Procedure Destroy_Object
57199>>>>>        Delegate Send Kill_All_Timers
57201>>>>>        Forward Send Destroy_Object
57203>>>>>    End_Procedure
57204>>>>>End_Class // TimersArray0
57205>>>>>
57205>>>>>Class DFTimerManager0 is a DFControl
57206>>>>>    Procedure Construct_Object
57208>>>>>        Forward Send Construct_Object
57210>>>>>        Set Visible_State to FALSE
57211>>>>>        Set External_Class_Name "DFTimer" to "static"
57212>>>>>        Set External_Message WM_TIMER to OnTimer
57213>>>>>        Object TimersArray0 is a TimersArray0
57215>>>>>            Set Array_Value item 0 to -9999 // So we don't use item 0
57216>>>>>        End_Object
57217>>>>>        Move self to giTimerManager#
57218>>>>>    End_Procedure
57219>>>>>
57219>>>>>    Procedure Set Timer_Active_State Integer iObj Integer iState
57221>>>>>        integer iTimerID iTimeout iResult iSet
57221>>>>>        Dword   nResult
57221>>>>>        Handle  hWnd
57221>>>>>        Get Window_Handle to hWnd
57222>>>>>        If Not hWnd Begin
57224>>>>>            Error 999 "DFTimerManager doesn't have Window_Handle!"
57225>>>>>>
57225>>>>>            Procedure_Return
57226>>>>>        End
57226>>>>>>
57226>>>>>
57226>>>>>        Move (TimersArray0(self)) to iSet
57227>>>>>        If iState Begin
57229>>>>>            Get MSG_Add_Object of iSet iObj to iTimerID
57230>>>>>            Get Timeout of iObj to iTimeout
57231>>>>>            Move (SetTimer0(hWnd, iTimerID, iTimeout, 0)) to iResult
57232>>>>>            If Not iResult Begin
57234>>>>>                Error 999 "Can't create timer. Too many?"
57235>>>>>>
57235>>>>>                Procedure_Return
57236>>>>>            End
57236>>>>>>
57236>>>>>        End
57236>>>>>>
57236>>>>>        Else Begin
57237>>>>>            Get Find_Object of iSet iObj to iTimerID
57238>>>>>            If iTimerID EQ -1 Procedure_Return
57241>>>>>            Move (KillTimer0(hWnd, iTimerID)) to iResult
57242>>>>>            If Not iResult Begin
57244>>>>>                Move (GetLastError0()) to nResult
57245>>>>>                Error 999 ("Can't kill timer! Windows error" * string(nResult) - "!")
57246>>>>>>
57246>>>>>                Procedure_Return
57247>>>>>            End
57247>>>>>>
57247>>>>>            Send Remove_Object to iSet iObj
57248>>>>>        End
57248>>>>>>
57248>>>>>    End_Procedure
57249>>>>>
57249>>>>>    Function Timer_Active_State Integer iObj Returns Integer
57251>>>>>        integer iResult
57251>>>>>        Get Find_Object of (TimersArray0(self)) iObj to iResult
57252>>>>>        Function_Return (iResult NE 0)
57253>>>>>    End_Function
57254>>>>>
57254>>>>>    Procedure Kill_All_Timers
57256>>>>>        integer iMax iSet iItem iObj iResult
57256>>>>>        Handle  hWnd
57256>>>>>
57256>>>>>        Get Window_Handle to hWnd
57257>>>>>        If Not hWnd Begin
57259>>>>>            Error 999 "DFTimerManager doesn't have Window_Handle!"
57260>>>>>>
57260>>>>>            Procedure_Return
57261>>>>>        End
57261>>>>>>
57261>>>>>
57261>>>>>        Move (TimersArray0(self)) to iSet
57262>>>>>        Get Item_Count of iSet to iMax
57263>>>>>        Decrement iMax
57264>>>>>        For iItem From 1 to iMax
57270>>>>>>
57270>>>>>            Get Integer_Value of iSet item iItem to iObj
57271>>>>>            If iObj Begin
57273>>>>>                Move (KillTimer0(hWnd, iItem)) to iResult
57274>>>>>                Set Array_Value of iSet item iItem to 0
57275>>>>>            End
57275>>>>>>
57275>>>>>        Loop
57276>>>>>>
57276>>>>>    End_Procedure
57277>>>>>
57277>>>>>    Procedure OnTimer Integer wParam Integer lParam
57279>>>>>        integer iObj
57279>>>>>        Get Integer_Value of (TimersArray0(self)) item wParam to iObj
57280>>>>>        If Not iObj Begin
57282>>>>>            Error 999 "OnTimer: Timer event without object!"
57283>>>>>>
57283>>>>>            Procedure_Return
57284>>>>>        End
57284>>>>>>
57284>>>>>        Send OnTimer to iObj wParam lParam
57285>>>>>    End_Procedure
57286>>>>>
57286>>>>>    Procedure Destroy_Object
57288>>>>>        Forward Send Destroy_Object
57290>>>>>        Move 0 to giTimerManager#
57291>>>>>    End_Procedure
57292>>>>>End_Class // DFTimerManger
57293>>>>>
57293>>>>>Class DFTimerManagerPanel0 is a DFPanel
57294>>>>>
57294>>>>>    Procedure Construct_Object
57296>>>>>        Forward Send Construct_Object
57298>>>>>        Set Visible_State to FALSE
57299>>>>>        Object DFTimerManager is a DFTimerManager0
57301>>>>>        End_Object
57302>>>>>    End_Procedure
57303>>>>>
57303>>>>>    Procedure End_Construct_Object
57305>>>>>        Forward Send End_Construct_Object
57307>>>>>        Send Page_Object TRUE
57308>>>>>        Broadcast Send Page_Object TRUE
57310>>>>>    End_Procedure
57311>>>>>End_Class
57312>>>>>
57312>>>>>Class DFTimer0 is a Textbox
57313>>>>>    Procedure Construct_Object
57315>>>>>        Forward Send Construct_Object
57317>>>>>        Set Visible_State to FALSE
57318>>>>>        Property Integer Timeout            Private 1000
57319>>>>>        Property Integer Timer_Message      Public  0
57320>>>>>        Property Integer Timer_Object       Public  0
57321>>>>>        Property Integer Auto_Start_State   Public  TRUE
57322>>>>>        Property Integer Auto_Stop_State    Public  TRUE
57323>>>>>    End_Procedure
57324>>>>>
57324>>>>>    Procedure Set Timer_Active_State Integer iState
57326>>>>>        integer iObj
57326>>>>>        Move self to iObj
57327>>>>>        If giTimerManager# Set Timer_Active_State of giTimerManager# iObj to iState
57330>>>>>    End_Procedure
57331>>>>>
57331>>>>>    Function Timer_Active_State returns integer
57333>>>>>        integer iState
57333>>>>>        integer iObj
57333>>>>>        Move self to iObj
57334>>>>>        If giTimerManager# Get Timer_Active_State of giTimerManager# iObj to iState
57337>>>>>        Function_Return iState
57338>>>>>    End_Function
57339>>>>>
57339>>>>>    Procedure Set Timeout Integer iTimeout
57341>>>>>        integer iActive
57341>>>>>        Set !$.Timeout to iTimeout
57342>>>>>        Get Timer_Active_State to iActive
57343>>>>>        If iActive Set Timer_Active_State to TRUE
57346>>>>>    End_Procedure
57347>>>>>
57347>>>>>    Function Timeout Returns Integer
57349>>>>>        integer iTimeout
57349>>>>>        Get !$.Timeout to iTimeout
57350>>>>>        Function_Return iTimeout
57351>>>>>    End_Function
57352>>>>>
57352>>>>>    Procedure OnTimer Integer iwParam Integer ilParam
57354>>>>>        integer iMsg
57354>>>>>        integer iObj
57354>>>>>        Get Timer_Message to iMsg
57355>>>>>        Get Timer_Object  to iObj
57356>>>>>        If (iMsg) Begin
57358>>>>>            Get Timer_Object  to iObj
57359>>>>>            If iObj Send iMsg to iObj iwParam ilParam
57362>>>>>            Else Send iMsg iwParam ilParam
57364>>>>>        End
57364>>>>>>
57364>>>>>    End_Procedure
57365>>>>>
57365>>>>>    Procedure Page_Object Integer iState
57367>>>>>        Forward Send Page_Object iState
57369>>>>>        If (iState AND Auto_Start_State(self)) Set Timer_Active_State to TRUE
57372>>>>>    End_Procedure
57373>>>>>
57373>>>>>    Procedure Page_Delete
57375>>>>>        If (Auto_Stop_State(self)) Set Timer_Active_State to FALSE
57378>>>>>        Forward Send Page_Delete
57380>>>>>    End_Procedure
57381>>>>>
57381>>>>>    Procedure Destroy_Object
57383>>>>>        Set Timer_Active_State to FALSE
57384>>>>>        Forward Send Destroy_Object
57386>>>>>    End_Procedure
57387>>>>>End_Class // DFTimer0
57388>>>>>
57388>>>>>// This is where this package differs from the DAC package. Object
57388>>>>>// DFTimerManagerPanel0 is NOT instantiated at program start up
57388>>>>>// thus leaving focus un-disturbed. Instead they are created the first
57388>>>>>// time Deferred_Request_Destroy_Object is sent.
57388>>>>>
57388>>>>>DEFINE_OBJECT_GROUP OG_DeferredTimer
57389>>>>>  Object DFTimerManagerPanel0 is a DFTimerManagerPanel0
57391>>>>>    // This object will make the program lose its focus if instantiated
57391>>>>>    // before Main.Client_Area has been created.
57391>>>>>  End_Object
57392>>>>>
57392>>>>>  object oMessages is an Array no_image
57394>>>>>  end_object
57395>>>>>
57395>>>>>  object oDestructionTimer is a DfTimer0
57397>>>>>    // And this object would have made the program crash
57397>>>>>    set auto_start_state to false
57398>>>>>    set auto_stop_state to false
57399>>>>>    property integer pDestroyObject public 0
57401>>>>>    procedure OnTimer
57404>>>>>      integer obj# msg# oMessages#
57404>>>>>      get pDestroyObject to obj#
57405>>>>>      if obj# begin
57407>>>>>        send request_destroy_object to obj#
57408>>>>>        set pDestroyObject to 0
57409>>>>>        set Timer_Active_State to false // Stop timer
57410>>>>>        if (item_count(oMessages(self))) begin
57412>>>>>          set TimeOut to 0 // This means "as soon as possible"
57413>>>>>          set Timer_Active_State to true // Start timer
57414>>>>>        end
57414>>>>>>
57414>>>>>      end
57414>>>>>>
57414>>>>>      else begin
57415>>>>>        move (oMessages(self)) to oMessages#
57416>>>>>        if (item_count(oMessages#)) begin
57418>>>>>          get value of oMessages# item 0 to msg#
57419>>>>>          get value of oMessages# item 1 to obj#
57420>>>>>          send delete_item to oMessages# 0
57421>>>>>          send delete_item to oMessages# 0
57422>>>>>          set Timer_Active_State to false // Stop timer
57423>>>>>          if obj# send msg# to obj#
57426>>>>>          else send msg#
57428>>>>>          if (item_count(oMessages#)) begin
57430>>>>>            set TimeOut to 0 // This means "as soon as possible"
57431>>>>>            set Timer_Active_State to true // Start timer
57432>>>>>          end
57432>>>>>>
57432>>>>>        end
57432>>>>>>
57432>>>>>      end
57432>>>>>>
57432>>>>>    end_procedure
57433>>>>>    procedure Deferred_Destroy integer obj#
57436>>>>>      set pDestroyObject to obj#
57437>>>>>      set TimeOut to 0 // This means "as soon as possible"
57438>>>>>      set Timer_Active_State to true // Start timer
57439>>>>>    end_procedure
57440>>>>>
57440>>>>>    procedure Send_Message integer msg# integer obj#
57443>>>>>      integer oMessages#
57443>>>>>      move (oMessages(self)) to oMessages#
57444>>>>>      set value of oMessages# item (item_count(oMessages#)) to msg#
57445>>>>>      set value of oMessages# item (item_count(oMessages#)) to obj#
57446>>>>>      set TimeOut to 0 // This means "as soon as possible"
57447>>>>>      set Timer_Active_State to true // Start timer
57448>>>>>    end_procedure
57449>>>>>  end_object
57450>>>>>END_DEFINE_OBJECT_GROUP
57451>>>>>
57451>>>>>Procedure Deferred_Request_Destroy_Object for BaseClass
57453>>>>>  integer self# Client_ID#
57453>>>>>  move self to self#
57454>>>>>  ifnot giTimerManager# begin //
57456>>>>>    move (Client_ID(self#)) to Client_ID#
57457>>>>>    if Client_ID# begin
57459>>>>>      CREATE_OBJECT_GROUP OG_DeferredTimer PARENT Client_ID#
57468>>>>>    end
57468>>>>>>
57468>>>>>    else error 666 "ClientArea not found!"
57470>>>>>  end
57470>>>>>>
57470>>>>>  send Deferred_Destroy to (oDestructionTimer(giTimerManager#)) self#
57471>>>>>End_Procedure
57472>>>>>
57472>>>>>Procedure Deferred_Message for BaseClass integer msg# integer obj#
57474>>>>>  integer self# Client_ID#
57474>>>>>  move self to self#
57475>>>>>  ifnot giTimerManager# begin //
57477>>>>>    move (Client_ID(self#)) to Client_ID#
57478>>>>>    if Client_ID# begin
57480>>>>>      CREATE_OBJECT_GROUP OG_DeferredTimer PARENT Client_ID#
57489>>>>>    end
57489>>>>>>
57489>>>>>    else error 666 "ClientArea not found!"
57491>>>>>  end
57491>>>>>>
57491>>>>>  if num_arguments gt 1 send send_message to (oDestructionTimer(giTimerManager#)) msg# obj#
57494>>>>>  else send send_message to (oDestructionTimer(giTimerManager#)) msg# self#
57496>>>>>End_Procedure
57497>>>>>
57497>>>Use DfmPrint.utl // Classes for printing DFMatrix reports.
Including file: dfmprint.utl    (C:\Apps\VDFQuery\AppSrc\dfmprint.utl)
57497>>>>>// Use DfmPrint.utl // Classes for printing DFMatrix reports.
57497>>>>>Use Output.utl   // Basic sequential output service
57497>>>>>
/DFMATRIX.HEADER
Image 4, DFMATRIX.HEADER
     DF-Matrix, ____________________________________________________ Page
    
/DFMatrix.Footer
Image 5, DFMATRIX.FOOTER
    
     _______________________________________ Printed on , 
/*
57497>>>>>
57497>>>>>class cDFMatrixSimpleReport is a cArray
57498>>>>>  procedure construct_object integer img#
57500>>>>>    forward send construct_object img#
57502>>>>>    property string  psTitle      public "Un-titled"
57503>>>>>    property integer piFDX_Server public 0
57504>>>>>  end_procedure
57505>>>>>  function iStartReport returns integer
57507>>>>>    integer rval#
57507>>>>>    send obs "Before"
57508>>>>>    move (iDirect_Output_Title(seq.object#,psTitle(self))) to rval#
57509>>>>>    send obs "After"
57510>>>>>    if rval# begin
57512>>>>>      set pHeader_image  of seq.object# to DFMatrix.Header.N
57513>>>>>      set pHeader_height of seq.object# to DFMatrix.Header.LINES
57514>>>>>      set pFooter_image  of seq.object# to DFMatrix.Footer.N
57515>>>>>      set pFooter_height of seq.object# to DFMatrix.Footer.LINES
57516>>>>>      move (psTitle(self)) to DFMatrix.Header.1
57517>>>>>      move (sOriginAsText(piFDX_Server(self))) to DFMatrix.Footer.1
57518>>>>>    end
57518>>>>>>
57518>>>>>    function_return rval#
57519>>>>>  end_function
57520>>>>>  procedure EndReport
57522>>>>>    seq.close_output
57523>>>>>  end_procedure
57524>>>>>end_class
57525>>>Use Login.utl    // DBMS_GetDriverLogin function
Including file: login.utl    (C:\Apps\VDFQuery\AppSrc\login.utl)
57525>>>>>// Use Login.utl    // DBMS_GetDriverLogin function
57525>>>>>Use Driver.nui   // This package is used to load a driver DLL
Including file: driver.nui    (C:\Apps\VDFQuery\AppSrc\driver.nui)
57525>>>>>>>// Use Driver.nui   // This package is used to load a driver DLL
57525>>>>>>>
57525>>>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
57525>>>>>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
57525>>>>>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
57525>>>>>>>
57525>>>>>>>function DRV_LoadDriverByName global string lsDriverName returns integer
57527>>>>>>>  string lsDriverFile lsDir
57527>>>>>>>  move (lsDriverName+".DLL") to lsDriverFile
57528>>>>>>>  if (SEQ_FileExists(lsDriverFile)<>SEQIT_FILE) begin
57530>>>>>>>    // What? Driver not found? We'll have to look for it then:
57530>>>>>>>    move (SEQ_FindFileAlongDFPath(lsDriverFile)) to lsDir
57531>>>>>>>    // What? Not found again? We'll look along the EXE search path then:
57531>>>>>>>    if lsDir eq "" move (SEQ_FindFileAlongPath(API_OtherAttr_Value(OA_PATH),lsDriverFile)) to lsDir
57534>>>>>>>    if lsDir eq "" function_return 0 // If we didn't find it it doesn't exist! Goodbye!
57537>>>>>>>    move (SEQ_ComposeAbsoluteFileName(lsDir,lsDriverName)) to lsDriverName
57538>>>>>>>  end
57538>>>>>>>>
57538>>>>>>>  load_driver lsDriverName
57539>>>>>>>  function_return 1
57540>>>>>>>end_function // DRV_LoadDriverByName
57541>>>>>>>
57541>>>>>>>function DRV_LoadDriverByType global integer liType returns integer
57543>>>>>>>  string lsDriverName
57543>>>>>>>  get DBMS_TypeToDriverName liType to lsDriverName
57544>>>>>>>  function_return (DRV_LoadDriverByName(lsDriverName))
57545>>>>>>>end_function // DRV_LoadDriverByType
57546>>>>>// Marcelo Nachbar da Silva [nachbar@mertechdata.com]
57546>>>>>
57546>>>>>Use Language    // Set default languange if not set by compiler command line
57546>>>>>Use Seq_Chnl    // Defines global sequential device management operations (DAW)
57546>>>>>use buttons.utl
57546>>>>>use dbms.utl
57546>>>>>use files.utl
57546>>>>>
57546>>>>>
57546>>>>>use aps
57546>>>>>class cDriverComboForm is a aps.ComboFormAux
57547>>>>>  procedure construct_object integer img#
57549>>>>>    forward send construct_object img#
57551>>>>>    set p_abstract to aft_ascii20
57552>>>>>    set entry_state item 0 to false
57553>>>>>    on_key kenter send next
57554>>>>>  end_procedure
57555>>>>>  procedure fill_list
57557>>>>>    integer id#
57557>>>>>    send Combo_Delete_Data
57558>>>>>    for id# from (DBMS_DRIVER_DATAFLEX+1) to (DBMS_DRIVER_MAX-1)
57564>>>>>>
57564>>>>>      if (DBMS_TypeToDriverName(id#)) ne "Unknown" begin
57566>>>>>        send combo_add_item (DBMS_Driver_UserName(id#)) id#
57567>>>>>      end
57567>>>>>>
57567>>>>>    loop
57568>>>>>>
57568>>>>>  end_procedure
57569>>>>>  procedure end_construct_object
57571>>>>>    send fill_list
57572>>>>>    forward send end_construct_object
57574>>>>>  end_procedure
57575>>>>>end_class // cDriverComboForm
57576>>>>>
57576>>>>>object oDriverLogin is a aps.TopMostModalPanel label "Login"
57579>>>>>  set p_left_margin   to 5
57580>>>>>  set p_right_margin  to 20
57581>>>>>  set p_top_margin    to 10
57582>>>>>  set p_bottom_margin to 10
57583>>>>>  set locate_mode to CENTER_ON_SCREEN
57584>>>>>  on_key ksave_record send close_panel_ok
57585>>>>>  on_key kcancel send close_panel
57586>>>>>  on_key kuser send DoLoadDriver
57587>>>>>  property integer piResult public 0
57589>>>>>  property string psDriverFileName public ""
57591>>>>>  send aps_init
57592>>>>>  set p_auto_column to 1
57593>>>>>  send tab_column_define 1 50 45 jmode_right // Default column setting
57594>>>>>  object oFrm0 is a cDriverComboForm label "Driver:"
57597>>>>>  end_object
57598>>>>>  object oFrm1 is a aps.Form label "Server:" abstract aft_ascii20
57602>>>>>    on_key kenter send next
57603>>>>>  end_object
57604>>>>>  object oFrm2 is a aps.Form label "User:" abstract aft_ascii20
57608>>>>>    on_key kenter send next
57609>>>>>  end_object
57610>>>>>  object oFrm3 is a aps.Form label "Password:" abstract aft_ascii20
57614>>>>>    set password_state item 0 to true
57615>>>>>    on_key kenter send next
57616>>>>>  end_object
57617>>>>>  object oSavePW is a aps.checkbox label "Save password"
57620>>>>>    on_key kenter send next
57621>>>>>  end_object
57622>>>>>  object oBtn1 is a aps.Multi_Button
57624>>>>>    on_item t.btn.ok send close_panel_ok
57625>>>>>  end_object
57626>>>>>  object oBtn2 is a aps.Multi_Button
57628>>>>>    on_item t.btn.cancel send close_panel
57629>>>>>  end_object
57630>>>>>  procedure DoLoadDriver
57633>>>>>    integer liDriverType
57633>>>>>    move (Combo_Current_Aux_Value(oFrm0(self))) to liDriverType
57634>>>>>    if (DRV_LoadDriverByType(liDriverType)) send obs "Driver loaded"
57637>>>>>    else send obs "Driver could not be found." "(and therefore it could not be loaded)"
57639>>>>>  end_procedure
57640>>>>>  send aps_locate_multi_buttons
57641>>>>>  procedure close_panel_ok
57644>>>>>    integer ch#
57644>>>>>    string fn#
57644>>>>>    get psDriverFileName to fn#
57645>>>>>    get SEQ_DirectOutput fn# to ch#
57646>>>>>    if (ch#>=0) begin
57648>>>>>      writeln (value(oFrm1(self),0))
57650>>>>>      writeln (value(oFrm2(self),0))
57652>>>>>      if (select_state(oSavePW(self),0)) writeln (value(oFrm3(self),0))
57656>>>>>      else writeln ""
57659>>>>>      close_output channel ch#
57661>>>>>      send Seq_Release_Channel ch#
57662>>>>>      set piResult to 1
57663>>>>>      send close_panel
57664>>>>>    end
57664>>>>>>
57664>>>>>  end_procedure
57665>>>>>  procedure reset
57668>>>>>    integer ch#
57668>>>>>    string fn# str#
57668>>>>>    set value of (oFrm1(self)) item 0 to ""
57669>>>>>    set value of (oFrm2(self)) item 0 to ""
57670>>>>>    set value of (oFrm3(self)) item 0 to ""
57671>>>>>    set select_state of (oSavePW(self)) item 0 to 0
57672>>>>>    get psDriverFileName to fn#
57673>>>>>    get SEQ_DirectInput fn# to ch#
57674>>>>>    if (ch#>=0) begin
57676>>>>>      readln str#
57677>>>>>      set value of (oFrm1(self)) item 0 to str#
57678>>>>>      readln str#
57679>>>>>      set value of (oFrm2(self)) item 0 to str#
57680>>>>>      readln str#
57681>>>>>      set value of (oFrm3(self)) item 0 to str#
57682>>>>>      if str# ne "" set select_state of (oSavePW(self)) item 0 to 1
57685>>>>>      close_input channel ch#
57687>>>>>      send Seq_Release_Channel ch#
57688>>>>>      //nd close_panel
57688>>>>>    end
57688>>>>>>
57688>>>>>  end_procedure
57689>>>>>  function iLogin.i integer driver# returns integer
57692>>>>>    string username# filename#
57692>>>>>    set piResult to 0
57693>>>>>    if driver# begin
57695>>>>>      get DBMS_TypeToDriverName driver# to filename#
57696>>>>>      get DBMS_Driver_UserName driver# to username#
57697>>>>>    end
57697>>>>>>
57697>>>>>    else move "drvlogin" to filename#
57699>>>>>    set psDriverFileName to (lowercase(filename#+".ini"))
57700>>>>>    if driver# begin
57702>>>>>      set object_shadow_state of (oFrm0(self)) to true
57703>>>>>      set value of (oFrm0(self)) to (DBMS_Driver_UserName(driver#))
57704>>>>>    end
57704>>>>>>
57704>>>>>    else set object_shadow_state of (oFrm0(self)) to false
57706>>>>>    set label to ("Login: "+username#)
57707>>>>>    send reset
57708>>>>>    send popup
57709>>>>>    function_return (piResult(self))
57710>>>>>  end_function
57711>>>>>end_object
57712>>>>>
57712>>>>>function DBMS_GetDriverLogin global integer driver# returns integer
57714>>>>>  integer rval#
57714>>>>>  get iLogin.i of (oDriverLogin(self)) driver# to rval#
57715>>>>>  function_return rval#
57716>>>>>end_function
57717>>>>>
57717>>>>>function DBMS_GetDriverLoginDriverID global returns integer
57719>>>>>  function_return (Combo_Current_Aux_Value(oFrm0(oDriverLogin(self))))
57720>>>>>end_function
57721>>>>>function DBMS_GetDriverLoginServer global returns string
57723>>>>>  function_return (value(oFrm1(oDriverLogin(self)),0))
57724>>>>>end_function
57725>>>>>function DBMS_GetDriverLoginUserID global returns string
57727>>>>>  function_return (value(oFrm2(oDriverLogin(self)),0))
57728>>>>>end_function
57729>>>>>function DBMS_GetDriverLoginPassWord global returns string
57731>>>>>  function_return (value(oFrm3(oDriverLogin(self)),0))
57732>>>>>end_function
57733>>>>>
57733>>>>>//get DBMS_GetDriverLogin DBMS_DRIVER_ORACLE to windowindex
57733>>>>>//get DBMS_GetDriverLogin 0 to windowindex
57733>>>>>//if windowindex begin
57733>>>>>//  showln (DBMS_GetDriverLoginServer())
57733>>>>>//  showln (DBMS_GetDriverLoginUserID())
57733>>>>>//  showln (DBMS_GetDriverLoginPassWord())
57733>>>>>//  inkey windowindex
57733>>>>>//end
57733>>>Use Focus.utl    // Retrieve basic information about object
Including file: focus.utl    (C:\Apps\VDFQuery\AppSrc\focus.utl)
57733>>>>>// **********************************************************************
57733>>>>>// Use Focus.utl    // Retrieve basic information about object
57733>>>>>//
57733>>>>>// by Sture Andersen
57733>>>>>//
57733>>>>>// Create: Can't remember
57733>>>>>// Update: Fri  30-06-2000 - Changed and doc'ed
57733>>>>>//
57733>>>>>//
57733>>>>>// This package is able to perform a runtime analysis of the object that
57733>>>>>// currently holds the focus. The following information may be retrieved:
57733>>>>>//
57733>>>>>//
57733>>>>>//       Info-ID             Type       Description
57733>>>>>//      -----------------------------------------------------------
57733>>>>>//       FOCUS_OK            (Bool)     Did this work at all?
57733>>>>>//       FOCUS_DEO_ID        (Integer)  Who did we ask?
57733>>>>>//       FOCUS_ITEM_FILE     (Integer)  What's the data file of the current
57733>>>>>//                                      item.
57733>>>>>//       FOCUS_ITEM_FIELD    (Integer)  What's the data field of the
57733>>>>>//                                      current item.
57733>>>>>//       FOCUS_MAIN_INDEX    (Integer)  What's the main index (if any)
57733>>>>>//       FOCUS_DD            (Integer)  Who's the server
57733>>>>>//       FOCUS_INDIRECT_DD   (Integer)  Which DDO is taking care of
57733>>>>>//                                      FOCUS_ITEM_FILE
57733>>>>>//       FOCUS_DEO_MODAL     (Bool)     Is that panel modal?
57733>>>>>//       FOCUS_CLIENT_ID     (Integer)  What (if any) is the ID
57733>>>>>//                                      of the client area?
57733>>>>>//       FOCUS_DEO_ITEM      (Integer)  What's current item in
57733>>>>>//                                      that objects
57733>>>>>//       FOCUS_SCOPED_PARENT (Integer)  Object ID of scoped parent
57733>>>>>//       FOCUS_ITEM_VALUE    (String)   Value of current item
57733>>>>>//
57733>>>>>//
57733>>>>>// To retrieve all this wonderful information send message Focus_Analyse_Focus.
57733>>>>>// After that you must use the Focus_Info function to actually get hold of if:
57733>>>>>//
57733>>>>>//   procedure OnlyIfCustomer
57733>>>>>//     integer iFile
57733>>>>>//     send Focus_Analyse_Focus
57733>>>>>//     get Focus_Info FOCUS_ITEM_FILE to iFile
57733>>>>>//     if iFile eq Customer.File_Number begin
57733>>>>>//       // Something fantastic
57733>>>>>//     end
57733>>>>>//     else send stop_box "Only do this from a Customer field!"
57733>>>>>//   end_procedure
57733>>>>>//
57733>>>>>// Public interface:
57733>>>>>//
57733>>>>>//
57733>>>>>// * function Focus_Find_Scoped_Parent global integer iObj returns integer
57733>>>>>//
57733>>>>>//     This function returns the innermost scoped parent (Scope_State = True)
57733>>>>>//     of the object passed in parameter iObj. If no such object is found
57733>>>>>//     DESKTOP is returned. If 0 is passed as iObj, 0 will be returned.
57733>>>>>//
57733>>>>>//
57733>>>>>// * procedure Focus_Analyze_DEO global integer iDEO integer iItem
57733>>>>>//
57733>>>>>//     Analyse object passed in the iDEO. The iItem parameter should indicate
57733>>>>>//     which item in iDeo should be used for retrieving item based info.
57733>>>>>//     Subsequently use the Focus_Info function to retrieve the information.
57733>>>>>//
57733>>>>>//
57733>>>>>//
57733>>>>>// * procedure Focus_Analyze_Focus global
57733>>>>>//
57733>>>>>//     Analyse object that currently holds the focus. Subsequently use the
57733>>>>>//     Focus_Info function to retrieve the information.
57733>>>>>//
57733>>>>>//
57733>>>>>// * function Focus_Info global integer iItem returns string
57733>>>>>//
57733>>>>>//     Use this function to get hold of information previously recorded
57733>>>>>//     by the Focus_Analyze_Focus (or Focus_Analyze_DEO) function.
57733>>>>>//
57733>>>>>//     Parameter iItem may be any of the following values:
57733>>>>>//
57733>>>>>//                FOCUS_OK            (Boolean)
57733>>>>>//                FOCUS_DEO_ID        (Integer)
57733>>>>>//                FOCUS_ITEM_FILE     (Integer)
57733>>>>>//                FOCUS_ITEM_FIELD    (Integer)
57733>>>>>//                FOCUS_MAIN_INDEX    (Integer)
57733>>>>>//                FOCUS_DD            (Integer)
57733>>>>>//                FOCUS_INDIRECT_DD   (Integer)
57733>>>>>//                FOCUS_DEO_MODAL     (Boolean)
57733>>>>>//                FOCUS_CLIENT_ID     (Integer)
57733>>>>>//                FOCUS_DEO_ITEM      (Integer)
57733>>>>>//                FOCUS_SCOPED_PARENT (Integer)
57733>>>>>//                FOCUS_ITEM_VALUE    (String)
57733>>>>>//
57733>>>>>//     The return type of this function is String but the return value
57733>>>>>//     may be converted to the type indicated in parenthesis.
57733>>>>>
57733>>>>>
57733>>>>>use ui
57733>>>>>
57733>>>>>enumeration_list
57733>>>>>  define FOCUS_OK            // Bool     Did this work at all?
57733>>>>>  define FOCUS_DEO_ID        // Integer  Who did we ask?
57733>>>>>  define FOCUS_DEO_ITEM      // Integer  What's current item in that objects
57733>>>>>  define FOCUS_ITEM_FILE     // Integer  What's the data file
57733>>>>>  define FOCUS_ITEM_FIELD    // Integer  What's the data field
57733>>>>>  define FOCUS_MAIN_INDEX    // Integer  What's the main index (if any)
57733>>>>>  define FOCUS_DD            // Integer  Who's the server
57733>>>>>  define FOCUS_INDIRECT_DD   // Integer  Who's taking care of FOCUS_ITEM_FILE
57733>>>>>  define FOCUS_DEO_MODAL     // Bool     Is that panel modal?
57733>>>>>  define FOCUS_CLIENT_ID     // Integer  What (if any) is the ID of the client area?
57733>>>>>  define FOCUS_SCOPED_PARENT // Integer  Object ID of scoped parent
57733>>>>>  define FOCUS_ITEM_VALUE    // The current value of the focused field
57733>>>>>end_enumeration_list
57733>>>>>
57733>>>>>integer FocusInf_Array#
57733>>>>>object FocusInf_Array is an array
57735>>>>>  move self to FocusInf_Array#
57736>>>>>end_object
57737>>>>>
57737>>>>>function Focus_Find_Scoped_Parent global integer obj# returns integer
57739>>>>>  integer st#
57739>>>>>  repeat
57739>>>>>>
57739>>>>>    get scope_state of obj# to st#
57740>>>>>    ifnot st# get parent of obj# to obj#
57743>>>>>  until (st# or obj#=desktop)
57745>>>>>  function_return obj#
57746>>>>>end_function
57747>>>>>
57747>>>>>procedure Focus_Analyze_DEO global integer deo# integer itm#
57749>>>>>  integer st# file# fld# dd# tmp# scoped_parent#
57749>>>>>  send delete_data to FocusInf_Array#
57750>>>>>  if deo# gt desktop begin
57752>>>>>    set value of FocusInf_Array# item FOCUS_OK to dfTrue
57753>>>>>    set value of FocusInf_Array# item FOCUS_DEO_ID to deo#
57754>>>>>    move (Focus_Find_Scoped_Parent(deo#)) to scoped_parent#
57755>>>>>    set value of FocusInf_Array# item FOCUS_SCOPED_PARENT to scoped_parent#
57756>>>>>    if scoped_parent# begin
57758>>>>>      set value of FocusInf_Array# item FOCUS_DEO_MODAL to (modal_state(scoped_parent#))
57759>>>>>    end
57759>>>>>>
57759>>>>>    else set value of FocusInf_Array# item FOCUS_DEO_MODAL to dfFalse
57761>>>>>    get delegation_mode of deo# to st#
57762>>>>>    set delegation_mode of deo# to NO_DELEGATE_OR_ERROR
57763>>>>>    get server of deo# to dd#
57764>>>>>    get data_file  of deo# item itm# to file#
57765>>>>>    get data_field of deo# item itm# to fld#
57766>>>>>    if (file# and fld#) begin
57768>>>>>      get_attribute DF_FIELD_INDEX of file# fld# to tmp#
57771>>>>>      set value of FocusInf_Array# item FOCUS_MAIN_INDEX to tmp#
57772>>>>>    end
57772>>>>>>
57772>>>>>
57772>>>>>    set delegation_mode of deo# to st#
57773>>>>>    set value of FocusInf_Array# item FOCUS_DEO_ITEM to itm#
57774>>>>>    set value of FocusInf_Array# item FOCUS_ITEM_FILE to file#
57775>>>>>    set value of FocusInf_Array# item FOCUS_ITEM_FIELD to fld#
57776>>>>>    set value of FocusInf_Array# item FOCUS_ITEM_VALUE to (value(deo#,itm#))
57777>>>>>    if dd# begin
57779>>>>>      set value of FocusInf_Array# item FOCUS_DD to dd#
57780>>>>>      get which_data_set of dd# file# to dd#
57781>>>>>      set value of FocusInf_Array# item FOCUS_INDIRECT_DD to dd#
57782>>>>>    end
57782>>>>>>
57782>>>>>  end
57782>>>>>>
57782>>>>>end_procedure
57783>>>>>
57783>>>>>procedure Focus_Analyze_Focus global
57785>>>>>  integer focus# itm# st#
57785>>>>>  get focus of desktop to focus#
57786>>>>>  if focus# gt desktop begin
57788>>>>>    get delegation_mode of focus# to st#
57789>>>>>    set delegation_mode of focus# to NO_DELEGATE_OR_ERROR
57790>>>>>    get current_item of focus# to itm#
57791>>>>>    set delegation_mode of focus# to st#
57792>>>>>  end
57792>>>>>>
57792>>>>>  else move -1 to itm#
57794>>>>>  send Focus_Analyze_DEO focus# itm#
57795>>>>>end_procedure
57796>>>>>
57796>>>>>function Focus_Info global integer itm# returns string
57798>>>>>  function_return (value(FocusInf_Array#,itm#))
57799>>>>>end_function
57800>>>Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface)
57800>>>Use LogFile.nui  // Class for handling a log file (No User Interface)
Including file: logfile.nui    (C:\Apps\VDFQuery\AppSrc\logfile.nui)
57800>>>>>// Use LogFile.nui  // Class for handling a log file (No User Interface)
57800>>>>>//
57800>>>>>// by Sture ApS
57800>>>>>//
57800>>>>>//
57800>>>>>// This package implements the cLogFile class. An object of this class may
57800>>>>>// be used to generate output to a logfile.
57800>>>>>//
57800>>>>>// Typical application:
57800>>>>>//
57800>>>>>//   Writing detailed information to a file as a batch process progresses.
57800>>>>>//   Could also be used to log information every time the application performs
57800>>>>>//   a specific action.
57800>>>>>//
57800>>>>>// Code sample:
57800>>>>>//
57800>>>>>//   object oStructure_LogFile is a cLogFile
57800>>>>>//     set psFileName to "dfmatrix.log" // Write to this file
57800>>>>>//     set piCloseOnWrite to DFTRUE     // Close the log file on each write
57800>>>>>//     set psPurpose to "Events during table restructuring" // A little friendliness won't hurt
57800>>>>>//   end_object // oStructure_LogFile
57800>>>>>//
57800>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
57800>>>>>Use Files.nui    // Utilities for handling file related stuff
57800>>>>>Use Dates.nui    // Date manipulation for VDF
57800>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
57800>>>>>
57800>>>>>class cLogFile is a cArray
57801>>>>>  procedure construct_object integer liImg
57803>>>>>    forward send construct_object liImg
57805>>>>>    // Public
57805>>>>>    property integer piCloseOnWrite  public DFFALSE
57806>>>>>    property string  psPurpose       public ""
57807>>>>>    property integer pbANSI_State    public 1
57808>>>>>    // Private
57808>>>>>    property string  prv.psFileName  public ""
57809>>>>>    property integer prv.piChannel   public -1
57810>>>>>  end_procedure
57811>>>>>
57811>>>>>  function psFileName returns string
57813>>>>>    function_return (prv.psFileName(self))
57814>>>>>  end_function
57815>>>>>
57815>>>>>  procedure set psFileName string lsFileName
57817>>>>>    integer liExists
57817>>>>>    if (SEQ_ExtractPathFromFileName(lsFileName)="") begin
57819>>>>>      get SEQ_FileExists lsFileName to liExists
57820>>>>>      if liExists eq SEQIT_DIRECTORY error 123 "Illegal file name in cLogFile object"
57823>>>>>      else begin
57824>>>>>        if liExists eq SEQIT_NONE get SEQ_TranslatePathToAbsolute lsFileName to lsFileName
57827>>>>>        else get SEQ_ConvertToAbsoluteFileName lsFileName to lsFileName
57829>>>>>      end
57829>>>>>>
57829>>>>>    end
57829>>>>>>
57829>>>>>    set prv.psFileName to lsFileName
57830>>>>>  end_procedure
57831>>>>>
57831>>>>>            procedure DirectOutputHelp integer liAppend string lsFileName
57833>>>>>              integer liChannel liWasCreated
57833>>>>>              string lsFile
57833>>>>>              if NUM_ARGUMENTS eq 2 begin
57835>>>>>                move lsFileName to lsFile
57836>>>>>                set psFileName to lsFile
57837>>>>>              end
57837>>>>>>
57837>>>>>              else get psFileName to lsFile
57839>>>>>              if liAppend begin
57841>>>>>                move (not(SEQ_FileExists(lsFile))) to liWasCreated
57842>>>>>                get SEQ_AppendOutput lsFile to liChannel
57843>>>>>              end
57843>>>>>>
57843>>>>>              else begin
57844>>>>>                get SEQ_DirectOutput lsFile to liChannel
57845>>>>>                move 1 to liWasCreated
57846>>>>>              end
57846>>>>>>
57846>>>>>              set prv.piChannel to liChannel
57847>>>>>              if (piCloseOnWrite(self)) Close_Output channel liChannel
57851>>>>>              if liWasCreated send OnLogFileCreated
57854>>>>>              send OnLogFileOpen
57855>>>>>            end_procedure
57856>>>>>
57856>>>>>  procedure OnLogFileOpen
57858>>>>>  end_procedure
57859>>>>>  procedure OnLogFileClose
57861>>>>>  end_procedure
57862>>>>>  procedure OnLogFileCreated
57864>>>>>    string lsPurpose
57864>>>>>    get psPurpose to lsPurpose
57865>>>>>    if (lsPurpose<>"") begin
57867>>>>>      send WriteLn lsPurpose
57868>>>>>      send WriteLn (repeat("-",length(lsPurpose)))
57869>>>>>      send DoWriteTimeEntry "File created"
57870>>>>>    end
57870>>>>>>
57870>>>>>  end_procedure
57871>>>>>
57871>>>>>  procedure DeleteFile string lsFileName
57873>>>>>    string lsFile
57873>>>>>    if NUM_ARGUMENTS eq 1 move lsFileName to lsFile
57876>>>>>    else get psFileName to lsFile
57878>>>>>    get SEQ_TranslatePathToAbsolute lsFile to lsFile
57879>>>>>    erasefile lsFile
57880>>>>>>
57880>>>>>  end_procedure
57881>>>>>
57881>>>>>  procedure DirectOutput string lsFileName
57883>>>>>    if NUM_ARGUMENTS send DirectOutputHelp DFFALSE lsFileName
57886>>>>>    else send DirectOutputHelp DFFALSE (psFileName(self))
57888>>>>>  end_procedure
57889>>>>>
57889>>>>>  procedure AppendOutput string lsFileName
57891>>>>>    if NUM_ARGUMENTS send DirectOutputHelp DFTRUE lsFileName
57894>>>>>    else send DirectOutputHelp DFTRUE (psFileName(self))
57896>>>>>  end_procedure
57897>>>>>
57897>>>>>  procedure CloseOutput
57899>>>>>    send OnLogFileClose
57900>>>>>    ifnot (piCloseOnWrite(self)) send SEQ_CloseOutput (prv.piChannel(self))
57903>>>>>    else send Seq_Release_Channel (prv.piChannel(self))
57905>>>>>    set prv.piChannel to -1
57906>>>>>  end_procedure
57907>>>>>
57907>>>>>  procedure WriteLn string lsLine
57909>>>>>    integer liCloseOnWrite liChannel lbRelease liPos liOriginalCloseOnWrite
57909>>>>>    if (pbANSI_State(self)) move (StringOemToAnsi(lsLine)) to lsLine
57912>>>>>    get piCloseOnWrite to liCloseOnWrite
57913>>>>>    get prv.piChannel to liChannel
57914>>>>>
57914>>>>>    if (liChannel=-1) begin
57916>>>>>      get Seq_New_Channel to liChannel
57917>>>>>      move (TRUE) to lbRelease
57918>>>>>      move liCloseOnWrite to liOriginalCloseOnWrite
57919>>>>>      move 1 to liCloseOnWrite
57920>>>>>    end
57920>>>>>>
57920>>>>>
57920>>>>>    if liCloseOnWrite Append_Output channel liChannel (psFileName(self))
57924>>>>>    if lbRelease begin
57926>>>>>      get_channel_position liChannel to liPos
57927>>>>>>
57927>>>>>      if (liPos<=0) begin
57929>>>>>        set piCloseOnWrite to 0
57930>>>>>        set prv.piChannel to liChannel
57931>>>>>        send OnLogFileCreated
57932>>>>>        set prv.piChannel to -1
57933>>>>>        set piCloseOnWrite to liOriginalCloseOnWrite
57934>>>>>      end
57934>>>>>>
57934>>>>>    end
57934>>>>>>
57934>>>>>    writeln channel liChannel lsLine
57937>>>>>    if liCloseOnWrite Close_Output channel liChannel
57941>>>>>
57941>>>>>    if lbRelease send Seq_Release_Channel liChannel
57944>>>>>  end_procedure
57945>>>>>
57945>>>>>  procedure DoWriteTimeEntry string lsValue
57947>>>>>    if NUM_ARGUMENTS send WriteLn (TS_ConvertToString(TS_SysTime())+": "+lsValue)
57950>>>>>    else send WriteLn (TS_ConvertToString(TS_SysTime()))
57952>>>>>  end_procedure
57953>>>>>
57953>>>>>  procedure Output_Image integer liImg
57955>>>>>    integer liAuxChannel liChannel liCloseOnWrite liSeqEof lbRelease
57955>>>>>    string lsLine
57955>>>>>
57955>>>>>    get Seq_New_Channel to liAuxChannel
57956>>>>>    get piCloseOnWrite to liCloseOnWrite
57957>>>>>    get prv.piChannel to liChannel
57958>>>>>
57958>>>>>    if (liChannel=-1) begin
57960>>>>>      get Seq_New_Channel to liChannel
57961>>>>>      move (TRUE) to lbRelease
57962>>>>>      move 1 to liCloseOnWrite
57963>>>>>    end
57963>>>>>>
57963>>>>>
57963>>>>>    if liCloseOnWrite Append_Output channel liChannel (psFileName(self))
57967>>>>>
57967>>>>>    direct_input channel liAuxChannel ("image: "+string(liImg))
57969>>>>>    ifnot (SeqEof) readln channel liAuxChannel lsLine
57973>>>>>    repeat
57973>>>>>>
57973>>>>>      move (SeqEof) to liSeqEof
57974>>>>>      ifnot liSeqEof begin
57976>>>>>        writeln channel liChannel (rtrim(lsLine))
57979>>>>>        readln channel liAuxChannel lsLine
57981>>>>>      end
57981>>>>>>
57981>>>>>    until liSeqEof
57983>>>>>    close_input channel liAuxChannel
57985>>>>>
57985>>>>>    if liCloseOnWrite Close_Output channel liChannel
57989>>>>>    if lbRelease send Seq_Release_Channel liChannel
57992>>>>>
57992>>>>>    send Seq_Release_Channel liAuxChannel
57993>>>>>  end_procedure
57994>>>>>end_class // cLogFile
57995>>>>>
57995>>>Use Flist.nui
Including file: flist.nui    (C:\Apps\VDFQuery\AppSrc\flist.nui)
57995>>>>>// Use FList.nui    // A lot of FLIST- procedures and functions
57995>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
57995>>>>>Use Files.nui    // Utilities for handling file related stuff
57995>>>>>
57995>>>>>desktop_section
58000>>>>>  object oFileListStack is a cStack no_image
58002>>>>>  end_object
58003>>>>>end_desktop_section
58008>>>>>
58008>>>>>procedure FLIST_CloseAllFiles global
58010>>>>>  close DF_ALL
58011>>>>>end_procedure
58012>>>>>
58012>>>>>function FLIST_CurrentFilelist global returns string
58014>>>>>  string lsRval
58014>>>>>  get_attribute DF_FILELIST_NAME to lsRval
58017>>>>>  move (ToOem(lsRval)) to lsRval
58018>>>>>  function_return lsRval
58019>>>>>end_function
58020>>>>>
58020>>>>>procedure FLIST_SetCurrentFilelist global string lsFileName
58022>>>>>  set_attribute DF_FILELIST_NAME to (ToAnsi(lsFileName))
58025>>>>>end_procedure
58026>>>>>
58026>>>>>procedure FLIST_SetOpenPath global string lsPath
58028>>>>>  set_attribute DF_OPEN_PATH to (ToAnsi(lsPath))
58031>>>>>end_procedure
58032>>>>>
58032>>>>>procedure FLIST_PushCurrentFilelist global
58034>>>>>  send Push.s to (oFileListStack(self)) (FLIST_CurrentFilelist())
58035>>>>>end_procedure
58036>>>>>procedure FLIST_PopCurrentFilelist global
58038>>>>>  send FLIST_CloseAllFiles
58039>>>>>  send FLIST_SetCurrentFilelist (sPop(oFileListStack(self)))
58040>>>>>end_procedure
58041>>>>>
58041>>>>>function FLIST_CurrentFileListFolder global returns string
58043>>>>>  string lsFileList lsFolder
58043>>>>>  get FLIST_CurrentFilelist to lsFileList
58044>>>>>  if (lsFileList<>SEQ_RemovePathFromFileName(lsFileList)) function_return (SEQ_ExtractPathFromFileName(lsFileList))
58047>>>>>  get SEQ_FindFileAlongDFPath lsFileList to lsFolder
58048>>>>>  function_return lsFolder
58049>>>>>end_function
58050>>>>>
58050>>>>>// Find an empty entry in filelist cfg, that is not temporarily used
58050>>>>>// by an "open as" statement. Start the search at entry liFile + 1.
58050>>>>>function FLIST_TemporaryEntry global integer liFile returns integer
58052>>>>>  integer lbOpened
58052>>>>>  repeat
58052>>>>>>
58052>>>>>    get_attribute DF_FILE_NEXT_EMPTY of liFile to liFile
58055>>>>>    if liFile begin
58057>>>>>      get_attribute DF_FILE_OPENED of liFile to lbOpened
58060>>>>>      ifnot lbOpened function_return liFile
58063>>>>>    end
58063>>>>>>
58063>>>>>  until liFile eq 0
58065>>>>>  function_return -1
58066>>>>>end_function
58067>>>>>
58067>>>>>// Returns DFTRUE if a filelist.cfg was created OK.
58067>>>>>function FLIST_CreateEmptyFileList global string lsFileListPathAndName returns integer
58069>>>>>  integer liCount liOrg liChannel
58069>>>>>  string lsFiller
58069>>>>>  send FLIST_PushCurrentFilelist // Remember who we where.
58070>>>>>  send FLIST_CloseAllFiles       // Close all files just in case.
58071>>>>>  get SEQ_DirectOutput ("binary:"+lsFileListPathAndName) to liChannel
58072>>>>>
58072>>>>>  if (liChannel>=0) begin
58074>>>>>    if 1 begin
58076>>>>>      get_argument_size To liOrg      // Create the filelist. It has to be of size
58077>>>>>      set_argument_size 524277        // 32128, if it is any smaller errors occur
58078>>>>>>
58078>>>>>      pad "" To lsFiller 524277       // when setting the filelist attributes.
58080>>>>>>
58080>>>>>      move (repeat(character(0),524277)) to lsFiller
58081>>>>>      write "filelist.cfg"            // This has to be the first 13 characters
58082>>>>>      write lsFiller                  //
58083>>>>>      send SEQ_CloseOutput liChannel
58084>>>>>      set_argument_size liOrg         // Restore max argument size.
58085>>>>>>
58085>>>>>//      set_attribute DF_FILELIST_NAME To lsFileListPathAndName // Setup the file list for DataFlex.
58085>>>>>      send FLIST_SetCurrentFilelist lsFileListPathAndName
58086>>>>>
58086>>>>>      set_attribute DF_FILE_ROOT_NAME    of 4095 to "temp"
58089>>>>>      set_attribute DF_FILE_LOGICAL_NAME of 4095 to "temp"
58092>>>>>      set_attribute DF_FILE_DISPLAY_NAME of 4095 to "temp"
58095>>>>>      set_attribute DF_FILE_ROOT_NAME    of 4095 to ""
58098>>>>>      set_attribute DF_FILE_LOGICAL_NAME of 4095 to ""
58101>>>>>      set_attribute DF_FILE_DISPLAY_NAME of 4095 to ""
58104>>>>>
58104>>>>>      set_attribute DF_FILE_ROOT_NAME    of 50 to "flexerrs"
58107>>>>>      set_attribute DF_FILE_LOGICAL_NAME of 50 to "FLEXERRS"
58110>>>>>      set_attribute DF_FILE_DISPLAY_NAME of 50 to "@DataFlex Error File"
58113>>>>>
58113>>>>>    //for liCount from 1 to 250                               // Fill the filelist.
58113>>>>>    //  set_attribute DF_FILE_ROOT_NAME    of liCount to ""   // Every slot must be
58113>>>>>    //  set_attribute DF_FILE_LOGICAL_NAME of liCount to ""   // emptied out. Otherwise
58113>>>>>    //  set_attribute DF_FILE_DISPLAY_NAME of liCount to ""   // the API thinks some of
58113>>>>>    //loop                                                    // the slots are used.
58113>>>>>    end
58113>>>>>>
58113>>>>>    else begin
58114>>>>>      get_argument_size To liOrg      // Create the filelist. It has to be of size
58115>>>>>      set_argument_size 32117         // 32128, if it is any smaller errors occur
58116>>>>>>
58116>>>>>      pad "" To lsFiller 32117        // when setting the filelist attributes.
58118>>>>>>
58118>>>>>      write "filelist.cfg"            // This has to be the first 13 characters
58119>>>>>      write lsFiller                  //
58120>>>>>      send SEQ_CloseOutput liChannel
58121>>>>>      set_argument_size liOrg         // Restore max argument size.
58122>>>>>>
58122>>>>>      set_attribute DF_FILELIST_NAME To lsFileListPathAndName // Setup the file list for DataFlex.
58125>>>>>      for liCount from 1 to 250                               // Fill the filelist.
58131>>>>>>
58131>>>>>        set_attribute DF_FILE_ROOT_NAME    of liCount to ""   // Every slot must be
58134>>>>>        set_attribute DF_FILE_LOGICAL_NAME of liCount to ""   // emptied out. Otherwise
58137>>>>>        set_attribute DF_FILE_DISPLAY_NAME of liCount to ""   // the API thinks some of
58140>>>>>      loop                                                    // the slots are used.
58141>>>>>>
58141>>>>>    end
58141>>>>>>
58141>>>>>    send FLIST_PopCurrentFilelist   // Restore current filelist.
58142>>>>>    function_return (SEQ_FileExists(lsFileListPathAndName)=SEQIT_FILE)
58143>>>>>  end
58143>>>>>>
58143>>>>>  else function_return 0
58145>>>>>end_function
58146>>>>>
58146>>>>>enumeration_list
58146>>>>>  define FLINFO_SIZE_BYTES     // Filesize of filelist.cfg (bytes)
58146>>>>>  define FLINFO_SIZE_ENTRIES   // Max number of entries in filelist.cfg
58146>>>>>  define FLINFO_LT_256         // Is this a (lt) 256 version (bool)
58146>>>>>end_enumeration_list
58146>>>>>
58146>>>>>function FLIST_Information global integer liWhat returns integer
58148>>>>>  integer liRval
58148>>>>>  string lsPath lsFileList
58148>>>>>
58148>>>>>  move -1 to liRval
58149>>>>>
58149>>>>>  if (liWhat=FLINFO_SIZE_BYTES) begin
58151>>>>>    get FLIST_CurrentFilelist to lsFileList
58152>>>>>    get SEQ_FileSize lsFileList to liRval
58153>>>>>  end
58153>>>>>>
58153>>>>>  if (liWhat=FLINFO_LT_256) begin
58155>>>>>    get FLIST_Information FLINFO_SIZE_BYTES to liRval
58156>>>>>    move (liRval<=32768) to liRval
58157>>>>>  end
58157>>>>>>
58157>>>>>  if (liWhat=FLINFO_SIZE_ENTRIES) begin
58159>>>>>    get FLIST_Information FLINFO_SIZE_BYTES to liRval
58160>>>>>    move (liRval/128-1) to liRval
58161>>>>>  end
58161>>>>>>
58161>>>>>  function_return liRval
58162>>>>>end_function
58163>>>>>
58163>>>>>procedure FLIST_Make4095 global
58165>>>>>  if (FLIST_Information(FLINFO_LT_256)) begin
58167>>>>>    set_attribute DF_FILE_ROOT_NAME    of 4095 to "temp"
58170>>>>>    set_attribute DF_FILE_LOGICAL_NAME of 4095 to "temp"
58173>>>>>    set_attribute DF_FILE_DISPLAY_NAME of 4095 to "temp"
58176>>>>>    set_attribute DF_FILE_ROOT_NAME    of 4095 to ""
58179>>>>>    set_attribute DF_FILE_LOGICAL_NAME of 4095 to ""
58182>>>>>    set_attribute DF_FILE_DISPLAY_NAME of 4095 to ""
58185>>>>>  end
58185>>>>>>
58185>>>>>end_procedure
58186>>>Use WsFunctions.pkg // Workspace functions encapsulated in WsFunctions object (VdfQueryLib)
Including file: WsFunctions.pkg    (C:\Apps\VDFQuery\AppSrc\WsFunctions.pkg)
58186>>>>>// Use WsFunctions.pkg // Workspace functions encapsulated in WsFunctions object (VdfQuery)
58186>>>>>
58186>>>>>Use VdfBase.pkg // DAW package, provides low level support expected of all VDF applications (windows and webapp)
58186>>>>>Use cRegistry.pkg // DAW package, provides access to the Windows system Registry
58186>>>>>
58186>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
58186>>>>>
58186>>>>>Desktop_Section
58191>>>>>
58191>>>>>        Object oWsSelector is a ModalPanel
58193>>>>>            Set Location to 4 13
58194>>>>>            Set size to 254 319
58195>>>>>            Set piMinSize to 254 319
58196>>>>>            Set label to "Work space selector"
58197>>>>>            Set Border_Style to Border_Thick
58198>>>>>            
58198>>>>>            Property Boolean pbAccept
58200>>>>>            On_Key kCancel Send close_panel
58201>>>>>            
58201>>>>>            Procedure AcceptPanel
58204>>>>>                Set pbAccept to True
58205>>>>>                Send close_panel
58206>>>>>            End_Procedure
58207>>>>>            
58207>>>>>            Object oTextBox is a TextBox
58209>>>>>                Set Size to 50 14
58210>>>>>                Set Location to 14 27
58211>>>>>                Set Label to "Currently selected workspace:"
58212>>>>>            End_Object
58213>>>>>            Object oForm is a Form
58215>>>>>                Set Size to 14 267
58216>>>>>                Set Location to 28 24
58217>>>>>                Set peAnchors to anTopLeftRight
58218>>>>>                Set Enabled_State to False
58219>>>>>            End_Object
58220>>>>>            Object oList is a List
58222>>>>>                Set Size to 156 267
58223>>>>>                Set Location to 46 24
58224>>>>>                Set peAnchors to anAll
58225>>>>>                Set Select_Mode to Auto_Select
58226>>>>>                On_Key kEnter Send AcceptPanel
58227>>>>>                Procedure DoFillList String[] aValues
58230>>>>>                    Integer iMax iItm
58230>>>>>                    Send delete_data
58231>>>>>                    Move (SizeOfArray(aValues)) to iMax
58232>>>>>                    Decrement iMax
58233>>>>>                    For iItm from 0 to iMax
58239>>>>>>
58239>>>>>                        Send add_item MSG_None aValues[iItm]
58240>>>>>                    Loop
58241>>>>>>
58241>>>>>                End_Procedure
58242>>>>>                Procedure Mouse_Click Integer iWindowNumber Integer iPosition // Sent on mouse double click.
58245>>>>>                    Send AcceptPanel
58246>>>>>                End_Procedure
58247>>>>>            End_Object
58248>>>>>            Object oButton1 is a Button
58250>>>>>                Set Location to 209 176
58251>>>>>                Set Label to "Select"
58252>>>>>                Set peAnchors to anBottomRight
58253>>>>>                Procedure OnClick
58256>>>>>                    Send AcceptPanel
58257>>>>>                End_Procedure
58258>>>>>            End_Object
58259>>>>>            Object oButton2 is a Button
58261>>>>>                Set Location to 209 240
58262>>>>>                Set Label to "Cancel"
58263>>>>>                Set peAnchors to anBottomRight
58264>>>>>                Procedure OnClick
58267>>>>>                    Send close_panel
58268>>>>>                End_Procedure
58269>>>>>            End_Object
58270>>>>>            
58270>>>>>            Function SelectSwsFile String[] aValues String sCurrent Returns String
58273>>>>>                String sRval
58273>>>>>                Set pbAccept to False
58274>>>>>                Set value of oForm to sCurrent
58275>>>>>                Send DoFillList of oList aValues
58276>>>>>                Send popup
58277>>>>>                If (pbAccept(Self)) Begin
58279>>>>>                    Get value of oList (Current_Item(oList)) to sRval
58280>>>>>                End
58280>>>>>>
58280>>>>>                Function_Return sRval
58281>>>>>            End_Function
58282>>>>>        End_Object // oWsSelector
58283>>>>>
58283>>>>>    Object WsFunctions is a cObject
58285>>>>>        Object oRecentWs is a cRegistry // Private
58287>>>>>            Set phRootKey to HKEY_CURRENT_USER
58288>>>>>        End_Object
58289>>>>>        
58289>>>>>        //> The VDF studio stores its "Recent Workspaces" list in the Windows registry. Use the ReadRegistryRecentWorkSpaces 
58289>>>>>        //> procedure to dig them out.
58289>>>>>        Procedure ReadRegistryRecentWorkSpaces String[] ByRef aValues
58292>>>>>            Boolean bOpen
58292>>>>>            Handle hoArray
58292>>>>>            Integer iMaxKey iKey
58292>>>>>            String sKey
58292>>>>>            Move (ResizeArray(aValues,0)) to aValues
58293>>>>>            Get OpenKey of oRecentWs "Software\Data Access Worldwide\Visual DataFlex Tools\12.0\Studio\RecentWorkspaces" to bOpen
58294>>>>>            If (bOpen) Begin
58296>>>>>                Get Create U_Array to hoArray // Create an array object
58297>>>>>                Get GetValues of oRecentWs hoArray to iMaxKey
58298>>>>>                Decrement iMaxKey
58299>>>>>                For iKey from 0 to iMaxKey
58305>>>>>>
58305>>>>>                    Get value of hoArray iKey to sKey
58306>>>>>                    Get ReadString of oRecentWs sKey to aValues[iKey]
58307>>>>>                Loop
58308>>>>>>
58308>>>>>                Send destroy of hoArray // Remove the array object from memory.
58309>>>>>            End
58309>>>>>>
58309>>>>>        End_Procedure
58310>>>>>
58310>>>>>        //> Returns a handle to cWorkSpace object currently in action.
58310>>>>>        Function WorkSpaceObject Returns Handle
58313>>>>>            Handle hRval
58313>>>>>            Move 0 to hRval
58314>>>>>            If (ghoApplication>=0) Begin
58316>>>>>                Get phoWorkspace of ghoApplication to hRval
58317>>>>>            End
58317>>>>>>
58317>>>>>            Function_Return hRval
58318>>>>>        End_Function
58319>>>>>
58319>>>>>        //> Returns the name (incl. full path) of the .ws file currently used.
58319>>>>>        Function WorkSpaceFile Returns String
58322>>>>>            Handle hoWs
58322>>>>>            String sFile
58322>>>>>            Get WorkSpaceObject to hoWs
58323>>>>>            If (hoWs>0) Begin
58325>>>>>                Get psWorkspaceWSFile of hoWs to sFile
58326>>>>>            End
58326>>>>>>
58326>>>>>            Else Begin
58327>>>>>                Move "" to sFile
58328>>>>>            End
58328>>>>>>
58328>>>>>            Function_Return sFile
58329>>>>>        End_Function
58330>>>>>
58330>>>>>        //> Use this function to calculate the absolute path of the .ws file corresponding to the abslute path of a .sws file given as parameter.
58330>>>>>        Function SwsFileToWsFile String sSwsFile Returns String
58333>>>>>            Boolean bStop
58333>>>>>            //Integer iChannel
58333>>>>>            Handle hoIniFile
58333>>>>>            String sWsFile sLine
58333>>>>>
58333>>>>>            Get Create U_cIniFile To hoIniFile
58334>>>>>
58334>>>>>            Set psFilename of hoIniFile To sSwsFile
58335>>>>>            Get ReadString of hoIniFile "WorkspacePaths" "ConfigFile" "" To sWsFile
58336>>>>>            Send Destroy of hoIniFile // destroy dynaically created inifile object
58337>>>>>
58337>>>>>            If (left(sWsFile,2)=".\") Begin // If that's not the case we assume that the path is absolute. (Maybe someday it is necessary to take "..\" into account also).
58339>>>>>                Move (Remove(swsFile,1,2)) to sWsFile // Remove the first two characters
58340>>>>>                
58340>>>>>                Get SEQ_ExtractPathFromFileName sSwsFile to sSwsFile // "C:\Apps\VdfQueryLib\VDFQueryLib.sws" -> "C:\Apps\VdfQueryLib"
58341>>>>>                Get Files_AppendPath sSwsFile sWsFile to sWsFile
58342>>>>>            End
58342>>>>>>
58342>>>>>            Function_Return sWsFile
58343>>>>>        End_Function
58344>>>>>
58344>>>>>        //> Function OpenWorkspace takes a .sws or .ws file and calls the "OpenWorkSpaceFile" method of the current cWorkSpace object. The return
58344>>>>>        //> value is one of the following:
58344>>>>>        //>     -1                      : cWorkSpace object not found
58344>>>>>        //>     wsWorkspaceOpened       : WS opened ok
58344>>>>>        //>     wsWorkspaceNotFound     : the named WS was not found in the global list
58344>>>>>        //>     wsWorkspaceFileNotFound : the WS file was not found
58344>>>>>        //>     wsDataPathEmpty         : the DataPath entry was empty
58344>>>>>        //>     wsFileListEmpty         : The FileList entry was empty
58344>>>>>        //>     wsFileListNotExist      : The FileList.cfg file could not be found
58344>>>>>        Function OpenWorkspace String sFile Returns Integer
58347>>>>>            Handle hoWs
58347>>>>>            Integer iRval
58347>>>>>            Get WorkSpaceObject to hoWs
58348>>>>>            If (hoWs>=0) Begin
58350>>>>>                If (lowercase(right(sFile,4))=".sws") Get SwsFileToWsFile sFile to sFile
58353>>>>>                Get OpenWorkspaceFile of hoWs sFile to iRval
58354>>>>>            End
58354>>>>>>
58354>>>>>            Function_Return iRval
58355>>>>>        End_Function
58356>>>>>
58356>>>>>        Function OpenWorkspaceErrorText integer iReturnValue returns string
58359>>>>>            if (iReturnValue=-1)                      function_return "cWorkSpace object not found"
58362>>>>>            if (iReturnValue=wsWorkspaceOpened)       function_return "WS opened ok"
58365>>>>>            if (iReturnValue=wsWorkspaceNotFound)     function_return "The named WS was not found in the global list"
58368>>>>>            if (iReturnValue=wsWorkspaceFileNotFound) function_return "The WS file was not found"
58371>>>>>            if (iReturnValue=wsDataPathEmpty)         function_return "The DataPath entry was empty"
58374>>>>>            if (iReturnValue=wsFileListEmpty)         function_return "The FileList entry was empty"
58377>>>>>            if (iReturnValue=wsFileListNotExist)      function_return "'FileList.cfg' file could not be found"
58380>>>>>            function_return ""
58381>>>>>        End_Function
58382>>>>>
58382>>>>>            Function SelectRecentWorkspaceFile Returns String
58385>>>>>                String sSwsFile sWsFile
58385>>>>>                String[] aValues
58386>>>>>                Send ReadRegistryRecentWorkSpaces (&aValues)
58387>>>>>                Get SelectSwsFile of oWsSelector aValues (WorkSpaceFile(Self)) to sSwsFile
58388>>>>>                Function_Return sSwsFile
58389>>>>>            End_Function
58390>>>>>    End_Object
58391>>>>>End_Desktop_Section
58396>>>
58396>>>define app.DFMatrix.Title   for "The DataFlex Matrix"
58396>>>define app.DFMatrix.Version for "DFM10.0/FDX2.0"
58396>>>
58396>>>procedure DFMatrix_Create_FDX global
58398>>>  send fdx.entry_create_empty 0 // Primary FDX object
58399>>>  send fdx.entry_create_empty 1 // Secondary FDX object
58400>>>  set piFDX_Server of (oFdxSetOfFields(self))     to (fdx.object_id(0))
58401>>>  set piFDX_Server of (oFdxSetOfTables(self))     to (fdx.object_id(0))
58402>>>  set piFDX_Server of (oFdxSetOfIndices(self))    to (fdx.object_id(0))
58403>>>  set piFDX_Server of (oAuxFdxSetOfFields(self))  to (fdx.object_id(0))
58404>>>  set piFDX_Server of (oAuxFdxSetOfTables(self))  to (fdx.object_id(0))
58405>>>  set piFDX_Server of (oAuxFdxSetOfIndices(self)) to (fdx.object_id(0))
58406>>>end_procedure
58407>>>send DFMatrix_Create_FDX
58408>>>
58408>>>//send fdx.open_file 0 "lws.fdx"
58408>>>//send fdx.open_file 1 "multi.fdx"
58408>>>
58408>>>enumeration_list // Who are you's
58408>>>  define WAY_GLOBAL_ATTRIBUTES_VW
58408>>>  define WAY_TABLE_SELECTOR_VW
58408>>>  define WAY_TABLE_DEFINITION_VW
58408>>>  define WAY_DIRECTORY_CONTENTS_VW
58408>>>  define WAY_SET_OF_TABLES_VW
58408>>>  define WAY_SET_OF_FIELDS_VW
58408>>>  define WAY_SET_OF_INDICES_VW
58408>>>end_enumeration_list
58408>>>
58408>>>object oDFMatrixViewPanels is a cArray no_image
58410>>>  property integer piCurrentFileInSelector public 0
58412>>>  property integer piWorkSpaceLoaded       public 0
58414>>>  property string  psCurrentWorkSpace      public "no workspace"
58416>>>  procedure add_row integer who_are_you# integer obj#
58419>>>    set value item who_are_you# to obj#
58420>>>  end_procedure
58421>>>end_object
58422>>>
58422>>>function DFMatrix_WorkSpaceLoaded global returns integer
58424>>>  function_return (piWorkSpaceLoaded(oDFMatrixViewPanels(self)))
58425>>>end_function
58426>>>function DFMatrix_CurrentWorkSpace global returns string
58428>>>  if (DFMatrix_WorkSpaceLoaded()) function_return (psCurrentWorkSpace(oDFMatrixViewPanels(self)))
58431>>>  function_return ""
58432>>>end_function
58433>>>
58433>>>procedure DFMatrix_Vw_Register global integer who_are_you# integer obj#
58435>>>  send add_row to (oDFMatrixViewPanels(self)) who_are_you# obj#
58436>>>end_procedure
58437>>>function DFMatrix_Vw_Object_ID global integer who_are_you# returns integer
58439>>>  function_return (value(oDFMatrixViewPanels(self),who_are_you#))
58440>>>end_function
58441>>>function DFMatrix_SelectorObject global returns integer
58443>>>  integer vw#
58443>>>  move (DFMatrix_Vw_Object_ID(WAY_TABLE_SELECTOR_VW)) to vw#
58444>>>  function_return (oLst(vw#))
58445>>>end_function
58446>>>procedure DFMatrix_NewFileInSelector global integer file#
58448>>>  set piCurrentFileInSelector of (oDFMatrixViewPanels(self)) to file#
58449>>>  send OnChangeFdxFile to (DFMatrix_Vw_Object_ID(WAY_TABLE_DEFINITION_VW))
58450>>>end_procedure
58451>>>procedure DFMatrix_CallBack_Selected_Files global integer msg# integer obj# integer selected# integer shaded# integer tmp#
58453>>>  integer oLst# master#
58453>>>  if num_arguments gt 4 move tmp# to master#
58456>>>  else move 0 to master#
58458>>>  get DFMatrix_SelectorObject to oLst#
58459>>>  send Callback_General to oLst# msg# obj# selected# shaded# master#
58460>>>end_procedure
58461>>>// (Probably) used by display definition view
58461>>>function DFMatrix_Current_File global returns integer
58463>>>  function_return (piCurrentFileInSelector(oDFMatrixViewPanels(self)))
58464>>>end_function
58465>>>
58465>>>function sFdxTitle.i global integer lhFDX returns string
58467>>>  string str#
58467>>>  if (piDataOrigin(lhFDX)) eq FDX_EMPTY move "(empty)" to str#
58470>>>  else begin
58471>>>    if (piDataOrigin(lhFDX)) eq FDX_REAL_WORLD begin
58473>>>      if (psFileName(lhFDX)<>"") move ("current ("+psFileName(lhFDX)+")") to str#
58476>>>      else move "Current" to str#
58478>>>    end
58478>>>>
58478>>>    else begin
58479>>>      if (psTitle(lhFDX)<>"") move (psTitle(lhFDX)+" ("+psFileName(lhFDX)+")") to str#
58482>>>      else move (psFileName(lhFDX)) to str#
58484>>>    end
58484>>>>
58484>>>  end
58484>>>>
58484>>>  function_return str#
58485>>>end_function
58486>>>
58486>>>function DFMatrix_RealDataPrimary global returns integer
58488>>>  integer lhFDX
58488>>>  move (fdx.object_id(0)) to lhFDX
58489>>>  function_return (piDataOrigin(lhFDX)=FDX_REAL_WORLD)
58490>>>end_function
58491>>>
58491>>>procedure DFMatrix_Update_App_Title global
58493>>>  integer lhFDX
58493>>>  string str#
58493>>>  move (fdx.object_id(0)) to lhFDX
58494>>>  if (piDataOrigin(lhFDX)) eq FDX_EMPTY move " (empty)" to str#
58497>>>  else begin
58498>>>    if (piDataOrigin(lhFDX)) eq FDX_REAL_WORLD begin
58500>>>      if (psFileName(lhFDX)<>"") move (", current ("+psFileName(lhFDX)+")") to str#
58503>>>      else move " (current)" to str#
58505>>>    end
58505>>>>
58505>>>    else begin
58506>>>      if (psTitle(lhFDX)<>"") move (", "+psTitle(lhFDX)+" ("+psFileName(lhFDX)+")") to str#
58509>>>      else move (" ("+psFileName(lhFDX)+")") to str#
58511>>>    end
58511>>>>
58511>>>  end
58511>>>>
58511>>>  set DFMatrix_App_Label to (app.dfMatrix.Title+", "+psCurrentWorkSpace(oDFMatrixViewPanels(self))+str#)
58512>>>end_procedure
58513>>>
58513>>>Procedure DFMatrix_Select_FileList
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
58515>>>  string lsFilelist lsPath
58515>>>
58515>>>  get SEQ_SelectFile "Open FILELIST.CFG" "filelist.cfg|filelist.cfg|*.cfg|*.CFG" to lsFileList
58516>>>  if (lsFileList<>"") begin
58518>>>    get SEQ_ExtractPathFromFileName lsFileList to lsPath
58519>>>    send FLIST_SetOpenPath lsPath
58520>>>    send FLIST_SetCurrentFilelist lsFileList
58521>>>    set psCurrentWorkSpace of (oDFMatrixViewPanels(self)) to lsFilelist
58522>>>    set piWorkSpaceLoaded of (oDFMatrixViewPanels(self)) to DFFALSE
58523>>>    send DFMatrix_CloseAll
58524>>>    send DFMatrix_PrimaryOpenCurrentFilelist
58525>>>  end
58525>>>>
58525>>>end_procedure
58526>>>
58526>>>  Use SelectWorkspace.dg
Including file: SelectWorkspace.dg    (c:\VDF12\Pkg\SelectWorkspace.dg)
58526>>>>>// Register all objects
58526>>>>>Register_Object oBrowse
58526>>>>>Register_Object oCancel
58526>>>>>Register_Object oCurrentWorkspace
58526>>>>>Register_Object oCurrentWorkspace_lb
58526>>>>>Register_Object oDescription
58526>>>>>Register_Object oHelp
58526>>>>>Register_Object oImages
58526>>>>>Register_Object oIni
58526>>>>>Register_Object oLineControl2
58526>>>>>Register_Object oName
58526>>>>>Register_Object oOpenDialog
58526>>>>>Register_Object oOrderBy
58526>>>>>Register_Object oSections
58526>>>>>Register_Object oSelect
58526>>>>>Register_Object oSelectedWorkspace
58526>>>>>Register_Object oSelectNewWorkspace_lb
58526>>>>>Register_Object oSelectWorkspace
58526>>>>>Register_Object oWorkspaces
58526>>>>>Register_Object oWorkspacesList
58526>>>>>
58526>>>>>
58526>>>>>
58526>>>>>//  Returns 0 if user press cancel
58526>>>>>//  Returns 1 if a new WS was created
58526>>>>>//
58526>>>>>External_Function32 StartDFWSWizard "StartDFWSWizard" DFWSWIZ.DLL Handle MyHnd Returns Integer
58527>>>>>
58527>>>>>// Change types Supported.
58527>>>>>Enum_list
58527>>>>>   Define WSNotChanged    // no change that we know of
58527>>>>>   Define WSNewWorkSpace  // selected New WS, No known editing
58527>>>>>   Define WSModified      // We may have edited, should be reinitialized
58527>>>>>End_Enum_list
58527>>>>>
58527>>>>>Procedure SetCurrentUserWorkspace GLOBAL String sWorkspace
58529>>>>>    Handle hoRegistry
58529>>>>>    Integer iError
58529>>>>>
58529>>>>>    Get Create U_cRegistry To hoRegistry
58530>>>>>
58530>>>>>    Get CreateKey of hoRegistry "SOFTWARE\Data Access Worldwide\Visual DataFlex\12.0\Workspaces" To iError
58531>>>>>    If (iError =0) Begin
58533>>>>>        Send WriteString of hoRegistry "Current Workspace" sWorkspace
58534>>>>>        Send CloseKey of hoRegistry
58535>>>>>    End
58535>>>>>>
58535>>>>>
58535>>>>>    Send Destroy of hoRegistry
58536>>>>>End_Procedure
58537>>>>>
58537>>>>>Function GetCurrentUserWorkspace GLOBAL Returns String
58539>>>>>    Handle hoRegistry
58539>>>>>    String sWorkspace
58539>>>>>    Boolean bOpened
58539>>>>>
58539>>>>>    Get Create U_cRegistry To hoRegistry
58540>>>>>
58540>>>>>    Get OpenKey of hoRegistry "SOFTWARE\Data Access Worldwide\Visual DataFlex\12.0\Workspaces" To bOpened
58541>>>>>    If bOpened Begin
58543>>>>>        If (ValueExists(hoRegistry, "Current Workspace")) Get ReadString of hoRegistry "Current Workspace" To sWorkspace
58546>>>>>        Send CloseKey of hoRegistry
58547>>>>>    End
58547>>>>>>
58547>>>>>
58547>>>>>    Send Destroy of hoRegistry
58548>>>>>    Function_Return sWorkspace
58549>>>>>End_Function
58550>>>>>
58550>>>>>
58550>>>>>Use Windows.pkg
58550>>>>>Use DfTreeVw.pkg
58550>>>>>Use dfRadio.pkg
Including file: Dfradio.pkg    (c:\VDF12\Pkg\Dfradio.pkg)
58550>>>>>>>Use windows.pkg // this now lives here. (you don't need to ever use this). 
58550>>>>>>>
58550>>>>>Use DfLine.Pkg
58550>>>>>Use File_dlg.Pkg
58550>>>>>
58550>>>>>
58550>>>>>
58550>>>>>Object oSelectWorkspace is a ModalPanel
58552>>>>>
58552>>>>>    On_Key kCancel Send Close_Panel
58553>>>>>    Property Integer pbSortByName True
58555>>>>>    
58555>>>>>    Property String  psWorkspaceSelected // what is the Name of the newly-selected Workspace
58557>>>>>    Property String  psOriginalWorkspace // what was the Name of Workspace when the dialog was displayed?
58559>>>>>    Property Boolean pbChangeSystemCurrent
58561>>>>>    Property Boolean pbResult
58563>>>>>    Property String  psCurrentWorkspaceDescription // description of Current Workspace at start of dialog
58565>>>>>    
58565>>>>>    Set Locate_Mode To CENTER_ON_SCREEN
58566>>>>>    
58566>>>>>    Object oWorkspacesList is an Array
58568>>>>>        Procedure DoAddWorkspace String sName String sDescription String sPath
58571>>>>>            Set Value (Item_Count(self)) To sName
58572>>>>>            Set Value (Item_Count(self)) To sDescription
58573>>>>>            Set Value (Item_Count(self)) To sPath
58574>>>>>        End_Procedure
58575>>>>>    End_Object
58576>>>>>    
58576>>>>>    Function GetVdfRootDir Returns String
58579>>>>>        String sVdfRootDir
58579>>>>>    
58579>>>>>        Get_Profile_String "Defaults" "VDFRootDir" To sVDFRootDir
58582>>>>>        If (Right(sVDFRootDir,1) = "\") Begin
58584>>>>>            Left sVDFRootDir To sVDFRootDir (Length(sVDFRootDir)-1)
58586>>>>>>
58586>>>>>        End
58586>>>>>>
58586>>>>>    
58586>>>>>        Function_Return sVdfRootDir
58587>>>>>    End_Function
58588>>>>>    
58588>>>>>
58588>>>>>    Set Border_Style to Border_Thick
58589>>>>>    Set Minimize_Icon to FALSE
58590>>>>>    Set Label to "C_$SelectWorkspace"
58591>>>>>    Set Location to 2 3
58592>>>>>    Set Size to 244 275
58593>>>>>    Set piMinSize to 244 275
58594>>>>>
58594>>>>>
58594>>>>>
58594>>>>>
58594>>>>>    Object oImages is a cImageList
58596>>>>>
58596>>>>>        //Set Focus_Mode To NonFocusable
58596>>>>>
58596>>>>>
58596>>>>>        Procedure OnCreate
58599>>>>>            Integer iVoid
58599>>>>>             Get AddTransparentImage "WorkspaceSelector.bmp" clFuchsia To iVoid
58600>>>>>        End_Procedure
58601>>>>>
58601>>>>>    End_Object    // oImages
58602>>>>>
58602>>>>>    Object oWorkspaces is a TreeView
58604>>>>>
58604>>>>>        Set TreeSortedState To True
58605>>>>>        
58605>>>>>        
58605>>>>>        Procedure DoShowWorkspaces
58608>>>>>            Integer iVOid iWorkspace
58608>>>>>            Handle hoSections
58608>>>>>            String sWorkspace sDescription sPath
58608>>>>>        
58608>>>>>            Move oSections To hoSections
58609>>>>>        
58609>>>>>            Send DoDeleteItem 0 // remove all items
58610>>>>>        
58610>>>>>            Send Delete_Data of hoSections
58611>>>>>            Send Delete_Data of oWorkspacesList // remove list of Names&Descriptions
58612>>>>>        
58612>>>>>            Object oIni is a cIniFile
58614>>>>>                // JVH - [VDF 8.3] cIniFile does not currently support delegation so
58614>>>>>                // the call to GetVdfRootDir must explicitly delegate to oSelectWorkspaces
58614>>>>>                // Set psFilename To (GetVdfRootDir(Self) +"\bin\Workspaces.ini")
58614>>>>>                Set psFilename To (GetVdfRootDir(oSelectWorkspace) + "\bin\Workspaces.ini")
58615>>>>>        
58615>>>>>                Send ReadSections hoSections
58616>>>>>        
58616>>>>>                For iWorkspace from 0 to (Item_Count(hoSections) -1)
58622>>>>>>
58622>>>>>                    Get Value of hoSections iWorkspace To sWorkspace
58623>>>>>                    Get ReadString sWorkspace "Description" "" To sDescription
58624>>>>>                    Get ReadString sWorkspace "Path" ""        To sPath
58625>>>>>        
58625>>>>>                    // JVH - [VDF 8.3] cIniFile does not currently support delegation so
58625>>>>>                    // the we must explicitly delegate to oSelectWorkspaces
58625>>>>>                    If (Uppercase(sWorkspace) = Uppercase(psOriginalWorkspace(oSelectWorkspace))) Set psCurrentWorkspaceDescription of oSelectWorkspace To sDescription
58628>>>>>        
58628>>>>>                    Send DoAddWorkspace of oWorkspacesList sWorkspace sDescription sPath // store the Name, Description & Path
58629>>>>>        
58629>>>>>                    If (pbSortByName(parent(self))) Delegate Get AddHierarchy 0 sWorkspace   To iVoid
58633>>>>>                    Else                            Delegate Get AddHierarchy 0 sDescription To iVoid
58636>>>>>                Loop
58637>>>>>>
58637>>>>>            End_Object
58638>>>>>        
58638>>>>>            Send Destroy of oIni
58639>>>>>        
58639>>>>>            Send DoShowCurrentWorkspace of oCurrentWorkspace
58640>>>>>        End_Procedure  // DoShowWorkspaces
58641>>>>>        
58641>>>>>        
58641>>>>>        Set ImageListObject To (oImages(self))
58642>>>>>        
58642>>>>>        Function IsWorkspace Handle hItem Returns Integer
58645>>>>>            Function_Return (ItemChildCount(self, hItem) =0)
58646>>>>>        End_Function
58647>>>>>        
58647>>>>>        Procedure OnCreateTree
58650>>>>>            Send DoShowWorkspaces
58651>>>>>        End_Procedure
58652>>>>>        
58652>>>>>
58652>>>>>        Set peAnchors to anAll
58653>>>>>        Set Size to 151 197
58654>>>>>        Set Location to 56 5
58655>>>>>        Set pbFullRowSelect to TRUE
58656>>>>>        Set TreeRetainSelState to TRUE
58657>>>>>
58657>>>>>                
58657>>>>>        Procedure OnWorkspaceSelected Handle hItem
58660>>>>>            Integer iItem
58660>>>>>        
58660>>>>>            Get ItemData hItem To iItem
58661>>>>>            Set psWorkspaceSelected To (Value(oWorkspacesList(self), iItem*3))
58662>>>>>            Send Stop_Modal_Ui //Close_Panel
58663>>>>>        End_Procedure  // OnWorkspaceSelected
58664>>>>>        
58664>>>>>        
58664>>>>>        Procedure OnItemDblClick Handle hItem
58667>>>>>            Set pbResult To True
58668>>>>>            Send DoWorkspaceSelected
58669>>>>>        End_Procedure
58670>>>>>        
58670>>>>>        
58670>>>>>        Procedure DoWorkspaceSelected
58673>>>>>            Handle hItem
58673>>>>>            Get CurrentTreeItem To hItem
58674>>>>>            If (IsWorkspace(self, hItem)) Send OnWorkspaceSelected hItem
58677>>>>>        End_Procedure  // DoWorkspaceSelected
58678>>>>>        
58678>>>>>        
58678>>>>>        Procedure OnItemChanged Handle hItemNew Handle hItemOld
58681>>>>>            Boolean bWorkspace
58681>>>>>            Integer iItem
58681>>>>>            String sName sDescription
58681>>>>>        
58681>>>>>            Get IsWorkspace hItemNew To bWorkspace
58682>>>>>        
58682>>>>>            Set Enabled_State of oSelect To bWorkspace
58683>>>>>        
58683>>>>>            If bWorkspace Begin
58685>>>>>                Get ItemData hItemNew To iItem
58686>>>>>                Get Value of oWorkspacesList (iItem *3)    To sName
58687>>>>>                Get Value of oWorkspacesList (iItem *3 +1) To sDescription
58688>>>>>        
58688>>>>>                Set value of oSelectedWorkspace To (sDescription * "- [" +sName +"]")
58689>>>>>            End
58689>>>>>>
58689>>>>>            Else Set value of oSelectedWorkspace To ("<" + C_$NoneSelected + ">")
58691>>>>>        End_Procedure
58692>>>>>        
58692>>>>>        Function AddHierarchy Handle hiParent String sHierarchy Returns Handle
58695>>>>>            // Returns item-handle that was added. 0=not added (already exists)
58695>>>>>            Integer iPos bMoreLevels bFound icItem
58695>>>>>            Handle hiLevel hiSearch hoWorkspaces
58695>>>>>            String sLevel sSearchLabel
58695>>>>>        
58695>>>>>            Move oWorkspacesList To hoWorkspaces
58696>>>>>        
58696>>>>>            // treat the ".." as a literal "." in a label and not as a "double delimeter"
58696>>>>>            //Move (Replaces("..", sHierarchy, character(8))) To sHierarchy
58696>>>>>        
58696>>>>>        
58696>>>>>            Pos "." in sHierarchy to iPos
58698>>>>>>
58698>>>>>            If iPos Begin
58700>>>>>                Move (Left(sHierarchy, iPos -1)) To sLevel
58701>>>>>                Move (Right(sHierarchy, length(sHierarchy) - iPos)) To sHierarchy
58702>>>>>                Move (True) To bMoreLevels
58703>>>>>            End
58703>>>>>>
58703>>>>>            Else Begin // no more levels
58704>>>>>                Move sHierarchy To sLevel
58705>>>>>                Move (False) To bMoreLevels
58706>>>>>            End
58706>>>>>>
58706>>>>>        
58706>>>>>            Move (Replaces(character(8), sLevel, ".")) To sLevel
58707>>>>>        
58707>>>>>            Get ChildItem hiParent To hiSearch
58708>>>>>        
58708>>>>>            Repeat
58708>>>>>>
58708>>>>>                Get ItemLabel hiSearch To sSearchLabel
58709>>>>>                If (Uppercase(sSearchLabel) = Uppercase(sLevel)) Begin
58711>>>>>                    Move (True) To bFound
58712>>>>>                End
58712>>>>>>
58712>>>>>                Else Get NextSiblingItem hiSearch To hiSearch
58714>>>>>            Until (hiSearch =0 or bFound)
58716>>>>>        
58716>>>>>        
58716>>>>>            If (bFound = 0) Begin
58718>>>>>                Get Item_Count of hoWorkspaces To icItem
58719>>>>>                Get AddTreeItem sLevel hiParent (icItem /3 -1) (bMoreLevels=0) (bMoreLevels=0) To hiLevel
58720>>>>>                If (Value(hoWorkspaces, icItem-3) = psWorkspaceSelected(self)) Set CurrentTreeItem To hiLevel
58723>>>>>                If bMoreLevels Get AddHierarchy hiLevel sHierarchy To hiLevel // recurse and ignore the result
58726>>>>>            End
58726>>>>>>
58726>>>>>            Else If bMoreLevels Get AddHierarchy hiSearch sHierarchy To hiLevel // recurse and ignore the result
58730>>>>>        
58730>>>>>            Function_Return hiLevel
58731>>>>>        End_Function
58732>>>>>
58732>>>>>    End_Object    // oWorkspaces
58733>>>>>
58733>>>>>    Object oSelect is a Button
58735>>>>>        Set Label to "C_$Select"
58736>>>>>        Set Location to 137 216
58737>>>>>        Set peAnchors to anBottomRight
58738>>>>>        Set Default_State to TRUE
58739>>>>>
58739>>>>>        Set Label to C_$Select
58740>>>>>        
58740>>>>>        Procedure OnClick
58743>>>>>            Set pbResult To True
58744>>>>>            Send DoWorkspaceSelected of oWorkspaces
58745>>>>>        End_Procedure // OnClick
58746>>>>>
58746>>>>>    End_Object    // oSelect
58747>>>>>
58747>>>>>    Object oBrowse is a Button
58749>>>>>        Set Label to "C_$Browse"
58750>>>>>        Set Location to 155 216
58751>>>>>        Set peAnchors to anBottomRight
58752>>>>>
58752>>>>>        Set Label to C_$Browse
58753>>>>>        
58753>>>>>        Function DoStripExtension String sFile Returns String
58756>>>>>            // Description
58756>>>>>            // -----------
58756>>>>>            //  Returns a filename without its extension.
58756>>>>>            //  e.g. C:\TMP\STUFF.TXT will become C:\TMP\STUFF
58756>>>>>            //
58756>>>>>            Integer iPos
58756>>>>>        
58756>>>>>            If Not '.' In sFile Function_Return sFile //optimized
58759>>>>>        
58759>>>>>            Move (Length(sFile)) To iPos
58760>>>>>            While (iPos >0)
58764>>>>>                If (Mid(sFile, 1, iPos)) eq '.' break
58767>>>>>                Decrement iPos
58768>>>>>            Loop
58769>>>>>>
58769>>>>>        
58769>>>>>            Function_Return (Left(sFile, iPos -1))
58770>>>>>        End_Function  // StripExtension
58771>>>>>        
58771>>>>>        
58771>>>>>        Procedure OnClick
58774>>>>>            // Description
58774>>>>>            // -----------
58774>>>>>            // use the open file dialog to select a workspace .ws file. If the selected file is
58774>>>>>            // registered, then open the workspace. If it is not registered, then offer to register
58774>>>>>            // it before opening it....
58774>>>>>            Boolean bFileSelected bFound
58774>>>>>            String  sWorkspaceFile
58774>>>>>            String  sWorkspaceName
58774>>>>>            String  sTestName
58774>>>>>            String  sVDFRootDir sWsRegCommand
58774>>>>>            Integer iWorkspace  icWorkspace
58774>>>>>            Integer eRetVal
58774>>>>>        
58774>>>>>            Get Show_Dialog of oOpenDialog To bFileSelected
58775>>>>>        
58775>>>>>            If (bFileSelected) Begin
58777>>>>>                // get the full path & filename....
58777>>>>>                Get File_Name  of oOpenDialog To sWorkspaceFile
58778>>>>>        
58778>>>>>                // determine the workspace name by removing the file
58778>>>>>                // extension from the filename....
58778>>>>>                Get File_Title of oOpenDialog       To sWorkspaceName
58779>>>>>                Get DoStripExtension sWorkspaceName To sWorkspaceName
58780>>>>>        
58780>>>>>                // Test if the workspace has been registered yet...
58780>>>>>                Get Item_Count of oSections To icWorkspace
58781>>>>>                Move (0)                    To iWorkspace
58782>>>>>                Move (False)                To bFound
58783>>>>>        
58783>>>>>                While (Not(bFound) and iWorkspace < (icWorkspace - 1))
58787>>>>>                    Get String_Value of oSections iWorkspace To sTestName
58788>>>>>                    Move (Uppercase(sTestName) = Uppercase(sWorkspaceName)) To bFound
58789>>>>>                    Increment iWorkspace
58790>>>>>                Loop
58791>>>>>>
58791>>>>>        
58791>>>>>                // If the Workspace hasn't been registered, then ask
58791>>>>>                // if they would like to register it....
58791>>>>>                If (Not(bFound)) Begin
58793>>>>>                    // Run wsReg to register the selected workspace....
58793>>>>>                    Send Info_Box ("The selected workspace\n\n" + ;                                   sWorkspaceName + "\n\n" + ;                                   "Must be registered before it can be opened.\n\n" + ;                                   "The Workspace Registration utility will now be launched\n" + ;                                   "so that you can register this workspace.") "Select Workspace"
58794>>>>>        
58794>>>>>                    Get_Profile_String "Defaults" "VDFRootDir" To sVDFRootDir
58797>>>>>                    If (Right(sVDFRootDir,1) = "\") Left sVDFRootDir  To sVDFRootDir (Length(sVDFRootDir)-1)
58801>>>>>                    Move (sVDFRootDir + "\Bin\WsReg.exe ")            To sWsRegCommand
58802>>>>>                    Move (sWsRegCommand + '"' + sWorkspaceFile + '"') To sWsRegCommand
58803>>>>>                    Runprogram Wait sWsRegCommand
58804>>>>>                End
58804>>>>>>
58804>>>>>        
58804>>>>>                // Now have the workspace opened....
58804>>>>>                Delegate Set pbResult            To True
58806>>>>>                Delegate Set psWorkspaceSelected To sWorkspaceName
58808>>>>>                Send Stop_Modal_Ui //Close_Panel
58809>>>>>            End
58809>>>>>>
58809>>>>>        End_Procedure // OnClick
58810>>>>>
58810>>>>>    End_Object    // oBrowse
58811>>>>>
58811>>>>>    Object oCancel is a Button
58813>>>>>        Set Label to "C_$Cancel"
58814>>>>>        Set Location to 173 216
58815>>>>>        Set peAnchors to anBottomRight
58816>>>>>
58816>>>>>        Set Label to C_$Cancel
58817>>>>>        
58817>>>>>        Procedure OnClick
58820>>>>>            Send Close_Panel
58821>>>>>        End_Procedure // OnClick
58822>>>>>
58822>>>>>    End_Object    // oCancel
58823>>>>>
58823>>>>>    Object oHelp is a Button
58825>>>>>        Set Label to "C_$Help"
58826>>>>>        Set Location to 191 216
58827>>>>>        Set peAnchors to anBottomRight
58828>>>>>
58828>>>>>        Set Label to C_$Help
58829>>>>>        
58829>>>>>        Procedure OnClick
58832>>>>>            Send Help
58833>>>>>        End_Procedure // OnClick
58834>>>>>
58834>>>>>    End_Object    // oHelp
58835>>>>>
58835>>>>>    Object oOrderBy is a RadioGroup
58837>>>>>        Set Size to 57 58
58838>>>>>        Set Location to 53 208
58839>>>>>        Set peAnchors to anRight
58840>>>>>        Set Label to "C_$OrderBy"
58841>>>>>        Object oName is a Radio
58843>>>>>            Set Label to "C_$Name"
58844>>>>>            Set Size to 10 35
58845>>>>>            Set Location to 19 3
58846>>>>>
58846>>>>>            Set Label to C_$Name
58847>>>>>
58847>>>>>        End_Object    // oName
58848>>>>>
58848>>>>>        Object oDescription is a Radio
58850>>>>>            Set Label to "C_$Description"
58851>>>>>            Set Size to 10 52
58852>>>>>            Set Location to 32 3
58853>>>>>
58853>>>>>            Set Label to C_$Description
58854>>>>>
58854>>>>>        End_Object    // oDescription
58855>>>>>
58855>>>>>
58855>>>>>        Set Label to C_$OrderBy
58856>>>>>        
58856>>>>>        Procedure Notify_Select_State integer iToItem integer iFromItem
58859>>>>>            Integer iWorkspace
58859>>>>>            Handle hoWorkspaces
58859>>>>>        
58859>>>>>            Set pbSortByName To (iToItem =0)
58860>>>>>        
58860>>>>>            Get ItemData of oWorkspaces (CurrentTreeItem(oWorkspaces(self))) To iWorkspace
58861>>>>>            Set psWorkspaceSelected To (Value(oWorkspacesList(self), iWorkspace *3))
58862>>>>>            Set CurrentTreeItem of oWorkspaces To -1 // stops all the item-changing events
58863>>>>>        
58863>>>>>            Send DoShowWorkspaces of oWorkspaces
58864>>>>>        End_Procedure
58865>>>>>
58865>>>>>    End_Object    // oOrderBy
58866>>>>>
58866>>>>>    Object oCurrentWorkspace_lb is a Textbox
58868>>>>>        Set Label to "C_$CurrentWorkspace"
58869>>>>>        Set Location to 5 8
58870>>>>>        Set Size to 10 63
58871>>>>>        Set FontWeight to 800
58872>>>>>        Set TypeFace to "MS Sans Serif"
58873>>>>>
58873>>>>>        Set Label to C_$CurrentWorkspace
58874>>>>>
58874>>>>>    End_Object    // oCurrentWorkspace_lb
58875>>>>>
58875>>>>>    Object oCurrentWorkspace is a Textbox
58877>>>>>        Set Label to "oTextBox2"
58878>>>>>        Set Auto_Size_State to FALSE
58879>>>>>        Set Location to 17 5
58880>>>>>        Set Size to 14 261
58881>>>>>        Set Border_Style to Border_StaticEdge
58882>>>>>        Set TypeFace to "MS Sans Serif"
58883>>>>>        Set peAnchors to anLeftRight
58884>>>>>
58884>>>>>        Procedure DoShowCurrentWorkspace
58887>>>>>            String sDescription sName
58887>>>>>        
58887>>>>>            Delegate Get psOriginalWorkspace To sName
58889>>>>>            Delegate Get psCurrentWorkspaceDescription to sDescription
58891>>>>>        
58891>>>>>            If (sDescription = "") Move ("<" + C_$Undefined + ">") To sDescription
58894>>>>>            If (sName = "")        Move ("<" + C_$Undefined + ">") To sName
58897>>>>>        
58897>>>>>            Set Value To (sDescription * "- [" +sName +"]")
58898>>>>>        End_Procedure
58899>>>>>
58899>>>>>    End_Object    // oCurrentWorkspace
58900>>>>>
58900>>>>>    Object oLineControl2 is a LineControl
58902>>>>>        Set Size to 2 267
58903>>>>>        Set Location to 39 2
58904>>>>>        Set peAnchors to anLeftRight
58905>>>>>
58905>>>>>        Procedure Set GuiSize Integer cy Integer cx
58908>>>>>            Forward Set GuiSize To 2 cx
58910>>>>>        End_Procedure
58911>>>>>
58911>>>>>    End_Object    // oLineControl2
58912>>>>>
58912>>>>>    Object oSelectedWorkspace is a Textbox
58914>>>>>        Set Label to "C_$SelectedWorkspace"
58915>>>>>        Set Auto_Size_State to FALSE
58916>>>>>        Set Location to 212 5
58917>>>>>        Set Size to 14 261
58918>>>>>        Set Border_Style to Border_StaticEdge
58919>>>>>        Set TypeFace to "MS Sans Serif"
58920>>>>>        Set peAnchors to anBottomLeftRight
58921>>>>>
58921>>>>>        Set Label to C_$SelectedWorkspace
58922>>>>>
58922>>>>>    End_Object    // oSelectedWorkspace
58923>>>>>
58923>>>>>    Object oSelectNewWorkspace_lb is a Textbox
58925>>>>>        Set Label to "C_$SelectNewWorkspace"
58926>>>>>        Set Location to 44 8
58927>>>>>        Set Size to 10 78
58928>>>>>        Set FontWeight to 800
58929>>>>>        Set TypeFace to "MS Sans Serif"
58930>>>>>
58930>>>>>        Set Label to C_$SelectNewWorkspace
58931>>>>>
58931>>>>>    End_Object    // oSelectNewWorkspace_lb
58932>>>>>
58932>>>>>    Object oOpenDialog is a OpenDialog
58934>>>>>        Set Dialog_Caption to "Select a Workspace File"
58935>>>>>        Set Filter_String to "Workspace Files (*.ws)|*.ws"
58936>>>>>
58936>>>>>                
58936>>>>>        Procedure Default_Initial_Folder
58939>>>>>            // Description
58939>>>>>            // -----------
58939>>>>>            // Determine the default Initial_Folder.
58939>>>>>            String sDefaultWorkspacePath
58939>>>>>            Get_Profile_String "Defaults" "DefaultWorkspacePath" To sDefaultWorkspacePath
58942>>>>>            If (Right(sDefaultWorkspacePath,1) = "\") Begin
58944>>>>>                Left sDefaultWorkspacePath To sDefaultWorkspacePath (Length(sDefaultWorkspacePath)-1)
58946>>>>>>
58946>>>>>            End
58946>>>>>>
58946>>>>>        
58946>>>>>            Set Initial_Folder To sDefaultWorkspacePath
58947>>>>>        End_Procedure  // Default_Initial_Folder
58948>>>>>        
58948>>>>>        Send Default_Initial_Folder
58949>>>>>        
58949>>>>>
58949>>>>>    End_Object    // oOpenDialog
58950>>>>>
58950>>>>>    Object oSections is a Array
58952>>>>>
58952>>>>>        // This array contains the list of Workspace Names.
58952>>>>>        
58952>>>>>
58952>>>>>
58952>>>>>                
58952>>>>>                
58952>>>>>
58952>>>>>    End_Object    // oSections
58953>>>>>
58953>>>>>
58953>>>>>    Set Label to C_$SelectWorkspace
58954>>>>>    
58954>>>>>    // === PUBLIC INTERFACE ===
58954>>>>>    Function SelectWorkspace Returns Boolean // new WS selected?
58957>>>>>        Boolean bWorkspaceSelected
58957>>>>>        String sWorkspaceName
58957>>>>>    
58957>>>>>        Set pbResult To False
58958>>>>>        Get psWorkspaceName Of (phoWorkspace (ghoApplication)) To sWorkspaceName
58959>>>>>        If (sWorkspaceName = "") Begin
58961>>>>>            Get GetCurrentUserWorkspace To sWorkspaceName
58962>>>>>        End
58962>>>>>>
58962>>>>>        Set psOriginalWorkspace To sWorkspaceName
58963>>>>>        Set psWorkspaceSelected To (psOriginalWorkspace(self))
58964>>>>>    
58964>>>>>        Set Enabled_State of oHelp To (Help_Id(self)) // disable if no Help_Id set (by calling program)
58965>>>>>    
58965>>>>>        Send Popup_Modal
58966>>>>>    
58966>>>>>        Move (pbResult(self) = True and psOriginalWorkspace(self) <> psWorkspaceSelected(self)) To bWorkspaceSelected
58967>>>>>    
58967>>>>>        If bWorkspaceSelected Begin
58969>>>>>            If (pbChangeSystemCurrent(self)) Begin
58971>>>>>                Send SetCurrentUserWorkspace (psWorkspaceSelected(self))
58972>>>>>            End
58972>>>>>>
58972>>>>>        End
58972>>>>>>
58972>>>>>    
58972>>>>>        Function_Return bWorkspaceSelected
58973>>>>>    End_Function
58974>>>>>
58974>>>>>End_Object    // oSelectWorkspace
58975>>>>>
58975>>>>>
58975>>>>>
58975>>>>>
58975>>>  Use WorkSpc.utl
Including file: workspc.utl    (C:\Apps\VDFQuery\AppSrc\workspc.utl)
58975>>>>>// Use WorkSpc.utl  // cWorkSpace class (that features function sMakePath)
58975>>>>>                    // and object oAllWorkspaces that reads all WS paths
58975>>>>>
58975>>>>>
58975>>>>>Use Base.utl     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
Including file: base.utl    (C:\Apps\VDFQuery\AppSrc\base.utl)
58975>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
58975>>>>>Use Version.nui
58975>>>>>
58975>>>>>Use cApplication.pkg
58975>>>>>Use SelectWorkspace.dg
58975>>>>>
58975>>>>>desktop_section
58980>>>>>  object oAllWorkspaces is a cArray
58982>>>>>    property string psCurrentMakePath public "" // Common to all WS
58984>>>>>    object oWorkSpaceTmp is a cWorkSpace
58986>>>>>    //procedure set kenter_next_state integer bNext
58986>>>>>    //end_procedure
58986>>>>>    //function kenter_next_state returns integer
58986>>>>>    //end_function
58986>>>>>    end_object
58987>>>>>    item_property_list
58987>>>>>      item_property string psKeyName.i
58987>>>>>      item_property string psName.i
58987>>>>>      item_property string psDataPath.i
58987>>>>>      item_property string psBitMapPath.i
58987>>>>>      item_property string psHelpPath.i
58987>>>>>      item_property string psAppSrcPath.i
58987>>>>>      item_property string psDDSrcPath.i
58987>>>>>      item_property string psProgramPath.i
58987>>>>>      item_property string psSystemDfPath.i
58987>>>>>      item_property string psFileListPath.i
58987>>>>>      item_property string psMakePath.i
58987>>>>>      // Since the SystemMakePath is the same for all WS we also provide
58987>>>>>      // the WS specific part of the MakePath:
58987>>>>>      item_property string psMakePathNoSysPath.i
58987>>>>>    end_item_property_list
#REM 59054 DEFINE FUNCTION PSMAKEPATHNOSYSPATH.I INTEGER LIROW RETURNS STRING
#REM 59059 DEFINE PROCEDURE SET PSMAKEPATHNOSYSPATH.I INTEGER LIROW STRING VALUE
#REM 59064 DEFINE FUNCTION PSMAKEPATH.I INTEGER LIROW RETURNS STRING
#REM 59069 DEFINE PROCEDURE SET PSMAKEPATH.I INTEGER LIROW STRING VALUE
#REM 59074 DEFINE FUNCTION PSFILELISTPATH.I INTEGER LIROW RETURNS STRING
#REM 59079 DEFINE PROCEDURE SET PSFILELISTPATH.I INTEGER LIROW STRING VALUE
#REM 59084 DEFINE FUNCTION PSSYSTEMDFPATH.I INTEGER LIROW RETURNS STRING
#REM 59089 DEFINE PROCEDURE SET PSSYSTEMDFPATH.I INTEGER LIROW STRING VALUE
#REM 59094 DEFINE FUNCTION PSPROGRAMPATH.I INTEGER LIROW RETURNS STRING
#REM 59099 DEFINE PROCEDURE SET PSPROGRAMPATH.I INTEGER LIROW STRING VALUE
#REM 59104 DEFINE FUNCTION PSDDSRCPATH.I INTEGER LIROW RETURNS STRING
#REM 59109 DEFINE PROCEDURE SET PSDDSRCPATH.I INTEGER LIROW STRING VALUE
#REM 59114 DEFINE FUNCTION PSAPPSRCPATH.I INTEGER LIROW RETURNS STRING
#REM 59119 DEFINE PROCEDURE SET PSAPPSRCPATH.I INTEGER LIROW STRING VALUE
#REM 59124 DEFINE FUNCTION PSHELPPATH.I INTEGER LIROW RETURNS STRING
#REM 59129 DEFINE PROCEDURE SET PSHELPPATH.I INTEGER LIROW STRING VALUE
#REM 59134 DEFINE FUNCTION PSBITMAPPATH.I INTEGER LIROW RETURNS STRING
#REM 59139 DEFINE PROCEDURE SET PSBITMAPPATH.I INTEGER LIROW STRING VALUE
#REM 59144 DEFINE FUNCTION PSDATAPATH.I INTEGER LIROW RETURNS STRING
#REM 59149 DEFINE PROCEDURE SET PSDATAPATH.I INTEGER LIROW STRING VALUE
#REM 59154 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 59159 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
#REM 59164 DEFINE FUNCTION PSKEYNAME.I INTEGER LIROW RETURNS STRING
#REM 59169 DEFINE PROCEDURE SET PSKEYNAME.I INTEGER LIROW STRING VALUE
59175>>>>>
59175>>>>>    procedure private.add_workspace string sWorkspace string sDescription string sPath
59178>>>>>      integer lhObj liRow liStatus
59178>>>>>      move (oWorkSpaceTmp(self)) to lhObj
59179>>>>>      send DoClearPaths to lhObj
59180>>>>>      get OpenWorkSpace of lhObj sWorkspace to liStatus
59181>>>>>      if (liStatus=WSWORKSPACEOPENED) begin
59183>>>>>        get row_count to liRow
59184>>>>>        set psKeyName.i      liRow to sWorkspace
59185>>>>>        set psName.i         liRow to sDescription
59186>>>>>        set psDataPath.i     liRow to (psDataPath(lhObj))
59187>>>>>        set psBitMapPath.i   liRow to (psBitmapPath(lhObj))
59188>>>>>        set psHelpPath.i     liRow to (psHelpPath(lhObj))
59189>>>>>        set psAppSrcPath.i   liRow to (psAppSrcPath(lhObj))
59190>>>>>        set psDDSrcPath.i    liRow to (psDdSrcPath(lhObj))
59191>>>>>        set psProgramPath.i  liRow to sPath
59192>>>>>        set psSystemDfPath.i liRow to (psSystemDfPath(lhObj))
59193>>>>>        set psFileListPath.i liRow to (psFileList(lhObj))
59194>>>>>        set psMakePathNoSysPath.i liRow to (psAppSrcPath(lhObj)+";"+sPath+";"+psDataPath(lhObj)+";"+psDdSrcPath(lhObj)+";"+psHelpPath(lhObj))
59195>>>>>        set psMakePath.i     liRow to (psMakePathNoSysPath.i(self,liRow)+";"+psSystemMakePath(lhObj))
59196>>>>>      end
59196>>>>>>
59196>>>>>    end_procedure
59197>>>>>
59197>>>>>    procedure ReadAllWorkspaces global // Public
59199>>>>>
59199>>>>>      Integer iVOid iWorkspace
59199>>>>>      Handle hoSections
59199>>>>>      String sWorkspace sDescription sPath
59199>>>>>      String sVdfRootDir
59199>>>>>
59199>>>>>      Get_Profile_String "Defaults" "VDFRootDir" To sVDFRootDir
59202>>>>>      If (Right(sVDFRootDir,1) = "\") Left sVDFRootDir To sVDFRootDir (Length(sVDFRootDir)-1)
59206>>>>>
59206>>>>>      send delete_data
59207>>>>>
59207>>>>>      Object oSections is an cArray
59209>>>>>        Move self To hoSections
59210>>>>>      End_Object
59211>>>>>
59211>>>>>      Object oIni is a cIniFile
59213>>>>>        Set psFilename To (sVDFRootDir+"\bin\Workspaces.ini")
59214>>>>>
59214>>>>>        Send ReadSections hoSections
59215>>>>>
59215>>>>>        For iWorkspace from 0 to (Item_Count(hoSections) -1)
59221>>>>>>
59221>>>>>          Get Value of hoSections iWorkspace To sWorkspace
59222>>>>>          Get ReadString sWorkspace "Description" "" To sDescription
59223>>>>>          Get ReadString sWorkspace "Path" ""        To sPath
59224>>>>>          send private.add_workspace sWorkspace sDescription sPath
59225>>>>>        Loop
59226>>>>>>
59226>>>>>      End_Object
59227>>>>>    end_procedure
59228>>>>>  end_object // oAllWorkspaces
59229>>>>>end_desktop_section
59234>>>>>
59234>>>>>function WorkSpc_SelectWS global returns string
59236>>>>>  integer lhObj
59236>>>>>  move (oSelectWorkspace(self)) to lhObj
59237>>>>>  Set pbResult of lhObj To DFFALSE
59238>>>>>  send popup to lhObj
59239>>>>>  if (pbResult(lhObj)) function_return (psWorkspaceSelected(lhObj))
59242>>>>>  else function_return ""
59244>>>>>end_function
59245>>>>>
59245>>>  Procedure DFMatrix_Clear_WorkSpace
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59247>>>  End_Procedure
59248>>>  
59248>>>  Procedure DFMatrix_Select_WorkSpace
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59250>>>    Integer iRval
59250>>>    String sFile sErr
59250>>>    Integer hoWorkspace
59250>>>    String sWorkspace DataPath# FileListPath# WsDescription#
59250>>>    
59250>>>    Get SelectRecentWorkspaceFile of WsFunctions to sFile
59251>>>    If (sFile<>"") Begin
59253>>>        Get WorkSpaceObject of WsFunctions to hoWorkspace
59254>>>        Send DoClearPaths of hoWorkspace
59255>>>        Get OpenWorkspace of WsFunctions sFile to iRval
59256>>>        If (iRval=wsWorkspaceOpened) Begin
59258>>>            Get psDataPath of hoWorkspace to DataPath#
59259>>>            Get psFileList of hoWorkspace to FileListPath#
59260>>>            Get psDescription of hoWorkspace to WsDescription#
59261>>>    
59261>>>            Send FLIST_SetOpenPath DataPath#
59262>>>            Send FLIST_SetCurrentFilelist FileListPath#
59263>>>    
59263>>>            Set psCurrentWorkSpace of (oDFMatrixViewPanels(Self)) to WsDescription#
59264>>>            Set piWorkSpaceLoaded of (oDFMatrixViewPanels(Self)) to DFTRUE
59265>>>            Send DFMatrix_CloseAll
59266>>>            If (MB_Verify("Open table definitions in the selected workspace?",1)) Send DFMatrix_PrimaryOpenCurrentFilelist
59269>>>        End
59269>>>>
59269>>>        Else Begin
59270>>>            Get OpenWorkspaceErrorText of WsFunctions iRval to sErr
59271>>>            Send Info_Box sErr
59272>>>        End
59272>>>>
59272>>>    End
59272>>>>
59272>>>  
59272>>>    //integer hoWorkspace eOpened
59272>>>    //string sWorkspace DataPath# FileListPath# WsDescription#
59272>>>//
59272>>>    //get phoWorkspace of ghoApplication To hoWorkspace
59272>>>    //get WorkSpc_SelectWS to sWorkspace
59272>>>    //If (sWorkspace<>"") Begin
59272>>>      //Send DoClearPaths of hoWorkspace
59272>>>      //Get OpenWorkspace of hoWorkspace sWorkspace To eOpened
59272>>>      //If (eOpened <> WSWORKSPACEOPENED) Begin
59272>>>        //send stop_box "The current default workspace is invalid."
59272>>>      //End
59272>>>      //else begin
59272>>>        //get psDataPath of hoWorkspace to DataPath#
59272>>>        //get psFileList of hoWorkspace to FileListPath#
59272>>>        //get psDescription of hoWorkspace to WsDescription#
59272>>>//
59272>>>        //send FLIST_SetOpenPath DataPath#
59272>>>        //send FLIST_SetCurrentFilelist FileListPath#
59272>>>//
59272>>>        //set psCurrentWorkSpace of (oDFMatrixViewPanels(self)) to WsDescription#
59272>>>        //set piWorkSpaceLoaded of (oDFMatrixViewPanels(self)) to DFTRUE
59272>>>        //send DFMatrix_CloseAll
59272>>>        //if (MB_Verify("Open table definitions in the selected workspace?",1)) send DFMatrix_PrimaryOpenCurrentFilelist
59272>>>      //end
59272>>>    //end
59272>>>  end_procedure
59273>>>
59273>>>//> This procedure will read in the 'current' data definitions in the
59273>>>//> primary slot.
59273>>>procedure DFMatrix_PrimaryOpenCurrentFilelist global
59275>>>  send fdx.entry_read_current 0
59276>>>  send DFMatrix_NotifyFdxChange
59277>>>  send Activate_Table_Selector
59278>>>end_procedure
59279>>>procedure DFMatrix_PrimaryReread global // This isn't actually a reread
59281>>>  send fdx.entry_read_current 0         // (It's called after a restructure)
59282>>>  send DFMatrix_NotifyFdxChange
59283>>>end_procedure
59284>>>procedure DFMatrix_SecondaryOpenCurrentFilelist global
59286>>>  send fdx.entry_read_current 1
59287>>>end_procedure
59288>>>
59288>>>procedure DFMatrix_OpenDirectoryContents global
59290>>>  integer lhFDX
59290>>>  move (fdx.object_id(0)) to lhFDX
59291>>>  if (piDataOrigin(lhFDX)) ne FDX_EMPTY begin
59293>>>    send fdx.wait.on
59294>>>    if (piDataOrigin(lhFDX)) eq FDX_REAL_WORLD send Read_Directory_Contents to lhFDX
59297>>>    if (piDataOrigin(lhFDX)) eq FDX_READ_FROM_FILE send Read_Directory_Contents_From_File to lhFDX
59300>>>    send fdx.wait.off
59301>>>    send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_DIRECTORY_CONTENTS_VW))
59302>>>    send Activate_Directory_Contents
59303>>>  end
59303>>>>
59303>>>end_procedure
59304>>>
59304>>>register_procedure OnChangeFDX_Broadcasted
59304>>>
59304>>>procedure DFMatrix_NotifyFdxChange global
59306>>>  send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_GLOBAL_ATTRIBUTES_VW))
59307>>>  send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_TABLE_SELECTOR_VW))
59308>>>  send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_TABLE_DEFINITION_VW))
59309>>>  send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_DIRECTORY_CONTENTS_VW))
59310>>>  send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_SET_OF_TABLES_VW))
59311>>>  send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_SET_OF_FIELDS_VW))
59312>>>  send OnChangeFDX to (DFMatrix_Vw_Object_ID(WAY_SET_OF_INDICES_VW))
59313>>>  broadcast recursive send OnChangeFDX_Broadcasted to desktop
59315>>>  send DFMatrix_Update_App_Title
59316>>>end_procedure
59317>>>
59317>>>procedure DFMatrix_CloseAll global
59319>>>  send fdx.reset_all
59320>>>  send DFMatrix_Create_FDX
59321>>>  send DFMatrix_NotifyFdxChange
59322>>>end_procedure
59323>>>
59323>>>procedure DFMatrix_PrimaryOpenFdxFile global
59325>>>  if (fdx.open_file_browse(0)) begin
59327>>>    send DFMatrix_NotifyFdxChange
59328>>>    send Activate_Table_Selector
59329>>>  end
59329>>>>
59329>>>end_procedure
59330>>>function DFMatrix_SecondaryOpenFdxFile global returns integer
59332>>>  function_return (fdx.open_file_browse(1))
59333>>>end_function
59334>>>procedure DFMatrix_PrimarySaveFdxAs global
59336>>>  integer lhFDX
59336>>>  move (fdx.object_id(0)) to lhFDX
59337>>>  if (piDataOrigin(lhFDX)) ne FDX_EMPTY begin
59339>>>    send fdx.entry_save_as 0
59340>>>    send DFMatrix_Update_App_Title
59341>>>  end
59341>>>>
59341>>>end_procedure
59342>>>function DFMatrix_Vw_Active global integer who_are_you# returns integer
59344>>>  function_return (active_state(value(oDFMatrixViewPanels(self),who_are_you#)))
59345>>>end_function
59346>>>
59346>>>procedure DFMatrix_Transfer_Set global integer origin# integer target# integer intersection#
59348>>>  if target# eq WAY_TABLE_SELECTOR_VW begin
59350>>>    if origin# eq WAY_SET_OF_TABLES_VW begin
59352>>>      send make_set_of_files to (oFdxSetOfTables(self)) (oAuxFdxSetOfTables(self))
59353>>>    end
59353>>>>
59353>>>    if origin# eq WAY_SET_OF_FIELDS_VW begin
59355>>>      send make_set_of_files to (oFdxSetOfFields(self)) (oAuxFdxSetOfTables(self))
59356>>>    end
59356>>>>
59356>>>    if origin# eq WAY_SET_OF_INDICES_VW begin
59358>>>      send make_set_of_fields to (oFdxSetOfIndices(self)) (oAuxFdxSetOfFields(self))
59359>>>      send make_set_of_files to (oAuxFdxSetOfFields(self)) (oAuxFdxSetOfTables(self))
59360>>>    end
59360>>>>
59360>>>    if intersection# send DoTableSelector_Intersection to (oAuxFdxSetOfTables(self))
59363>>>    else send DoTableSelector_Union to (oAuxFdxSetOfTables(self))
59365>>>    send Activate_Table_Selector
59366>>>  end
59366>>>>
59366>>>  if target# eq WAY_SET_OF_TABLES_VW begin
59368>>>    if origin# eq WAY_SET_OF_FIELDS_VW begin
59370>>>      send make_set_of_files to (oFdxSetOfFields(self)) (oAuxFdxSetOfTables(self))
59371>>>    end
59371>>>>
59371>>>    if origin# eq WAY_SET_OF_INDICES_VW begin
59373>>>      send make_set_of_fields to (oFdxSetOfIndices(self)) (oAuxFdxSetOfFields(self))
59374>>>      send make_set_of_files to (oAuxFdxSetOfFields(self)) (oAuxFdxSetOfTables(self))
59375>>>    end
59375>>>>
59375>>>    if intersection# send DoInterSection.i to (oFdxSetOfTables(self)) (oAuxFdxSetOfTables(self))
59378>>>    else send DoUnion.i to (oFdxSetOfTables(self)) (oAuxFdxSetOfTables(self))
59380>>>    send update_display to (DFMatrix_Vw_Object_ID(WAY_SET_OF_TABLES_VW))
59381>>>    send Activate_SetOfTables
59382>>>  end
59382>>>>
59382>>>  if target# eq WAY_SET_OF_FIELDS_VW begin
59384>>>    if origin# eq WAY_SET_OF_INDICES_VW begin
59386>>>      send make_set_of_fields to (oFdxSetOfIndices(self)) (oAuxFdxSetOfFields(self))
59387>>>    end
59387>>>>
59387>>>    if intersection# send DoInterSection.i to (oFdxSetOfFields(self)) (oAuxFdxSetOfFields(self))
59390>>>    else send DoUnion.i to (oFdxSetOfFields(self)) (oAuxFdxSetOfFields(self))
59392>>>    send update_display to (DFMatrix_Vw_Object_ID(WAY_SET_OF_FIELDS_VW))
59393>>>    send Activate_SetOfFields
59394>>>  end
59394>>>>
59394>>>end_procedure
59395>>>
59395>>>
59395>>>// ********************** REPORT UTILITY SECTION ***************************
59395>>>// The order in which these symbols are defined determines the order in which
59395>>>// the reports appear in the report pull down menu:
59395>>>enumeration_list // FDX report identifiers
59395>>>  define FDXRPT_VALIDY_CHECK   // Check validity of table definitions
59395>>>  define FDXRPT_RELATION_TREE
59395>>>  define FDXRPT_DEFINITION
59395>>>  define FDXRPT_GLOBAL_ATTR
59395>>>  define FDXRPT_FIND_FIELDS    // Locate fields with specific characteristics
59395>>>end_enumeration_list
59395>>>
59395>>>object oFdxReportArray is a cArray
59397>>>  item_property_list
59397>>>    item_property string  psTitle.i
59397>>>    item_property integer piPreCond.i
59397>>>    item_property integer piUI_Object.i
59397>>>  end_item_property_list
#REM 59437 DEFINE FUNCTION PIUI_OBJECT.I INTEGER LIROW RETURNS INTEGER
#REM 59442 DEFINE PROCEDURE SET PIUI_OBJECT.I INTEGER LIROW INTEGER VALUE
#REM 59447 DEFINE FUNCTION PIPRECOND.I INTEGER LIROW RETURNS INTEGER
#REM 59452 DEFINE PROCEDURE SET PIPRECOND.I INTEGER LIROW INTEGER VALUE
#REM 59457 DEFINE FUNCTION PSTITLE.I INTEGER LIROW RETURNS STRING
#REM 59462 DEFINE PROCEDURE SET PSTITLE.I INTEGER LIROW STRING VALUE
59468>>>end_object
59469>>>procedure fdx.add_report global integer row# string title# integer obj# integer precond#
59471>>>  integer arr#
59471>>>  move (oFdxReportArray(self)) to arr#
59472>>>  set psTitle.i     of arr# row# to title#
59473>>>  set piUI_Object.i of arr# row# to obj#
59474>>>  set piPreCond.i   of arr# row# to precond#
59475>>>end_procedure
59476>>>class fdxrpt.ModalClient is a aps.ModalPanel
59477>>>  procedure construct_object integer img#
59479>>>    forward send construct_object img#
59481>>>    on_key kcancel send cancel
59482>>>    on_key ksave_record send DoReport
59483>>>    on_key key_ctrl+key_r send DoReport
59484>>>    on_key key_ctrl+key_s send DoProperties
59485>>>    property integer piId           public 0
59486>>>    property string  psTitle        public ""
59487>>>    property integer piPrecond      public 0
59488>>>    property integer piFDX_Server   public 0
59489>>>    property integer piDontRegister public 0 // Should the report automatically register with the main menu
59490>>>    set locate_mode to CENTER_ON_SCREEN
59491>>>  end_procedure
59492>>>  procedure define_report integer id# string title# integer precond#
59494>>>    set piId      to id#
59495>>>    set psTitle   to title#
59496>>>    set piPrecond to precond#
59497>>>  end_procedure
59498>>>  procedure DoReport
59500>>>  end_procedure
59501>>>  procedure DoProperties
59503>>>  end_procedure
59504>>>  procedure Callback_Filelist_Entry integer file# integer selected# integer shaded#
59506>>>  end_procedure
59507>>>  procedure Callback_Filelist_Entries integer selected# integer shaded#
59509>>>    integer oLst#
59509>>>    get DFMatrix_SelectorObject to oLst#
59510>>>    send Callback_General to oLst# msg_CallBack_Filelist_Entry self selected# shaded#
59511>>>  end_procedure
59512>>>  procedure end_construct_object
59514>>>    forward send end_construct_object
59516>>>    ifnot (piDontRegister(self)) send fdx.add_report (piId(self)) (psTitle(self)) self (piPrecond(self))
59519>>>  end_procedure
59520>>>  procedure DoDefaults
59522>>>  end_procedure
59523>>>  procedure popup
59525>>>    set piFDX_Server to (fdx.object_id(0))
59526>>>    send DoDefaults
59527>>>    forward send popup
59529>>>  end_procedure
59530>>>end_class // fdxrpt.client
59531>>>
59531>>>//enumeration_list
59531>>>//  define DFMOP_NONE      // No opearion
59531>>>//  define DFMOP_PRIMLOAD  // Load primary FDX
59531>>>//  define DFMOP_OPENVIEW  // Open a view
59531>>>//end_enumeration_list
59531>>>
59531>>>function DfmBatchMode global returns integer
59533>>>  function_return 0
59534>>>end_function
59535>>>
59535>>>function DfmBatchMode_LogfileName global returns string
59537>>>end_function
59538>>>
59538>>>
59538>>>procedure DFMatrix_Login global
59540>>>  integer rval# driver#
59540>>>  string server# user# pw#
59540>>>  get DBMS_GetDriverLogin 0 to rval#
59541>>>  if rval# begin
59543>>>    get DBMS_GetDriverLoginDriverID to driver#
59544>>>    get DBMS_GetDriverLoginServer   to server#
59545>>>    get DBMS_GetDriverLoginUserID   to user#
59546>>>    get DBMS_GetDriverLoginPassWord to pw#
59547>>>    login server# user# pw# (DBMS_TypeToDriverName(driver#))
59549>>>  end
59549>>>>
59549>>>end_procedure
59550>>>procedure DFMatrix_Logout global
59552>>>  logout
59553>>>end_procedure
59554>>>
59554>>>class fdxrpt.report_control is a cArray
59555>>>  procedure construct_object integer img#
59557>>>    forward send construct_object img#
59559>>>  end_procedure
59560>>>end_class // fdxrpt.report_control
59561>>>// ********************** REPORT UTILITY SECTION ***************************
59561>>>
59561>>>function DFMatrix_RealData_Check global returns integer //
59563>>>  integer liDataOrigin
59563>>>  move (piDataOrigin(fdx.object_id(0))) to liDataOrigin
59564>>>  if (liDataOrigin=FDX_REAL_WORLD) function_return 1
59567>>>  if (liDataOrigin=FDX_READ_FROM_FILE) send obs "You cannot execute this function on definitions read from an FDX file"
59570>>>  else send obs "In order to execute this function you need to read some" "table definitions first (use the 'File' menu)."
59572>>>end_function
59573>>>
59573>>>function DFMatrix_Primary_Origin global returns integer
59575>>>  function_return (piDataOrigin(fdx.object_id(0)))
59576>>>end_function
59577>>>
59577>>>on_key key_ctrl+key_t send Request_Activate_Table_Selector
59578>>>procedure Request_Activate_Table_Selector
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59580>>>  send Focus_Analyze_Focus
59581>>>  ifnot (integer(Focus_Info(FOCUS_DEO_MODAL))) send Activate_Table_Selector
59584>>>end_procedure
59585>>>
59585>Use MdiExt.utl   // MDI Extensions
Including file: mdiext.utl    (C:\Apps\VDFQuery\AppSrc\mdiext.utl)
59585>>>// **********************************************************************
59585>>>// Use MdiExt.utl   // MDI Extensions
59585>>>//
59585>>>// By Sture Andersen
59585>>>//
59585>>>// Create: Mon  15-12-1997
59585>>>//
59585>>>//
59585>>>// Usage:
59585>>>//
59585>>>//   Substitute:
59585>>>//
59585>>>//     Use dfStdBtn
59585>>>//
59585>>>//   for:
59585>>>//
59585>>>//     Object Tool_Bar is a cSturesToolBar
59585>>>//       send Add_Standard_Toolbar_Buttons         // Adds the standard buttons
59585>>>//     //send Add_Space
59585>>>//     //send Add_Calendar_tbButton self // Add calendar button
59585>>>//     //send Add_LinkView_tbButton self // Add link view button
59585>>>//     End_Object
59585>>>//
59585>>>//   and:
59585>>>//
59585>>>//     Use DfStdSbr
59585>>>//
59585>>>//   for:
59585>>>//
59585>>>//     Object Status_Bar is a cStatusBar
59585>>>//     End_Object
59585>>>//
59585>>>// ***********************************************************************
59585>>>
59585>>>Use DFMainBt  // Standard dfMain_ButtonBar (DAC)
Including file: Dfmainbt.pkg    (c:\VDF12\Pkg\Dfmainbt.pkg)
59585>>>>>//-------------------------------------------------------------------------
59585>>>>>// DFMainBt.pkg - DfMain_ButtonBar class
59585>>>>>//
59585>>>>>//
59585>>>>>// 07/23/96 JJT - New Class names
59585>>>>>//-------------------------------------------------------------------------
59585>>>>>
59585>>>>>Use Dfabtbar.pkg
59585>>>>>
59585>>>>>Class ToolBar is a AppToolBar
59586>>>>>
59586>>>>>    Function Is_Function Integer MsgId Integer ObjId Integer DelegateFg Returns Integer
59588>>>>>      integer rval MainObj#
59588>>>>>      Get Main_Panel_id to MainObj#
59589>>>>>      If (ObjId>Desktop AND MainObj#) ;         Get Is_Function of MainObj# MsgId ObjId DelegateFg to rVal
59592>>>>>      Function_Return rVal
59593>>>>>    End_Function
59594>>>>>
59594>>>>>    Procedure Redirect_Button_Message integer Itm
59596>>>>>         integer Msg# Aux# rval Understood
59596>>>>>         If (Shadow_State(self,itm)) Procedure_Return
59599>>>>>         Get Message   item itm  to Msg#
59600>>>>>         Get Aux_Value item itm  to Aux#
59601>>>>>         If Msg# Begin
59603>>>>>           If Aux# eq 0 Begin
59605>>>>>              Get Focus of desktop to Aux#
59606>>>>>              Get Is_Function Get_DEO_Object Aux# TRUE to Understood
59607>>>>>              If Not Understood Move 0 to Aux#
59610>>>>>           End
59610>>>>>>
59610>>>>>           If Aux# Get Msg# of Aux# to rval
59613>>>>>           Procedure_return rval
59614>>>>>         end
59614>>>>>>
59614>>>>>    End_Procedure // Redirect_Message
59615>>>>>
59615>>>>>End_Class
59616>>>>>
59616>>>>>
59616>>>Use DFMainSt  // Standard Status bar class (DAC)
Including file: Dfmainst.pkg    (c:\VDF12\Pkg\Dfmainst.pkg)
59616>>>>>// 07/23/96 JJT - New Class names
59616>>>>>// 12/13/2001 JJT - Updated Syntax Add_item to AddPane (suggested syntax)
59616>>>>>Use LanguageText.pkg
59616>>>>>Use dfAstbar.pkg
59616>>>>>
59616>>>>>Class StatusBar is a AppStatusBar
59617>>>>>
59617>>>>>    Procedure Construct_Object
59619>>>>>       Forward Send Construct_Object
59621>>>>>       //
59621>>>>>       Send AddPane 350  '' sbLOWERED    // micro-help
59622>>>>>       Send AddPane  40  C_$View sbNORMAL
59623>>>>>       Send AddPane 200  '' sbLOWERED    // view name
59624>>>>>       Send AddPane   0  '' sbNORMAL     // spring 'normal' to end
59625>>>>>
59625>>>>>    End_Procedure // Construct_Object
59626>>>>>
59626>>>>>    Procedure Show_View_Name String sName
59628>>>>>        Set Value item 2 to sName
59629>>>>>    End_Procedure
59630>>>>>
59630>>>>>End_Class
59631>>>Use FieldInf  // Global field info objects
59631>>>Use MsgBox    // DAC class
59631>>>Use Language  // Set default languange if not set by compiler command line
59631>>>Use API_Attr.utl // Functions for querying API attributes
Including file: api_attr.utl    (C:\Apps\VDFQuery\AppSrc\api_attr.utl)
59631>>>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
59631>>>
59631>>>   define t.TbBtn.Bgn.Tip      for "Beginning of file"
59631>>>   define t.TbBtn.Bgn.StHlp    for "Find the First record (Ctrl+Home)"
59631>>>   define t.TbBtn.Prev.Tip     for "Find Previous"
59631>>>   define t.TbBtn.Prev.StHlp   for "Find the Previous record (F7)"
59631>>>   define t.TbBtn.Next.Tip     for "Find Next"
59631>>>   define t.TbBtn.Next.StHlp   for "Find the Next record (F8)"
59631>>>   define t.TbBtn.End.Tip      for "End of File"
59631>>>   define t.TbBtn.End.StHlp    for "Find the Last record (Ctrl+End)"
59631>>>   define t.TbBtn.Prompt.Tip   for "Prompt"
59631>>>   define t.TbBtn.Prompt.StHlp for "Show available selections (F4)"
59631>>>   define t.TbBtn.Print.Tip    for "Print"
59631>>>   define t.TbBtn.Print.StHlp  for "Print report (Shift+F4)"
59631>>>   define t.TbBtn.Clear.Tip    for "Clear"
59631>>>   define t.TbBtn.Clear.StHlp  for "Clear current record / Add a new record (F5)"
59631>>>   define t.TbBtn.ClearA.Tip   for "Clear All"
59631>>>   define t.TbBtn.ClearA.StHlp for "Clear all data from view (Ctrl+F5)"
59631>>>   define t.TbBtn.Save.Tip     for "Save"
59631>>>   define t.TbBtn.Save.StHlp   for "Save the current record (F2)"
59631>>>   define t.TbBtn.Del.Tip      for "Delete"
59631>>>   define t.TbBtn.Del.StHlp    for "Delete the current record (Shift+F2)"
59631>>>   define t.TbBtn.Cut.Tip      for "Cut"
59631>>>   define t.TbBtn.Cut.StHlp    for "Cuts the selection and puts it on the Clipboard"
59631>>>   define t.TbBtn.Copy.Tip     for "Copy"
59631>>>   define t.TbBtn.Copy.StHlp   for "Copies the selection and puts it on the Clipboard"
59631>>>   define t.TbBtn.Paste.Tip    for "Paste"
59631>>>   define t.TbBtn.Paste.StHlp  for "Inserts Clipboard contents"
59631>>>   define t.LnkVw.NotDefined   for "Linked view not defined for '#'"
59631>>>   define t.LnkVw.ToolTip      for "Jump to linked view"
59631>>>   define t.LnkVw.StatusHelp   for "Jumps to linked view (Ctrl+O)"
59631>>>   define t.LnkVw.DoesNotExist for "Linked view does not exist (#)"
59631>>>
59631>>>// Return the object ID of the prompt list attached to obj#, if any:
59631>>>function iDDPrompt_Object global integer obj# returns integer
59633>>>  integer dm# svr# file# fld# rval#
59633>>>  get delegation_mode of obj# to dm#
59634>>>  set delegation_mode of obj# to no_delegate_or_error
59635>>>  get data_file  of obj# item CURRENT to file#
59636>>>  get data_field of obj# item CURRENT to fld#
59637>>>  set delegation_mode of obj# to dm#
59638>>>  if (file#*fld#) begin
59640>>>    get server of obj# to svr#
59641>>>    if svr# begin
59643>>>      if (main_file(svr#)<>file#) get which_data_set of svr# file# to svr#
59646>>>      if svr# begin // This way we will not error if we are dealing a data_set
59648>>>        get delegation_mode of svr# to dm#
59649>>>        set delegation_mode of svr# to no_delegate_or_error
59650>>>        get field_prompt_object of svr# fld# to rval#
59651>>>        set delegation_mode of svr# to dm#
59652>>>      end
59652>>>>
59652>>>    end
59652>>>>
59652>>>  end
59652>>>>
59652>>>  function_return rval#
59653>>>end_function
59654>>>
59654>>>class cAvailableFileObjects is an array
59655>>>  // An object of this class is meant to hold an object and a corresponding
59655>>>  // access method per file in filelist.cfg. These objects are added to the
59655>>>  // list via the add_data_file_object message.
59655>>>
59655>>>  procedure construct_object
59657>>>    forward send construct_object
59659>>>    property string pErrMsgNotAvail public ""
59660>>>  end_procedure
59661>>>
59661>>>  procedure add_data_file_object integer file# integer msg# integer tmp_obj#
59663>>>    integer obj#
59663>>>    if num_arguments gt 1 move tmp_obj# to obj#
59666>>>    else move 0 to obj#
59668>>>    set value item (file#*2)   to obj#
59669>>>    set value item (file#*2+1) to msg#
59670>>>  end_procedure
59671>>>
59671>>>  procedure exec_data_file_object integer file#
59673>>>    integer obj# msg#
59673>>>    string str# err#
59673>>>    get value item (file#*2)   to obj#
59674>>>    get value item (file#*2+1) to msg#
59675>>>    if msg# begin
59677>>>      if obj# send msg# to obj#
59680>>>      else send msg#
59682>>>    end
59682>>>>
59682>>>    else begin
59683>>>      get File_Display_Name file# to str#
59684>>>      get pErrMsgNotAvail to err#
59685>>>      send Info_Box (replace("#",err#,str#))
59686>>>    end
59686>>>>
59686>>>  end_procedure
59687>>>
59687>>>  function exists_data_file_object integer file# returns integer
59689>>>    function_return (integer(value(self,file#*2+1)))
59690>>>  end_function
59691>>>end_class // cAvailableFileObjects
59692>>>
59692>>>object oAvailableFileViews is a cAvailableFileObjects
59694>>>  set pErrMsgNotAvail to t.LnkVw.NotDefined
59695>>>end_object
59696>>>
59696>>>procedure Add_LinkView_File for BaseClass integer file# integer msg# integer tmp_obj#
59698>>>  integer obj#
59698>>>  if num_arguments gt 2 move tmp_obj# to obj#
59701>>>  else move self to obj#
59703>>>  send add_data_file_object to (oAvailableFileViews(self)) file# msg# obj#
59704>>>end_procedure
59705>>>
59705>>>register_function iLinkViewFile integer itm# returns integer
59705>>>procedure Activate_LinkView for BaseClass
59707>>>  integer file# dm# obj# itm#
59707>>>  move (focus(desktop)) to obj# // Which object has the focus?
59708>>>  if obj# gt desktop begin
59710>>>    get delegation_mode of obj# to dm# // Make sure that the object does not make
59711>>>    set delegation_mode of obj# to no_delegate_or_error // noise when asked below.
59712>>>    get current_item of obj# to itm#
59713>>>    get iLinkViewFile of obj# itm# to file#
59714>>>    ifnot file# get data_file of obj# item itm# to file# // Get 'filenumber'
59717>>>    set delegation_mode of obj# to dm# // Restore delegation mode.
59718>>>    send exec_data_file_object to (oAvailableFileViews(self)) file#
59719>>>  end
59719>>>>
59719>>>end_procedure
59720>>>
59720>>>procedure Activate_LinkView_File integer file#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59722>>>  send exec_data_file_object to (oAvailableFileViews(self)) file#
59723>>>end_procedure
59724>>>
59724>>>function Exists_LinkView returns integer
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59726>>>  integer rval# file# dm# obj# itm#
59726>>>  move (focus(desktop)) to obj# // Which object has the focus?
59727>>>  if obj# gt desktop begin
59729>>>    get delegation_mode of obj# to dm# // Make sure that the object does not make
59730>>>    set delegation_mode of obj# to no_delegate_or_error // noise when asked below.
59731>>>    get current_item of obj# to itm#
59732>>>    get iLinkViewFile of obj# itm# to file#
59733>>>    ifnot file# get data_file of obj# item current to file# // Get 'filenumber'
59736>>>    set delegation_mode of obj# to dm# // Restore delegation mode.
59737>>>    get exists_data_file_object of (oAvailableFileViews(self)) file# to rval#
59738>>>  end
59738>>>>
59738>>>  function_return rval#
59739>>>end_function
59740>>>
59740>>>function Exists_LinkView_File integer file# returns integer
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59742>>>  integer rval#
59742>>>  get exists_data_file_object of (oAvailableFileViews(self)) file# to rval#
59743>>>  function_return rval#
59744>>>end_function
59745>>>
59745>>>procedure Add_LinkView_tbButton integer oTb#
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59747>>>  send Add_Toolbar_Button_Bitmap to oTb# "tbvwlnsm.bmp" t.LnkVw.ToolTip t.LnkVw.StatusHelp msg_Activate_LinkView
59748>>>end_procedure
59749>>>
59749>>>// For backwards compatibility:
59749>>>
59749>>>// If automatic promptlists (AutoPrmpt.utl) has been used prior to this package
59749>>>// we hook up on to it:
59749>>>
59749>>>integer oToolBar#
59749>>>move 0 to oToolBar#
59750>>>
59750>>> Class cSturesToolBar is a ToolBar
59751>>>  Procedure construct_object
59753>>>    forward send construct_object
59755>>>    ifnot oToolBar# move self to oToolBar#
59758>>>    property integer pImageList_Item_Count public 0
59759>>>    property integer pAutoShadow_State public 1
59760>>>//    Set default_icons to (IDB_STANDARD IOR IDB_VIEW IOR IDB_LARGE)
59760>>>    Send ImageList_Add 'bgn.bmp'   // 0
59761>>>    Send ImageList_Add 'end.bmp'   // 1
59762>>>    Send ImageList_Add 'next.bmp'  // 2
59763>>>    Send ImageList_Add 'prev.bmp'  // 3
59764>>>    Send ImageList_Add 'clr.bmp'   // 4
59765>>>    Send ImageList_Add 'clra.bmp'  // 5
59766>>>  End_Procedure
59767>>>
59767>>>  Procedure end_construct_object
59769>>>    forward send end_construct_object
59771>>>    ifnot (item_count(self)) send Add_Standard_Toolbar_Buttons
59774>>>    send Update_Toolbar_Shadow_States
59775>>>  End_Procedure
59776>>>
59776>>>  Procedure ImageList_Add string bmp_fn#
59778>>>    forward send ImageList_Add bmp_fn#
59780>>>    set pImageList_Item_Count to (pImageList_Item_Count(self)+1)
59781>>>  End_Procedure
59782>>>
59782>>>  Procedure Add_Toolbar_Button integer ico# string Tip# string StHlp# integer msg# integer obj#
59784>>>    if num_arguments gt 4 send Add_button ico# msg# obj#
59787>>>    else                  send Add_button ico# msg#
59789>>>    send Add_ToolTip Tip#
59790>>>    set  Status_Help To StHlp#
59791>>>  End_Procedure
59792>>>
59792>>>  // If a "normal" prompt list object we send message prompt to the object.
59792>>>  // Otherwise we attempt to popup the default selection list.
59792>>>  register_procedure Request_Popup_DefaultPromptList
59792>>>  procedure Extended_Prompt
59794>>>    integer NormalPrompt# foc# obj#
59794>>>    move (focus(desktop)) to foc#
59795>>>    get iDDPrompt_Object foc# to NormalPrompt#
59796>>>    if NormalPrompt# send prompt to foc#
59799>>>    else send Request_Popup_DefaultPromptList
59801>>>  end_procedure
59802>>>
59802>>>  Procedure Print_Report
59804>>>    send Print_Report to (focus(desktop))
59805>>>  End_Procedure
59806>>>
59806>>>  Procedure Add_Toolbar_Button_Bitmap string bmp# string Tip# string StHlp# integer msg# integer obj#
59808>>>    integer ico#
59808>>>    send ImageList_Add bmp#
59809>>>    move (ICO_USER+pImageList_Item_Count(self)-1) to ico#
59810>>>    if num_arguments gt 4 send Add_Toolbar_Button ico# Tip# StHlp# msg# obj#
59813>>>    else                  send Add_Toolbar_Button ico# Tip# StHlp# msg#
59815>>>  End_Procedure
59816>>>
59816>>>  Procedure Add_Print_Button
59818>>>    send Add_Toolbar_Button ICO_STD_PRINT t.TbBtn.Print.Tip t.TbBtn.Print.StHlp  msg_Print_Report self
59819>>>  End_Procedure
59820>>>
59820>>>  // This procedure adds the standard tool bar buttons.
59820>>>  Procedure Add_Standard_Toolbar_Buttons
59822>>>    send Add_Space
59823>>>    send Add_Toolbar_Button (ICO_USER+0)     t.TbBtn.Bgn.Tip    t.TbBtn.Bgn.StHlp     msg_Beginning_Of_Data
59824>>>    send Add_Toolbar_Button (ICO_USER+3)     t.TbBtn.Prev.Tip   t.TbBtn.Prev.StHlp    msg_Find_Previous
59825>>>    send Add_Toolbar_Button (ICO_USER+2)     t.TbBtn.Next.Tip   t.TbBtn.Next.StHlp    msg_Find_Next
59826>>>    send Add_Toolbar_Button (ICO_USER+1)     t.TbBtn.End.Tip    t.TbBtn.End.StHlp     msg_End_Of_Data
59827>>>    send Add_Space
59828>>>    send Add_Toolbar_Button ICO_STD_FIND     t.TbBtn.Prompt.Tip t.TbBtn.Prompt.StHlp  msg_Extended_Prompt self
59829>>>    send Add_Toolbar_Button (ICO_USER+4)     t.TbBtn.Clear.Tip  t.TbBtn.Clear.StHlp   msg_Request_Clear
59830>>>    send Add_Toolbar_Button (ICO_USER+5)     t.TbBtn.ClearA.Tip t.TbBtn.ClearA.StHlp  msg_Request_Clear_All
59831>>>    send Add_Space
59832>>>    send Add_Toolbar_Button ICO_STD_FILESAVE t.TbBtn.Save.Tip   t.TbBtn.Save.StHlp    msg_Request_Save
59833>>>    send Add_Toolbar_Button ICO_STD_DELETE   t.TbBtn.Del.Tip    t.TbBtn.Del.StHlp     msg_Request_Delete
59834>>>    send Add_Space
59835>>>    send Add_Toolbar_Button ICO_STD_CUT      t.TbBtn.Cut.Tip    t.TbBtn.Cut.StHlp     msg_Cut
59836>>>    send Add_Toolbar_Button ICO_STD_COPY     t.TbBtn.Copy.Tip   t.TbBtn.Copy.StHlp    msg_Copy
59837>>>    send Add_Toolbar_Button ICO_STD_PASTE    t.TbBtn.Paste.Tip  t.TbBtn.Paste.StHlp   msg_Paste
59838>>>  End_Procedure
59839>>>End_Class
59840>>>
59840>>>
59840>>>register_function iAllowRequestFind returns integer
59840>>>register_function iDisAllowRequestFind returns integer
59840>>>function iFieldOptions.i integer obj# returns integer
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59842>>>  integer rval# dm# file# fld# tmp# svr# findok# not_findok#
59842>>>  integer link_to_file#
59842>>>  get delegation_mode of obj# to dm#
59843>>>  set delegation_mode of obj# to no_delegate_or_error
59844>>>  get data_file of obj# item CURRENT to file#
59845>>>  get iLinkViewFile of obj# item CURRENT to link_to_file#
59846>>>  get data_field of obj# item CURRENT to fld#
59847>>>  get iAllowRequestFind of obj# to findok#
59848>>>  get iDisAllowRequestFind of obj# to not_findok#
59849>>>  move 0 to rval#
59850>>>  get form_datatype of obj# item CURRENT to tmp#
59851>>>  move (tmp#=DATE_WINDOW) to tmp#
59852>>>  if tmp# move (rval#+FLDOPT_DATE) to rval#
59855>>>  if (file#*fld#) begin
59857>>>    if (integer(API_AttrValue_FILE(DF_FILE_OPENED,file#))) begin
59859>>>      ifnot not_findok# ifnot findok# get_attribute DF_FIELD_INDEX of file# fld# to findok#
59866>>>      if (should_save(obj#)) move (rval#+FLDOPT_SAVE) to rval#
59869>>>      get server of obj# to svr#
59870>>>      if svr# move (current_record(svr#)) to tmp#
59873>>>      if tmp# move (rval#+FLDOPT_DELETE) to rval#
59876>>>      if link_to_file# get Exists_LinkView_File link_to_file# to tmp#
59879>>>      else get Exists_LinkView_File file# to tmp#
59881>>>      if tmp# move (rval#+FLDOPT_LINKVW) to rval#
59884>>>    end
59884>>>>
59884>>>  end
59884>>>>
59884>>>  if findok# move (rval#+FLDOPT_FIND) to rval#
59887>>>  set delegation_mode of obj# to dm#
59888>>>  function_return rval#
59889>>>end_function
59890>>>
59890>>>register_procedure Request_Popup_Calendar
59890>>>
59890>>>Procedure Update_Toolbar_Shadow_States
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
59892>>>  integer foc# itm# max# msg# opt#
59892>>>  if oToolBar# begin
59894>>>    if (pAutoShadow_State(oToolBar#)) begin
59896>>>      move (focus(desktop)) to foc#
59897>>>      if foc# gt desktop get iFieldOptions.i foc# to opt#
59900>>>      get item_count of oToolBar# to max#
59901>>>      for itm# from 0 to (max#-1)
59907>>>>
59907>>>        get message of oToolBar# item itm# to msg#
59908>>>        if (msg#=msg_beginning_of_data or msg#=msg_find_previous or msg#=msg_find_next or msg#=msg_end_of_data) set shadow_state of oToolBar# item itm# to (not(opt# iAND FLDOPT_FIND))
59911>>>      //if (msg#=msg_Request_Save)           set shadow_state of oToolBar# item itm# to (not(opt# iAND FLDOPT_SAVE))
59911>>>      //if (msg#=msg_Request_Clear)          set shadow_state of oToolBar# item itm# to (not((opt# iAND FLDOPT_SAVE) or (opt# iAND FLDOPT_DELETE)))
59911>>>      //if (msg#=msg_Request_Delete)         set shadow_state of oToolBar# item itm# to (not(opt# iAND FLDOPT_DELETE))
59911>>>        if (msg#=msg_Request_Popup_Calendar) set shadow_state of oToolBar# item itm# to (not(opt# iAND FLDOPT_DATE))
59914>>>        if (msg#=msg_Activate_LinkView)      set shadow_state of oToolBar# item itm# to (not(opt# iAND FLDOPT_LINKVW))
59917>>>      loop
59918>>>>
59918>>>    end
59918>>>>
59918>>>  end
59918>>>>
59918>>>End_Procedure
59919>>>
59919>>>Class cSturesStatusBar is a StatusBar
59920>>>  Procedure Show_Status_Help string str#
59922>>>    forward send Show_Status_Help str#
59924>>>    send Update_Toolbar_Shadow_States
59925>>>  End_Procedure
59926>>>End_Class
59927>>>
59927>>>class cViewPopupMenu is a ViewPopupMenu
59928>>>  procedure construct_object
59930>>>    forward send construct_object
59932>>>    property string pTitle       public ""
59933>>>    property string pStatus_Help public ""
59934>>>  end_procedure
59935>>>  procedure end_construct_object
59937>>>    integer itm# self#
59937>>>    string title# status_help#
59937>>>    get pTitle to title#
59938>>>    get pStatus_Help to status_help#
59939>>>    forward send end_construct_object
59941>>>    move self to self#
59942>>>    delegate send add_item 0 title# // 0 betyder aktiver child menu
59944>>>    get item_count of (parent(self)) to itm#
59945>>>    set aux_value of (parent(self)) item (itm#-1) to self#
59946>>>    set status_help of (parent(self)) item (itm#-1) to status_help#
59947>>>  end_procedure
59948>>>  function Message integer itm# returns integer
59950>>>     integer rVal#
59950>>>     Forward Get message item itm# to rVal#
59952>>>     // Apparantly global messages cannot be represented via the add_item
59952>>>     // message. Therefore we have to do this:
59952>>>     if rval# gt 10000 move (rval#-65536) to rval#
59955>>>     function_return rval#
59956>>>  end_function
59957>>>  procedure add_menu_item integer msg# string label# string status_help# integer tmp_aux#
59959>>>    integer aux#
59959>>>    if num_arguments begin
59961>>>      send add_item msg# label#
59962>>>      if num_arguments gt 3 move tmp_aux# to aux#
59965>>>      else move -1 to aux# // -1 will automatically get replaced with client_id
59967>>>      set aux_value item (item_count(self)-1) to aux#
59968>>>      set status_help item (item_count(self)-1) to status_help#
59969>>>    end
59969>>>>
59969>>>    else send add_item msg_none ""
59971>>>  end_procedure
59972>>>  procedure add_standard_menu_items
59974>>>  end_procedure
59975>>>end_class
59976>Use StrucTrc.utl // Object for tracing a restructure operation
Including file: structrc.utl    (C:\Apps\VDFQuery\AppSrc\structrc.utl)
59976>>>// Use StrucTrc.utl // Object for tracing a restructure operation
59976>>>
59976>>>Use Structur.utl // Object for restructuring table definitions
Including file: structur.utl    (C:\Apps\VDFQuery\AppSrc\structur.utl)
59976>>>>>//**********************************************************************
59976>>>>>// Use Structur.utl // Object for restructuring table definitions
59976>>>>>//
59976>>>>>// By Sture Andersen
59976>>>>>//
59976>>>>>// Create: Sun  24-10-1999
59976>>>>>// Update: Tue  25-01-2000 - Windows interface added to the waiter...
59976>>>>>//         Fri  03-03-2000 - RS_RestructureGroup class added
59976>>>>>//         Sat  22-04-2000 - RS_TableOpenName function added
59976>>>>>//**********************************************************************
59976>>>>>//
59976>>>>>// This package defines a global object for restructuring tables. This global
59976>>>>>// object is manipulated via a bunch of global messages all prefixed with
59976>>>>>// the letters "RS_".
59976>>>>>//
59976>>>>>// The advantage of using this object instead of using the SET_ATTRIBUTE and
59976>>>>>// GET_ATTRIBUTE commands directly is that the global object makes up for a
59976>>>>>// few shortcomings that these commands exhibits.
59976>>>>>//
59976>>>>>
59976>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
59976>>>>>Use Structur.nui
Including file: structur.nui    (C:\Apps\VDFQuery\AppSrc\structur.nui)
59976>>>>>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
59976>>>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
59976>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
59976>>>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
59976>>>>>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
59976>>>>>>>Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles) (No User Interface)
Including file: openstat.nui    (C:\Apps\VDFQuery\AppSrc\openstat.nui)
59976>>>>>>>>>// Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles) (No User Interface)
59976>>>>>>>>>
59976>>>>>>>>>//> Usually when a DataFlex program is running a number of data tables
59976>>>>>>>>>//> have been opened (with the open command). Each open table is assigned
59976>>>>>>>>>//> a number usually identical to the number of the entry in FILELIST.CFG.
59976>>>>>>>>>//>
59976>>>>>>>>>//> An object of the cTablesOpenStatus is capable of taking a snapshot
59976>>>>>>>>>//> of which tables are open. After a 'snapshop' has been taken you may
59976>>>>>>>>>//> open new tables or change the open mode of already open tables.
59976>>>>>>>>>//>
59976>>>>>>>>>//> At this point the object is capable of restoring the status to the
59976>>>>>>>>>//> the time of the snapshot.
59976>>>>>>>>>//>
59976>>>>>>>>>//>
59976>>>>>>>>>//>   object oOpenStat is a cTablesOpenStatus
59976>>>>>>>>>//>   end_object
59976>>>>>>>>>//>
59976>>>>>>>>>//>   send RegisterCurrentOpenFiles to (oOpenStat(self)) // Snap!
59976>>>>>>>>>//>   open this
59976>>>>>>>>>//>   close that
59976>>>>>>>>>//>   send RestoreFiles to (oOpenStat(self)) // Restore
59976>>>>>>>>>
59976>>>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
59976>>>>>>>>>Use DBMS.nui     // Basic DBMS functions
59976>>>>>>>>>
59976>>>>>>>>>          class cTablesOpenPrepareList is an cArray // This must be embedded in a cTablesOpenStatus object
59977>>>>>>>>>            item_property_list
59977>>>>>>>>>              item_property integer piFile.i
59977>>>>>>>>>              item_property integer piMode.i
59977>>>>>>>>>              item_property integer piIdx.i
59977>>>>>>>>>              item_property string  psRootName.i
59977>>>>>>>>>            end_item_property_list cTablesOpenPrepareList
#REM 60015 DEFINE FUNCTION PSROOTNAME.I INTEGER LIROW RETURNS STRING
#REM 60019 DEFINE PROCEDURE SET PSROOTNAME.I INTEGER LIROW STRING VALUE
#REM 60023 DEFINE FUNCTION PIIDX.I INTEGER LIROW RETURNS INTEGER
#REM 60027 DEFINE PROCEDURE SET PIIDX.I INTEGER LIROW INTEGER VALUE
#REM 60031 DEFINE FUNCTION PIMODE.I INTEGER LIROW RETURNS INTEGER
#REM 60035 DEFINE PROCEDURE SET PIMODE.I INTEGER LIROW INTEGER VALUE
#REM 60039 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 60043 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
60048>>>>>>>>>            procedure prepare_open integer liFile integer liMode integer liIndex string lsRootName
60050>>>>>>>>>              integer liRow
60050>>>>>>>>>              get row_count to liRow
60051>>>>>>>>>              set piFile.i     liRow to liFile
60052>>>>>>>>>              set piMode.i     liRow to liMode
60053>>>>>>>>>              set piIdx.i      liRow to liIndex
60054>>>>>>>>>              set psRootName.i liRow to lsRootName
60055>>>>>>>>>            end_procedure
60056>>>>>>>>>            //> Function iOpen_Prepared will return 0 if all tables in the set
60056>>>>>>>>>            //> was opened as specified. If this cannot be done the function
60056>>>>>>>>>            //> will return the number of the first table, that could not be
60056>>>>>>>>>            //> opened. If the function returns a non zero value, the number of
60056>>>>>>>>>            //> tables actually opened by the function is undefined.
60056>>>>>>>>>            function iOpen_Prepared.i integer lbQuiet returns integer
60058>>>>>>>>>              integer liRval liMax liRow lbStop
60058>>>>>>>>>              integer liFile liMode liIndex lbOpen
60058>>>>>>>>>              string lsRootName
60058>>>>>>>>>              get row_count to liMax
60059>>>>>>>>>              move 0 to liRval
60060>>>>>>>>>              move 0 to liRow
60061>>>>>>>>>              move 0 to lbStop
60062>>>>>>>>>              repeat
60062>>>>>>>>>>
60062>>>>>>>>>                if liRow lt liMax begin
60064>>>>>>>>>                  get piFile.i     liRow to liFile
60065>>>>>>>>>                  get piMode.i     liRow to liMode
60066>>>>>>>>>                  get piIdx.i      liRow to liIndex
60067>>>>>>>>>                  get psRootName.i liRow to lsRootName
60068>>>>>>>>>                  if lsRootName eq "" get iOpen_File.ii liFile liMode to lbOpen
60071>>>>>>>>>                  else                get DBMS_OpenFileAs lsRootName liFile liMode liIndex to lbOpen
60073>>>>>>>>>
60073>>>>>>>>>                  ifnot lbOpen begin
60075>>>>>>>>>                    move 1 to lbStop
60076>>>>>>>>>                    ifnot lbQuiet error 772 ("File: "+string(liFile)+" can't be opened ("+lsRootName+")")
60079>>>>>>>>>                    move liFile to liRval
60080>>>>>>>>>                  end
60080>>>>>>>>>>
60080>>>>>>>>>                  else increment liRow
60082>>>>>>>>>                end
60082>>>>>>>>>>
60082>>>>>>>>>                else move 1 to lbStop
60084>>>>>>>>>              until lbStop
60086>>>>>>>>>              function_return liRval
60087>>>>>>>>>            end_function
60088>>>>>>>>>
60088>>>>>>>>>            function sRootName_Prepared integer liFile returns string
60090>>>>>>>>>              integer liRow liMax lbFin
60090>>>>>>>>>              string lsRval
60090>>>>>>>>>              get row_count to liMax
60091>>>>>>>>>              move 0 to lbFin
60092>>>>>>>>>              move 0 to liRow
60093>>>>>>>>>              move "" to lsRval
60094>>>>>>>>>              if liMax begin
60096>>>>>>>>>                repeat
60096>>>>>>>>>>
60096>>>>>>>>>                  if (piFile.i(self,liRow)=liFile) begin
60098>>>>>>>>>                    move (psRootName.i(self,liRow)) to lsRval
60099>>>>>>>>>                    if lsRval eq "" get_attribute DF_FILE_ROOT_NAME of liFile to lsRval
60104>>>>>>>>>                    move 1 to lbFin
60105>>>>>>>>>                  end
60105>>>>>>>>>>
60105>>>>>>>>>                  ifnot lbFin increment liRow
60108>>>>>>>>>                  if liRow ge liMax move 1 to lbFin
60111>>>>>>>>>                until lbFin
60113>>>>>>>>>              end
60113>>>>>>>>>>
60113>>>>>>>>>              function_return lsRval
60114>>>>>>>>>            end_function
60115>>>>>>>>>          end_class // cTablesOpenPrepareList
60116>>>>>>>>>
60116>>>>>>>>>class cTablesOpenStatus is a cArray
60117>>>>>>>>>  procedure construct_object
60119>>>>>>>>>    forward send construct_object
60121>>>>>>>>>    object oFilesToOpen is a cTablesOpenPrepareList no_image
60123>>>>>>>>>    end_object
60124>>>>>>>>>    property integer pbRestoreOpened private 0
60125>>>>>>>>>    property integer pbQuiet private 0
60126>>>>>>>>>  end_procedure
60127>>>>>>>>>
60127>>>>>>>>>  item_property_list
60127>>>>>>>>>    item_property integer piIsOpen.i         // 1=Yes, 0=No
60127>>>>>>>>>    item_property integer piOpenMode.i       // DF_SHARE, DF_EXCLUSIVE
60127>>>>>>>>>    item_property integer piFilemode.i       // DF_FILE_ALIAS_DEFAULT, DF_FILE_IS_MASTER, DF_FILE_IS_ALIAS
60127>>>>>>>>>    item_property integer piFileAlias.i      // Is it an alias file?
60127>>>>>>>>>    item_property string  psPhysicalName.i   // Runtimes idea of the root name of the file
60127>>>>>>>>>    item_property string  psRootName.i       // Filelist.cfg's idea of the root name
60127>>>>>>>>>    item_property integer piDriver.i         // Comes from the DBMS_FileDriverType function (dbms.nui)
60127>>>>>>>>>    item_property integer psWhereIsIt.i      // Sture's private investigation to figure out where the data file is.
60127>>>>>>>>>  end_item_property_list cTablesOpenStatus
#REM 60177 DEFINE FUNCTION PSWHEREISIT.I INTEGER LIROW RETURNS INTEGER
#REM 60181 DEFINE PROCEDURE SET PSWHEREISIT.I INTEGER LIROW INTEGER VALUE
#REM 60185 DEFINE FUNCTION PIDRIVER.I INTEGER LIROW RETURNS INTEGER
#REM 60189 DEFINE PROCEDURE SET PIDRIVER.I INTEGER LIROW INTEGER VALUE
#REM 60193 DEFINE FUNCTION PSROOTNAME.I INTEGER LIROW RETURNS STRING
#REM 60197 DEFINE PROCEDURE SET PSROOTNAME.I INTEGER LIROW STRING VALUE
#REM 60201 DEFINE FUNCTION PSPHYSICALNAME.I INTEGER LIROW RETURNS STRING
#REM 60205 DEFINE PROCEDURE SET PSPHYSICALNAME.I INTEGER LIROW STRING VALUE
#REM 60209 DEFINE FUNCTION PIFILEALIAS.I INTEGER LIROW RETURNS INTEGER
#REM 60213 DEFINE PROCEDURE SET PIFILEALIAS.I INTEGER LIROW INTEGER VALUE
#REM 60217 DEFINE FUNCTION PIFILEMODE.I INTEGER LIROW RETURNS INTEGER
#REM 60221 DEFINE PROCEDURE SET PIFILEMODE.I INTEGER LIROW INTEGER VALUE
#REM 60225 DEFINE FUNCTION PIOPENMODE.I INTEGER LIROW RETURNS INTEGER
#REM 60229 DEFINE PROCEDURE SET PIOPENMODE.I INTEGER LIROW INTEGER VALUE
#REM 60233 DEFINE FUNCTION PIISOPEN.I INTEGER LIROW RETURNS INTEGER
#REM 60237 DEFINE PROCEDURE SET PIISOPEN.I INTEGER LIROW INTEGER VALUE
60242>>>>>>>>>
60242>>>>>>>>>  //> This procedure resets the set of files to be openend by the
60242>>>>>>>>>  //> iOpen_Prepared function.
60242>>>>>>>>>  procedure reset_prepared
60244>>>>>>>>>    send delete_data to (oFilesToOpen(self))
60245>>>>>>>>>  end_procedure
60246>>>>>>>>>  procedure reset
60248>>>>>>>>>    send reset_prepared
60249>>>>>>>>>    send delete_data
60250>>>>>>>>>  end_procedure
60251>>>>>>>>>  //> When you want a set of files to be openend in exclusive mode or
60251>>>>>>>>>  //> if you want to open a set of files different the ones currently
60251>>>>>>>>>  //> opened you may use the Prepare_Open message to register which
60251>>>>>>>>>  //> files you want opened in what entries (1-4095).
60251>>>>>>>>>  procedure prepare_open integer liFile integer liMode integer liIndex string lsRootName
60253>>>>>>>>>    send prepare_open to (oFilesToOpen(self)) liFile liMode liIndex lsRootName
60254>>>>>>>>>  end_procedure
60255>>>>>>>>>
60255>>>>>>>>>  procedure prepare_open_all_registered_tables_exclusive
60257>>>>>>>>>    integer liMax liTable
60257>>>>>>>>>    get row_count to liMax
60258>>>>>>>>>    decrement liMax
60259>>>>>>>>>    for liTable from 0 to liMax
60265>>>>>>>>>>
60265>>>>>>>>>      if (piIsOpen.i(self,liTable)) begin
60267>>>>>>>>>        if (piFileAlias.i(self,litable)<>DF_FILE_IS_ALIAS) begin
60269>>>>>>>>>          send prepare_open liTable DF_EXCLUSIVE 0 (psPhysicalName.i(self,liTable))
60270>>>>>>>>>        end
60270>>>>>>>>>>
60270>>>>>>>>>      end
60270>>>>>>>>>>
60270>>>>>>>>>    loop
60271>>>>>>>>>>
60271>>>>>>>>>  end_procedure
60272>>>>>>>>>
60272>>>>>>>>>  function iOpen_Prepared returns integer
60274>>>>>>>>>    function_return (iOpen_Prepared.i(oFilesToOpen(self),0))
60275>>>>>>>>>  end_function
60276>>>>>>>>>  function iOpen_Prepared_Quiet returns integer
60278>>>>>>>>>    function_return (iOpen_Prepared.i(oFilesToOpen(self),1))
60279>>>>>>>>>  end_function
60280>>>>>>>>>  function sRootName_Prepared integer liFile returns string
60282>>>>>>>>>    function_return (sRootName_Prepared(oFilesToOpen(self),liFile))
60283>>>>>>>>>  end_function
60284>>>>>>>>>
60284>>>>>>>>>  //> Takes a snap shot of open files.
60284>>>>>>>>>  procedure RegisterCurrentOpenFiles
60286>>>>>>>>>    integer liFile lbOpen liFileOpenMode liFileMode liFileAlias
60286>>>>>>>>>    string lsPhysicalName lsRootName lsWhereIsIt
60286>>>>>>>>>    send delete_data
60287>>>>>>>>>    move 0 to liFile
60288>>>>>>>>>    repeat
60288>>>>>>>>>>
60288>>>>>>>>>      get_attribute DF_FILE_NEXT_OPENED of liFile to liFile
60291>>>>>>>>>      if liFile begin
60293>>>>>>>>>        get_attribute DF_FILE_OPEN_MODE     of liFile to liFileOpenMode // DF_SHARE, DF_EXCLUSIVE
60296>>>>>>>>>        get_attribute DF_FILE_MODE          of liFile to liFileMode     // DF_FILE_ALIAS_DEFAULT, DF_FILE_IS_MASTER, DF_FILE_IS_ALIAS
60299>>>>>>>>>        get_attribute DF_FILE_ALIAS         of liFile to liFileAlias    // I don't know what this is!
60302>>>>>>>>>        get_attribute DF_FILE_PHYSICAL_NAME of liFile to lsPhysicalName // Runtimes idea of the root name of the file
60305>>>>>>>>>        get_attribute DF_FILE_ROOT_NAME     of liFile to lsRootName     // Filelist.cfg's idea of the root name
60308>>>>>>>>>
60308>>>>>>>>>        get DBMS_TablePath liFile to lsWhereIsIt
60309>>>>>>>>>
60309>>>>>>>>>        set piIsOpen.i       liFile to 1 // Open!
60310>>>>>>>>>        set piOpenMode.i     liFile to liFileOpenMode
60311>>>>>>>>>        set piFilemode.i     liFile to liFileMode
60312>>>>>>>>>        set piFileAlias.i    liFile to liFileAlias
60313>>>>>>>>>        set psPhysicalName.i liFile to lsPhysicalName
60314>>>>>>>>>        set psRootName.i     liFile to lsRootName
60315>>>>>>>>>        set piDriver.i       liFile to (DBMS_FileDriverType(liFile))
60316>>>>>>>>>        set psWhereIsIt.i    liFile to lsWhereIsIt
60317>>>>>>>>>      end
60317>>>>>>>>>>
60317>>>>>>>>>    until liFile eq 0
60319>>>>>>>>>  end_procedure
60320>>>>>>>>>  procedure CloseAllFiles
60322>>>>>>>>>    Close DF_ALL
60323>>>>>>>>>  end_procedure
60324>>>>>>>>>  procedure CloseAllFilesOnDriver integer liDriver
60326>>>>>>>>>    integer liFile
60326>>>>>>>>>    move 0 to liFile
60327>>>>>>>>>    repeat
60327>>>>>>>>>>
60327>>>>>>>>>      get_attribute DF_FILE_NEXT_OPENED of liFile to liFile
60330>>>>>>>>>      if liFile if (DBMS_FileDriverType(liFile)) eq liDriver close liFile
60335>>>>>>>>>    until liFile eq 0
60337>>>>>>>>>  end_procedure
60338>>>>>>>>>  //> Close the ones that weren't open at the time of the last snapshot
60338>>>>>>>>>  procedure RestoreClosed
60340>>>>>>>>>    integer liFile
60340>>>>>>>>>    move 0 to liFile
60341>>>>>>>>>    repeat
60341>>>>>>>>>>
60341>>>>>>>>>      get_attribute DF_FILE_NEXT_OPENED of liFile to liFile
60344>>>>>>>>>      if liFile ifnot (piIsOpen.i(self,liFile)) close liFile
60349>>>>>>>>>    until liFile eq 0
60351>>>>>>>>>  end_procedure
60352>>>>>>>>>  //> Open the ones that were open at the time of the last snapshot
60352>>>>>>>>>  procedure RestoreOpened
60354>>>>>>>>>    integer liFile lbOpen liFileOpenMode liFileMode liFileAlias liMax lbQuiet
60354>>>>>>>>>    string lsPhysicalName lsRootName
60354>>>>>>>>>    get cTablesOpenStatus.pbQuiet to lbQuiet
60355>>>>>>>>>    get row_count to liMax
60356>>>>>>>>>    decrement liMax
60357>>>>>>>>>    for liFile from 1 to liMax
60363>>>>>>>>>>
60363>>>>>>>>>      get piIsOpen.i liFile to lbOpen
60364>>>>>>>>>      if lbOpen begin
60366>>>>>>>>>        get piOpenMode.i     liFile to liFileOpenMode
60367>>>>>>>>>        get piFilemode.i     liFile to liFileMode
60368>>>>>>>>>        get piFileAlias.i    liFile to liFileAlias
60369>>>>>>>>>        get psPhysicalName.i liFile to lsPhysicalName
60370>>>>>>>>>        get psRootName.i     liFile to lsRootName
60371>>>>>>>>>        if (uppercase(lsPhysicalName)) ne (uppercase(lsRootName)) begin
60373>>>>>>>>>          move (DBMS_OpenFileAs(lsPhysicalName,liFile,liFileOpenMode,0)) to lbOpen
60374>>>>>>>>>          ifnot lbOpen begin
60376>>>>>>>>>            ifnot lbQuiet begin
60378>>>>>>>>>              error 666 ("Can't restore open files (file: "+string(liFile)+")")
60379>>>>>>>>>>
60379>>>>>>>>>              error 666 ("Name: "+lsPhysicalName+"!")
60380>>>>>>>>>>
60380>>>>>>>>>            end
60380>>>>>>>>>>
60380>>>>>>>>>            set cTablesOpenStatus.pbRestoreOpened to false
60381>>>>>>>>>          end
60381>>>>>>>>>>
60381>>>>>>>>>        end
60381>>>>>>>>>>
60381>>>>>>>>>        else move (DBMS_OpenFile(liFile,liFileOpenMode,0)) to lbOpen
60383>>>>>>>>>        if lbOpen begin
60385>>>>>>>>>          set_attribute DF_FILE_MODE  of liFile to liFileMode
60388>>>>>>>>>          set_attribute DF_FILE_ALIAS of liFile to liFileAlias
60391>>>>>>>>>        //send obs "File Mode:" (string(liFileMode)) "File Alias:" (string(liFileAlias))
60391>>>>>>>>>        end
60391>>>>>>>>>>
60391>>>>>>>>>        else begin
60392>>>>>>>>>          ifnot lbQuiet begin
60394>>>>>>>>>            error 668 "Error: Cannot reconnect to database!" //"(Sounds serious, but it isn't)" "Restart program (not the computer)" (uppercase(lsPhysicalName)) (uppercase(lsRootName)) (string(liFileOpenMode)) (string(liFileMode))
60395>>>>>>>>>>
60395>>>>>>>>>          end
60395>>>>>>>>>>
60395>>>>>>>>>          set cTablesOpenStatus.pbRestoreOpened to false
60396>>>>>>>>>        end
60396>>>>>>>>>>
60396>>>>>>>>>      end
60396>>>>>>>>>>
60396>>>>>>>>>    loop
60397>>>>>>>>>>
60397>>>>>>>>>  end_procedure
60398>>>>>>>>>  function bRestoreOpened integer lbQuiet returns integer
60400>>>>>>>>>    integer lbRval
60400>>>>>>>>>    set cTablesOpenStatus.pbRestoreOpened to true
60401>>>>>>>>>    set cTablesOpenStatus.pbQuiet to lbQuiet
60402>>>>>>>>>    send RestoreOpened
60403>>>>>>>>>    get cTablesOpenStatus.pbRestoreOpened to lbRval
60404>>>>>>>>>    set cTablesOpenStatus.pbQuiet to false
60405>>>>>>>>>    function_return lbRval
60406>>>>>>>>>  end_function
60407>>>>>>>>>
60407>>>>>>>>>  // This may be used to make sure that the file_mode and file_alias attributes
60407>>>>>>>>>  // are identical before and after reindexing a file.
60407>>>>>>>>>  procedure write_file
60409>>>>>>>>>    integer liFile liChannel liFileMode liFileAlias
60409>>>>>>>>>    get Seq_New_Channel to liChannel
60410>>>>>>>>>    direct_output channel liChannel "openstat.txt"
60412>>>>>>>>>    move 0 to liFile
60413>>>>>>>>>    repeat
60413>>>>>>>>>>
60413>>>>>>>>>      get_attribute DF_FILE_NEXT_OPENED of liFile to liFile
60416>>>>>>>>>      if liFile begin
60418>>>>>>>>>        get_attribute DF_FILE_MODE          of liFile to liFileMode
60421>>>>>>>>>        get_attribute DF_FILE_ALIAS         of liFile to liFileAlias
60424>>>>>>>>>        writeln channel liChannel ("File:"+string(liFile))
60427>>>>>>>>>        writeln "File Mode:" (string(liFileMode)) "File Alias:" (string(liFileAlias))
60432>>>>>>>>>      end
60432>>>>>>>>>>
60432>>>>>>>>>    until liFile eq 0
60434>>>>>>>>>    close_output channel liChannel
60436>>>>>>>>>    send Seq_Release_Channel liChannel
60437>>>>>>>>>  end_procedure
60438>>>>>>>>>
60438>>>>>>>>>  procedure RestoreFiles
60440>>>>>>>>>    send RestoreClosed
60441>>>>>>>>>    send RestoreOpened
60442>>>>>>>>>  end_procedure
60443>>>>>>>>>  //> Open a file of the previous snapshot in a new and exciting mode.
60443>>>>>>>>>  function iOpen_File.ii integer liFile integer liMode returns integer
60445>>>>>>>>>    string lsPhysicalName
60445>>>>>>>>>    get psPhysicalName.i liFile to lsPhysicalName
60446>>>>>>>>>    if lsPhysicalName ne "" function_return (DBMS_OpenFileAs(lsPhysicalName,liFile,liMode,0))
60449>>>>>>>>>    function_return (DBMS_OpenFile(liFile,liMode,0))
60450>>>>>>>>>  end_function
60451>>>>>>>>>end_class // cTablesOpenStatus
60452>>>>>>>>>
60452>>>>>>>>>desktop_section
60457>>>>>>>>>  object oTablesOpenStatus_Global is a cTablesOpenStatus
60459>>>>>>>>>  end_object
60460>>>>>>>>>end_desktop_section
60465>>>>>>>>>
60465>>>>>>>>>procedure OpenStat_RegisterFiles global
60467>>>>>>>>>  send RegisterCurrentOpenFiles to (oTablesOpenStatus_Global(self))
60468>>>>>>>>>end_procedure
60469>>>>>>>>>procedure OpenStat_CloseAllFiles global
60471>>>>>>>>>  send CloseAllFiles to (oTablesOpenStatus_Global(self))
60472>>>>>>>>>end_procedure
60473>>>>>>>>>procedure OpenStat_RestoreFiles global
60475>>>>>>>>>  send RestoreFiles to (oTablesOpenStatus_Global(self))
60476>>>>>>>>>end_procedure
60477>>>>>>>>>
60477>>>>>>>>>function OpenStat_RestoreFilesFunction global integer lbQuiet returns integer
60479>>>>>>>>>  integer lbRval
60479>>>>>>>>>  send RestoreClosed to (oTablesOpenStatus_Global(self))
60480>>>>>>>>>  get bRestoreOpened of (oTablesOpenStatus_Global(self)) lbQuiet to lbRval
60481>>>>>>>>>  function_return lbRval
60482>>>>>>>>>end_function
60483>>>>>>>>>
60483>>>>>>>>>//> Calling this procedure will close and re-open all embedded database tables currently open
60483>>>>>>>>>//> by the application. I can't remember why I did it, but here it is.
60483>>>>>>>>>procedure FlushAllDataFlexBuffers global
60485>>>>>>>>>  integer lhObj
60485>>>>>>>>>  move (oTablesOpenStatus_Global(self)) to lhObj
60486>>>>>>>>>  send RegisterCurrentOpenFiles to lhObj
60487>>>>>>>>>  send CloseAllFilesOnDriver to lhObj DBMS_DRIVER_DATAFLEX
60488>>>>>>>>>  send RestoreOpened to lhObj
60489>>>>>>>>>end_procedure
60490>>>>>>>>>
60490>>>>>>>
60490>>>>>>> define t.STRUCT.Restart for "The program will now attempt to re-start"
60490>>>>>>>
60490>>>>>>> string Struc$ErrDescr
60490>>>>>>>
60490>>>>>>>integer cRestructurer#
60490>>>>>>>if dfFalse begin
60492>>>>>>>  cRestructurer_Error:
60492>>>>>>>    send structure_error to cRestructurer#
60493>>>>>>>  return
60494>>>>>>>end
60494>>>>>>>>
60494>>>>>>>
60494>>>>>>>enumeration_list
60494>>>>>>>  define RSOP_BEGIN
60494>>>>>>>  define RSOP_CREATEFIELD
60494>>>>>>>  define RSOP_DELETEFIELD
60494>>>>>>>  define RSOP_DELETEINDEX
60494>>>>>>>  define RSOP_SETFILEATTR
60494>>>>>>>  define RSOP_SETFIELDATTR
60494>>>>>>>  define RSOP_SETINDEXATTR
60494>>>>>>>  define RSOP_SETINDEXSEGATTR
60494>>>>>>>  define RSOP_TRUNCATED
60494>>>>>>>  define RSOP_ERROR_OCCURRED
60494>>>>>>>  define RSOP_END
60494>>>>>>>end_enumeration_list
60494>>>>>>>
60494>>>>>>>enumeration_list
60494>>>>>>>  define ERRORTRAP_ATTRCHANGE
60494>>>>>>>  define ERRORTRAP_FIELDCREATE
60494>>>>>>>  define ERRORTRAP_FIELDDELETE
60494>>>>>>>  define ERRORTRAP_INDEXCREATE
60494>>>>>>>  define ERRORTRAP_INDEXDELETE
60494>>>>>>>end_enumeration_list
60494>>>>>>>
60494>>>>>>>object oStructureErrorInfo is a cArray no_image
60496>>>>>>>  property string psLine1 public ""
60498>>>>>>>  property string psLine2 public ""
60500>>>>>>>  procedure DoPrepare
60503>>>>>>>    integer attr# attr_type# field# index# segment# ErrTrapType#
60503>>>>>>>    string line1# line2# value#
60503>>>>>>>    get value item 0 to ErrTrapType#
60504>>>>>>>    move "" to line1#
60505>>>>>>>    move "" to line2#
60506>>>>>>>    if ErrTrapType# eq ERRORTRAP_ATTRCHANGE  begin
60508>>>>>>>      get value item 1 to attr#
60509>>>>>>>      get API_AttrType attr# to attr_type#
60510>>>>>>>      if attr_type# eq ATTRTYPE_FILELIST begin
60512>>>>>>>        get value item 3 to value#
60513>>>>>>>        move "Set_Attribute # to #" to line1#
60514>>>>>>>        replace "#" in line1# with (API_Attr_Name(attr#))
60516>>>>>>>        replace "#" in line1# with (API_Attr_ValueName(attr#,value#))
60518>>>>>>>      end
60518>>>>>>>>
60518>>>>>>>      if attr_type# eq ATTRTYPE_FILE begin
60520>>>>>>>        get value item 3 to value#
60521>>>>>>>        move "Set_Attribute # to #" to line1#
60522>>>>>>>        replace "#" in line1# with (API_Attr_Name(attr#))
60524>>>>>>>        replace "#" in line1# with (API_Attr_ValueName(attr#,value#))
60526>>>>>>>      end
60526>>>>>>>>
60526>>>>>>>      if attr_type# eq ATTRTYPE_FIELD begin
60528>>>>>>>        get value item 3 to field#
60529>>>>>>>        get value item 4 to value#
60530>>>>>>>        move "Set_Attribute # field #" to line1#
60531>>>>>>>        move "to #" to line2#
60532>>>>>>>        replace "#" in line1# with (API_Attr_Name(attr#))
60534>>>>>>>        replace "#" in line1# with (string(field#))
60536>>>>>>>        replace "#" in line2# with (API_Attr_ValueName(attr#,value#))
60538>>>>>>>      end
60538>>>>>>>>
60538>>>>>>>      if attr_type# eq ATTRTYPE_INDEX begin
60540>>>>>>>        get value item 3 to index#
60541>>>>>>>        get value item 4 to value#
60542>>>>>>>        move "Set_Attribute # index #" to line1#
60543>>>>>>>        move "to #" to line2#
60544>>>>>>>        replace "#" in line1# with (API_Attr_Name(attr#))
60546>>>>>>>        replace "#" in line1# with (string(index#))
60548>>>>>>>        replace "#" in line2# with (API_Attr_ValueName(attr#,value#))
60550>>>>>>>      end
60550>>>>>>>>
60550>>>>>>>      if attr_type# eq ATTRTYPE_IDXSEG begin
60552>>>>>>>        get value item 3 to index#
60553>>>>>>>        get value item 4 to segment#
60554>>>>>>>        get value item 5 to value#
60555>>>>>>>        move "Set_Attribute # index # segment #" to line1#
60556>>>>>>>        move "to #" to line2#
60557>>>>>>>        replace "#" in line1# with (API_Attr_Name(attr#))
60559>>>>>>>        replace "#" in line1# with (string(index#))
60561>>>>>>>        replace "#" in line1# with (string(segment#))
60563>>>>>>>        replace "#" in line2# with (API_Attr_ValueName(attr#,value#))
60565>>>>>>>      end
60565>>>>>>>>
60565>>>>>>>    end
60565>>>>>>>>
60565>>>>>>>    if ErrTrapType# eq ERRORTRAP_FIELDCREATE begin
60567>>>>>>>      move "Create_Field # at #" to line1#
60568>>>>>>>      move (replace("#",line1#,string(value(self,1)))) to line1#
60569>>>>>>>      move (replace("#",line1#,string(value(self,2)))) to line1#
60570>>>>>>>    end
60570>>>>>>>>
60570>>>>>>>    if ErrTrapType# eq ERRORTRAP_FIELDDELETE begin
60572>>>>>>>      move "Delete_Field #" to line1#
60573>>>>>>>      move (replace("#",line1#,string(value(self,1)))) to line1#
60574>>>>>>>    end
60574>>>>>>>>
60574>>>>>>>    if ErrTrapType# eq ERRORTRAP_INDEXCREATE begin
60576>>>>>>>      move "Create_Index # at #" to line1#
60577>>>>>>>      move (replace("#",line1#,string(value(self,1)))) to line1#
60578>>>>>>>      move (replace("#",line1#,string(value(self,2)))) to line1#
60579>>>>>>>    end
60579>>>>>>>>
60579>>>>>>>    if ErrTrapType# eq ERRORTRAP_INDEXDELETE begin
60581>>>>>>>      move "Delete_Index #" to line1#
60582>>>>>>>      move (replace("#",line1#,string(value(self,1)))) to line1#
60583>>>>>>>    end
60583>>>>>>>>
60583>>>>>>>    set psLine1 to line1#
60584>>>>>>>    set psLine2 to line2#
60585>>>>>>>    send NotifyTracer to cRestructurer# RSOP_ERROR_OCCURRED 0 0 0 0 (line1#*line2#)
60586>>>>>>>  end_procedure
60587>>>>>>>end_object // oStructureErrorInfo
60588>>>>>>>
60588>>>>>>>procedure set StructureErrorInfo global integer type# string value#
60590>>>>>>>  set value of (oStructureErrorInfo(self)) item type# to value#
60591>>>>>>>end_procedure
60592>>>>>>>function StructureErrorInfo global integer type# returns string
60594>>>>>>>  function_return (value(oStructureErrorInfo(self),type#))
60595>>>>>>>end_function
60596>>>>>>>procedure DoClearStructureErrorInfo global
60598>>>>>>>  send delete_data to (oStructureErrorInfo(self))
60599>>>>>>>end_procedure
60600>>>>>>>
60600>>>>>>>//#IFDEF Is$WebApp
60600>>>>>>>// define Structur$ErrorTrapping for 0
60600>>>>>>>//#ELSE
60600>>>>>>> define Structur$ErrorTrapping for 1
60600>>>>>>>//#ENDIF
60600>>>>>>>
60600>>>>>>>
60600>>>>>>>
60600>>>>>>>
60600>>>>>
60600>>>>>Use LogFile.nui  // Class for handling a log file (No User Interface)
60600>>>>>Use FdxIndex.nui // Index analysing functions
Including file: fdxindex.nui    (C:\Apps\VDFQuery\AppSrc\fdxindex.nui)
60600>>>>>>>// Use FdxIndex.nui // Index analysing functions
60600>>>>>>>
60600>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
60600>>>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
60600>>>>>>>Use FdxField.nui // FDX Field things
Including file: fdxfield.nui    (C:\Apps\VDFQuery\AppSrc\fdxfield.nui)
60600>>>>>>>>>// Use FdxField.nui // FDX Field things
60600>>>>>>>>>//
60600>>>>>>>>>// Wed 10-09-2003 - Added FDX_ReadRecordBufferToArray_LD
60600>>>>>>>>>
60600>>>>>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
60600>>>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
60600>>>>>>>>>Use Strings.nui  // String manipulation for VDF
60600>>>>>>>>>Use Dates.nui    // Date manipulation for VDF
60600>>>>>>>>>
60600>>>>>>>>>//> Translates an overlap field into the sequence of fields that makes up
60600>>>>>>>>>//> the overlap field. The field sequence is returned in a string where each
60600>>>>>>>>>//> field in the sequence takes up four characters. The sequence of fields
60600>>>>>>>>>//> 2, 3 and 4 would return as "2   3   4   ".
60600>>>>>>>>>function FDX_FieldsInOverlap global integer lhFDX integer liFile integer lbOverlap returns string
60602>>>>>>>>>  integer liField liMax
60602>>>>>>>>>  string lsValue
60602>>>>>>>>>  move "" to lsValue
60603>>>>>>>>>  // Only go through this if lbOverlap is indeed an overlap field:
60603>>>>>>>>>  if (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,lbOverlap))) eq DF_OVERLAP begin
60605>>>>>>>>>    move (FDX_AttrValue_FILE(lhFDX,DF_FILE_NUMBER_FIELDS,liFile)) to liMax
60606>>>>>>>>>    for liField from 1 to liMax
60612>>>>>>>>>>
60612>>>>>>>>>      // Only check to see if field is part of the overlap if it is not itself an overlap field:
60612>>>>>>>>>      if (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liField))) ne DF_OVERLAP begin
60614>>>>>>>>>        if (integer(FDX_AttrValue_SPECIAL1(lhFDX,DF_FIELD_OVERLAP,liFile,lbOverlap,liField))) move (lsValue+pad(liField,4)) to lsValue
60617>>>>>>>>>      end
60617>>>>>>>>>>
60617>>>>>>>>>    loop
60618>>>>>>>>>>
60618>>>>>>>>>  end
60618>>>>>>>>>>
60618>>>>>>>>>  else move (pad(lbOverlap,4)) to lsValue
60620>>>>>>>>>  function_return lsValue
60621>>>>>>>>>end_function // FDX_FieldsInOverlap
60622>>>>>>>>>
60622>>>>>>>>>//> The function returns a set of (overlap-) fields all overlapping
60622>>>>>>>>>//> the field passed as an arguments
60622>>>>>>>>>function FDX_FieldsOverlappingField global integer lhFDX integer liFile integer liField returns string
60624>>>>>>>>>  integer liMaxField liTestField
60624>>>>>>>>>  string lsRval
60624>>>>>>>>>  move "" to lsRval
60625>>>>>>>>>  move (FDX_AttrValue_FILE(lhFDX,DF_FILE_NUMBER_FIELDS,liFile)) to liMaxField
60626>>>>>>>>>  for liTestField from 1 to liMaxField
60632>>>>>>>>>>
60632>>>>>>>>>    if (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liTestField))) eq DF_OVERLAP begin
60634>>>>>>>>>      if (integer(FDX_AttrValue_SPECIAL1(lhFDX,DF_FIELD_OVERLAP,liFile,liTestField,liField))) move (lsRval+pad(liTestField,4)) to lsRval
60637>>>>>>>>>    end
60637>>>>>>>>>>
60637>>>>>>>>>  loop
60638>>>>>>>>>>
60638>>>>>>>>>  function_return lsRval
60639>>>>>>>>>end_function // FDX_FieldsInOverlap
60640>>>>>>>>>
60640>>>>>>>>>//> Remove dublettes from a sequence of fields
60640>>>>>>>>>function FDX_FieldsRemoveDublettes global string lsFields returns string
60642>>>>>>>>>  integer liMaxPos liSegment
60642>>>>>>>>>  string lsValue liField
60642>>>>>>>>>  move "" to lsValue
60643>>>>>>>>>  move (length(lsFields)+3/4) to liMaxPos
60644>>>>>>>>>  for liSegment from 1 to liMaxPos
60650>>>>>>>>>>
60650>>>>>>>>>    move (mid(lsFields,4,liSegment-1*4+1)) to liField
60651>>>>>>>>>    ifnot liField in lsValue move (lsValue+liField) to lsValue
60654>>>>>>>>>  loop
60655>>>>>>>>>>
60655>>>>>>>>>  function_return lsValue
60656>>>>>>>>>end_function
60657>>>>>>>>>
60657>>>>>>>>>//> This function takes a sequence of fields translating each overlap field
60657>>>>>>>>>//> in the sequence to its underlying real fields and returns the translated
60657>>>>>>>>>//> sequence.
60657>>>>>>>>>function FDX_FieldsTranslateOverlaps global integer lhFDX integer liFile string lsFields returns string
60659>>>>>>>>>  integer liMaxPos liField liPos
60659>>>>>>>>>  string lsValue
60659>>>>>>>>>  move "" to lsValue
60660>>>>>>>>>  move (length(lsFields)+3/4) to liMaxPos
60661>>>>>>>>>  for liPos from 0 to (liMaxPos-1)
60667>>>>>>>>>>
60667>>>>>>>>>    move (mid(lsFields,4,liPos*4+1)) to liField
60668>>>>>>>>>    if (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liField))) eq DF_OVERLAP move (lsValue+FDX_FieldsInOverlap(lhFDX,liFile,liField)) to lsValue
60671>>>>>>>>>    else move (lsValue+pad(liField,4)) to lsValue
60673>>>>>>>>>  loop
60674>>>>>>>>>>
60674>>>>>>>>>  function_return lsValue
60675>>>>>>>>>end_function // FDX_FieldsTranslateOverlaps
60676>>>>>>>>>
60676>>>>>>>>>//> Use to check if two fields are identically defined
60676>>>>>>>>>function FDX_FieldIdenticalFieldDefinition global integer lhFDX integer liFile1 integer liField1 integer liFile2 integer liField2 returns integer
60678>>>>>>>>>  if (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile1,liField1))<>integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile2,liField2))) function_return 0
60681>>>>>>>>>  if (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_LENGTH,liFile1,liField1))<>integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_LENGTH,liFile2,liField2))) function_return 0
60684>>>>>>>>>  if (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_PRECISION,liFile1,liField1))<>integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_PRECISION,liFile2,liField2))) function_return 0
60687>>>>>>>>>  function_return 1 // Yes, they are identical
60688>>>>>>>>>end_function
60689>>>>>>>>>
60689>>>>>>>>>//> Use to check if two sequences of fields are identically defined. Returns TRUE if identical
60689>>>>>>>>>function FDX_FieldIdenticalFieldSequenceDefinition global integer lhFDX integer liFile1 string lsFields1 integer liFile2 string lsFields2 returns integer
60691>>>>>>>>>  integer liMaxPos liField liPos liField1 liField2
60691>>>>>>>>>  if (length(lsFields1)<>length(lsFields2)) function_return 0
60694>>>>>>>>>  move (length(lsFields1)+3/4) to liMaxPos
60695>>>>>>>>>  for liPos from 0 to (liMaxPos-1)
60701>>>>>>>>>>
60701>>>>>>>>>    move (mid(lsFields1,4,liPos*4+1)) to liField1
60702>>>>>>>>>    move (mid(lsFields2,4,liPos*4+1)) to liField2
60703>>>>>>>>>    ifnot (FDX_FieldIdenticalFieldDefinition(lhFDX,liFile1,liField1,liFile2,liField2)) function_return 0
60706>>>>>>>>>  loop
60707>>>>>>>>>>
60707>>>>>>>>>  function_return 1 // Yes, they are identical
60708>>>>>>>>>end_function
60709>>>>>>>>>
60709>>>>>>>>>//> Use this to compare two overlap fields. Returns TRUE if identical.
60709>>>>>>>>>function FDX_FieldIdenticalOverlapStructures global integer lhFDX integer liFile1 integer liField1 integer liFile2 integer liField2 returns integer
60711>>>>>>>>>  string lsFields1 lsFields2
60711>>>>>>>>>  get FDX_FieldsInOverlap lhFDX liFile1 liField1 to lsFields1
60712>>>>>>>>>  get FDX_FieldsInOverlap lhFDX liFile2 liField2 to lsFields2
60713>>>>>>>>>  function_return (FDX_FieldIdenticalFieldSequenceDefinition(lhFDX,liFile1,lsFields1,liFile2,lsFields2))
60714>>>>>>>>>end_function
60715>>>>>>>>>
60715>>>>>>>>>function FDX_FieldName global integer lhFDX integer liFile integer liField integer lbIncludeTable returns string
60717>>>>>>>>>  string lsLogName lsFieldName
60717>>>>>>>>>  ifnot liFile function_return ""
60720>>>>>>>>>  move (FDX_AttrValue_FILELIST(lhFDX,DF_FILE_LOGICAL_NAME,liFile)) to lsLogName
60721>>>>>>>>>  if liField move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_NAME,liFile,liField)) to lsFieldName
60724>>>>>>>>>  else move "RECNUM" to lsFieldName
60726>>>>>>>>>  if lbIncludeTable function_return (lsLogName+"."+lsFieldName)
60729>>>>>>>>>  function_return lsFieldName
60730>>>>>>>>>end_function
60731>>>>>>>>>
60731>>>>>>>>>function FDX_FieldNames global integer lhFDX integer liFile string lsFields returns string
60733>>>>>>>>>  integer liMaxPos liSegment
60733>>>>>>>>>  string lsRval lsField
60733>>>>>>>>>  move "" to lsRval
60734>>>>>>>>>  move (length(lsFields)+3/4) to liMaxPos
60735>>>>>>>>>  for liSegment from 1 to liMaxPos
60741>>>>>>>>>>
60741>>>>>>>>>    move (mid(lsFields,4,liSegment-1*4+1)) to lsField
60742>>>>>>>>>    move (lsRval+FDX_FieldName(lhFDX,liFile,lsField,0)) to lsRval
60743>>>>>>>>>    if liSegment ne liMaxPos move (lsRval+",") to lsRval
60746>>>>>>>>>  loop
60747>>>>>>>>>>
60747>>>>>>>>>  function_return lsRval
60748>>>>>>>>>end_function
60749>>>>>>>>>
60749>>>>>>>>>function FDX_FieldTypeName global integer lhFDX integer liFile integer liField returns string
60751>>>>>>>>>  integer liType
60751>>>>>>>>>  move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liField)) to liType
60752>>>>>>>>>  function_return (StringFieldType(liType))
60753>>>>>>>>>end_function
60754>>>>>>>>>
60754>>>>>>>>>function FDX_FieldLength global integer lhFDX integer liFile integer liField returns string
60756>>>>>>>>>  integer liType liLen liDec lhObj
60756>>>>>>>>>  string lsRval
60756>>>>>>>>>  move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liField)) to liType
60757>>>>>>>>>  move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_LENGTH,liFile,liField)) to liLen
60758>>>>>>>>>  move liLen to lsRval
60759>>>>>>>>>  if liType eq DF_BCD begin
60761>>>>>>>>>    move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_PRECISION,liFile,liField)) to liDec
60762>>>>>>>>>    move "#.#" to lsRval
60763>>>>>>>>>    replace "#" in lsRval with (string(liLen-liDec))
60765>>>>>>>>>    replace "#" in lsRval with (string(liDec))
60767>>>>>>>>>  end
60767>>>>>>>>>>
60767>>>>>>>>>  function_return lsRval
60768>>>>>>>>>end_function
60769>>>>>>>>>
60769>>>>>>>>>function FDX_FieldTypeAndLengthName global integer lhFDX integer liFile integer liField returns string
60771>>>>>>>>>  string lsRval
60771>>>>>>>>>  get FDX_FieldTypeName lhFDX liFile liField to lsRval
60772>>>>>>>>>  move (uppercase(left(lsRval,3))) to lsRval
60773>>>>>>>>>  function_return (lsRval+" "+FDX_FieldLength(lhFDX,liFile,liField))
60774>>>>>>>>>end_function
60775>>>>>>>>>
60775>>>>>>>>>function FDX_FieldTypeAndLengthName2 global integer lhFDX integer liFile integer liField returns string
60777>>>>>>>>>  string lsRval
60777>>>>>>>>>  get FDX_FieldTypeName lhFDX liFile liField to lsRval
60778>>>>>>>>>  function_return (lsRval+" "+FDX_FieldLength(lhFDX,liFile,liField))
60779>>>>>>>>>end_function
60780>>>>>>>>>
60780>>>>>>>>>//> Returns "Field Name (NUM 2.2)"
60780>>>>>>>>>function FDX_FieldNameAndType global integer lhFDX integer liFile integer liField returns string
60782>>>>>>>>>  string lsRval
60782>>>>>>>>>  get FDX_AttrValue_FIELD lhFDX DF_FIELD_NAME liFile liField to lsRval
60783>>>>>>>>>  move (StringUppercaseFirstLetters(replaces("_",lsRval," "))) to lsRval
60784>>>>>>>>>  function_return (lsRval+" ("+FDX_FieldTypeAndLengthName(lhFDX,liFile,liField)+")")
60785>>>>>>>>>end_function
60786>>>>>>>>>
60786>>>>>>>>>//> Returns the concatenated values of the fields in sFields parameter
60786>>>>>>>>>//> separated by space characters. Overlap fields are ignored. (and so
60786>>>>>>>>>//> are Text and Binary fields)
60786>>>>>>>>>function FDX_FieldValues global integer lhFDX integer iFile string sFields returns string
60788>>>>>>>>>  integer iMaxPos iField iPos iType iLen iDec
60788>>>>>>>>>  string sRval sFieldVal
60788>>>>>>>>>  move "" to sRval
60789>>>>>>>>>  ifnot lhFDX begin
60791>>>>>>>>>    move (length(sFields)+3/4) to iMaxPos
60792>>>>>>>>>    for iPos from 1 to iMaxPos
60798>>>>>>>>>>
60798>>>>>>>>>      move (mid(sFields,4,iPos-1*4+1)) to iField
60799>>>>>>>>>      move (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,iFile,iField))) to iType
60800>>>>>>>>>      get_field_value iFile iField to sFieldVal
60803>>>>>>>>>      if iType eq DF_ASCII move (sRval+rtrim(sFieldVal)) to sRval
60806>>>>>>>>>      if iType eq DF_BCD begin
60808>>>>>>>>>        get_attribute DF_FIELD_LENGTH of iFile iField to iLen
60811>>>>>>>>>        get_attribute DF_FIELD_PRECISION of iFile iField to iDec
60814>>>>>>>>>        if iDec increment iLen // Make room for comma
60817>>>>>>>>>        move (sRval+NumToStrR(sFieldVal,iDec,iLen)) to sRval
60818>>>>>>>>>      end
60818>>>>>>>>>>
60818>>>>>>>>>      if iType eq DF_DATE move (sRval+string(DateToInteger(sFieldVal))) to sRval
60821>>>>>>>>>      if iPos ne iMaxPos move (sRval+" ") to sRval
60824>>>>>>>>>    loop
60825>>>>>>>>>>
60825>>>>>>>>>  end
60825>>>>>>>>>>
60825>>>>>>>>>  else function_return "Function FDX_FieldValues may only be called with lhFDX=0"
60827>>>>>>>>>  function_return sRval
60828>>>>>>>>>end_function
60829>>>>>>>>>
60829>>>>>>>>>//> Returns the concatenated values of the fields in sFields parameter
60829>>>>>>>>>//> separated by "-" characters. Overlap fields are ignored. (and so
60829>>>>>>>>>//> are Text and Binary fields). The returns value of this function is
60829>>>>>>>>>//> meant to be used as the a file name.
60829>>>>>>>>>function FDX_FieldValuesFileName_Help global string lsSource returns string
60831>>>>>>>>>  integer liPos liLen liByte
60831>>>>>>>>>  string lsChar lsRval
60831>>>>>>>>>  move "" to lsRval
60832>>>>>>>>>  move (length(lsSource)) to liLen
60833>>>>>>>>>  for liPos from 1 to liLen
60839>>>>>>>>>>
60839>>>>>>>>>    move (mid(lsSource,1,liPos)) to lsChar
60840>>>>>>>>>    move (lsRval+ByteToHex(ascii(lsChar))) to lsRval
60841>>>>>>>>>  loop
60842>>>>>>>>>>
60842>>>>>>>>>  function_return lsRval
60843>>>>>>>>>end_function
60844>>>>>>>>>function FDX_FieldValuesFileName global integer lhFDX integer liFile string lsFields returns string
60846>>>>>>>>>  integer liMaxPos liField liPos liType liLen liDec
60846>>>>>>>>>  string lsRval lsFieldValue
60846>>>>>>>>>  move "" to lsRval
60847>>>>>>>>>  ifnot lhFDX begin
60849>>>>>>>>>    move (length(lsFields)+3/4) to liMaxPos
60850>>>>>>>>>    for liPos from 1 to liMaxPos
60856>>>>>>>>>>
60856>>>>>>>>>      move (mid(lsFields,4,liPos-1*4+1)) to liField
60857>>>>>>>>>      move (integer(FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liField))) to liType
60858>>>>>>>>>      get_field_value liFile liField to lsFieldValue
60861>>>>>>>>>      if liType eq DF_ASCII move (lsRval+FDX_FieldValuesFileName_Help(lsFieldValue)) to lsRval
60864>>>>>>>>>      if liType eq DF_BCD begin
60866>>>>>>>>>        get_attribute DF_FIELD_LENGTH of liFile liField to liLen
60869>>>>>>>>>        get_attribute DF_FIELD_PRECISION of liFile liField to liDec
60872>>>>>>>>>        if liDec increment liLen // Make room for comma
60875>>>>>>>>>        move (lsRval+NumToStrRzf(lsFieldValue,liDec,liLen)) to lsRval
60876>>>>>>>>>      end
60876>>>>>>>>>>
60876>>>>>>>>>      if liType eq DF_DATE move (lsRval+string(DateToInteger(lsFieldValue))) to lsRval
60879>>>>>>>>>      if liPos ne liMaxPos move (lsRval+"-") to lsRval
60882>>>>>>>>>    loop
60883>>>>>>>>>>
60883>>>>>>>>>  end
60883>>>>>>>>>>
60883>>>>>>>>>  else function_return "Function FDX_FieldValues may only be called with lhFDX=0"
60885>>>>>>>>>  move (replaces(".",lsRval,"")) to lsRval
60886>>>>>>>>>  move (replaces(",",lsRval,"")) to lsRval
60887>>>>>>>>>  move (replaces(" ",lsRval,"")) to lsRval
60888>>>>>>>>>  function_return lsRval
60889>>>>>>>>>end_function
60890>>>>>>>>>
60890>>>>>>>>>//
60890>>>>>>>>>// Recieving procedure should be defined like this:
60890>>>>>>>>>//
60890>>>>>>>>>// Procedure HandleField integer liFile integer liField string lsName integer liType integer liLen integer liPrec integer liRelFile integer liRelField integer liIndex integer liOffSet
60890>>>>>>>>>//
60890>>>>>>>>>//
60890>>>>>>>>>procedure FDX_FieldCallBack global integer lhFDX integer liFile integer liMsg integer lhObj
60892>>>>>>>>>  integer liMaxField liField
60892>>>>>>>>>  integer liType liLen liPrec liRelFile liRelField liIndex liOffSet
60892>>>>>>>>>  string lsName
60892>>>>>>>>>  move (FDX_AttrValue_FILE(lhFDX,DF_FILE_NUMBER_FIELDS,liFile)) to liMaxField
60893>>>>>>>>>  for liField from 1 to liMaxField
60899>>>>>>>>>>
60899>>>>>>>>>
60899>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_NAME          liFile liField to lsName
60900>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_TYPE          liFile liField to liType
60901>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_LENGTH        liFile liField to liLen
60902>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_PRECISION     liFile liField to liPrec
60903>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_RELATED_FILE  liFile liField to liRelFile
60904>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_RELATED_FIELD liFile liField to liRelField
60905>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_INDEX         liFile liField to liIndex
60906>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_OFFSET        liFile liField to liOffSet
60907>>>>>>>>>    // procedure handle_field integer liFile integer liField string lsName integer liType integer liLen integer liPrec integer liRelFile integer liRelField integer liIndex integer liOffSet
60907>>>>>>>>>    send liMsg to lhObj liFile liField lsName liType liLen liPrec liRelFile liRelField liIndex liOffSet
60908>>>>>>>>>  loop
60909>>>>>>>>>>
60909>>>>>>>>>end_procedure
60910>>>>>>>>>
60910>>>>>>>>>function FDX_FindField global integer lhFDX integer liFile string lsFieldName returns integer
60912>>>>>>>>>  integer liMax liField
60912>>>>>>>>>  string lsValue
60912>>>>>>>>>  move (uppercase(lsFieldName)) to lsFieldName
60913>>>>>>>>>  if (lsFieldName="RECNUM") function_return 0
60916>>>>>>>>>  move (FDX_AttrValue_FILE(lhFDX,DF_FILE_NUMBER_FIELDS,liFile)) to liMax
60917>>>>>>>>>  for liField from 1 to liMax
60923>>>>>>>>>>
60923>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_NAME liFile liField to lsValue
60924>>>>>>>>>    if (uppercase(lsValue)=lsFieldName) function_return liField
60927>>>>>>>>>  loop
60928>>>>>>>>>>
60928>>>>>>>>>  function_return -1
60929>>>>>>>>>end_function
60930>>>>>>>>>
60930>>>>>>>>>//> Reads a record like the SEQ_ReadRecordBuffer_LD procedure but places the
60930>>>>>>>>>//> result in the array passed in the lhArray instead of directly in the
60930>>>>>>>>>//> record buffer.
60930>>>>>>>>>procedure FDX_ReadRecordBufferToArray_LD global integer lhFDX integer liChannel integer liFile integer lhArray
60932>>>>>>>>>  integer liMax liField liLen liType
60932>>>>>>>>>  string lsValue
60932>>>>>>>>>  send delete_data to lhArray
60933>>>>>>>>>  get FDX_AttrValue_FILE lhFDX DF_FILE_NUMBER_FIELDS liFile to liMax
60934>>>>>>>>>  read channel liChannel // Set channel
60935>>>>>>>>>  for liField from 1 to liMax
60941>>>>>>>>>>
60941>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_TYPE liFile liField to liType
60942>>>>>>>>>    if liType ne DF_OVERLAP begin
60944>>>>>>>>>      if (liType=DF_BINARY or liType=DF_TEXT) begin
60946>>>>>>>>>        readln liLen
60947>>>>>>>>>        read_block lsValue liLen
60948>>>>>>>>>      end
60948>>>>>>>>>>
60948>>>>>>>>>      else readln lsValue
60950>>>>>>>>>    end
60950>>>>>>>>>>
60950>>>>>>>>>    set value of lhArray item liField to lsValue
60951>>>>>>>>>  loop
60952>>>>>>>>>>
60952>>>>>>>>>end_procedure
60953>>>>>>>>>
60953>>>>>>>>>//> Returns set of (child table) fields that relates to parent table.
60953>>>>>>>>>function FDX_FieldsRelatingToParent global integer lhFDX integer liChild integer liParent returns string
60955>>>>>>>>>  integer liMax liField liTest
60955>>>>>>>>>  string lsValue
60955>>>>>>>>>  get FDX_AttrValue_FILE lhFDX DF_FILE_NUMBER_FIELDS liChild to liMax
60956>>>>>>>>>  move "" to lsValue
60957>>>>>>>>>
60957>>>>>>>>>  for liField from 1 to liMax
60963>>>>>>>>>>
60963>>>>>>>>>    get FDX_AttrValue_FIELD lhFDX DF_FIELD_RELATED_FILE liChild liField to liTest
60964>>>>>>>>>    if (liTest=liParent) move (lsValue+pad(liField,4)) to lsValue
60967>>>>>>>>>  loop
60968>>>>>>>>>>
60968>>>>>>>>>
60968>>>>>>>>>  function_return lsValue
60969>>>>>>>>>end_function
60970>>>>>>>
60970>>>>>>>//> This function returns an index as a sequence of fields. The field
60970>>>>>>>//> sequence is returned in a string where each field in the sequence
60970>>>>>>>//> takes up four characters. The sequence of fields 2, 3 and 4 would
60970>>>>>>>//> return as "2   3   4   ".
60970>>>>>>>function FDX_IndexAsFields global integer oFDX# integer file# integer index# returns string
60972>>>>>>>  integer segment# max_seg# field#
60972>>>>>>>  string rval#
60972>>>>>>>  move "" to rval#
60973>>>>>>>  get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index# to max_seg#
60974>>>>>>>  if max_seg# begin // If there's an index at all
60976>>>>>>>    for segment# from 1 to max_seg#
60982>>>>>>>>
60982>>>>>>>      get FDX_AttrValue_IDXSEG oFDX# DF_INDEX_SEGMENT_FIELD file# index# segment# to field#
60983>>>>>>>      move (rval#+pad(field#,4)) to rval#
60984>>>>>>>    loop
60985>>>>>>>>
60985>>>>>>>  end
60985>>>>>>>>
60985>>>>>>>  function_return rval#
60986>>>>>>>end_function // FDX_IndexAsFields
60987>>>>>>>
60987>>>>>>>//> Returns DFTRUE if index# if last segment of index# is not RECNUM. If the
60987>>>>>>>//> index does not exist DFFALSE is returned.
60987>>>>>>>function FDX_IndexUnique global integer oFDX# integer file# integer index# returns integer
60989>>>>>>>  string str#
60989>>>>>>>  if index# eq 0 function_return 1
60992>>>>>>>  get FDX_IndexAsFields oFDX# file# index# to str#
60993>>>>>>>  function_return (integer(right(str#,4)))
60994>>>>>>>end_function
60995>>>>>>>
60995>>>>>>>//> Function FDX_IndexAsFieldNames returns the specified index as field names
60995>>>>>>>//> separated by commas. A descending segment will be marked by a minus
60995>>>>>>>//> sign while uppercased segments will appear with an uppercased field
60995>>>>>>>//> name. The width# parameter will (if not 0) break up the return value
60995>>>>>>>//> in strings none of which is longer than indicated by its value. In this
60995>>>>>>>//> case the sub-strings will be separated by a character 10.
60995>>>>>>>function FDX_IndexAsFieldNames global integer oFDX# integer file# integer index# integer width# returns string
60997>>>>>>>  integer max_seg# segment# field# dir# case# liType
60997>>>>>>>  string rval# lf# fname# substring# test#
60997>>>>>>>
60997>>>>>>>  get FDX_AttrValue_INDEX oFDX# DF_INDEX_TYPE file# index# to liType
60998>>>>>>>  ifnot width# move 1000 to width#
61001>>>>>>>  move (character(10)) to lf#
61002>>>>>>>  get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index# to max_seg#
61003>>>>>>>
61003>>>>>>>  if (liType=DF_INDEX_TYPE_ONLINE) move "" to substring#
61006>>>>>>>  else move "(Batch) " to substring#
61008>>>>>>>
61008>>>>>>>  for segment# from 1 to max_seg#
61014>>>>>>>>
61014>>>>>>>    get FDX_AttrValue_IDXSEG oFDX# DF_INDEX_SEGMENT_FIELD     file# index# segment# to field#
61015>>>>>>>    if field# get FDX_AttrValue_FIELD  oFDX# DF_FIELD_NAME    file# field# to fname#
61018>>>>>>>    else move "recnum" to fname#
61020>>>>>>>    get FDX_AttrValue_IDXSEG oFDX# DF_INDEX_SEGMENT_DIRECTION file# index# segment# to dir#
61021>>>>>>>    get FDX_AttrValue_IDXSEG oFDX# DF_INDEX_SEGMENT_CASE      file# index# segment# to case#
61022>>>>>>>
61022>>>>>>>    if dir# eq DF_DESCENDING move ("-"+fname#) to fname#
61025>>>>>>>    if case# eq DF_CASE_IGNORED move (uppercase(fname#)) to fname#
61028>>>>>>>    else move (lowercase(fname#)) to fname#
61030>>>>>>>
61030>>>>>>>    if segment# ne max_seg# move (fname#+",") to fname# // If not the last segment append a comma to the name
61033>>>>>>>    move (substring#+fname#) to test#
61034>>>>>>>
61034>>>>>>>    if (length(test#)>width# and substring#<>"") begin
61036>>>>>>>      // If we go in here the length of the substring is too long and
61036>>>>>>>      // we will have to insert a lf character.
61036>>>>>>>      if rval# eq "" move substring# to rval#
61039>>>>>>>      else move (rval#+lf#+substring#) to rval#
61041>>>>>>>      move fname# to substring#
61042>>>>>>>    end
61042>>>>>>>>
61042>>>>>>>    else begin // It's not too wide
61043>>>>>>>      if substring# eq "" move fname# to substring#
61046>>>>>>>      else move (substring#+fname#) to substring#
61048>>>>>>>    end
61048>>>>>>>>
61048>>>>>>>  loop
61049>>>>>>>>
61049>>>>>>>
61049>>>>>>>  if rval# eq "" move substring# to rval#
61052>>>>>>>  else move (rval#+lf#+substring#) to rval#
61054>>>>>>>  function_return rval#
61055>>>>>>>end_function // FDX_IndexAsFieldNames
61056>>>>>>>
61056>>>>>>>//> This function will return the number of the first unique index
61056>>>>>>>//> defined for the file passed. If no such index is found, 0 will
61056>>>>>>>//> be returned.
61056>>>>>>>function FDX_IndexFindPrimary global integer oFDX# integer file# returns integer
61058>>>>>>>  integer index# fin# rval# max_seg# segment# field#
61058>>>>>>>  move 1 to index#
61059>>>>>>>  move 0 to fin#
61060>>>>>>>  move 0 to rval#
61061>>>>>>>  repeat
61061>>>>>>>>
61061>>>>>>>    if index# gt 15 move 1 to fin#
61064>>>>>>>    ifnot fin# begin
61066>>>>>>>      get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index# to max_seg#
61067>>>>>>>      for segment# from 1 to max_seg#
61073>>>>>>>>
61073>>>>>>>        get FDX_AttrValue_IDXSEG oFDX# DF_INDEX_SEGMENT_FIELD file# index# segment# to field#
61074>>>>>>>        if (segment#=max_seg# and field#<>0) begin
61076>>>>>>>          move 1 to fin#
61077>>>>>>>          move index# to rval#
61078>>>>>>>        end
61078>>>>>>>>
61078>>>>>>>      loop
61079>>>>>>>>
61079>>>>>>>      increment index#
61080>>>>>>>    end
61080>>>>>>>>
61080>>>>>>>  until fin#
61082>>>>>>>  function_return rval#
61083>>>>>>>end_function // FDX_IndexFindPrimary
61084>>>>>>>
61084>>>>>>>function FDX_IndexFindAny global integer lhFDX integer liFile integer liIndex integer lbMustBeUnique integer lbMustBeOnLine returns integer
61086>>>>>>>  integer lbFin liRval liSegments lbOk liType
61086>>>>>>>  move 0 to lbFin
61087>>>>>>>  move 0 to liRval
61088>>>>>>>  increment liIndex
61089>>>>>>>  repeat
61089>>>>>>>>
61089>>>>>>>    if liIndex gt 15 move 1 to lbFin
61092>>>>>>>    ifnot lbFin begin
61094>>>>>>>      get FDX_AttrValue_INDEX lhFDX DF_INDEX_NUMBER_SEGMENTS liFile liIndex to liSegments
61095>>>>>>>
61095>>>>>>>      if liSegments begin // If index exists
61097>>>>>>>        move DFTRUE to lbOk
61098>>>>>>>        if lbMustBeUnique get FDX_IndexUnique lhFDX liFile liIndex to lbOk
61101>>>>>>>        if lbMustBeOnLine begin
61103>>>>>>>          get FDX_AttrValue_INDEX lhFDX DF_INDEX_TYPE liFile liIndex to liType
61104>>>>>>>          move (liType=DF_INDEX_TYPE_ONLINE) to lbOk
61105>>>>>>>        end
61105>>>>>>>>
61105>>>>>>>        if lbOk begin
61107>>>>>>>          move 1 to lbFin
61108>>>>>>>          move liIndex to liRval
61109>>>>>>>        end
61109>>>>>>>>
61109>>>>>>>      end
61109>>>>>>>>
61109>>>>>>>      increment liIndex
61110>>>>>>>    end
61110>>>>>>>>
61110>>>>>>>  until lbFin
61112>>>>>>>  function_return liRval
61113>>>>>>>end_function
61114>>>>>>>
61114>>>>>>>//> This tries to find an index uniquely composed of the fields passed in
61114>>>>>>>//> fields parameter. If such an index can be found its number will be
61114>>>>>>>//> returned (otherwise 0 is returned). The search will begin at index
61114>>>>>>>//> start_idx#+1.
61114>>>>>>>function FDX_IndexFindUnique global integer oFDX# integer file# string fields# integer start_idx# returns integer
61116>>>>>>>  integer index# pos# segment# max#
61116>>>>>>>  string idx_fields# check_fields# field#
61116>>>>>>>  get FDX_FieldsTranslateOverlaps oFDX# file# fields# to fields#
61117>>>>>>>  get FDX_FieldsRemoveDublettes fields# to fields#
61118>>>>>>>  for index# from (start_idx#+1) to 15
61124>>>>>>>>
61124>>>>>>>    get FDX_IndexAsFields oFDX# file# index# to idx_fields#
61125>>>>>>>    if idx_fields# ne "" begin
61127>>>>>>>      move fields# to check_fields#
61128>>>>>>>      get FDX_FieldsTranslateOverlaps oFDX# file# idx_fields# to idx_fields#
61129>>>>>>>      get FDX_FieldsRemoveDublettes idx_fields# to idx_fields#
61130>>>>>>>      move (length(idx_fields#)/4) to max#
61131>>>>>>>      for segment# from 1 to max#
61137>>>>>>>>
61137>>>>>>>        move (mid(fields#,4,segment#-1*4+1)) to field#
61138>>>>>>>        move (replace(field#,check_fields#,"")) to check_fields#
61139>>>>>>>      loop
61140>>>>>>>>
61140>>>>>>>      if check_fields# eq "" function_return index#
61143>>>>>>>    end
61143>>>>>>>>
61143>>>>>>>  loop
61144>>>>>>>>
61144>>>>>>>  function_return 0
61145>>>>>>>end_function // FDX_IndexFindUnique
61146>>>>>>>
61146>>>>>>>//> Find an index that has fields as its most significant segments (in that
61146>>>>>>>//> order)
61146>>>>>>>function FDX_IndexFindMatching global integer oFDX# integer file# string fields# integer start_idx# returns integer
61148>>>>>>>  integer index# pos# segment# max# field1# field2# good#
61148>>>>>>>  string idx_fields# field#
61148>>>>>>>  get FDX_FieldsTranslateOverlaps oFDX# file# fields# to fields#
61149>>>>>>>  move (length(fields#)/4) to max#
61150>>>>>>>  for index# from (start_idx#+1) to 15
61156>>>>>>>>
61156>>>>>>>    get FDX_IndexAsFields oFDX# file# index# to idx_fields#
61157>>>>>>>    if idx_fields# ne "" begin
61159>>>>>>>      get FDX_FieldsTranslateOverlaps oFDX# file# idx_fields# to idx_fields#
61160>>>>>>>      move 1 to good#
61161>>>>>>>      for segment# from 1 to max#
61167>>>>>>>>
61167>>>>>>>        if good# begin
61169>>>>>>>          move (mid(fields#,4,segment#-1*4+1)) to field1#
61170>>>>>>>          move (mid(idx_fields#,4,segment#-1*4+1)) to field2#
61171>>>>>>>          if field1# ne field2# move 0 to good#
61174>>>>>>>        end
61174>>>>>>>>
61174>>>>>>>      loop
61175>>>>>>>>
61175>>>>>>>      if good# function_return index#
61178>>>>>>>    end
61178>>>>>>>>
61178>>>>>>>  loop
61179>>>>>>>>
61179>>>>>>>  function_return 0
61180>>>>>>>end_function // FDX_IndexFindMatching
61181>>>>>>>
61181>>>>>>>//> Find a field that is not part of liIndex. The field returned will not be a
61181>>>>>>>//> overlap field. If no such field can be found, 0 is returned.
61181>>>>>>>function FDX_FieldNotInIndex global integer oFDX# integer liFile integer liIndex returns integer
61183>>>>>>>  integer liField liMax
61183>>>>>>>  string lsFields
61183>>>>>>>  if liIndex begin // If not recnum
61185>>>>>>>    get FDX_IndexAsFields oFDX# liFile liIndex to lsFields
61186>>>>>>>    get FDX_FieldsTranslateOverlaps oFDX# liFile lsFields to lsFields
61187>>>>>>>  end
61187>>>>>>>>
61187>>>>>>>  else move "" to lsFields
61189>>>>>>>  move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,liFile)) to liMax
61190>>>>>>>  for liField from 1 to liMax
61196>>>>>>>>
61196>>>>>>>    // Only check to see if field is part of the overlap if it is not itself an overlap field:
61196>>>>>>>    if (integer(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,liFile,liField))) ne DF_OVERLAP begin
61198>>>>>>>      ifnot (IsIntegerPresent(lsFields,liField)) function_return liField
61201>>>>>>>    end
61201>>>>>>>>
61201>>>>>>>  loop
61202>>>>>>>>
61202>>>>>>>  function_return 0
61203>>>>>>>end_function
61204>>>>>>>
61204>>>>>>>//> This function returns all
61204>>>>>>>function FDX_MostSignificantFieldsInIndexNotRelating global integer oFDX# integer liFile integer liIndex returns string
61206>>>>>>>  integer liPos liMaxPos liField liStillRelating liOverlapField
61206>>>>>>>  integer liMaxOverlap liOverlapPos liAnyRelatingOverlaps
61206>>>>>>>  string lsFields lsRval lsOverlaps
61206>>>>>>>  get FDX_IndexAsFields oFDX# liFile liIndex to lsFields
61207>>>>>>>  get FDX_FieldsTranslateOverlaps oFDX# liFile lsFields to lsFields
61208>>>>>>>  move "" to lsRval
61209>>>>>>>  move 1 to liStillRelating
61210>>>>>>>  move (length(lsFields)+3/4) to liMaxPos
61211>>>>>>>  for liPos from 0 to (liMaxPos-1)
61217>>>>>>>>
61217>>>>>>>    move (mid(lsFields,4,liPos*4+1)) to liField
61218>>>>>>>
61218>>>>>>>    if liStillRelating begin
61220>>>>>>>      ifnot (integer(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FILE,liFile,liField))) begin
61222>>>>>>>        get FDX_FieldsOverlappingField oFDX# liFile liField to lsOverlaps
61223>>>>>>>        move (length(lsFields)+3/4) to liMaxOverlap
61224>>>>>>>        move 0 to liAnyRelatingOverlaps
61225>>>>>>>        for liOverlapPos from 0 to (liMaxOverlap-1)
61231>>>>>>>>
61231>>>>>>>          move (mid(lsOverlaps,4,liOverlapPos*4+1)) to liOverlapField
61232>>>>>>>          if (integer(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FILE,liFile,liOverlapField))) move 1 to liAnyRelatingOverlaps
61235>>>>>>>        loop
61236>>>>>>>>
61236>>>>>>>        ifnot liAnyRelatingOverlaps move 0 to liStillRelating
61239>>>>>>>      end
61239>>>>>>>>
61239>>>>>>>    end
61239>>>>>>>>
61239>>>>>>>    ifnot liStillRelating move (lsRval+pad(liField,4)) to lsRval
61242>>>>>>>  loop
61243>>>>>>>>
61243>>>>>>>  function_return lsRval
61244>>>>>>>end_function
61245>>>>>>>
61245>>>>>>>// Parameter liIndexType must be DF_INDEX_TYPE_ONLINE or DF_INDEX_TYPE_BATCH
61245>>>>>>>//    Define call back like this:
61245>>>>>>>//    procedure HandleIndex integer liFile integer liIndex string lsFields integer liType
61245>>>>>>>procedure FDX_IndexCallback global integer lhFDX integer liFile integer liIndexType integer liMsg integer lhObj
61247>>>>>>>  integer liIndex liType
61247>>>>>>>  string lsIndexDef
61247>>>>>>>  for liIndex from 1 to 15
61253>>>>>>>>
61253>>>>>>>    get FDX_IndexAsFields lhFDX liFile liIndex to lsIndexDef
61254>>>>>>>    if (lsIndexDef<>"") begin
61256>>>>>>>      get FDX_AttrValue_INDEX lhFDX DF_INDEX_TYPE liFile liIndex to liType
61257>>>>>>>      if (liType=liIndexType) send liMsg to lhObj liFile liIndex lsIndexDef liType
61260>>>>>>>    end
61260>>>>>>>>
61260>>>>>>>  loop
61261>>>>>>>>
61261>>>>>>>end_procedure
61262>>>>>>>
61262>>>>>>>desktop_section
61267>>>>>>>  object oFdxIndexTempArray is a cArray
61269>>>>>>>    property string psRval public ""
61271>>>>>>>    procedure AddToRval integer liFile integer liIndex string lsIndexDef integer liIndexType
61274>>>>>>>      string lsRval
61274>>>>>>>      get psRval to lsRval
61275>>>>>>>      if (lsRval="") set psRval to (string(liIndex))
61278>>>>>>>      set psRval to (lsRval+" "+string(liIndex))
61279>>>>>>>    end_procedure
61280>>>>>>>    function sSetOfIndices integer lhFDX integer liFile integer liIndexType returns string
61283>>>>>>>      set psRval to ""
61284>>>>>>>      send FDX_IndexCallback lhFDX liFile liIndexType msg_AddToRval self
61285>>>>>>>      function_return (psRval(self))
61286>>>>>>>    end_function
61287>>>>>>>  end_object
61288>>>>>>>end_desktop_section
61293>>>>>>>
61293>>>>>>>//> Returns all indices of type liIndexType (DF_INDEX_TYPE_ONLINE or DF_INDEX_TYPE_BATCH)
61293>>>>>>>function FDX_SetOfIndices global integer lhFDX integer liFile integer liIndexType returns string
61295>>>>>>>  string lsRval
61295>>>>>>>  get sSetOfIndices of (oFdxIndexTempArray(self)) lhFDX liFile liIndexType to lsRval
61296>>>>>>>  function_return lsRval
61297>>>>>>>end_function
61298>>>>>>>
61298>>>>>>>//> Returns all indices that may be used efficiently for finding records in liFile by specifying
61298>>>>>>>//> fields in lsFields
61298>>>>>>>function FDX_SetOfIndicesFieldConstrained global integer lhFDX integer liFile string lsFields returns string
61300>>>>>>>  integer liIndex liField liMaxPos liPos
61300>>>>>>>  string lsTakeThemOut lsValue lsIndex lsField
61300>>>>>>>  move "" to lsValue
61301>>>>>>>  get FDX_FieldsRemoveDublettes lsFields to lsFields
61302>>>>>>>  for liIndex from 1 to 15
61308>>>>>>>>
61308>>>>>>>    move lsFields to lsTakeThemOut
61309>>>>>>>
61309>>>>>>>    get FDX_IndexAsFields lhFDX liFile liIndex to lsIndex
61310>>>>>>>    get FDX_FieldsTranslateOverlaps lhFDX liFile lsIndex to lsIndex
61311>>>>>>>    get FDX_FieldsRemoveDublettes lsIndex to lsIndex
61312>>>>>>>
61312>>>>>>>    // Note that we calculate liMaxPos based on lsFields and NOT lsIndex. The
61312>>>>>>>    // reason is that we want lsFields (=lsTakeThemOut) to appear as the most
61312>>>>>>>    // significant segments of the index (in no particular order) and not
61312>>>>>>>    // scattered all over the index.
61312>>>>>>>    move (length(lsFields)+3/4) to liMaxPos
61313>>>>>>>    for liPos from 1 to liMaxPos
61319>>>>>>>>
61319>>>>>>>      move (mid(lsIndex,4,liPos-1*4+1)) to liField
61320>>>>>>>      move (pad(liField,4)) to lsField
61321>>>>>>>      move (replace(lsField,lsTakeThemOut,"")) to lsTakeThemOut
61322>>>>>>>    loop
61323>>>>>>>>
61323>>>>>>>
61323>>>>>>>    if (lsTakeThemOut="") move (lsValue+pad(liIndex,4)) to lsValue
61326>>>>>>>  loop
61327>>>>>>>>
61327>>>>>>>
61327>>>>>>>  function_return lsValue
61328>>>>>>>end_function
61329>>>>>>>
61329>>>>>>>//> Returns all indices that may be used efficiently for finding records in liChildTable
61329>>>>>>>function FDX_SetOfIndicesTableConstrained global integer lhFDX integer liChildTable integer liParentTable returns string
61331>>>>>>>  string lsRelatingFields lsValue
61331>>>>>>>  get FDX_FieldsRelatingToParent lhFDX liChildTable liParentTable to lsRelatingFields
61332>>>>>>>  get FDX_FieldsTranslateOverlaps lhFDX liChildTable lsRelatingFields to lsRelatingFields
61333>>>>>>>  get FDX_SetOfIndicesFieldConstrained lhFDX liChildTable to lsRelatingFields
61334>>>>>>>  function_return lsValue
61335>>>>>>>end_function
61336>>>>>>>
61336>>>>>>>
61336>>>>>>>
61336>>>>>
61336>>>>>  define Structur$UI for 1
61336>>>>>
61336>>>>> Use Fdx2.utl     // FDX aware object for displaying a table definiton
61336>>>>> Use Wait.utl     // Something to put on screen while batching.
61336>>>>> Use MsgBox.utl   // obs procedure
61336>>>>>
61336>>>>>desktop_section
61341>>>>>  object oStructure_LogFile is a cLogFile
61343>>>>>    set psFileName     to "dfmatrix.log"
61344>>>>>    set piCloseOnWrite to DFTRUE
61345>>>>>    set psPurpose      to "Events during table restructuring"
61346>>>>>    property integer pbError public 0
61348>>>>>    procedure OnLogFileOpen
61351>>>>>      set pbError to DFFALSE
61352>>>>>    end_procedure
61353>>>>>
61353>>>>>    register_object oBatchModeLogFile
61353>>>>>    procedure WriteLn string lsValue
61356>>>>>      forward send WriteLn lsValue
61358>>>>>        if (DfmBatchMode()) send WriteLn to (oBatchModeLogFile(self)) lsValue
61361>>>>>    end_procedure
61362>>>>>
61362>>>>>    procedure OnLogFileClose
61365>>>>>    end_procedure
61366>>>>>    procedure WriteLnError string lsValue
61369>>>>>      send WriteLn ("Error: "+lsValue)
61370>>>>>      set pbError to DFTRUE
61371>>>>>    end_procedure
61372>>>>>  end_object
61373>>>>>end_desktop_section
61378>>>>>
61378>>>>>   Use APS          // Auto Positioning and Sizing classes for VDF
61378>>>>>   object oStructureError is a aps.ModalPanel label "Restructure error"
61381>>>>>     set Locate_Mode to CENTER_ON_SCREEN
61382>>>>>     on_key kcancel send close_panel
61383>>>>>
61383>>>>>     // Must be provided if local error handler is to be created
61383>>>>>
61383>>>>>     property integer error_processing_state      public DFFALSE
61385>>>>>     property integer piOriginalErrorObject       public 0
61387>>>>>
61387>>>>>     object oTb1 is a aps.TextBox label "DataFlex reported this error:"
61390>>>>>     end_object
61391>>>>>     object oFrm1 is a aps.Form abstract AFT_ASCII50 snap SL_DOWN
61395>>>>>       set object_shadow_state to true
61396>>>>>     end_object
61397>>>>>     object oFrm2 is a aps.Form abstract AFT_ASCII50 snap SL_DOWN
61401>>>>>       set object_shadow_state to true
61402>>>>>     end_object
61403>>>>>     object oTb2 is a aps.TextBox label "While executing this instruction:" snap SL_DOWN
61407>>>>>     end_object
61408>>>>>     object oFrm3 is a aps.Form abstract AFT_ASCII50 snap SL_DOWN
61412>>>>>       set object_shadow_state to true
61413>>>>>     end_object
61414>>>>>     object oFrm4 is a aps.Form abstract AFT_ASCII50 snap SL_DOWN
61418>>>>>       set object_shadow_state to true
61419>>>>>     end_object
61420>>>>>     object oFrm5 is a aps.Form abstract AFT_ASCII50 snap SL_DOWN
61424>>>>>       set object_shadow_state to true
61425>>>>>     end_object
61426>>>>>     object oBtn1 is a aps.Multi_Button
61428>>>>>       on_item "End script"  send end_script
61429>>>>>     end_object
61430>>>>>     object oBtn2 is a aps.Multi_Button
61432>>>>>       on_item "Display def" send display_definition
61433>>>>>     end_object
61434>>>>>     object oBtn3 is a aps.Multi_Button
61436>>>>>       on_item "Continue" send close_panel
61437>>>>>     end_object
61438>>>>>     send aps_locate_multi_buttons
61439>>>>>     procedure Error_Report integer liErrNum integer liErr_Line string lsValue
61442>>>>>       integer lhObj lhStructure_LogFile
61442>>>>>       string lsValue1 lsValue2 lsError1 lsError2
61442>>>>>       If (error_processing_state(self)) procedure_return // this prevents recursion
61445>>>>>       set error_processing_state to DFTRUE
61446>>>>>       move (Error_Description(self,liErrNum,lsValue))                      to lsError1
61447>>>>>       move ("(Error "+string(liErrNum)+" on line "+string(liErr_Line)+")") to lsError2
61448>>>>>       set value of (oFrm1(self)) item 0 to lsError1
61449>>>>>       set value of (oFrm2(self)) item 0 to lsError2
61450>>>>>       move (oStructureErrorInfo(self)) to lhObj
61451>>>>>       send DoPrepare to lhObj
61452>>>>>       get psLine1 of lhObj to lsValue1
61453>>>>>       get psLine2 of lhObj to lsValue2
61454>>>>>       set value of (oFrm3(self)) item 0 to lsValue1
61455>>>>>       set value of (oFrm4(self)) item 0 to lsValue2
61456>>>>>       set value of (oFrm5(self)) item 0 to Struc$ErrDescr
61457>>>>>       move (oStructure_LogFile(self)) to lhStructure_LogFile
61458>>>>>       send WriteLnError to lhStructure_LogFile "  DataFlex reported this error:"
61459>>>>>       send WriteLn to lhStructure_LogFile ("    "+lsError1)
61460>>>>>       send WriteLn to lhStructure_LogFile ("    "+lsError2)
61461>>>>>       if (lsValue1<>"" or lsValue2<>"") begin
61463>>>>>         send WriteLn to lhStructure_LogFile "  While executing this instruction:"
61464>>>>>         if lsValue1 ne "" send WriteLn to lhStructure_LogFile ("    "+lsValue1)
61467>>>>>         if lsValue2 ne "" send WriteLn to lhStructure_LogFile ("    "+lsValue2)
61470>>>>>         if Struc$ErrDescr ne "" send WriteLn to lhStructure_LogFile ("    "+Struc$ErrDescr)
61473>>>>>       end
61473>>>>>>
61473>>>>>       send popup
61474>>>>>       set error_processing_state to DFFALSE
61475>>>>>     end_procedure
61476>>>>>
61476>>>>>     // Stolen right out of error.pkg:
61476>>>>>     //*** Build complete error description from Flexerrs and user error message.
61476>>>>>     function Error_Description integer liError string lsErrMsg returns string
61479>>>>>       string lsFullErrorText
61479>>>>>       trim lsErrMsg to lsErrMsg
61480>>>>>>
61480>>>>>       move (trim(error_text(DESKTOP,liError))) to lsFullErrorText
61481>>>>>       if lsErrMsg ne "" begin
61483>>>>>         if ((lsFullErrorText ne "") AND error_text_available(DESKTOP,liError)) append lsFullErrorText " " lsErrMsg
61487>>>>>         else move lsErrMsg to lsFullErrorText
61489>>>>>       end
61489>>>>>>
61489>>>>>       function_return lsFullErrorText
61490>>>>>     end_function
61491>>>>>
61491>>>>>     procedure end_script
61494>>>>>       error 774 "No such thing as 'End script'"
61495>>>>>>
61495>>>>>     end_procedure
61496>>>>>
61496>>>>>     procedure display_definition
61499>>>>>       send RS_DisplayDef
61500>>>>>     end_procedure
61501>>>>>   end_object // oStructureError
61502>>>>>
61502>>>>>procedure DFMatrixError_On global // Set error trapping mode to DFMatrix
61504>>>>>    integer lhObj
61504>>>>>    move (oStructureError(self)) to lhObj
61505>>>>>    if Error_Object_Id ne lhObj begin
61507>>>>>      set piOriginalErrorObject of lhObj to Error_Object_Id
61508>>>>>      move lhObj to Error_Object_Id
61509>>>>>    end
61509>>>>>>
61509>>>>>end_procedure
61510>>>>>procedure DFMatrixError_Off global // Set error trapping mode back to normal
61512>>>>>    integer lhObj
61512>>>>>    move (oStructureError(self)) to lhObj
61513>>>>>    if Error_Object_Id eq lhObj get piOriginalErrorObject of lhObj to Error_Object_Id
61516>>>>>end_procedure
61517>>>>>
61517>>>>>
61517>>>>>enumeration_list // Progress modes
61517>>>>>  define RS_PG_DEFAULT
61517>>>>>  define RS_PG_NONE
61517>>>>>  define RS_PG_LEAVE_ON
61517>>>>>  define RS_PG_OFF
61517>>>>>end_enumeration_list
61517>>>>>
61517>>>>>
61517>>>>>  object oStructureWait is a cBatchCompanion
61519>>>>>    property string psMostRecentProgressTitle public ""
61521>>>>>    set allow_cancel_state to false
61522>>>>>    function callback string lsText integer liType returns integer
61525>>>>>      if liType eq DF_MESSAGE_HEADING_1 send batch_update lsText
61528>>>>>      else if liType eq DF_MESSAGE_PROGRESS_TITLE begin
61531>>>>>        set psMostRecentProgressTitle to (lsText+": ")
61532>>>>>        send batch_update2 lsText
61533>>>>>      end
61533>>>>>>
61533>>>>>      else if liType eq DF_MESSAGE_PROGRESS_VALUE send batch_update2 lsText (psMostRecentProgressTitle(self)+replace(",",lsText," of "))
61537>>>>>      else begin
61538>>>>>        if liType eq DF_MESSAGE_HEADING_2 send batch_update3 lsText ("HDR2: "+lsText)
61541>>>>>        else if liType eq DF_MESSAGE_HEADING_3 send batch_update3 ("HDR3: "+lsText)
61545>>>>>        else if liType eq DF_MESSAGE_HEADING_4 send batch_update3 ("HDR4: "+lsText)
61549>>>>>        else if liType eq DF_MESSAGE_HEADING_5 send batch_update3 ("HDR5: "+lsText)
61553>>>>>        else if liType eq DF_MESSAGE_WARNING   begin
61556>>>>>          send batch_update3 ("WARN: "+lsText)
61557>>>>>          send WriteLnError to (oStructure_LogFile(self)) ("  Warning: "+lsText)
61558>>>>>        end
61558>>>>>>
61558>>>>>        else if liType eq DF_MESSAGE_TEXT      send batch_update3 ("      "+lsText)
61562>>>>>        else send batch_update3 ("????: "+lsText)
61564>>>>>      end
61564>>>>>>
61564>>>>>      function_return 0 // Continue please
61565>>>>>    end_function
61566>>>>>    procedure activate_title string lsTitle
61569>>>>>      send batch_on lsTitle
61570>>>>>      send batch_update  "Doing something" // 1
61571>>>>>      send batch_update2 "No idea..."
61572>>>>>      send batch_update3 ""
61573>>>>>      set psMostRecentProgressTitle to ""
61574>>>>>    end_procedure
61575>>>>>    procedure deactivate_display
61578>>>>>      send batch_off
61579>>>>>    end_procedure
61580>>>>>    function batch_interrupt returns integer // Cancel (no interupting!)
61583>>>>>    end_function
61584>>>>>  end_object
61585>>>>>
61585>>>>>define FIX_31D_RESTRUCT_ERROR for 1
61585>>>>>
61585>>>>>define IMPLICIT_FIELD for -1
61585>>>>>
61585>>>>>
61585>>>>>function sRSErr_Text.i global integer op# returns string
61587>>>>>  enumeration_list
61587>>>>>    define_rserr RSERR.NO_ERROR         "No error"
61590>>>>>    define_rserr RSERR.NOTAVALIDFLENTRY "Not a valid FILELIST entry"
61593>>>>>    define_rserr RSERR.NOEXCLACCESS     "Exclusive access could not be obtained"
61596>>>>>    define_rserr RSERR.NOT_A_DF_FILE    "Cannot restructure files in foreign DB"
61599>>>>>  end_enumeration_list
61599>>>>>  function_return "Undefined error"
61600>>>>>end_function
61601>>>>>
61601>>>>>
61601>>>>>// This class is used for setting FILE attribute DF_FILE_RECORD_LENGTH. I would
61601>>>>>// agree if you argue that it seems gross overkill to handle this with an
61601>>>>>// array and procedures instead of simply a single property.
61601>>>>>register_function piTraceState returns integer
61601>>>>>class cPostponedFileSettings is a cArray
61602>>>>>  item_property_list
61602>>>>>    item_property integer piAttribute.i
61602>>>>>    item_property string  psValue.i
61602>>>>>  end_item_property_list cPostponedFileSettings
#REM 61634 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 61638 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 61642 DEFINE FUNCTION PIATTRIBUTE.I INTEGER LIROW RETURNS INTEGER
#REM 61646 DEFINE PROCEDURE SET PIATTRIBUTE.I INTEGER LIROW INTEGER VALUE
61651>>>>>  procedure postponed_setting integer attr# string value#
61653>>>>>    integer row#
61653>>>>>    get row_count to row#
61654>>>>>    set piAttribute.i row# to attr#
61655>>>>>    set psValue.i     row# to value#
61656>>>>>  end_procedure
61657>>>>>  procedure execute string physname#
61659>>>>>    integer row# max# liFile attr#
61659>>>>>    string value#
61659>>>>>    get piFileHandle to liFile
61660>>>>>    get row_count to max#
61661>>>>>    for row# from 0 to (max#-1)
61667>>>>>>
61667>>>>>      get piAttribute.i row# to attr#
61668>>>>>      get psValue.i     row# to value#
61669>>>>>      // If DF_FILE_RECORD_LENGTH and -1 we must trim the record size:
61669>>>>>      if (attr#=DF_FILE_RECORD_LENGTH and integer(value#)=-1) get_attribute DF_FILE_RECORD_LENGTH_USED of liFile to value#
61674>>>>>      ErrorTrapping.set_attribute attr# of liFile to value#
61682>>>>>      send NotifyTracer RSOP_SETFILEATTR attr# 0 0 0 value#
61683>>>>>    loop
61684>>>>>>
61684>>>>>  end_procedure
61685>>>>>end_class
61686>>>>>// This is used simply for postponing setting the DF_FIELD_INDEX attribute.
61686>>>>>class cPostponedFieldSettings is a cArray
61687>>>>>  item_property_list
61687>>>>>    item_property integer piAttribute.i
61687>>>>>    item_property integer piField.i
61687>>>>>    item_property string  psValue.i
61687>>>>>  end_item_property_list cPostponedFieldSettings
#REM 61722 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 61726 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 61730 DEFINE FUNCTION PIFIELD.I INTEGER LIROW RETURNS INTEGER
#REM 61734 DEFINE PROCEDURE SET PIFIELD.I INTEGER LIROW INTEGER VALUE
#REM 61738 DEFINE FUNCTION PIATTRIBUTE.I INTEGER LIROW RETURNS INTEGER
#REM 61742 DEFINE PROCEDURE SET PIATTRIBUTE.I INTEGER LIROW INTEGER VALUE
61747>>>>>  procedure postponed_setting integer attr# integer field# string value#
61749>>>>>    integer row#
61749>>>>>    get row_count to row#
61750>>>>>    set piAttribute.i row# to attr#
61751>>>>>    set piField.i     row# to field#
61752>>>>>    set psValue.i     row# to value#
61753>>>>>  end_procedure
61754>>>>>
61754>>>>>  function iCheckMainIndexSetting integer liFile integer field# integer index# returns integer
61756>>>>>    integer segment# max_seg# seg_field# liMaxField liTestField lbOverlaps
61756>>>>>    if index# begin
61758>>>>>      // Either index is non-zero in which case we need to check that the
61758>>>>>      // field is actuially part of the index:
61758>>>>>      get_attribute DF_INDEX_NUMBER_SEGMENTS of liFile index# to max_seg#
61761>>>>>      for segment# from 1 to max_seg#
61767>>>>>>
61767>>>>>        get_attribute DF_INDEX_SEGMENT_FIELD of liFile index# segment# to seg_field#
61770>>>>>        if seg_field# eq field# function_return 1
61773>>>>>        if (integer(FDX_AttrValue_SPECIAL1(0,DF_FIELD_OVERLAP,liFile,field#,seg_field#))) function_return 1
61776>>>>>      loop
61777>>>>>>
61777>>>>>    end
61777>>>>>>
61777>>>>>    else begin
61778>>>>>      // Or index is zero in which case field cannot be part of ANY index.
61778>>>>>      // (Unfortunately I don't have time to code this so we just say it's
61778>>>>>      // alright. The point is that if a field is not part of ANY index
61778>>>>>      // its main_index is automatically set to zero - I think).
61778>>>>>      function_return 1
61779>>>>>    end
61779>>>>>>
61779>>>>>    // function_return 0
61779>>>>>  end_function
61780>>>>>  procedure execute string physname#
61782>>>>>    integer row# max# attr# liFile field# lhStructure_LogFile
61782>>>>>    string value# test# lsValue
61782>>>>>    get piFileHandle to liFile
61783>>>>>    get row_count to max#
61784>>>>>    for row# from 0 to (max#-1)
61790>>>>>>
61790>>>>>      get piAttribute.i row# to attr#
61791>>>>>      get piField.i     row# to field#
61792>>>>>      get psValue.i     row# to value#
61793>>>>>      move "#, Field: #, value: #" to Struc$ErrDescr
61794>>>>>      replace "#" in Struc$ErrDescr with physname#
61796>>>>>      replace "#" in Struc$ErrDescr with field#
61798>>>>>      replace "#" in Struc$ErrDescr with value#
61800>>>>>      get_attribute attr# of liFile field# to test#
61803>>>>>      if (integer(value#)<>integer(test#)) begin
61805>>>>>        if (iCheckMainIndexSetting(self,liFile,field#,value#)) begin
61807>>>>>          ErrorTrapping.set_attribute attr# of liFile field# to value#
61816>>>>>          send NotifyTracer RSOP_SETFIELDATTR attr# field# 0 0 value#
61817>>>>>//        send obs Struc$ErrDescr (API_Attr_Name(ATTR#))
61817>>>>>        end
61817>>>>>>
61817>>>>>        else begin
61818>>>>>          move (oStructure_LogFile(self)) to lhStructure_LogFile
61819>>>>>          move "Can not set index.# as main index for field #." to lsValue
61820>>>>>          move (replace("#",lsValue,value#)) to lsValue
61821>>>>>          move (replace("#",lsValue,string(field#))) to lsValue
61822>>>>>//          send obs lsValue "" "Field is not part of (or overlapped by a field that" "is path of) the index."
61822>>>>>          send WriteLnError to lhStructure_LogFile ("  "+lsValue+" "+"Field is not part of (or overlapped by a field that is path of) the index.")
61823>>>>>        end
61823>>>>>>
61823>>>>>      end
61823>>>>>>
61823>>>>>    loop
61824>>>>>>
61824>>>>>    move "" to Struc$ErrDescr
61825>>>>>  end_procedure
61826>>>>>end_class // cPostponedFieldSettings
61827>>>>>
61827>>>>>//> The cRSIndexCreations class is used within an cBasicRestructurer object
61827>>>>>//> to keep track of indices that were created as part of a restructure
61827>>>>>//> operation. Why? Because we may need to manually move the corresponding
61827>>>>>//> index files next to the DAT files. Otherwise the index files will
61827>>>>>//> remain in the first directory in the current search path (DF_OPEN_PATH)
61827>>>>>class cRSIndexCreations is an cArray
61828>>>>>end_class
61829>>>>>
61829>>>>>//> This class is also used from within an cBasicRestructurer object for
61829>>>>>//> the following reason. The '@' is not allowed as part of a field name.
61829>>>>>//> However, in vintage DataFlex the '@' sign is perfectly valid and in fact
61829>>>>>//> was used as part of a field name as an indication that the field is an
61829>>>>>//> overlap field or otherwise should not be presented to the end user
61829>>>>>//> (DFQuery and VDFQuery automatically filters such fields out).
61829>>>>>//> The cFieldNameRepair class is used to temporarily substitute 'illegal'
61829>>>>>//> field names with something legal. After the restructure has ended
61829>>>>>//> this object will edit the resulting TAG file.
61829>>>>>class cFieldNameRepair is an cArray
61830>>>>>  item_property_list
61830>>>>>    item_property string psRealName.i // "@ROAD_ID"
61830>>>>>    item_property string psTempName.i // "RSTMPFLDNAME001"
61830>>>>>  end_item_property_list cFieldNameRepair
#REM 61862 DEFINE FUNCTION PSTEMPNAME.I INTEGER LIROW RETURNS STRING
#REM 61866 DEFINE PROCEDURE SET PSTEMPNAME.I INTEGER LIROW STRING VALUE
#REM 61870 DEFINE FUNCTION PSREALNAME.I INTEGER LIROW RETURNS STRING
#REM 61874 DEFINE PROCEDURE SET PSREALNAME.I INTEGER LIROW STRING VALUE
61879>>>>>  procedure construct_object integer img#
61881>>>>>    forward send construct_object img#
61883>>>>>    property integer piTmpCounter private 0
61884>>>>>    object oTagFileArray is an cArray no_image
61886>>>>>    end_object
61887>>>>>  end_procedure
61888>>>>>  procedure reset
61890>>>>>    send delete_data
61891>>>>>    set !$.piTmpCounter to 1
61892>>>>>  end_procedure
61893>>>>>  function sRealName.s string tempname# returns string
61895>>>>>    integer max# row#
61895>>>>>    get row_count to max#
61896>>>>>    for row# from 0 to (max#-1)
61902>>>>>>
61902>>>>>      if (psTempName.i(self,row#)) eq tempname# function_return (psRealName.i(self,row#))
61905>>>>>    loop
61906>>>>>>
61906>>>>>    function_return ""
61907>>>>>  end_function
61908>>>>>  function sTempName.s string realname# returns string
61910>>>>>    integer max# row#
61910>>>>>    get row_count to max#
61911>>>>>    for row# from 0 to (max#-1)
61917>>>>>>
61917>>>>>      if (psRealName.i(self,row#)) eq realname# function_return (psTempName.i(self,row#))
61920>>>>>    loop
61921>>>>>>
61921>>>>>    function_return ""
61922>>>>>  end_function
61923>>>>>  function sAddField.s string realname# returns string
61925>>>>>    integer counter# row#
61925>>>>>    string rval#
61925>>>>>    get !$.piTmpCounter to counter#
61926>>>>>    move ("RSTMPFLDNAME"+IntToStrRzf(counter#,3)) to rval#
61927>>>>>    get row_count to row#
61928>>>>>    set psRealName.i row# to realname#
61929>>>>>    set psTempName.i row# to rval#
61930>>>>>    set !$.piTmpCounter to (counter#+1)
61931>>>>>    function_return rval#
61932>>>>>  end_function
61933>>>>>  procedure fix_the_tag_file
61935>>>>>    integer arr# ch# max# itm#
61935>>>>>    string root# name# real_name#
61935>>>>>    if (row_count(self)) begin // Only if necessary
61937>>>>>      get sRootInclPath to root#
61938>>>>>      move (root#+".tag") to root#
61939>>>>>      //send obs "sRootInclPath" root#
61939>>>>>      move (SEQ_DirectInput(root#)) to ch#
61940>>>>>      if ch# ge 0 begin
61942>>>>>        move (oTagFileArray(self)) to arr#
61943>>>>>        send delete_data to arr#
61944>>>>>        repeat
61944>>>>>>
61944>>>>>          move (SEQ_ReadLn(ch#)) to name#
61945>>>>>          if name# ne "" set value of arr# item (item_count(arr#)) to name#
61948>>>>>        until name# eq ""
61950>>>>>        send SEQ_CloseInput ch#
61951>>>>>        move (SEQ_DirectOutput(root#)) to ch#
61952>>>>>        get item_count of arr# to max#
61953>>>>>        for itm# from 0 to (max#-1)
61959>>>>>>
61959>>>>>          move (value(arr#,itm#)) to name#
61960>>>>>          get sRealName.s name# to real_name#
61961>>>>>          if real_name# ne "" writeln real_name#
61965>>>>>          else writeln name#
61968>>>>>        loop
61969>>>>>>
61969>>>>>        send SEQ_CloseOutput ch#
61970>>>>>      end
61970>>>>>>
61970>>>>>      else error 672 ("TAG file not found ("+root#+")")
61972>>>>>    end
61972>>>>>>
61972>>>>>  end_procedure
61973>>>>>end_class // cFieldNameRepair
61974>>>>>
61974>>>>>//> Attribute DF_FILE_NUMBER_FIELDS does not work as stated by the
61974>>>>>//> documentation (it simply returns the current position of the
61974>>>>>//> field at any time). To overcome this a stunt based on this class
61974>>>>>//> is performed.
61974>>>>>class cBleedingOldFieldNumbers is a cArray // Godammit!
61975>>>>>  procedure initialize
61977>>>>>    integer liFile max# field#
61977>>>>>    send delete_data
61978>>>>>    get piFileHandle to liFile
61979>>>>>    get_attribute DF_FILE_NUMBER_FIELDS of liFile to max#
61982>>>>>    for field# from 1 to max#
61988>>>>>>
61988>>>>>      set value item field# to field#
61989>>>>>    loop
61990>>>>>>
61990>>>>>  end_procedure
61991>>>>>  procedure delete_field integer field#
61993>>>>>    send delete_item field#
61994>>>>>  end_procedure
61995>>>>>  procedure insert_item integer itm#
61997>>>>>    integer xitm# max#
61997>>>>>    get item_count to max#
61998>>>>>    for_ex xitm# from max# down_to (itm#+1)
62005>>>>>      set value item xitm# to (value(self,xitm#-1))
62006>>>>>    loop
62007>>>>>>
62007>>>>>    set value item itm# to 0
62008>>>>>  end_procedure
62009>>>>>  procedure create_field integer field#
62011>>>>>    integer append#
62011>>>>>    move 0 to append#
62012>>>>>    ifnot field# move 1 to append#
62015>>>>>    if field# gt (item_count(self)) move 1 to append#
62018>>>>>    if append# set value item (item_count(self)) to 0
62021>>>>>    else begin
62022>>>>>      send insert_item field#
62023>>>>>      set value item field# to 0
62024>>>>>    end
62024>>>>>>
62024>>>>>  end_procedure
62025>>>>>  function iFindFieldOldNumber.i integer old_field# returns integer
62027>>>>>    integer itm# max# field#
62027>>>>>    get item_count to max#
62028>>>>>    for itm# from 1 to (max#-1)
62034>>>>>>
62034>>>>>      get value item itm# to field#
62035>>>>>      if old_field# eq field# function_return itm#
62038>>>>>    loop
62039>>>>>>
62039>>>>>    function_return -1
62040>>>>>  end_function
62041>>>>>end_class // cBleedingOldFieldNumbers
62042>>>>>
62042>>>>>register_procedure RegisterUpdate integer op# integer attr# integer field# integer index# integer seg# string value#
62042>>>>>class cBasicRestructurer is a cArray
62043>>>>>  procedure construct_object integer img#
62045>>>>>    forward send construct_object img#
62047>>>>>    property integer         piRS_State        public 0 // Are preconditions ok for RS?
62048>>>>>    property integer         piFileHandle      public 0 // File handle during restructure, File number during probe
62049>>>>>    property integer         piMainFile        public 0 // File number during restructure and probe
62050>>>>>    property string          psDriver          public "DATAFLEX"
62051>>>>>    // Used for tracking field insertion error in DF31D:
62051>>>>>    property integer piInitialNumberOfFields   public 0
62052>>>>>    property integer piIgnoreTheRestState      public 0
62053>>>>>
62053>>>>>    property integer         piErrorHandling   public 0 // Catch DF errors?
62054>>>>>    property integer         piProbeState      public 0 //
62055>>>>>    property integer private.piOrigOnError     public 0
62056>>>>>    property integer private.piDropCounter     public 0
62057>>>>>    property integer private.piCurrentField    public 0
62058>>>>>    property integer         piFieldTrackState public 1
62059>>>>>    // Name of DAT file being restructured
62059>>>>>    property string          psDatFilePath     public ""
62060>>>>>    property string          psDatFileName     public "" //
62061>>>>>    property integer         piTraceState      public 0
62062>>>>>    property integer         piTraceObject     public 0
62063>>>>>    property integer         piProgressMode    public RS_PG_DEFAULT // Wait image behavior
62064>>>>>
62064>>>>>    property integer private.piSortOnEndStructure public DFFALSE
62065>>>>>
62065>>>>>    object oPostponedFileSettings is a cPostponedFileSettings no_image
62067>>>>>    end_object
62068>>>>>    object oPostponedFieldSettings is a cPostponedFieldSettings no_image
62070>>>>>    end_object
62071>>>>>    object oRSIndexCreations is a cRSIndexCreations no_image
62073>>>>>    end_object
62074>>>>>    object oTmpArray is a cArray no_image
62076>>>>>      // Used when creating indices.
62076>>>>>    end_object
62077>>>>>    object oFieldNameRepair is a cFieldNameRepair no_image
62079>>>>>    end_object
62080>>>>>    object oOldFieldNumbersRepair is a cBleedingOldFieldNumbers no_image
62082>>>>>    end_object
62083>>>>>  end_procedure
62084>>>>>
62084>>>>>//procedure reset // I don't know who'd call this
62084>>>>>//  set piRS_State to 0
62084>>>>>//  set piProbeState to 0
62084>>>>>//  set piFileHandle to 0
62084>>>>>//  set piMainFile   to 0
62084>>>>>//  set private.piCurrentField to -1
62084>>>>>//  send delete_data to (oRSIndexCreations(self))
62084>>>>>//end_procedure
62084>>>>>
62084>>>>>  function field_count returns integer
62086>>>>>    integer liFile rval#
62086>>>>>    get piFileHandle to liFile
62087>>>>>    get_attribute DF_FILE_NUMBER_FIELDS of liFile to rval#
62090>>>>>    function_return rval#
62091>>>>>  end_function
62092>>>>>
62092>>>>>  procedure SetFieldNumber integer field#
62094>>>>>    set private.piCurrentField to field#
62095>>>>>  end_procedure
62096>>>>>
62096>>>>>  procedure CreateField integer field# string name# integer type#
62098>>>>>    integer liFile WasIRightOrWasIRight# InitialNumberOfFields#
62098>>>>>    integer liFieldNameAlreadyExists
62098>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62100>>>>>      get piFileHandle to liFile
62101>>>>>      if field# gt (field_count(self)) move 0 to field# // Append
62104>>>>>      get piInitialNumberOfFields to InitialNumberOfFields#
62105>>>>>      ErrorTrapping.create_field liFile at field#
62110>>>>>      send create_field to (oOldFieldNumbersRepair(self)) field#
62111>>>>>      // If fieldname begins with "@" we have to cheat
62111>>>>>      if "@"      in    name# move (sAddField.s(oFieldNameRepair(self),name#)) to name#
62114>>>>>      // If fieldname begins with "FIELD" we have to cheat
62114>>>>>      if (StringBeginsWith(name#,"FIELD")) move (sAddField.s(oFieldNameRepair(self),name#)) to name#
62117>>>>>      // If fieldname already exists (but we intend to create the other field later) we have to cheat
62117>>>>>      get iFindFieldName.s name# to liFieldNameAlreadyExists
62118>>>>>      if (liFieldNameAlreadyExists<>-1) move (sAddField.s(oFieldNameRepair(self),name#)) to name#
62121>>>>>      ErrorTrapping.set_attribute DF_FIELD_NAME of liFile field# to name#
62130>>>>>      ErrorTrapping.set_attribute DF_FIELD_TYPE of liFile field# to type#
62139>>>>>      if field# set private.piCurrentField to field#
62142>>>>>      else set private.piCurrentField to (field_count(self))
62144>>>>>      send NotifyTracer RSOP_CREATEFIELD 0 field# type# 0 name#
62145>>>>>    end
62145>>>>>>
62145>>>>>  end_procedure
62146>>>>>  procedure CreateField_OldNumber integer old_number# string name# integer type#
62148>>>>>    integer field#
62148>>>>>    get iFindFieldOldNumber.i old_number# to field#
62149>>>>>    if field# ne -1 send CreateField field# name# type#
62152>>>>>    else error 667 ("Old number not found ("+string(old_number#)+")")
62154>>>>>  end_procedure
62155>>>>>
62155>>>>>  procedure AppendField string name# integer type#
62157>>>>>    ifnot (piIgnoreTheRestState(self)) ;      send CreateField 0 name# type#
62160>>>>>  end_procedure
62161>>>>>  procedure DeleteField integer field#
62163>>>>>    integer liFile
62163>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62165>>>>>      get piFileHandle to liFile
62166>>>>>      ErrorTrapping.delete_field liFile field#
62171>>>>>      send delete_field to (oOldFieldNumbersRepair(self)) field#
62172>>>>>      send NotifyTracer RSOP_DELETEFIELD 0 field# 0 0 ""
62173>>>>>    end
62173>>>>>>
62173>>>>>  end_procedure
62174>>>>>
62174>>>>>  procedure DeleteField_OldNumber integer old_number#
62176>>>>>    integer field#
62176>>>>>    get iFindFieldOldNumber.i old_number# to field#
62177>>>>>    if field# ne -1 send DeleteField field#
62180>>>>>    else error 668 ("Old number not found ("+string(old_number#)+")")
62182>>>>>  end_procedure
62183>>>>>
62183>>>>>  procedure DeleteIndex integer idx#
62185>>>>>    integer liFile segments#
62185>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62187>>>>>      get piFileHandle to liFile
62188>>>>>      get_attribute DF_INDEX_NUMBER_SEGMENTS of liFile idx# to segments#
62191>>>>>      // We have to check if there are any segments in the index before we
62191>>>>>      // delete it. If there aren't we will get an error if we try to delete it.
62191>>>>>      if segments# delete_index liFile idx#
62194>>>>>      send NotifyTracer RSOP_DELETEINDEX 0 0 idx# 0 ""
62195>>>>>    end
62195>>>>>>
62195>>>>>  end_procedure
62196>>>>>
62196>>>>>  procedure structure_abort
62198>>>>>    integer liFile
62198>>>>>    get piFileHandle to liFile
62199>>>>>    structure_abort liFile
62200>>>>>    set piFileHandle to liFile
62201>>>>>    if (piErrorHandling(self)) get private.piOrigOnError to |VI31 // Restore normal error handling routine
62204>>>>>  end_procedure
62205>>>>>  procedure structure_error
62207>>>>>    integer liFile
62207>>>>>    get piFileHandle to liFile
62208>>>>>    error 673 ("An error occured while re-structuring file number "+string(liFile)+". Program will abort.")
62209>>>>>>
62209>>>>>    send structure_abort
62210>>>>>    system
62211>>>>>>
62211>>>>>  end_procedure
62212>>>>>  procedure structure_start
62214>>>>>    integer liFile
62214>>>>>    string root#
62214>>>>>    if (piErrorHandling(self)) begin
62216>>>>>      move self to cRestructurer#  // Make global integer cRestructurer# point to this object
62217>>>>>      set private.piOrigOnError to |VI31     // If an error occurs while restructuring we must abort the
62218>>>>>      on error gosub cRestructurer_Error     // re-structuring AND the program
62219>>>>>      indicate err false                     // This just needs to be done (can't remember why)
62220>>>>>    end
62220>>>>>>
62220>>>>>    send delete_data to (oPostponedFileSettings(self))
62221>>>>>    send delete_data to (oPostponedFieldSettings(self))
62222>>>>>    send reset to (oFieldNameRepair(self))
62223>>>>>    get piMainFile to liFile
62224>>>>>    structure_start liFile (psDriver(self))
62225>>>>>    set piFileHandle to liFile
62226>>>>>    send initialize to (oOldFieldNumbersRepair(self))
62227>>>>>    if (piTraceState(self)) begin
62229>>>>>      get sRootInclPath to root#
62230>>>>>      send NotifyTracer RSOP_BEGIN 0 0 0 0 root#
62231>>>>>    end
62231>>>>>>
62231>>>>>  end_procedure
62232>>>>>  procedure SetProgressMode integer mode#
62234>>>>>    // Possible values for mode# are: RS_PG_DEFAULT RS_PG_NONE RS_PG_LEAVE_ON RS_PG_OFF
62234>>>>>    if mode# eq RS_PG_OFF begin
62236>>>>>      send deactivate_display to (oStructureWait(self))
62237>>>>>      set piProgressMode to RS_PG_DEFAULT
62238>>>>>    end
62238>>>>>>
62238>>>>>    else set piProgressMode to mode#
62240>>>>>  end_procedure
62241>>>>>  procedure structure_end
62243>>>>>    integer liFile callback_obj# wmode# lbOpen
62243>>>>>    integer lhSortHandle
62243>>>>>    string physical_name#
62243>>>>>    if (piProbeState(self)) begin
62245>>>>>      error 773 "No STRUCTURE_END while in probe mode"
62246>>>>>>
62246>>>>>      procedure_return
62247>>>>>    end
62247>>>>>>
62247>>>>>    move (oStructureWait(self)) to callback_obj#
62248>>>>>    get piProgressMode to wmode#
62249>>>>>    get piFileHandle to liFile
62250>>>>>    get_attribute DF_FILE_PHYSICAL_NAME of liFile to physical_name#
62253>>>>>    send execute to (oPostponedFileSettings(self)) physical_name#
62254>>>>>    send execute to (oPostponedFieldSettings(self)) physical_name#
62255>>>>>    if wmode# ne RS_PG_NONE begin
62257>>>>>      send activate_title to callback_obj# physical_name#
62258>>>>>      structure_end liFile DF_STRUCTEND_OPT_NONE "." callback_obj# // (pRestuctOpt(self)) (pTempDir(self)) (pCallBackObj(self))
62260>>>>>    end
62260>>>>>>
62260>>>>>    else begin
62261>>>>>      structure_end liFile DF_STRUCTEND_OPT_NONE "." // (pRestuctOpt(self)) (pTempDir(self))
62263>>>>>    end
62263>>>>>>
62263>>>>>
62263>>>>>    send fix_the_tag_file to (oFieldNameRepair(self))
62264>>>>>    set piFileHandle to liFile
62265>>>>>//  send DFMatrixError_Off
62265>>>>>//  if (piErrorHandling(self)) get private.piOrigOnError to |VI31 // Restore normal error handling routine
62265>>>>>    send NotifyTracer RSOP_END 0 0 0 0 ""
62266>>>>>    send delete_data to (oOldFieldNumbersRepair(self))
62267>>>>>
62267>>>>>    if (private.piSortOnEndStructure(self)) begin
62269>>>>>      get piMainFile to lhSortHandle
62270>>>>>      if lhSortHandle begin // We don't reindex files that were just created
62272>>>>>        send WriteLn to (oStructure_LogFile(self)) "  Forcing reindex..."
62273>>>>>        close lhSortHandle
62274>>>>>//      send WriteLn to (oStructure_LogFile(self)) ("  And the sort handle is: "+string(lhSortHandle))
62274>>>>>//      send WriteLn to (oStructure_LogFile(self)) ("  And the rootname is: "+physical_name#)
62274>>>>>//      if (lhSortHandle=1 or lhSortHandle=21 or lhSortHandle=95) begin
62274>>>>>//        send obs "open physical_name# as" physical_name# lhSortHandle DF_EXCLUSIVE
62274>>>>>
62274>>>>>//        send obs "Errors?" WINDOWINDEX
62274>>>>>//      end
62274>>>>>//      open physical_name# as lhSortHandle DF_EXCLUSIVE
62274>>>>>
62274>>>>>        get DBMS_OpenFileAs physical_name# lhSortHandle DF_EXCLUSIVE 0 to lbOpen
62275>>>>>        if lbOpen begin
62277>>>>>          if wmode# ne RS_PG_NONE sort lhSortHandle '' (DF_SORT_OPTION_BAD_DATA_FILE ior DF_SORT_OPTION_DUP_DATA_FILE) callback_obj#
62281>>>>>          else sort lhSortHandle '' (DF_SORT_OPTION_BAD_DATA_FILE ior DF_SORT_OPTION_DUP_DATA_FILE)
62284>>>>>        end
62284>>>>>>
62284>>>>>        else send WriteLnError to (oStructure_LogFile(self)) "  Table could not be opened for reindexing!"
62286>>>>>//      if (FDX_SetOfIndices(0,lhSortHandle,DF_INDEX_TYPE_ONLINE)+FDX_SetOfIndices(0,lhSortHandle,DF_INDEX_TYPE_BATCH)) ne "" begin
62286>>>>>//        if wmode# ne RS_PG_NONE sort lhSortHandle '' (DF_SORT_OPTION_BAD_DATA_FILE ior DF_SORT_OPTION_DUP_DATA_FILE) callback_obj#
62286>>>>>//        else sort lhSortHandle '' (DF_SORT_OPTION_BAD_DATA_FILE ior DF_SORT_OPTION_DUP_DATA_FILE)
62286>>>>>//      end
62286>>>>>//      else send WriteLn to (oStructure_LogFile(self)) "  No indices on table, reindex abandoned!"
62286>>>>>        close lhSortHandle
62287>>>>>      end
62287>>>>>>
62287>>>>>    end
62287>>>>>>
62287>>>>>
62287>>>>>    send DFMatrixError_Off
62288>>>>>    if (piErrorHandling(self)) get private.piOrigOnError to |VI31 // Restore normal error handling routine
62291>>>>>
62291>>>>>    send CloseOutput to (oStructure_LogFile(self)) // Structure_End
62292>>>>>
62292>>>>>    if wmode# eq RS_PG_DEFAULT send deactivate_display to callback_obj#
62295>>>>>  end_procedure
62296>>>>>
62296>>>>>  procedure SetFileAttr integer attr# string value#
62298>>>>>    integer liFile
62298>>>>>    if (piProbeState(self)) begin
62300>>>>>      error 674 "Sorry, no SETFILEATTR while in probe mode"
62301>>>>>>
62301>>>>>      procedure_return
62302>>>>>    end
62302>>>>>>
62302>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62304>>>>>      if attr# eq DF_FILE_RECORD_LENGTH send postponed_setting to (oPostponedFileSettings(self)) attr# value#
62307>>>>>      else begin
62308>>>>>        get piFileHandle to liFile
62309>>>>>        //send obs "SET FileAttribute of" liFile (API_Attr_Name(attr#)) value#
62309>>>>>        ErrorTrapping.set_attribute attr# of liFile to value#
62317>>>>>        send NotifyTracer RSOP_SETFILEATTR attr# 0 0 0 value#
62318>>>>>      end
62318>>>>>>
62318>>>>>    end
62318>>>>>>
62318>>>>>  end_procedure
62319>>>>>  procedure SetFieldAttr integer attr# integer field# string value#
62321>>>>>    integer liFile
62321>>>>>    if (piProbeState(self)) begin
62323>>>>>      error 675 "Sorry, no SETFIELDATTR while in probe mode"
62324>>>>>>
62324>>>>>      procedure_return
62325>>>>>    end
62325>>>>>>
62325>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62327>>>>>      if attr# eq DF_FIELD_NAME begin
62329>>>>>        if "@" in value# move (sAddField.s(oFieldNameRepair(self),value#)) to value#
62332>>>>>        if (StringBeginsWith(value#,"FIELD")) move (sAddField.s(oFieldNameRepair(self),value#)) to value#
62335>>>>>      end
62335>>>>>>
62335>>>>>      if attr# eq DF_FIELD_INDEX begin
62337>>>>>        // We postpone main index setting until the very end. Then we are
62337>>>>>        // sure that the relevant index is present
62337>>>>>        if field# eq IMPLICIT_FIELD get private.piCurrentField to field#
62340>>>>>        send postponed_setting to (oPostponedFieldSettings(self)) attr# field# value#
62341>>>>>      end
62341>>>>>>
62341>>>>>      else begin
62342>>>>>        if field# eq IMPLICIT_FIELD get private.piCurrentField to field#
62345>>>>>        get piFileHandle to liFile
62346>>>>>        ErrorTrapping.set_attribute attr# of liFile field# to value#
62355>>>>>        send NotifyTracer RSOP_SETFIELDATTR attr# field# 0 0 value#
62356>>>>>      end
62356>>>>>>
62356>>>>>    end
62356>>>>>>
62356>>>>>  end_procedure
62357>>>>>  function iFindFieldOldNumber.i integer old_number# returns integer
62359>>>>>    integer liFile max# field# test#
62359>>>>>    // Very unfortunately, this function doesn't work! (DF_FIELD_OLD_NUMBER returns rubbish)
62359>>>>>    // Therefore we call another procedure until DAW gets it fixed
62359>>>>>    function_return (iFindFieldOldNumber.i(oOldFieldNumbersRepair(self),old_number#))
62360>>>>>    get piFileHandle to liFile
62361>>>>>    get_attribute DF_FILE_NUMBER_FIELDS of liFile to max#
62364>>>>>    for field# from 1 to max#
62370>>>>>>
62370>>>>>      get_attribute DF_FIELD_OLD_NUMBER of liFile field# to test#
62373>>>>>      if test# eq old_number# function_return field#
62376>>>>>    loop
62377>>>>>>
62377>>>>>    function_return -1
62378>>>>>  end_function
62379>>>>>  function iFindFieldName.s string name# returns integer
62381>>>>>    integer field# max# liFile
62381>>>>>    string test_name#
62381>>>>>    get piFileHandle to liFile
62382>>>>>    get field_count to max#
62383>>>>>    // First we look for the name passed:
62383>>>>>    for field# from 1 to max#
62389>>>>>>
62389>>>>>      get_attribute DF_FIELD_NAME of liFile field# to test_name#
62392>>>>>      if test_name# eq name# function_return field#
62395>>>>>    loop
62396>>>>>>
62396>>>>>    // If not found we now see if it helps to translate it:
62396>>>>>    get sTempName.s of (oFieldNameRepair(self)) name# to name#
62397>>>>>    if name# ne "" begin
62399>>>>>      for field# from 1 to max#
62405>>>>>>
62405>>>>>        get_attribute DF_FIELD_NAME of liFile field# to test_name#
62408>>>>>        if test_name# eq name# function_return field#
62411>>>>>      loop
62412>>>>>>
62412>>>>>    end
62412>>>>>>
62412>>>>>    function_return -1
62413>>>>>  end_function
62414>>>>>  procedure SetFieldAttr_OldNumber integer attr# integer old_number# string value#
62416>>>>>    integer field#
62416>>>>>    error 678 "Procedure SetFieldAttr_OldNumber in STRUCTUR.UTL) was called"
62417>>>>>>
62417>>>>>    get iFindFieldOldNumber.i old_number# to field#
62418>>>>>    if field# ne -1 send SetFieldAttr attr# field# value#
62421>>>>>    else error 669 ("Old number not found ("+string(old_number#)+")")
62423>>>>>  end_procedure
62424>>>>>  procedure SetFieldAttr_ByName integer attr# string name# string value#
62426>>>>>    integer field#
62426>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62428>>>>>      get iFindFieldName.s name# to field#
62429>>>>>      if field# ne -1 send SetFieldAttr attr# field# value#
62432>>>>>      else error 670 ("Field name not found ("+name#+")")
62434>>>>>    end
62434>>>>>>
62434>>>>>  end_procedure
62435>>>>>  procedure SetIndexAttr_Help integer index#
62437>>>>>    integer liFile index_handle# arr# max#
62437>>>>>    if (index#<1 or index#>15) error 671 ("Index number out of bounds ("+string(index#)+")")
62440>>>>>    move (oTmpArray(self)) to arr#
62441>>>>>    send delete_data to arr#
62442>>>>>    get piFileHandle to liFile
62443>>>>>    move index# to index_handle#
62444>>>>>    repeat
62444>>>>>>
62444>>>>>      ErrorTrapping.create_index liFile at index_handle#
62449>>>>>      if index_handle# ne index# set value of arr# item index_handle# to 1
62452>>>>>    until index_handle# eq index#
62454>>>>>    get item_count of arr# to max#
62455>>>>>    for index# from 0 to (max#-1)
62461>>>>>>
62461>>>>>      if (integer(value(arr#,index#))) ErrorTrapping.delete_index liFile index#
62468>>>>>    loop
62469>>>>>>
62469>>>>>    send delete_data to arr#
62470>>>>>  end_procedure
62471>>>>>  procedure SetIndexAttr integer attr# integer index# string value#
62473>>>>>    integer liFile segments#
62473>>>>>    if (piProbeState(self)) begin
62475>>>>>      error 676 "Sorry, not while in probe mode"
62476>>>>>>
62476>>>>>      procedure_return
62477>>>>>    end
62477>>>>>>
62477>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62479>>>>>      if (attr#=DF_INDEX_NUMBER_SEGMENTS and integer(value#)=0) send DeleteIndex index#
62482>>>>>      else begin
62483>>>>>        get piFileHandle to liFile
62484>>>>>        get_attribute DF_INDEX_NUMBER_SEGMENTS of liFile index# to segments#
62487>>>>>        ifnot segments# send SetIndexAttr_Help index# // create_index liFile at index#
62490>>>>>        ErrorTrapping.set_attribute attr# of liFile index# to value#
62499>>>>>        send NotifyTracer RSOP_SETINDEXATTR attr# 0 index# 0 value#
62500>>>>>      end
62500>>>>>>
62500>>>>>    end
62500>>>>>>
62500>>>>>  end_procedure
62501>>>>>  procedure SetIndexSegAttr integer attr# integer index# integer seg# string value#
62503>>>>>    integer liFile field# type#
62503>>>>>    if (piProbeState(self)) begin
62505>>>>>      error 677 "Sorry, not while in probe mode"
62506>>>>>>
62506>>>>>      procedure_return
62507>>>>>    end
62507>>>>>>
62507>>>>>    ifnot (piIgnoreTheRestState(self)) begin
62509>>>>>      get piFileHandle to liFile
62510>>>>>      if attr# eq DF_INDEX_SEGMENT_CASE begin
62512>>>>>        get_attribute DF_INDEX_SEGMENT_FIELD of liFile index# seg# to field#
62515>>>>>        get_attribute DF_FIELD_TYPE of liFile field# to type#
62518>>>>>        if (type#<>DF_ASCII and integer(value#)=DF_CASE_IGNORED) procedure_return // We only do this for ASCII fields
62521>>>>>      end
62521>>>>>>
62521>>>>>      ErrorTrapping.set_attribute attr# of liFile index# seg# to value#
62531>>>>>      send NotifyTracer RSOP_SETINDEXSEGATTR attr# 0 index# seg# value#
62532>>>>>    end
62532>>>>>>
62532>>>>>  end_procedure
62533>>>>>
62533>>>>>  function GetFileAttr integer attr# returns string
62535>>>>>    integer liFile
62535>>>>>    string value#
62535>>>>>    get piFileHandle to liFile
62536>>>>>    get_attribute attr# of liFile to value#
62539>>>>>    function_return value#
62540>>>>>  end_function
62541>>>>>  function GetFieldAttr integer attr# integer field# returns string
62543>>>>>    integer liFile
62543>>>>>    string value#
62543>>>>>    if field# eq IMPLICIT_FIELD get private.piCurrentField to field#
62546>>>>>    get piFileHandle to liFile
62547>>>>>    get_attribute attr# of liFile field# to value#
62550>>>>>    function_return value#
62551>>>>>  end_function
62552>>>>>  function GetIndexAttr integer attr# integer index# returns string
62554>>>>>    integer liFile
62554>>>>>    string value#
62554>>>>>    get piFileHandle to liFile
62555>>>>>    get_attribute attr# of liFile index# to value#
62558>>>>>    function_return value#
62559>>>>>  end_function
62560>>>>>  function GetIndexSegAttr integer attr# integer index# integer seg# returns string
62562>>>>>    integer liFile
62562>>>>>    string value#
62562>>>>>    get piFileHandle to liFile
62563>>>>>    get_attribute attr# of liFile index# seg# to value#
62566>>>>>    function_return value#
62567>>>>>  end_function
62568>>>>>  function GetFileListAttr integer attr# returns string
62570>>>>>    integer liFile
62570>>>>>    string value#
62570>>>>>    get piFileHandle to liFile
62571>>>>>    get_attribute attr# of liFile to value#
62574>>>>>    function_return value#
62575>>>>>  end_function
62576>>>>>
62576>>>>>  procedure TableDropHelp string lsFile
62578>>>>>    integer liError
62578>>>>>    move (uppercase(lsFile)) to lsFile
62579>>>>>    if (right(lsFile,3)="DAT") move 1 to liError
62582>>>>>    if (right(lsFile,3)="TAG") move 1 to liError
62585>>>>>    if (right(lsFile,3)="VLD") move 1 to liError
62588>>>>>    if (right(lsFile,3)="HDR") move 1 to liError
62591>>>>>//    if (right(lsFile,1)="K")   move 1 to liError
62591>>>>>    if (right(lsFile,3)="DEF") move 1 to liError
62594>>>>>    if (right(lsFile,2)="FD")  move 1 to liError
62597>>>>>    if liError set private.piDropCounter to (private.piDropCounter(self)+1)
62600>>>>>  end_procedure
62601>>>>>  function iTableDrop.s string lsRoot returns integer
62603>>>>>    string lsDatFile lsPath liGrb
62603>>>>>    move (lowercase(lsRoot)) to lsRoot
62604>>>>>    move (lsRoot+".dat") to lsDatFile
62605>>>>>    move (SEQ_FindFileAlongDFPath(lsDatFile)) to lsPath
62606>>>>>    move (SEQ_ComposeAbsoluteFileName(lsPath,lsRoot)) to lsRoot
62607>>>>>    get SEQ_EraseFile (lsRoot+".dat") to liGrb
62608>>>>>    get SEQ_EraseFile (lsRoot+".tag") to liGrb
62609>>>>>    get SEQ_EraseFile (lsRoot+".vld") to liGrb
62610>>>>>    get SEQ_EraseFile (lsRoot+".hdr") to liGrb
62611>>>>>    get SEQ_EraseFile (lsRoot+".k?") to liGrb
62612>>>>>    get SEQ_EraseFile (lsRoot+".def") to liGrb
62613>>>>>    get SEQ_EraseFile (lsRoot+".fd") to liGrb
62614>>>>>    send SEQ_Load_ItemsInDir (lsRoot+".*")
62615>>>>>    set private.piDropCounter to 0
62616>>>>>    send SEQ_CallBack_ItemsInDir SEQCB_FILES_ONLY msg_TableDropHelp self
62617>>>>>    function_return (private.piDropCounter(self))
62618>>>>>  end_function
62619>>>>>  function iTableProbe.i integer liFile returns integer
62621>>>>>    integer rval#
62621>>>>>    move (DBMS_OpenFile(liFile,DF_SHARE,0)) to rval#
62622>>>>>    set piProbeState to rval#
62623>>>>>    if rval# begin
62625>>>>>      set piMainFile to liFile
62626>>>>>      set piFileHandle to liFile
62627>>>>>    end
62627>>>>>>
62627>>>>>    function_return (not(rval#)) // Returns 0 if success
62628>>>>>  end_function
62629>>>>>  procedure Probe_End
62631>>>>>    if (piProbeState(self)) begin
62633>>>>>      close (piMainFile(self))
62634>>>>>      set piProbeState to false
62635>>>>>    end
62635>>>>>>
62635>>>>>    else error 679 "Probing not initialized"
62637>>>>>  end_procedure
62638>>>>>
62638>>>>>  procedure reset.is integer liFile string lsRootName
62640>>>>>    send DFMatrixError_On
62641>>>>>    if liFile send DoWriteTimeEntry to (oStructure_LogFile(self)) ("Restructuring table: "+lsRootName+" ("+string(liFile)+")")
62644>>>>>    else      send DoWriteTimeEntry to (oStructure_LogFile(self)) ("Creating table: "+lsRootName)
62646>>>>>    set piMainFile to liFile
62647>>>>>    if liFile set piInitialNumberOfFields to (API_AttrValue_FILE(DF_FILE_NUMBER_FIELDS,liFile))
62650>>>>>    else set piInitialNumberOfFields to 0
62652>>>>>    set piIgnoreTheRestState to 0
62653>>>>>  end_procedure
62654>>>>>
62654>>>>>  function iTableOpen.is integer liFile string fn# returns integer
62656>>>>>    integer rval#
62656>>>>>    string path#
62656>>>>>    move (DBMS_OpenFileAs(fn#,liFile,DF_EXCLUSIVE,0)) to rval#
62657>>>>>    if rval# begin
62659>>>>>      //move (rval#=DBMS_DRIVER_DATAFLEX) to rval# // Only DataFlex files
62659>>>>>      ifnot rval# close liFile
62662>>>>>    end
62662>>>>>>
62662>>>>>    if rval# begin
62664>>>>>      send AppendOutput to (oStructure_LogFile(self))
62665>>>>>      send reset.is liFile fn#
62666>>>>>      move (fn#+".dat") to fn#
62667>>>>>      move (SEQ_ExtractPathFromFileName(fn#)) to path#
62668>>>>>      set psDatFileName to (SEQ_RemovePathFromFileName(fn#))
62669>>>>>      if path# eq "" move (SEQ_FindFileAlongDFPath(fn#)) to path#
62672>>>>>      set psDatFilePath to path#
62673>>>>>      send structure_start
62674>>>>>    end
62674>>>>>>
62674>>>>>    else send CloseOutput to (oStructure_LogFile(self)) // Close log file if table could not open
62676>>>>>    set piRS_State to rval#
62677>>>>>    function_return (not(rval#)) // Returns 0 if success
62678>>>>>  end_function
62679>>>>>
62679>>>>>  function iTableOpen.i integer liFile returns integer
62681>>>>>    integer rval#
62681>>>>>    string fn# path#
62681>>>>>    move (DBMS_IsOpenFile(liFile)) to rval#
62682>>>>>    if rval# ifnot (integer(API_AttrValue_FILE(DF_FILE_OPEN_MODE,liFile))=DF_EXCLUSIVE) move 0 to rval#
62687>>>>>    ifnot rval# move (DBMS_OpenFile(liFile,DF_EXCLUSIVE,0)) to rval#
62690>>>>>    if rval# begin
62692>>>>>      //move (rval#=DBMS_DRIVER_DATAFLEX) to rval# // Only DataFlex files
62692>>>>>      ifnot rval# close liFile
62695>>>>>    end
62695>>>>>>
62695>>>>>    if rval# begin
62697>>>>>      move (API_AttrValue_FILELIST(DF_FILE_ROOT_NAME,liFile)) to fn#
62698>>>>>      send AppendOutput to (oStructure_LogFile(self))
62699>>>>>      send reset.is liFile fn#
62700>>>>>      move (fn#+".dat") to fn#
62701>>>>>      move (SEQ_ExtractPathFromFileName(fn#)) to path#
62702>>>>>      set psDatFileName to (SEQ_RemovePathFromFileName(fn#))
62703>>>>>      if path# eq "" move (SEQ_FindFileAlongDFPath(fn#)) to path#
62706>>>>>      set psDatFilePath to path#
62707>>>>>      send structure_start
62708>>>>>    end
62708>>>>>>
62708>>>>>    else send CloseOutput to (oStructure_LogFile(self)) //
62710>>>>>    set piRS_State to rval#
62711>>>>>    function_return (not(rval#)) // Returns 0 if success
62712>>>>>  end_function
62713>>>>>
62713>>>>>  function iTableExists.s string root# returns integer
62715>>>>>    integer rval#
62715>>>>>    function_return 1
62716>>>>>  end_function
62717>>>>>
62717>>>>>  //> Specifying a root name that does already exist on
62717>>>>>  //> disk will overwrite existing data.
62717>>>>>  //> Omitting the path from the root name will place the
62717>>>>>  //> table in the first directory of the current DFPATH.
62717>>>>>  //> Returns 0 if all is well
62717>>>>>  function iTableCreate.s string lsRoot returns integer
62719>>>>>    send AppendOutput to (oStructure_LogFile(self))
62720>>>>>    send reset.is 0 lsRoot
62721>>>>>    set psDatFileName to (SEQ_RemovePathFromFileName(lsRoot)+".dat")
62722>>>>>    set psDatFilePath to (SEQ_ExtractPathFromFileName(lsRoot))
62723>>>>>    if (SEQ_FileExists(ToAnsi(lsRoot)+".dat")=SEQIT_NONE) begin
62725>>>>>    //send obs "psDatFileName" (psDatFileName(self)) "psDatFilePath" (psDatFilePath(self))
62725>>>>>      send structure_start
62726>>>>>      send SetFileAttr DF_FILE_MAX_RECORDS   10000 // Set up a few default values
62727>>>>>      send SetFileAttr DF_FILE_MULTIUSER     DF_FILE_USER_MULTI
62728>>>>>      send SetFileAttr DF_FILE_REUSE_DELETED DF_FILE_DELETED_REUSE
62729>>>>>      send SetFileAttr DF_FILE_PHYSICAL_NAME (ToAnsi(lsRoot))
62730>>>>>      function_return 0 // 0 means OK
62731>>>>>    end
62731>>>>>>
62731>>>>>    send WriteLnError to (oStructure_LogFile(self)) ("  Cannot create existing file "+lsRoot+".dat")
62732>>>>>    send DFMatrixError_Off
62733>>>>>    send CloseOutput to (oStructure_LogFile(self)) // Closes log file if Table could not be created
62734>>>>>    function_return 1
62735>>>>>  end_function
62736>>>>>  procedure display_definition
62738>>>>>    integer liFile
62738>>>>>    get piFileHandle to liFile
62739>>>>>
62739>>>>>    send FDX_ModalDisplayFileAttributes 0 liFile
62740>>>>>  end_procedure
62741>>>>>  procedure NotifyTracer integer op# integer attr# integer field# integer index# integer seg# string value#
62743>>>>>    integer liFile
62743>>>>>    get piFileHandle to liFile
62744>>>>>    if (piTraceObject(self)) send RegisterUpdate to (piTraceObject(self)) liFile op# attr# field# index# seg# value#
62747>>>>>  end_procedure
62748>>>>>
62748>>>>>  //> This function returns the root name of the file including path
62748>>>>>  //> if a path was originally specified:
62748>>>>>  function sRootInclPath returns string
62750>>>>>    string root# path#
62750>>>>>    get psDatFileName to root#
62751>>>>>    move (replace(".dat",root#,"")) to root#
62752>>>>>    move (replace(".DAT",root#,"")) to root#
62753>>>>>    get psDatFilePath to path#
62754>>>>>    if path# ne "" move (SEQ_ComposeAbsoluteFileName(path#,root#)) to root#
62757>>>>>    function_return root#
62758>>>>>  end_function
62759>>>>>end_class // cBasicRestructurer
62760>>>>>
62760>>>>>integer oRestructurer#
62760>>>>>object oRestructurer is a cBasicRestructurer
62762>>>>>  move self to oRestructurer#
62763>>>>>end_object
62764>>>>>
62764>>>>>// This one is used to control whether the sentinel should be
62764>>>>>// removed from screen when a restructure has ended.
62764>>>>>procedure RS_Progress global integer mode#
62766>>>>>  send SetProgressMode to oRestructurer# mode#
62767>>>>>end_procedure
62768>>>>>
62768>>>>>// ********************** GLOBAL INTERFACE ******************************
62768>>>>>//> Display the definition as it looks right now. May be sent during a
62768>>>>>//> restructure for debug purposes.
62768>>>>>procedure RS_DisplayDef global
62770>>>>>  send Display_Definition to oRestructurer#
62771>>>>>end_procedure
62772>>>>>//> May be used to manually set the field pointed to by the symbol
62772>>>>>//> IMPLICIT_FIELD (which is in fact -1)
62772>>>>>procedure RS_SetFieldNumber global integer field#
62774>>>>>  send SetFieldNumber to oRestructurer# field#
62775>>>>>end_procedure
62776>>>>>//> Inserts a new field before existing field number field#. When this
62776>>>>>//> is done you should take care manually to change the offsets and
62776>>>>>//> lengths of affected overlap fields.
62776>>>>>procedure RS_CreateField global integer field# string name# integer type#
62778>>>>>  send CreateField to oRestructurer# field# name# type#
62779>>>>>end_procedure
62780>>>>>procedure RS_CreateField_OldNumber global integer field# string name# integer type#
62782>>>>>  send CreateField_OldNumber to oRestructurer# field# name# type#
62783>>>>>end_procedure
62784>>>>>//> Appends a field to the existing ones. Following this there should
62784>>>>>//> always be messages to set the length of the field.
62784>>>>>procedure RS_AppendField global string name# integer type#
62786>>>>>  send AppendField to oRestructurer# name# type#
62787>>>>>end_procedure
62788>>>>>//> Deletes a field.
62788>>>>>procedure RS_DeleteField global integer field#
62790>>>>>  send DeleteField to oRestructurer# field#
62791>>>>>end_procedure
62792>>>>>//> Deletes a field.
62792>>>>>procedure RS_DeleteField_OldNumber global integer old_field#
62794>>>>>  send DeleteField_OldNumber to oRestructurer# old_field#
62795>>>>>end_procedure
62796>>>>>//> Deletes an index.
62796>>>>>procedure RS_DeleteIndex global integer idx#
62798>>>>>  send DeleteIndex to oRestructurer# idx#
62799>>>>>end_procedure
62800>>>>>//> Abort the restructure.
62800>>>>>procedure RS_Structure_Abort global
62802>>>>>  send Structure_Abort to oRestructurer#
62803>>>>>end_procedure
62804>>>>>//> Lets the changes that you have made so far take effect.
62804>>>>>procedure RS_Structure_End global integer liForceExtraSort
62806>>>>>  integer liDoSort
62806>>>>>  if num_arguments gt 0 move liForceExtraSort to liDoSort
62809>>>>>  else move DFFALSE to liDoSort
62811>>>>>  set private.piSortOnEndStructure of oRestructurer# to liDoSort
62812>>>>>  send Structure_End to oRestructurer#
62813>>>>>  set private.piSortOnEndStructure of oRestructurer# to DFFALSE
62814>>>>>end_procedure
62815>>>>>//> Closes the file formerly opened for probing.
62815>>>>>procedure RS_Probe_End global
62817>>>>>  send Probe_End to oRestructurer#
62818>>>>>end_procedure
62819>>>>>
62819>>>>>//> Returns the current number of fields.
62819>>>>>function RS_CurrentFieldCount global returns integer
62821>>>>>  function_return (field_count(oRestructurer#))
62822>>>>>end_function
62823>>>>>
62823>>>>>//> RS_TableOpenNumber returns 1 if the file was successfully opened
62823>>>>>//> for restructuring. The restructuring presumably anout to take place
62823>>>>>//> should be terminated with a RS_Structure_End or RS_Structure_Abort
62823>>>>>//> message.
62823>>>>>function RS_TableOpenNumber global integer liFile returns integer
62825>>>>>  function_return (not(iTableOpen.i(oRestructurer#,liFile)))
62826>>>>>end_function
62827>>>>>
62827>>>>>//> RS_TableOpenName returns 1 if the file was successfully opened
62827>>>>>//> for restrucuring. The restructuring presumably anout to take place
62827>>>>>//> should be terminated with a RS_Structure_End or RS_Structure_Abort
62827>>>>>//> message.
62827>>>>>function RS_TableOpenName global integer liFile string fn# returns integer
62829>>>>>  function_return (not(iTableOpen.is(oRestructurer#,liFile,fn#)))
62830>>>>>end_function
62831>>>>>
62831>>>>>//> RS_TableProbeNumber returns 1 if the file was successfully opened
62831>>>>>//> for probing. Probing should be ended with a RS_Probe_End message.
62831>>>>>function RS_TableProbeNumber global integer liFile returns integer
62833>>>>>  function_return (not(iTableProbe.i(oRestructurer#,liFile)))
62834>>>>>end_function
62835>>>>>function RS_TableCreateName global string root# returns integer
62837>>>>>  function_return (not(iTableCreate.s(oRestructurer#,root#)))
62838>>>>>end_function
62839>>>>>
62839>>>>>function RS_TableDropName global string root# returns integer
62841>>>>>  function_return (not(iTableDrop.s(oRestructurer#,root#)))
62842>>>>>end_function
62843>>>>>function RS_TableExistsName global string root# returns integer
62845>>>>>  function_return (iTableExists.s(oRestructurer#,root#))
62846>>>>>end_function
62847>>>>>
62847>>>>>//> Set value of File type attribute during restructuring.
62847>>>>>procedure RS_SetFileAttr global integer attr# string value#
62849>>>>>  send SetFileAttr to oRestructurer# attr# value#
62850>>>>>end_procedure
62851>>>>>//> Set value of Field type attribute during restructuring.
62851>>>>>procedure RS_SetFieldAttr global integer attr# integer field# string value#
62853>>>>>  send SetFieldAttr to oRestructurer# attr# field# value#
62854>>>>>end_procedure
62855>>>>>//> Set value of Field type attribute during restructuring. Field referenced by OLD_NUMBER
62855>>>>>procedure RS_SetFieldAttr_OldNumber global integer attr# integer field# string value#
62857>>>>>  send SetFieldAttr_OldNumber to oRestructurer# attr# field# value#
62858>>>>>end_procedure
62859>>>>>//> Set value of Field type attribute during restructuring. Field referenced by NAME
62859>>>>>procedure RS_SetFieldAttr_ByName global integer attr# string name# string value#
62861>>>>>  send SetFieldAttr_ByName to oRestructurer# attr# name# value#
62862>>>>>end_procedure
62863>>>>>//> Set value of Index type attribute during restructuring.
62863>>>>>procedure RS_SetIndexAttr global integer attr# integer index# string value#
62865>>>>>  send SetIndexAttr to oRestructurer# attr# index# value#
62866>>>>>end_procedure
62867>>>>>//> Set value of Index Segment type attribute during restructuring.
62867>>>>>procedure RS_SetIndexSegAttr global integer attr# integer index# integer seg# string value#
62869>>>>>  send SetIndexSegAttr to oRestructurer# attr# index# seg# value#
62870>>>>>end_procedure
62871>>>>>//> Set value of FileList type attribute during restructuring.
62871>>>>>procedure RS_SetFileListAttr global integer attr# integer liFile string value#
62873>>>>>  ErrorTrapping.set_attribute attr# of liFile to value#
62881>>>>>end_procedure
62882>>>>>
62882>>>>>//> Get value of File type attribute while restructuring or probing.
62882>>>>>function RS_GetFileAttr global integer attr# returns string
62884>>>>>  function_return (GetFileAttr(oRestructurer#,attr#))
62885>>>>>end_function
62886>>>>>//> Get value of Field type attribute while restructuring or probing.
62886>>>>>function RS_GetFieldAttr global integer attr# integer field# returns string
62888>>>>>  function_return (GetFieldAttr(oRestructurer#,attr#,field#))
62889>>>>>end_function
62890>>>>>//> Get value of Index type attribute while restructuring or probing.
62890>>>>>function RS_GetIndexAttr global integer attr# integer index# returns string
62892>>>>>  function_return (GetIndexAttr(oRestructurer#,attr#,index#))
62893>>>>>end_function
62894>>>>>//> Get value of Index Segment type attribute while restructuring or probing.
62894>>>>>function RS_GetIndexSegAttr global integer attr# integer index# integer seg# returns string
62896>>>>>  function_return (GetIndexSegAttr(oRestructurer#,attr#,index#,seg#))
62897>>>>>end_function
62898>>>>>//> Get value of FileList type attribute while restructuring or probing.
62898>>>>>function RS_GetFileListAttr global integer attr# returns string
62900>>>>>  function_return (GetFileListAttr(oRestructurer#,attr#))
62901>>>>>end_function
62902>>>>>
62902>>>Use FDX.nui      // cFDX class
62902>>>Use Macros.utl   // Various macros (FOR_EX...)
62902>>>Use Strings.nui  // String manipulation for VDF
62902>>>Use Files.utl    // Utilities for handling file related stuff
62902>>>
62902>>>function sRSOP_Text.i global integer op# returns string
62904>>>  if op# eq RSOP_BEGIN           function_return "Initial definiton"
62907>>>  if op# eq RSOP_CREATEFIELD     function_return "Create field"
62910>>>  if op# eq RSOP_DELETEFIELD     function_return "Delete field"
62913>>>  if op# eq RSOP_DELETEINDEX     function_return "Delete index"
62916>>>  if op# eq RSOP_SETFILEATTR     function_return "Set "
62919>>>  if op# eq RSOP_SETFIELDATTR    function_return "Set "
62922>>>  if op# eq RSOP_SETINDEXATTR    function_return "Set "
62925>>>  if op# eq RSOP_SETINDEXSEGATTR function_return "Set "
62928>>>  if op# eq RSOP_TRUNCATED       function_return "Restructure truncated!"
62931>>>  if op# eq RSOP_ERROR_OCCURRED  function_return "Error: "
62934>>>end_function
62935>>>
62935>>>desktop_section
62940>>>  object oFdxTraceArray is a cArray
62942>>>    item_property_list
62942>>>      item_property integer piFdx.i
62942>>>      item_property integer piFile.i
62942>>>      item_property integer piOperation.i
62942>>>      item_property integer piAttribute.i
62942>>>      item_property integer piField.i
62942>>>      item_property integer piIndex.i
62942>>>      item_property integer piSegment.i
62942>>>      item_property string  psValue.i
62942>>>    end_item_property_list
#REM 62997 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 63002 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 63007 DEFINE FUNCTION PISEGMENT.I INTEGER LIROW RETURNS INTEGER
#REM 63012 DEFINE PROCEDURE SET PISEGMENT.I INTEGER LIROW INTEGER VALUE
#REM 63017 DEFINE FUNCTION PIINDEX.I INTEGER LIROW RETURNS INTEGER
#REM 63022 DEFINE PROCEDURE SET PIINDEX.I INTEGER LIROW INTEGER VALUE
#REM 63027 DEFINE FUNCTION PIFIELD.I INTEGER LIROW RETURNS INTEGER
#REM 63032 DEFINE PROCEDURE SET PIFIELD.I INTEGER LIROW INTEGER VALUE
#REM 63037 DEFINE FUNCTION PIATTRIBUTE.I INTEGER LIROW RETURNS INTEGER
#REM 63042 DEFINE PROCEDURE SET PIATTRIBUTE.I INTEGER LIROW INTEGER VALUE
#REM 63047 DEFINE FUNCTION PIOPERATION.I INTEGER LIROW RETURNS INTEGER
#REM 63052 DEFINE PROCEDURE SET PIOPERATION.I INTEGER LIROW INTEGER VALUE
#REM 63057 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 63062 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
#REM 63067 DEFINE FUNCTION PIFDX.I INTEGER LIROW RETURNS INTEGER
#REM 63072 DEFINE PROCEDURE SET PIFDX.I INTEGER LIROW INTEGER VALUE
63078>>>    function sDescription.i integer row# returns string
63081>>>      integer op# attr# field# index# seg#
63081>>>      string value# rval#
63081>>>      get piOperation.i row# to op#
63082>>>      get piAttribute.i row# to attr#
63083>>>      get piField.i     row# to field#
63084>>>      get piIndex.i     row# to index#
63085>>>      get piSegment.i   row# to seg#
63086>>>      get psValue.i     row# to value#
63087>>>      move (string(IntToStrRzf(row#+1,length(string(row_count(self)+1))))) to rval#
63088>>>      move (rval#*sRSOP_Text.i(op#)) to rval#
63089>>>      if op# eq RSOP_BEGIN        move (rval#*value#) to rval#
63092>>>      if op# eq RSOP_CREATEFIELD  move (rval#*value#*"at"*string(field#)*"type: "*API_Attr_DisplayValueName(DF_FIELD_TYPE,index#)) to rval#
63095>>>      if op# eq RSOP_DELETEFIELD  move (rval#*string(field#)) to rval#
63098>>>      if op# eq RSOP_DELETEINDEX  move (rval#*string(index#)) to rval#
63101>>>      if op# eq RSOP_SETFILEATTR  move (rval#*API_Attr_Name(attr#)*"to"*API_Attr_ValueName(attr#,value#)) to rval#
63104>>>      if op# eq RSOP_SETFIELDATTR move (rval#*API_Attr_Name(attr#)*"field"*string(field#)*"to"*API_Attr_ValueName(attr#,value#)) to rval#
63107>>>      if op# eq RSOP_SETINDEXATTR move (rval#*API_Attr_Name(attr#)*"index"*string(index#)*"to"*API_Attr_ValueName(attr#,value#)) to rval#
63110>>>      if op# eq RSOP_SETINDEXSEGATTR move (rval#*API_Attr_Name(attr#)*"index"*string(index#)*"segment"*string(seg#)*"to"*API_Attr_ValueName(attr#,value#)) to rval#
63113>>>      if op# eq RSOP_ERROR_OCCURRED move (rval#*value#) to rval#
63116>>>      function_return rval#
63117>>>    end_function
63118>>>    procedure reset
63121>>>      integer row# max#
63121>>>      get row_count to max#
63122>>>      for row# from 0 to (max#-1)
63128>>>>
63128>>>        send request_destroy_object to (piFdx.i(self,row#))
63129>>>      loop
63130>>>>
63130>>>      send delete_data
63131>>>    end_procedure
63132>>>    procedure add_row.iiiiiiis integer obj# integer file# integer op# integer attr# integer field# integer index# integer seg# string value#
63135>>>      integer row#
63135>>>      get row_count to row#
63136>>>      set piFdx.i       row# to obj#
63137>>>      set piFile.i      row# to file#
63138>>>      set piOperation.i row# to op#
63139>>>      set piAttribute.i row# to attr#
63140>>>      set piField.i     row# to field#
63141>>>      set piIndex.i     row# to index#
63142>>>      set piSegment.i   row# to seg#
63143>>>      set psValue.i     row# to value#
63144>>>    end_procedure
63145>>>    procedure RegisterUpdate integer file# integer op# integer attr# integer field# integer index# integer seg# string value#
63148>>>      integer row# obj# ch#
63148>>>      string fn#
63148>>>      if op# eq RSOP_BEGIN send reset
63151>>>      if op# eq RSOP_END begin
63153>>>        get sRootInclPath of oRestructurer# to fn#
63154>>>        move (fn#+".rst") to fn#
63155>>>        move (SEQ_DirectOutput(fn#)) to ch#
63156>>>        send seq_write ch#
63157>>>        send SEQ_CloseOutput ch#
63158>>>        send reset
63159>>>      end
63159>>>>
63159>>>      else begin
63160>>>        get row_count to row#
63161>>>        object oFdxTrace is a cFdxFileDef
63163>>>          move self to obj#
63164>>>          set piReadDuringRestruct to DFTRUE
63165>>>          send Read_File_Definition.i file#
63166>>>          set piReadDuringRestruct to DFFALSE
63167>>>        end_object
63168>>>        send add_row.iiiiiiis obj# file# op# attr# field# index# seg# value#
63169>>>      end
63169>>>>
63169>>>    end_procedure
63170>>>    procedure seq_read integer ch#
63173>>>      integer row# max# oFDX#
63173>>>      send SEQ_ReadArrayItems ch# self
63174>>>      get row_count to max#
63175>>>      for row# from 0 to (max#-1)
63181>>>>
63181>>>        object oFdxTrace is a cFdxFileDef
63183>>>          move self to oFDX#
63184>>>        end_object
63185>>>        set piFdx.i row# to oFDX#
63186>>>        send Seq_Read to oFDX# ch#
63187>>>      loop
63188>>>>
63188>>>    end_procedure
63189>>>    procedure seq_write integer ch#
63192>>>      integer row# max# oFDX#
63192>>>      send SEQ_WriteArrayItems ch# self
63193>>>      get row_count to max#
63194>>>      for row# from 0 to (max#-1)
63200>>>>
63200>>>        get piFdx.i row# to oFDX#
63201>>>        send Seq_Write to oFDX# ch#
63202>>>      loop
63203>>>>
63203>>>    end_procedure
63204>>>    procedure save_trace
63207>>>      integer ch#
63207>>>      string fn#
63207>>>      move (SEQ_SelectOutFile("Save restructure trace","Restructure trace (*.rst)|*.RST")) to fn#
63208>>>      if fn# ne "" begin
63210>>>        move (SEQ_DirectOutput(fn#)) to ch#
63211>>>        send seq_write ch#
63212>>>        send SEQ_CloseOutput ch#
63213>>>      end
63213>>>>
63213>>>    end_procedure
63214>>>    procedure load_trace_file string fn#
63217>>>      integer ch#
63217>>>      if fn# ne "" begin
63219>>>        move (SEQ_DirectInput(fn#)) to ch#
63220>>>        send reset
63221>>>        send seq_read ch#
63222>>>        send SEQ_CloseInput ch#
63223>>>      end
63223>>>>
63223>>>    end_procedure
63224>>>    procedure load_trace
63227>>>      string fn#
63227>>>      move (SEQ_SelectInFile("Load restructure trace","Restructure trace (*.rst)|*.RST")) to fn#
63228>>>      send load_trace_file fn#
63229>>>    end_procedure
63230>>>  end_object // oFdxTraceArray
63231>>>end_desktop_section
63236>>>
63236>>>procedure RS_TraceOn global
63238>>>  integer oFdxTraceArray#
63238>>>  move (oFdxTraceArray(self)) to oFdxTraceArray#
63239>>>  send reset to oFdxTraceArray#
63240>>>  set piTraceState  of oRestructurer# to dfTrue
63241>>>  set piTraceObject of oRestructurer# to oFdxTraceArray#
63242>>>end_procedure
63243>>>procedure RS_TraceOff global
63245>>>  set piTraceState  of oRestructurer# to dfFalse
63246>>>  set piTraceObject of oRestructurer# to 0
63247>>>end_procedure
63248>>>procedure RS_TraceReset global
63250>>>  send reset to (oFdxTraceArray(self))
63251>>>end_procedure
63252>>>
63252>>>Use APS
63252>>>class cRSTraceList is a aps.List
63253>>>  procedure fill_list
63255>>>    integer obj# max# row#
63255>>>    send delete_data
63256>>>    move (oFdxTraceArray(self)) to obj#
63257>>>    get row_count of obj# to max#
63258>>>    for row# from 0 to (max#-1)
63264>>>>
63264>>>      send add_item msg_none (sDescription.i(obj#,row#))
63265>>>      set aux_value item row# to row#
63266>>>    loop
63267>>>>
63267>>>    if (active_state(self)) set dynamic_update_state to true
63270>>>  end_procedure
63271>>>  procedure display_definition
63273>>>    integer row# oFDX# file#
63273>>>    if (item_count(self)) begin
63275>>>      get aux_value item (current_item(self)) to row#
63276>>>      get piFdx.i of (oFdxTraceArray(self)) item row# to oFDX#
63277>>>      get piFile.i of (oFdxTraceArray(self)) item row# to file#
63278>>>      send FDX_ModalDisplayFileAttributes oFDX# file#
63279>>>    end
63279>>>>
63279>>>  end_procedure
63280>>>  procedure save_trace
63282>>>    integer obj#
63282>>>    move (oFdxTraceArray(self)) to obj#
63283>>>    if (row_count(obj#)) send save_trace to obj#
63286>>>  end_procedure
63287>>>  procedure load_trace
63289>>>    send load_trace to (oFdxTraceArray(self))
63290>>>    send fill_list to (oLst(self))
63291>>>  end_procedure
63292>>>end_class // cRSTraceList
63293>>>
63293>
63293>//use vdfquery.utl
63293>
63293>Use OpenStat.pkg // Call DFMatrix, Display open tables ...
Including file: openstat.pkg    (C:\Apps\VDFQuery\AppSrc\openstat.pkg)
63293>>>// Use OpenStat.pkg // Call DFMatrix, Display open tables ...
63293>>>
63293>>>Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles)
63293>>>Use Files.nui    // Utilities for handling file related stuff
63293>>>Use MsgBox.utl   // obs procedure
63293>>>Use GridUtil.utl // Grid and List utilities
63293>>>Use Version.nui
63293>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
63293>>>Use FieldInf     // Global field info objects and abstract field types
63293>>>
63293>>>
63293>>>    define OpenStat.PrgExt for "exe" // VDF 8 and on
63293>>>
63293>>>procedure OpenStat.Chain_Wait global string program# string parameters# integer lbDontWait
63295>>>  string path# prg_fn#
63295>>>  move (program#+"."+OpenStat.PrgExt) to prg_fn#
63296>>>  get SEQ_FindFileAlongDFPath prg_fn# to path#
63297>>>  if path# ne "" begin
63299>>>    move (SEQ_ComposeAbsoluteFileName(prg_fn#,path#)) to program#
63300>>>    send OpenStat_RegisterFiles
63301>>>    send OpenStat_CloseAllFiles
63302>>>
63302>>>    runprogram background (trim(prg_fn#*parameters#))
63303>>>    send OpenStat_RestoreFiles
63304>>>  end
63304>>>>
63304>>>  else send obs (replace("#",t.OpenStat.PrgNotFound,prg_fn#))
63306>>>end_procedure
63307>>>
63307>>>procedure OpenStat.Chain_DFMatrix global
63309>>>  send OpenStat.Chain_Wait "Dfm" "" DFFALSE
63310>>>end_procedure
63311>>>
63311>>>procedure OpenStat.Chain_DbExplor global
63313>>>  send OpenStat.Chain_Wait "DbExplor" "noworkspace" DFFALSE
63314>>>end_procedure
63315>>>
63315>>>procedure OpenStat.Chain_DbBuilder global
63317>>>  send OpenStat.Chain_Wait "DbBldr" "" DFTRUE
63318>>>end_procedure
63319>>>
63319>>>object oOpenStatTableLocations is a aps.ModalPanel label t.OpenStat.LocOpenFiles
63322>>>  set locate_mode to center_on_screen
63323>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
63324>>>  set pMinimumSize to 80 0
63325>>>  on_key kcancel send close_panel
63326>>>  object oGrd is a aps.grid
63328>>>    set size to 205 0
63329>>>    set gridline_mode to GRID_VISIBLE_NONE
63330>>>    send GridPrepare_AddColumn "#" AFT_ASCII3
63331>>>    send GridPrepare_AddColumn t.OpenStat.UserName AFT_ASCII20
63332>>>    send GridPrepare_AddColumn t.OpenStat.Location AFT_ASCII50
63333>>>    send GridPrepare_AddColumn t.OpenStat.Driver   AFT_ASCII12
63334>>>    send GridPrepare_Apply self
63335>>>    set select_mode to no_select
63336>>>    set peAnchors to (anTop+anLeft+anRight+anBottom)
63337>>>    Set peResizeColumn to rcSelectedColumn // make sure mode is correct
63338>>>    Set piResizeColumn to 2
63339>>>
63339>>>    procedure fill_list
63342>>>      integer file# itm# max# type# lbIsOpenedAs
63342>>>      string str# cur_dir# driver#
63342>>>      get_current_directory to cur_dir#
63343>>>      send cursor_wait to (cursor_control(self))
63344>>>      send delete_data
63345>>>      move 0 to file#
63346>>>      repeat
63346>>>>
63346>>>        get_attribute DF_FILE_NEXT_OPENED of file# to file#
63349>>>        if file# begin
63351>>>          send add_item msg_none (string(file#))
63352>>>          send add_item msg_none (File_Display_Name(file#))
63353>>>          get_attribute DF_FILE_DRIVER of file# to driver#
63356>>>          get DBMS_DriverNameToType driver# to type#
63357>>>          get DBMS_TablePath file# to str#
63358>>>          send add_item msg_none (uppercase(str#))
63359>>>          send add_item msg_none ("("+DBMS_Driver_UserName(type#)+")")
63360>>>        end
63360>>>>
63360>>>      until file# eq 0
63362>>>      get item_count to max#
63363>>>      for itm# from 0 to (max#-1)
63369>>>>
63369>>>        set entry_state item itm# to false
63370>>>      loop
63371>>>>
63371>>>      send cursor_ready to (cursor_control(self))
63372>>>    end_procedure
63373>>>  end_object
63374>>>  object oBtn is a aps.Multi_Button
63376>>>    set peAnchors to (anRight+anBottom)
63377>>>    on_item t.btn.close send close_panel
63378>>>  end_object
63379>>>  send aps_locate_multi_buttons
63380>>>  procedure popup
63383>>>    send fill_list to (oGrd(self))
63384>>>    forward send popup
63386>>>  end_procedure
63387>>>end_object // oOpenStatTableLocations
63388>>>send aps_SetMinimumDialogSize (oOpenStatTableLocations(self))
63389>>>
63389>>>
63389>>>procedure OpenStat.DisplayFileLocations global
63391>>>  send popup to (oOpenStatTableLocations(self))
63392>>>end_procedure
63393>>>
63393>
63393>
63393>// open employee
63393>// find gt employee by index.1
63393>// find gt employee by index.1
63393>// find gt employee by index.1
63393>//
63393>Object Main is a Panel
63395>  DFCreate_Menu Main_Menu
63398>    DFCreate_Menu "&File" FilePullDown is a ViewPopupMenu
63402>      on_item "Select &workspace"         send DFMatrix_Select_WorkSpace
63403>      on_item "Select &filelist"          send DFMatrix_Select_FileList
63404>      on_item "&Open FDX file..."         send DFMatrix_PrimaryOpenFdxFile
63405>      on_item ""                          send none
63406>      on_item "&Save as..."               send DFMatrix_PrimarySaveFdxAs
63407>      on_item ""                          send none
63408>      on_item "Table selector"            send Activate_Table_Selector
63409>      on_item ""                          send none
63410>      on_item "&DBMS Login"               send DFMatrix_Login
63411>      on_item ""                          send none
63412>      on_item "E&xit \aAlt+F4"            send exit_application
63413>//    on_item "Open ¤t definitions" send DFMatrix_PrimaryOpenCurrentFilelist
63413>//    on_item "C&lose"                    send DFMatrix_CloseAll
63413>//    on_item "Lo&gout"                   send DFMatrix_Logout
63413>      Procedure OnInitMenu
63416>        integer Shade_CloseAndSave# fdx# fdx_state#
63416>        move (fdx.object_id(0)) to fdx#
63417>        get piDataOrigin of fdx# to fdx_state#
63418>        move (fdx_state#=FDX_EMPTY) to Shade_CloseAndSave#
63419>        set Shadow_State item 4 to Shade_CloseAndSave#
63420>      End_Procedure
63421>    End_Menu
63423>    DFCreate_Menu "Fu&nctions" FunctionsPullDown is a ViewPopupMenu
63427>      on_item "Check definitions"       send Activate_FdxCheck_Vw
63428>      on_item "&Find stray index files" send Popup_FindStrayIndexFiles
63429>
63429>      on_item "C&ompare table definitions" send Activate_RestructPrograms
63430>      on_item "Compa&re table data"        send Activate_CompareTables
63431>
63431>      on_item "Create empty tables"     send Popup_CreateFromFdx
63432>      on_item "Test file locking"       send Popup_TestLockPanel
63433>//      on_item "Create DEF/FD files"     send Popup_CreateDEF_FD
63433>      on_item ""                        send none
63434>      on_item "Reindex"                 send Activate_SortUtil_Vw
63435>      on_item "Year 2000 check"         send Activate_Conv2000_Vw
63436>      on_item "Import/Export data"      send Popup_ImportExport
63437>      on_item "Dump/Load data"          send Activate_ImportExport_View
63438>      on_item "Field statistics"        send Activate_DataSampler_Vw
63439>      on_item ""                        send none
63440>//    on_item "ODBC Viewer"             send Activate_ODBCViewer
63440>      on_item "Import data"             send Activate_FdxImport_Vw
63441>      on_item "Miscellaneous"           send Activate_SmallDfmThings_Vw
63442>      on_item ""                        send none
63443>      on_item "Find file"               send Activate_SetDirTestVw
63444>      on_item "Compare directories"     send Activate_Dircomp_Vw
63445>      on_item "Explore folder sizes"    send Activate_oFolderSizeTreePanel
63446>//    on_item "Query current data..."   send DFMatrix_Activate_Query_Vw
63446>//    DFCreate_Menu "Maybe's" TestPullDown is a ViewPopupMenu
63446>//      on_item "DF-Script..."         send activate_dfscript_ide
63446>//    End_Menu
63446>    End_Menu
63448>    DFCreate_Menu "DAW-&Utilities" DawPullDown is a ViewPopupMenu
63452>      on_item "Database &Builder"  send OpenStat.Chain_DbBuilder
63453>      on_item "Database &Explorer" send OpenStat.Chain_DbExplor
63454>      on_item ""                   send none
63455>      on_item "About"              send DoAbout
63456>    End_Menu
63458>  End_Menu
63460>
63460>  Object Client_Area IS A AppClientArea
63462>    use DFMatrix.vw  // Table selector, Global attr and table definition
Including file: dfmatrix.vw    (C:\Apps\VDFQuery\AppSrc\dfmatrix.vw)
63462>>>Use Fdx1.utl     // FDX aware display global attributes (FDX_DisplayGlobalAttributes procedure)
63462>>>Use Fdx2.utl     // FDX aware object for displaying a table definiton
63462>>>Use Fdx3.utl     // FDX aware cFileList_List selector class
63462>>>Use SetFiles.pkg // Class for displaying the contents of a cSetOfFiles object
Including file: setfiles.pkg    (C:\Apps\VDFQuery\AppSrc\setfiles.pkg)
63462>>>>>// Use SetFiles.pkg // Class for displaying the contents of a cSetOfFiles object
63462>>>>>Use SetFiles.utl // SetOfFiles class (for disk files)
63462>>>>>Use GridUtil.utl // Grid and List utilities
63462>>>>>
63462>>>>>class cSetOfFilesList is a aps.Grid
63463>>>>>  procedure SetupCheckBoxColumn
63465>>>>>  end_procedure
63466>>>>>  procedure construct_object integer img#
63468>>>>>    forward send construct_object img#
63470>>>>>    property integer piSetOfFilesObject public 0
63471>>>>>    property string  psConstrainPath    public ""
63472>>>>>    property integer piCheckBoxColumn   public 0
63473>>>>>    set select_mode to NO_SELECT
63474>>>>>    send SetupCheckBoxColumn
63475>>>>>    send GridPrepare_AddColumn "Filename"  AFT_ASCII12
63476>>>>>    send GridPrepare_AddColumn "Type"      AFT_ASCII4
63477>>>>>    send GridPrepare_AddColumn "Size"      AFT_ASCII6
63478>>>>>    send GridPrepare_AddColumn "Modified"  AFT_ASCII20
63479>>>>>    send GridPrepare_AddColumn "Directory" AFT_ASCII60
63480>>>>>    send GridPrepare_Apply self
63481>>>>>    set gridline_mode to GRID_VISIBLE_NONE
63482>>>>>    set highlight_row_state to true
63483>>>>>    on_key KNEXT_ITEM     send switch
63484>>>>>    on_key KPREVIOUS_ITEM send switch_back
63485>>>>>    on_key KEY_CTRL+KEY_R send user_sort
63486>>>>>    on_key KEY_CTRL+KEY_W send DoWriteToFile
63487>>>>>    on_key KEY_CTRL+KEY_C send DoCopyFiles
63488>>>>>  end_procedure
63489>>>>>  procedure DoWriteToFile
63491>>>>>    send Grid_DoWriteToFile self
63492>>>>>  end_procedure
63493>>>>>  procedure DoCopyFiles
63495>>>>>    string lsTargetDir
63495>>>>>    get SEQ_SelectDirectory "Select target directory" to lsTargetDir
63496>>>>>    if (lsTargetDir<>"") begin
63498>>>>>      if (SEQ_FileExists(lsTargetDir)=SEQIT_DIRECTORY) send DoCopyFiles to (piSetOfFilesObject(self)) lsTargetDir
63501>>>>>      else send obs "Illegal target directory"
63503>>>>>    end
63503>>>>>>
63503>>>>>  end_procedure
63504>>>>>  procedure fill_list
63506>>>>>    integer obj# row# max# itm# file_count# base#
63506>>>>>    number total_bytes# file_size#
63506>>>>>    string ConstrainPath# path#
63506>>>>>    get psConstrainPath to ConstrainPath#
63507>>>>>    get piSetOfFilesObject to obj#
63508>>>>>    if obj# begin
63510>>>>>      move 0 to total_bytes#
63511>>>>>      move 0 to file_count#
63512>>>>>      get iFile_Count of obj# to max#
63513>>>>>      send delete_data
63514>>>>>      set dynamic_update_state to false
63515>>>>>      for itm# from 0 to (max#-1)
63521>>>>>>
63521>>>>>        get iFile_Row.i of obj# itm# to row#
63522>>>>>        move (psFilePath.i(obj#,row#)) to path#
63523>>>>>        if (ConstrainPath#="" or ConstrainPath#=path#) begin
63525>>>>>          get item_count to base#
63526>>>>>          if (piCheckBoxColumn(self)) begin
63528>>>>>            send add_item msg_none ""
63529>>>>>            set checkbox_item_state item base# to true
63530>>>>>          end
63530>>>>>>
63530>>>>>          send add_item msg_none (psFileName.i(obj#,row#))
63531>>>>>          set aux_value item base# to row#
63532>>>>>          send add_item msg_none (psFileType.i(obj#,row#))
63533>>>>>          move (piFileSize.i(obj#,row#)) to file_size#
63534>>>>>          send add_item msg_none (SEQ_FileSizeToString(file_size#))
63535>>>>>          send add_item msg_none (TS_ConvertToString(pnFileTime.i(obj#,row#)))
63536>>>>>          send add_item msg_none path#
63537>>>>>          move (total_bytes#+file_size#) to total_bytes#
63538>>>>>          increment file_count#
63539>>>>>        end
63539>>>>>>
63539>>>>>      loop
63540>>>>>>
63540>>>>>      send Grid_SetEntryState self dfFalse
63541>>>>>      set dynamic_update_state to true
63542>>>>>      send display_totals file_count# total_bytes#
63543>>>>>    end
63543>>>>>>
63543>>>>>  end_procedure
63544>>>>>  procedure display_totals number file_count# number total_bytes#
63546>>>>>  end_procedure
63547>>>>>  procedure sort.i integer by#
63549>>>>>    set piOrdering of (piSetOfFilesObject(self)) to by#
63550>>>>>    send fill_list
63551>>>>>  end_procedure
63552>>>>>  procedure sort_by_column integer column#
63554>>>>>    if (piCheckBoxColumn(self)) decrement column#
63557>>>>>    if column# eq 0 send sort.i LF_ORDERING_NAME
63560>>>>>    if column# eq 1 send sort.i LF_ORDERING_TYPE
63563>>>>>    if column# eq 2 send sort.i LF_ORDERING_SIZE
63566>>>>>    if column# eq 3 send sort.i LF_ORDERING_TIME
63569>>>>>    if column# eq 4 send sort.i LF_ORDERING_PATH
63572>>>>>  end_procedure
63573>>>>>  procedure header_mouse_click integer itm#
63575>>>>>    send sort_by_column itm#
63576>>>>>    forward send header_mouse_click itm#
63578>>>>>  end_procedure
63579>>>>>  procedure user_sort
63581>>>>>    integer itm#
63581>>>>>    get current_item to itm#
63582>>>>>    send sort_by_column (itm#-((itm#/5)*5))
63583>>>>>  end_procedure
63584>>>>>end_class // cSetOfFilesList
63585>>>>>
63585>>>>>class cSetOfFilesListSelect is a cSetOfFilesList
63586>>>>>  procedure SetupCheckBoxColumn
63588>>>>>    set piCheckBoxColumn to true
63589>>>>>    set select_mode to MULTI_SELECT
63590>>>>>    send GridPrepare_AddColumn ""  AFT_ASCII3
63591>>>>>  end_procedure
63592>>>>>end_class
63593>>>Use GridUtil.utl // Grid and List utilities
63593>>>Use FDXSet.vw    // Display contents of cSetOfFiles cSetOfFieldsUse FDXSet.vw    // Display contents of cSetOfFiles cSetOfFields
Including file: fdxset.vw    (C:\Apps\VDFQuery\AppSrc\fdxset.vw)
63593>>>>>// Use FDXSet.vw    // Display contents of cSetOfFiles cSetOfFields
63593>>>>>Use FdxSet.pkg   // cFdxSetOfFieldsList class
Including file: fdxset.pkg    (C:\Apps\VDFQuery\AppSrc\fdxset.pkg)
63593>>>>>>>// Use FdxSet.pkg   // cFdxSetOfFieldsList class
63593>>>>>>>Use Strings.nui  // String manipulation for VDF
63593>>>>>>>Use GridUtil.utl // Grid and List utilities
63593>>>>>>>Use FdxField.nui // FDX Field things
63593>>>>>>>Use FdxIndex.utl // Index analysing functions
Including file: fdxindex.utl    (C:\Apps\VDFQuery\AppSrc\fdxindex.utl)
63593>>>>>>>>>Use FdxIndex.nui // Index analysing functions
63593>>>>>>>
63593>>>>>>>class cFdxSetOfTablesList is a aps.Grid
63594>>>>>>>  procedure construct_object integer img#
63596>>>>>>>    forward send construct_object img#
63598>>>>>>>    property integer piFDX_Server public 0
63599>>>>>>>    property integer piSOT_Server public 0 // SOF = SetOfTables
63600>>>>>>>    set line_width to 4 0
63601>>>>>>>    send GridPrepare_AddColumn "#"            AFT_ASCII4
63602>>>>>>>    send GridPrepare_AddColumn "Display name" AFT_ASCII40
63603>>>>>>>    send GridPrepare_AddColumn "DF name"      AFT_ASCII10
63604>>>>>>>    send GridPrepare_AddColumn "Root name"    AFT_ASCII32
63605>>>>>>>    send GridPrepare_Apply self
63606>>>>>>>    set select_mode to NO_SELECT
63607>>>>>>>    on_key KNEXT_ITEM send switch
63608>>>>>>>    on_key KPREVIOUS_ITEM send switch_back
63609>>>>>>>    on_key KENTER send next
63610>>>>>>>    on_key KDELETE_RECORD send delete_table
63611>>>>>>>    property integer piAllowDelete public dfFalse
63612>>>>>>>    on_key KEY_CTRL+KEY_R send sort_data
63613>>>>>>>    on_key KEY_CTRL+KEY_W send DoWriteToFile
63614>>>>>>>  end_procedure
63615>>>>>>>
63615>>>>>>>  procedure DoWriteToFile
63617>>>>>>>    send Grid_DoWriteToFile self
63618>>>>>>>  end_procedure
63619>>>>>>>
63619>>>>>>>  function iSpecialSortValueOnColumn.i integer column# returns integer
63621>>>>>>>    if column# eq 0 function_Return 1
63624>>>>>>>  end_function
63625>>>>>>>
63625>>>>>>>  function sSortValue.ii integer column# integer itm# returns string
63627>>>>>>>    if column# eq 0 function_return (IntToStrR(value(self,itm#),4))
63630>>>>>>>  end_function
63631>>>>>>>
63631>>>>>>>  procedure sort_data.i integer column#
63633>>>>>>>    send Grid_SortByColumn self column#
63634>>>>>>>  end_procedure
63635>>>>>>>
63635>>>>>>>  procedure sort_data
63637>>>>>>>    integer cc#
63637>>>>>>>    get Grid_CurrentColumn self to cc#
63638>>>>>>>    send sort_data.i cc#
63639>>>>>>>  end_procedure
63640>>>>>>>  procedure header_mouse_click integer itm#
63642>>>>>>>    send sort_data.i itm#
63643>>>>>>>    forward send header_mouse_click itm#
63645>>>>>>>  end_procedure
63646>>>>>>>  function iNumberOfFiles returns integer
63648>>>>>>>    function_return (iNumberOfFiles(piSOT_Server(self)))
63649>>>>>>>  end_function
63650>>>>>>>  procedure delete_table
63652>>>>>>>    integer base# file# field# row# oSOF#
63652>>>>>>>    if (piAllowDelete(self) and item_count(self)) begin
63654>>>>>>>      get Grid_BaseItem self to base#
63655>>>>>>>      get aux_value item base# to file#
63656>>>>>>>      get value item (base#+1) to field#
63657>>>>>>>      get piSOT_Server to oSOF#
63658>>>>>>>      get iFindItem.ii of oSOF# file# field# to row#
63659>>>>>>>      if row# ne -1 send delete_row to oSOF# row#
63662>>>>>>>      get Grid_CurrentRow self to row#
63663>>>>>>>      send Grid_DeleteRow self row#
63664>>>>>>>      send update_display_counter (iNumberOfFiles(self))
63665>>>>>>>    end
63665>>>>>>>>
63665>>>>>>>  end_procedure
63666>>>>>>>  procedure fill_list.i integer oSOT#
63668>>>>>>>    integer file# itm# max# oFDX#
63668>>>>>>>    set dynamic_update_state to DFFALSE
63669>>>>>>>    send delete_data
63670>>>>>>>    set piSOT_Server to oSOT#
63671>>>>>>>    get piFDX_Server of oSOT# to oFDX#
63672>>>>>>>    set piFDX_Server to oFDX#
63673>>>>>>>    get row_count of oSOT# to max#
63674>>>>>>>    for itm# from 0 to (max#-1)
63680>>>>>>>>
63680>>>>>>>      get piFile.i of oSOT# item itm# to file#
63681>>>>>>>      send add_item msg_none (string(file#))
63682>>>>>>>      send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_DISPLAY_NAME,file#))
63683>>>>>>>      send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#))
63684>>>>>>>      send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_ROOT_NAME,file#))
63685>>>>>>>    loop
63686>>>>>>>>
63686>>>>>>>    send Grid_SetEntryState self DFFALSE
63687>>>>>>>    send update_display_counter (iNumberOfFiles(self))
63688>>>>>>>    set dynamic_update_state to DFTRUE
63689>>>>>>>  end_procedure
63690>>>>>>>  procedure fill_list.ii integer oSOT# integer oFDX#
63692>>>>>>>    set piFDX_Server of oSOT# to oFDX#
63693>>>>>>>    send fill_list.i oSOT#
63694>>>>>>>  end_procedure
63695>>>>>>>  procedure update_display_counter integer files#
63697>>>>>>>  end_procedure
63698>>>>>>>end_class // cFdxSetOfTablesList
63699>>>>>>>
63699>>>>>>>
63699>>>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
63699>>>>>>>class cFdxSetOfFieldsList is a aps.Grid
63700>>>>>>>  procedure construct_object integer img#
63702>>>>>>>    forward send construct_object img#
63704>>>>>>>    property integer piFDX_Server public 0
63705>>>>>>>    property integer piSOF_Server public 0 // SOF = SetOfFields
63706>>>>>>>    property integer piAllowDelete public dfFalse
63707>>>>>>>    set line_width to 8 0
63708>>>>>>>
63708>>>>>>>    send GridPrepare_AddColumn "Table"    AFT_ASCII10
63709>>>>>>>    send GridPrepare_AddColumn "#"        AFT_ASCII2
63710>>>>>>>    send GridPrepare_AddColumn "Name"     AFT_ASCII15
63711>>>>>>>    send GridPrepare_AddColumn "Type"     AFT_ASCII4
63712>>>>>>>    send GridPrepare_AddColumn "Len"      AFT_ASCII5
63713>>>>>>>    send GridPrepare_AddColumn "Offset"   AFT_ASCII5
63714>>>>>>>    send GridPrepare_AddColumn "Idx"      AFT_ASCII3
63715>>>>>>>    send GridPrepare_AddColumn "Relation" AFT_ASCII30
63716>>>>>>>    send GridPrepare_Apply self
63717>>>>>>>    set select_mode to NO_SELECT
63718>>>>>>>    on_key knext_item send switch
63719>>>>>>>    on_key kprevious_item send switch_back
63720>>>>>>>    on_key kenter send next
63721>>>>>>>    on_key kdelete_record send delete_field
63722>>>>>>>    on_key key_ctrl+key_r send sort_data
63723>>>>>>>    on_key key_ctrl+key_w send DoWriteToFile
63724>>>>>>>  end_procedure
63725>>>>>>>
63725>>>>>>>  procedure DoWriteToFile
63727>>>>>>>    send Grid_DoWriteToFile self
63728>>>>>>>  end_procedure
63729>>>>>>>
63729>>>>>>>  function iSpecialSortValueOnColumn.i integer liColumn returns integer
63731>>>>>>>    if liColumn eq 1 function_Return 1
63734>>>>>>>    if liColumn eq 4 function_Return 1
63737>>>>>>>    if liColumn eq 5 function_Return 1
63740>>>>>>>    if liColumn eq 6 function_Return 1
63743>>>>>>>  end_function
63744>>>>>>>
63744>>>>>>>  function sSortValue.ii integer liColumn integer liItem returns string
63746>>>>>>>    string lsValue lsSep
63746>>>>>>>    if liColumn eq 1 function_return (IntToStrR(value(self,liItem),4))
63749>>>>>>>    if liColumn eq 4 begin
63751>>>>>>>      get value item liItem to lsValue
63752>>>>>>>      get CurrentDecimalSeparator to lsSep
63753>>>>>>>      replace "." in lsValue with lsSep
63755>>>>>>>      replace "," in lsValue with lsSep
63757>>>>>>>      function_return (NumToStrR(lsValue,2,8))
63758>>>>>>>    end
63758>>>>>>>>
63758>>>>>>>    if liColumn eq 5 function_return (IntToStrR(value(self,liItem),5))
63761>>>>>>>    if liColumn eq 6 function_return (IntToStrR(value(self,liItem),2))
63764>>>>>>>  end_function
63765>>>>>>>
63765>>>>>>>  procedure sort_data.i integer liColumn
63767>>>>>>>    send Grid_SortByColumn self liColumn
63768>>>>>>>  end_procedure
63769>>>>>>>
63769>>>>>>>  procedure sort_data
63771>>>>>>>    integer liColumn
63771>>>>>>>    get Grid_CurrentColumn self to liColumn
63772>>>>>>>    send sort_data.i liColumn
63773>>>>>>>  end_procedure
63774>>>>>>>
63774>>>>>>>  procedure header_mouse_click integer liItem
63776>>>>>>>    send sort_data.i liItem
63777>>>>>>>    forward send header_mouse_click liItem
63779>>>>>>>  end_procedure
63780>>>>>>>
63780>>>>>>>  function sRelFieldName.ii integer liFile integer liField returns string
63782>>>>>>>    integer lhFDX
63782>>>>>>>    get piFDX_Server to lhFDX
63783>>>>>>>    function_return (FDX_FieldName(lhFDX,liFile,liField,1))
63784>>>>>>>  end_function
63785>>>>>>>  function iNumberOfFiles returns integer
63787>>>>>>>    function_return (iNumberOfFiles(piSOF_Server(self)))
63788>>>>>>>  end_function
63789>>>>>>>  function iNumberOfFields returns integer
63791>>>>>>>    function_return (row_count(piSOF_Server(self)))
63792>>>>>>>  end_function
63793>>>>>>>  procedure delete_field
63795>>>>>>>    integer liBase liFile liField liRow lhSOF
63795>>>>>>>    if (piAllowDelete(self) and item_count(self)) begin
63797>>>>>>>      get Grid_BaseItem self to liBase
63798>>>>>>>      get aux_value item liBase to liFile
63799>>>>>>>      get value item (liBase+1) to liField
63800>>>>>>>      get piSOF_Server to lhSOF
63801>>>>>>>      get iFindItem.ii of lhSOF liFile liField to liRow
63802>>>>>>>      if liRow ne -1 send delete_row to lhSOF liRow
63805>>>>>>>      get Grid_CurrentRow self to liRow
63806>>>>>>>      send Grid_DeleteRow self liRow
63807>>>>>>>      send update_display_counter (iNumberOfFiles(self)) (iNumberOfFields(self))
63808>>>>>>>    end
63808>>>>>>>>
63808>>>>>>>  end_procedure
63809>>>>>>>  procedure fill_list.i integer lhSOF
63811>>>>>>>    integer lhFDX liRow liMax liFile liField liType liLen liDec liIdx
63811>>>>>>>    set dynamic_update_state to DFFALSE
63812>>>>>>>    send delete_data
63813>>>>>>>    set piSOF_Server to lhSOF
63814>>>>>>>    get piFDX_Server of lhSOF to lhFDX
63815>>>>>>>    set piFDX_Server to lhFDX
63816>>>>>>>    get row_count of lhSOF to liMax
63817>>>>>>>    for liRow from 0 to (liMax-1)
63823>>>>>>>>
63823>>>>>>>      get piFile.i  of lhSOF liRow to liFile
63824>>>>>>>      get piItem.i of lhSOF liRow to liField
63825>>>>>>>      send add_item msg_none (FDX_AttrValue_FILELIST(lhFDX,DF_FILE_LOGICAL_NAME,liFile))
63826>>>>>>>      set aux_value item (item_count(self)-1) to liFile
63827>>>>>>>      send add_item msg_none (string(liField))
63828>>>>>>>      send add_item msg_none (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_NAME,liFile,liField))
63829>>>>>>>
63829>>>>>>>      move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liField)) to liType
63830>>>>>>>      send add_item msg_none (API_ShortFieldTypeName(liType))
63831>>>>>>>      move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_LENGTH,liFile,liField)) to liLen
63832>>>>>>>      if liType eq DF_BCD begin
63834>>>>>>>        move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_PRECISION,liFile,liField)) to liDec
63835>>>>>>>        send add_item msg_none (string(liLen-liDec)+"."+string(liDec))
63836>>>>>>>      end
63836>>>>>>>>
63836>>>>>>>      else send add_item msg_none (string(liLen))
63838>>>>>>>      send add_item msg_none (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_OFFSET,liFile,liField))
63839>>>>>>>      move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_INDEX,liFile,liField)) to liIdx
63840>>>>>>>      if liIdx send add_item msg_none (string(liIdx))
63843>>>>>>>      else    send add_item msg_none ""
63845>>>>>>>      send add_item msg_none (sRelFieldName.ii(self,FDX_AttrValue_FIELD(lhFDX,DF_FIELD_RELATED_FILE,liFile,liField),FDX_AttrValue_FIELD(lhFDX,DF_FIELD_RELATED_FIELD,liFile,liField)))
63846>>>>>>>    loop
63847>>>>>>>>
63847>>>>>>>    send Grid_SetEntryState self false
63848>>>>>>>    send update_display_counter (iNumberOfFiles(self)) (iNumberOfFields(self))
63849>>>>>>>    set dynamic_update_state to DFTRUE
63850>>>>>>>  end_procedure
63851>>>>>>>  procedure update_display_counter integer liFiles integer liFields
63853>>>>>>>  end_procedure
63854>>>>>>>  function row_file.i integer liRow returns integer
63856>>>>>>>    integer liBase
63856>>>>>>>    if (item_count(self)) begin
63858>>>>>>>      get Grid_RowBaseItem self liRow to liBase
63859>>>>>>>      function_return (aux_value(self,liBase))
63860>>>>>>>    end
63860>>>>>>>>
63860>>>>>>>    // function_return 0
63860>>>>>>>  end_function
63861>>>>>>>  function row_field.i integer liRow returns integer
63863>>>>>>>    integer liBase
63863>>>>>>>    if (item_count(self)) begin
63865>>>>>>>      get Grid_RowBaseItem self liRow to liBase
63866>>>>>>>      function_return (value(self,liBase+1))
63867>>>>>>>    end
63867>>>>>>>>
63867>>>>>>>    // function_return 0
63867>>>>>>>  end_function
63868>>>>>>>  function row_field_name.i integer liRow returns string
63870>>>>>>>    integer liBase
63870>>>>>>>    if (item_count(self)) begin
63872>>>>>>>      get Grid_RowBaseItem self liRow to liBase
63873>>>>>>>      function_return (value(self,liBase+2))
63874>>>>>>>    end
63874>>>>>>>>
63874>>>>>>>    function_return ""
63875>>>>>>>  end_function
63876>>>>>>>end_class // cFdxSetOfFieldsList
63877>>>>>>>
63877>>>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
63877>>>>>>>class cFdxSetOfIndicesList is a aps.Grid
63878>>>>>>>  procedure construct_object integer img#
63880>>>>>>>    forward send construct_object img#
63882>>>>>>>    property integer piFDX_Server public 0
63883>>>>>>>    property integer piSOF_Server public 0 // SOF = SetOfIndices
63884>>>>>>>    set line_width to 3 0
63885>>>>>>>    send GridPrepare_AddColumn "Table"  AFT_ASCII10
63886>>>>>>>    send GridPrepare_AddColumn "Idx"    AFT_ASCII3
63887>>>>>>>    send GridPrepare_AddColumn "Fields" AFT_ASCII50
63888>>>>>>>    send GridPrepare_Apply self
63889>>>>>>>    set select_mode to NO_SELECT
63890>>>>>>>    on_key knext_item send switch
63891>>>>>>>    on_key kprevious_item send switch_back
63892>>>>>>>    on_key kenter send next
63893>>>>>>>    on_key kdelete_record send delete_index
63894>>>>>>>    on_key key_ctrl+key_w send DoWriteToFile
63895>>>>>>>    property integer piAllowDelete public dfFalse
63896>>>>>>>  end_procedure
63897>>>>>>>
63897>>>>>>>  procedure DoWriteToFile
63899>>>>>>>    send Grid_DoWriteToFile self
63900>>>>>>>  end_procedure
63901>>>>>>>
63901>>>>>>>  function iNumberOfFiles returns integer
63903>>>>>>>    function_return (iNumberOfFiles(piSOF_Server(self)))
63904>>>>>>>  end_function
63905>>>>>>>  function iNumberOfIndices returns integer
63907>>>>>>>    function_return (row_count(piSOF_Server(self)))
63908>>>>>>>  end_function
63909>>>>>>>  procedure delete_index
63911>>>>>>>    integer base# file# index# row# oSOF#
63911>>>>>>>    if (piAllowDelete(self) and item_count(self)) begin
63913>>>>>>>      get Grid_BaseItem self to base#
63914>>>>>>>      get aux_value item base# to file#
63915>>>>>>>      get value item (base#+1) to index#
63916>>>>>>>      get piSOF_Server to oSOF#
63917>>>>>>>      get iFindItem.ii of oSOF# file# index# to row#
63918>>>>>>>      if row# ne -1 send delete_row to oSOF# row#
63921>>>>>>>      get Grid_CurrentRow self to row#
63922>>>>>>>      send Grid_DeleteRow self row#
63923>>>>>>>      send update_display_counter (iNumberOfFiles(self)) (iNumberOfIndices(self))
63924>>>>>>>    end
63924>>>>>>>>
63924>>>>>>>  end_procedure
63925>>>>>>>  procedure fill_list.i integer oSOF#
63927>>>>>>>    integer oFDX# row# max# file# index# type# len# dec# idx# itm# itm_max#
63927>>>>>>>    string IdxAsStr# lf#
63927>>>>>>>    set dynamic_update_state to DFFALSE
63928>>>>>>>    send delete_data
63929>>>>>>>    move (character(10)) to lf#
63930>>>>>>>    set piSOF_Server to oSOF#
63931>>>>>>>    get piFDX_Server of oSOF# to oFDX#
63932>>>>>>>    set piFDX_Server to oFDX#
63933>>>>>>>    get row_count of oSOF# to max#
63934>>>>>>>    for row# from 0 to (max#-1)
63940>>>>>>>>
63940>>>>>>>      get piFile.i of oSOF# row# to file#
63941>>>>>>>      get piItem.i of oSOF# row# to index#
63942>>>>>>>      send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#))
63943>>>>>>>      set aux_value item (item_count(self)-1) to file#
63944>>>>>>>      send add_item msg_none (string(index#))
63945>>>>>>>      move (FDX_IndexAsFieldNames(oFDX#,file#,index#,50)) to IdxAsStr#
63946>>>>>>>      move (HowManyWords(IdxAsStr#,lf#)) to itm_max#
63947>>>>>>>      for itm# from 1 to itm_max#
63953>>>>>>>>
63953>>>>>>>        if itm# eq 1 send add_item msg_none (ExtractWord(IdxAsStr#,lf#,itm#))
63956>>>>>>>        else begin
63957>>>>>>>          send add_item msg_none ""
63958>>>>>>>          set aux_value item (item_count(self)-1) to file#
63959>>>>>>>          send add_item msg_none ""
63960>>>>>>>          send add_item msg_none (ExtractWord(IdxAsStr#,lf#,itm#))
63961>>>>>>>        end
63961>>>>>>>>
63961>>>>>>>      loop
63962>>>>>>>>
63962>>>>>>>    loop
63963>>>>>>>>
63963>>>>>>>    send Grid_SetEntryState self false
63964>>>>>>>    send update_display_counter (iNumberOfFiles(self)) (iNumberOfIndices(self))
63965>>>>>>>    set dynamic_update_state to DFTRUE
63966>>>>>>>  end_procedure
63967>>>>>>>  procedure update_display_counter integer files# integer Indices#
63969>>>>>>>  end_procedure
63970>>>>>>>end_class // cFdxSetOfIndicesList
63971>>>>>>>
63971>>>>>Use FdxSet.nui   // cFdxSetOfFiles, cSetOfFields, cSetOfIndices
63971>>>>>Use FdxSelct.utl // Functions iFdxSelectOneFile and iFdxSelectOneField
Including file: fdxselct.utl    (C:\Apps\VDFQuery\AppSrc\fdxselct.utl)
63971>>>>>>>// Use FdxSelct.utl // Functions iFdxSelectOneFile and iFdxSelectOneField
63971>>>>>>>Use Fdx_Attr.utl // FDX compatible attribute functions
Including file: fdx_attr.utl    (C:\Apps\VDFQuery\AppSrc\fdx_attr.utl)
63971>>>>>>>>>Use FDX_Attr.nui
63971>>>>>>>Use FdxField.nui // FDX Field things
63971>>>>>>>Use FdxIndex.nui // Index analysing functions
63971>>>>>>>Use GridUtil.utl // Grid and List utilities
63971>>>>>>>Use SetOfFld.utl // cSetOfFields class
Including file: setoffld.utl    (C:\Apps\VDFQuery\AppSrc\setoffld.utl)
63971>>>>>>>>>// Use SetOfFld.utl // cSetOfFields class
63971>>>>>>>>>Use Base.utl     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
63971>>>>>>>>>Use Strings.nui  // String manipulation for VDF
63971>>>>>>>>>
63971>>>>>>>>>class cSetOfFields is a cArray
63972>>>>>>>>>  item_property_list
63972>>>>>>>>>    item_property integer piFile.i
63972>>>>>>>>>    item_property integer piField.i
63972>>>>>>>>>  end_item_property_list cSetOfFields
#REM 64004 DEFINE FUNCTION PIFIELD.I INTEGER LIROW RETURNS INTEGER
#REM 64008 DEFINE PROCEDURE SET PIFIELD.I INTEGER LIROW INTEGER VALUE
#REM 64012 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 64016 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
64021>>>>>>>>>  procedure add_field integer file# integer field#
64023>>>>>>>>>    integer row#
64023>>>>>>>>>    get row_count to row#
64024>>>>>>>>>    set piFile.i  row# to file#
64025>>>>>>>>>    set piField.i row# to field#
64026>>>>>>>>>  end_procedure
64027>>>>>>>>>  function iFindField.ii integer file# integer field# returns integer
64029>>>>>>>>>    integer row# max#
64029>>>>>>>>>    get row_count to max#
64030>>>>>>>>>    for row# from 0 to (max#-1)
64036>>>>>>>>>>
64036>>>>>>>>>      if (file#=piFile.i(self,row#) and field#=piField.i(self,row#)) function_return row#
64039>>>>>>>>>    loop
64040>>>>>>>>>>
64040>>>>>>>>>    function_return -1
64041>>>>>>>>>  end_function
64042>>>>>>>>>  procedure reset
64044>>>>>>>>>    send delete_data
64045>>>>>>>>>  end_procedure
64046>>>>>>>>>  procedure CallBack_Files integer msg# integer obj#
64048>>>>>>>>>    integer row# max# file# itm#
64048>>>>>>>>>    string files#
64048>>>>>>>>>    move "" to files#
64049>>>>>>>>>    get row_count to max#
64050>>>>>>>>>    for row# from 0 to (max#-1)
64056>>>>>>>>>>
64056>>>>>>>>>      get piFile.i row# to file#
64057>>>>>>>>>      ifnot (IsIntegerPresent(files#,file#)) move (AddIntegerToString(files#,file#)) to files#
64060>>>>>>>>>    loop
64061>>>>>>>>>>
64061>>>>>>>>>    move (HowManyIntegers(files#)) to max#
64062>>>>>>>>>    for itm# from 1 to max#
64068>>>>>>>>>>
64068>>>>>>>>>      send msg# to obj# (ExtractInteger(files#,itm#))
64069>>>>>>>>>    loop
64070>>>>>>>>>>
64070>>>>>>>>>  end_procedure
64071>>>>>>>>>end_class
64072>>>>>>>Use DBMS.utl     // Basic DBMS functions
64072>>>>>>>
64072>>>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
64072>>>>>>>class cFdxSelectOneFileList is a aps.Grid
64073>>>>>>>  procedure construct_object integer img#
64075>>>>>>>    forward send construct_object img#
64077>>>>>>>    set line_width to 4 0
64078>>>>>>>    set header_label item 0 to "#"
64079>>>>>>>    set header_label item 1 to "Display name"
64080>>>>>>>    set header_label item 2 to "DF name"
64081>>>>>>>    set header_label item 3 to "Root name"
64082>>>>>>>    set form_margin item 0 to  4   //
64083>>>>>>>    set form_margin item 1 to  40  //
64084>>>>>>>    set form_margin item 2 to  10  //
64085>>>>>>>    set form_margin item 3 to  32  //
64086>>>>>>>    set highlight_row_state to true
64087>>>>>>>    set CurrentCellColor     to clHighlight
64088>>>>>>>    set CurrentCellTextColor to clHighlightText
64089>>>>>>>    set CurrentRowColor      to clHighlight
64090>>>>>>>    set CurrentRowTextColor  to clHighlightText
64091>>>>>>>//   set highlight_row_color to (rgb(0,255,255))
64091>>>>>>>//   set current_item_color to (rgb(0,255,255))
64091>>>>>>>    set select_mode to no_select
64092>>>>>>>    on_key knext_item send switch
64093>>>>>>>    on_key kprevious_item send switch_back
64094>>>>>>>    on_key key_ctrl+key_r send sort_data
64095>>>>>>>    property integer piValidateFunction public 0
64096>>>>>>>    property integer piValidateObject   public 0
64097>>>>>>>  end_procedure
64098>>>>>>>
64098>>>>>>>  procedure mouse_click integer liItem integer liGrb
64100>>>>>>>    if ((liItem-1)>>>>>>  end_procedure
64104>>>>>>>
64104>>>>>>>  function sSortValue.ii integer column# integer itm# returns string
64106>>>>>>>    if column# eq 0 function_return (IntToStrR(value(self,itm#),4))
64109>>>>>>>  end_function
64110>>>>>>>  function iSpecialSortValueOnColumn.i integer column# returns integer
64112>>>>>>>    if column# eq 0 function_return 1
64115>>>>>>>    function_return 0 // Otherwise no special anything
64116>>>>>>>  end_function
64117>>>>>>>
64117>>>>>>>  procedure sort_data.i integer column#
64119>>>>>>>    send Grid_SortByColumn self column#
64120>>>>>>>  end_procedure
64121>>>>>>>  procedure sort_data
64123>>>>>>>    integer cc#
64123>>>>>>>    get Grid_CurrentColumn self to cc#
64124>>>>>>>    send sort_data.i cc#
64125>>>>>>>  end_procedure
64126>>>>>>>  procedure header_mouse_click integer itm#
64128>>>>>>>    send sort_data.i itm#
64129>>>>>>>    forward send header_mouse_click itm#
64131>>>>>>>  end_procedure
64132>>>>>>>  procedure fill_list.ii integer oFDX# integer suggest_file#
64134>>>>>>>    integer file# suggest_itm# fnc# obj# ok#
64134>>>>>>>    send delete_data
64135>>>>>>>    get piValidateFunction to fnc#
64136>>>>>>>    get piValidateObject   to obj#
64137>>>>>>>    move 0 to file#
64138>>>>>>>    move -1 to suggest_itm#
64139>>>>>>>    send cursor_wait to (cursor_control(self))
64140>>>>>>>    repeat
64140>>>>>>>>
64140>>>>>>>      move (FDX_AttrValue_FLSTNAV(oFDX#,DF_FILE_NEXT_USED,file#)) to file#
64141>>>>>>>      if file# begin
64143>>>>>>>//      if (iCanOpen.i(oFDX#,file#)) begin
64143>>>>>>>        if (FDX_CanOpenFile(oFDX#,file#)) begin
64145>>>>>>>          if obj# ne 0 get fnc# of obj# file# to ok#
64148>>>>>>>          else move 1 to ok#
64150>>>>>>>          if ok# begin
64152>>>>>>>            if file# eq suggest_file# move (item_count(self)) to suggest_itm#
64155>>>>>>>            send add_item msg_none (string(file#))
64156>>>>>>>            send add_item msg_none (rtrim(FDX_AttrValue_FILELIST(oFDX#,DF_FILE_DISPLAY_NAME,file#)))
64157>>>>>>>            send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#))
64158>>>>>>>            send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_ROOT_NAME,file#))
64159>>>>>>>          end
64159>>>>>>>>
64159>>>>>>>        end
64159>>>>>>>>
64159>>>>>>>      end
64159>>>>>>>>
64159>>>>>>>    until file# eq 0
64161>>>>>>>    send cursor_ready to (cursor_control(self))
64162>>>>>>>    set dynamic_update_state to dfTrue
64163>>>>>>>    if suggest_itm# ne -1 set current_item to suggest_itm#
64166>>>>>>>     send Grid_SetEntryState self 0
64167>>>>>>>  end_procedure
64168>>>>>>>  function iCurrentFile returns integer
64170>>>>>>>    integer itm#
64170>>>>>>>    ifnot (item_count(self)) function_return 0
64173>>>>>>>    get current_item to itm#
64174>>>>>>>    move ((itm#/4)*4) to itm#
64175>>>>>>>    function_return (value(self,itm#))
64176>>>>>>>  end_function
64177>>>>>>>end_class // cFdxSelectOneFileList
64178>>>>>>>
64178>>>>>>>class cFdxSelectOneFieldList is a aps.Grid
64179>>>>>>>  procedure construct_object integer img#
64181>>>>>>>    forward send construct_object img#
64183>>>>>>>    set line_width to 7 0
64184>>>>>>>    set header_label item 0 to "#"
64185>>>>>>>    set header_label item 1 to "Name"
64186>>>>>>>    set header_label item 2 to "Type"
64187>>>>>>>    set header_label item 3 to "Len"
64188>>>>>>>    set header_label item 4 to "Offset"
64189>>>>>>>    set header_label item 5 to "Idx"
64190>>>>>>>    set header_label item 6 to "Relation"
64191>>>>>>>    set form_margin item 0 to  2   // #
64192>>>>>>>    set form_margin item 1 to  15  // Name
64193>>>>>>>    set form_margin item 2 to  4   // Type
64194>>>>>>>    set form_margin item 3 to  5   // Len
64195>>>>>>>    set form_margin item 4 to  5   // Offset
64196>>>>>>>    set form_margin item 5 to  3   // Idx
64197>>>>>>>    set form_margin item 6 to  30  // Relation
64198>>>>>>>    set highlight_row_state to true
64199>>>>>>>    set CurrentCellColor     to clHighlight
64200>>>>>>>    set CurrentCellTextColor to clHighlightText
64201>>>>>>>    set CurrentRowColor      to clHighlight
64202>>>>>>>    set CurrentRowTextColor  to clHighlightText
64203>>>>>>>//  set highlight_row_color to (rgb(0,255,255))
64203>>>>>>>//  set current_item_color to (rgb(0,255,255))
64203>>>>>>>    set select_mode to no_select
64204>>>>>>>    on_key knext_item send switch
64205>>>>>>>    on_key kprevious_item send switch_back
64206>>>>>>>  end_procedure
64207>>>>>>>  function sRelFieldName.iii integer oFDX# integer file# integer field# returns string
64209>>>>>>>    function_return (FDX_FieldName(oFDX#,file#,field#,1))
64210>>>>>>>  end_function
64211>>>>>>>  procedure fill_list.iiii integer oFDX# integer file# integer suggest_file# integer suggest_field#
64213>>>>>>>    integer field# max_field# suggest_itm# type# len# dec# idx#
64213>>>>>>>    send delete_data
64214>>>>>>>    ifnot file# get FDX_NextFileThatCanOpen oFDX# 0 to file#
64217>>>>>>>    if file# ne suggest_file# move 0 to suggest_field#
64220>>>>>>>    move -1 to suggest_itm#
64221>>>>>>>    if (FDX_CanOpenFile(oFDX#,file#)) begin
64223>>>>>>>      move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,file#)) to max_field#
64224>>>>>>>      for field# from 1 to max_field#
64230>>>>>>>>
64230>>>>>>>        if field# eq suggest_field# move (item_count(self)) to suggest_itm#
64233>>>>>>>        send add_item msg_none (string(field#))
64234>>>>>>>        send add_item msg_none (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_NAME,file#,field#))
64235>>>>>>>        move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,file#,field#)) to type#
64236>>>>>>>        send add_item msg_none (API_ShortFieldTypeName(type#))
64237>>>>>>>        move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_LENGTH,file#,field#)) to len#
64238>>>>>>>        if type# eq DF_BCD begin
64240>>>>>>>          move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_PRECISION,file#,field#)) to dec#
64241>>>>>>>          send add_item msg_none (string(len#-dec#)+"."+string(dec#))
64242>>>>>>>        end
64242>>>>>>>>
64242>>>>>>>        else send add_item msg_none (string(len#))
64244>>>>>>>        send add_item msg_none (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET,file#,field#))
64245>>>>>>>        move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_INDEX,file#,field#)) to idx#
64246>>>>>>>        if idx# send add_item msg_none (string(idx#))
64249>>>>>>>        else    send add_item msg_none ""
64251>>>>>>>        send add_item msg_none (sRelFieldName.iii(self,oFDX#,FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FILE,file#,field#),FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FIELD,file#,field#)))
64252>>>>>>>      loop
64253>>>>>>>>
64253>>>>>>>    end
64253>>>>>>>>
64253>>>>>>>    set dynamic_update_state to true
64254>>>>>>>    if suggest_itm# ne -1 set current_item to suggest_itm#
64257>>>>>>>    send Grid_SetEntryState self 0
64258>>>>>>>  end_procedure
64259>>>>>>>  function iCurrentField returns integer
64261>>>>>>>    integer itm#
64261>>>>>>>    ifnot (item_count(self)) function_return 0
64264>>>>>>>    get current_item to itm#
64265>>>>>>>    move ((itm#/7)*7) to itm#
64266>>>>>>>    function_return (value(self,itm#))
64267>>>>>>>  end_function
64268>>>>>>>end_class // cFdxSelectOneFieldList
64269>>>>>>>
64269>>>>>>>desktop_section
64274>>>>>>>object oFdxSelectOneFile is a aps.ModalPanel label "Select table"
64277>>>>>>>  set locate_mode to CENTER_ON_SCREEN
64278>>>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
64279>>>>>>>  property integer piResult public 0
64281>>>>>>>  on_key ksave_record send close_panel_ok
64282>>>>>>>  on_key kcancel send close_panel
64283>>>>>>>  object oLst is a cFdxSelectOneFileList
64285>>>>>>>    set size to 200 0
64286>>>>>>>    on_key kenter send close_panel_ok
64287>>>>>>>  end_object
64288>>>>>>>  object oBtn1 is a aps.Multi_Button
64290>>>>>>>      on_item t.btn.ok send close_panel_ok
64291>>>>>>>  end_object
64292>>>>>>>  object oBtn2 is a aps.Multi_Button
64294>>>>>>>      on_item t.btn.cancel send close_panel
64295>>>>>>>  end_object
64296>>>>>>>  send aps_locate_multi_buttons
64297>>>>>>>  procedure close_panel_ok
64300>>>>>>>    set piResult to 1
64301>>>>>>>    send close_panel
64302>>>>>>>  end_procedure
64303>>>>>>>  function iPopup.iiii integer oFDX# integer suggest# integer fnc# integer obj# returns integer
64306>>>>>>>    integer rval#
64306>>>>>>>    set piValidateFunction of (oLst(self)) to fnc#
64307>>>>>>>    set piValidateObject   of (oLst(self)) to obj#
64308>>>>>>>    send fill_list.ii to (oLst(self)) oFDX# suggest#
64309>>>>>>>    set piResult to 0
64310>>>>>>>    send popup
64311>>>>>>>    if (piResult(self)) move (iCurrentFile(oLst(self))) to rval#
64314>>>>>>>    else move 0 to rval#
64316>>>>>>>    function_return rval#
64317>>>>>>>  end_function
64318>>>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
64321>>>>>>>    send aps_resize (oLst(self)) delta_rw# 0
64322>>>>>>>    send aps_register_multi_button (oBtn1(self))
64323>>>>>>>    send aps_register_multi_button (oBtn2(self))
64324>>>>>>>    send aps_locate_multi_buttons
64325>>>>>>>    send aps_auto_size_container
64326>>>>>>>  end_procedure
64327>>>>>>>end_object // oFdxSelectOneFile
64328>>>>>>>
64328>>>>>>>//>This function is defined in a package called "fdxselct.utl". This
64328>>>>>>>//>function calls an object defined just before the function (note that two
64328>>>>>>>//>versions of this object is defined, one for VDF and one for DF3.2). The
64328>>>>>>>//>Function returns the number of the selected file or 0 if the user
64328>>>>>>>//>cancelled the dialog.
64328>>>>>>>//>
64328>>>>>>>//>lhFDX: Object ID that holds a set of table definitions. VDFQuery passes
64328>>>>>>>//>zero in order not to use such an object and instead let the user select
64328>>>>>>>//>a table that is actually there (physically present).
64328>>>>>>>//>
64328>>>>>>>//>liDefaultFile: If this parameter is not zero, the cursor will locate
64328>>>>>>>//>itself on the corresponding file as the the dialog pops up. VDFQuery
64328>>>>>>>//>passes the number of the currently selected file.
64328>>>>>>>//>
64328>>>>>>>//>liValidFnc, liValidObj: Identifies a booelan function (liValidFnc) in an
64328>>>>>>>//>object (liValidObj) that may be used to validate each file, before it is
64328>>>>>>>//>added to the selection list (1 makes the file go in the list, 0 excludes
64328>>>>>>>//>the file). VDFQuery passes a function that checks that "@" is not part
64328>>>>>>>//>of the display name, and the the file has not been excluded by the
64328>>>>>>>//>programmer (this is what Dan Walsh describes with the
64328>>>>>>>//>VdfQuery_ExcludeFile message).
64328>>>>>>>//>
64328>>>>>>>//>Check the code calling this function in VDFQuery.utl to get the full
64328>>>>>>>//>picture
64328>>>>>>>function iFdxSelectOneFileValidate global integer lhFDX integer liDefaultFile integer liValidFnc integer liValidObj returns integer
64330>>>>>>>  function_return (iPopup.iiii(oFdxSelectOneFile(self),lhFDX,liDefaultFile,liValidFnc,liValidObj))
64331>>>>>>>end_function
64332>>>>>>>
64332>>>>>>>//> Function iFdxSelectOneFile returns number of selected file or 0
64332>>>>>>>//> if the user cancelled the dialog. If the liDefaultFile parameter is the number
64332>>>>>>>//> of an existing table, the cursor will locate itself on that as the
64332>>>>>>>//> the dialog pops up.
64332>>>>>>>function iFdxSelectOneFile global integer lhFDX integer liDefaultFile returns integer
64334>>>>>>>  function_return (iFdxSelectOneFileValidate(lhFDX,liDefaultFile,0,0))
64335>>>>>>>end_function
64336>>>>>>>
64336>>>>>>>object oFdxSelectOneField is a aps.ModalPanel label "Select field"
64339>>>>>>>  set locate_mode to CENTER_ON_SCREEN
64340>>>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
64341>>>>>>>  property integer piResult public 0
64343>>>>>>>  property integer piFDX_Server  public 0
64345>>>>>>>  property integer piCurrentFile public 0
64347>>>>>>>  property integer piLockFile    public 0
64349>>>>>>>  on_key ksave_record send close_panel_ok
64350>>>>>>>  on_key kcancel      send close_panel
64351>>>>>>>  on_key kprompt      send Table_Select
64352>>>>>>>  send aps_make_row_space 10
64353>>>>>>>  object oFrm1 is a aps.Form label "Table" abstract AFT_NUMERIC4.0
64357>>>>>>>    set label_justification_mode to JMODE_TOP
64358>>>>>>>    set object_shadow_state to true
64359>>>>>>>  end_object
64360>>>>>>>  object oFrm2 is a aps.Form label "Display name" abstract AFT_ASCII40 snap SL_RIGHT
64365>>>>>>>    set label_justification_mode to JMODE_TOP
64366>>>>>>>    set object_shadow_state to true
64367>>>>>>>  end_object
64368>>>>>>>  object oFrm3 is a aps.Form label "DF name" abstract AFT_ASCII10 snap SL_RIGHT
64373>>>>>>>    set label_justification_mode to JMODE_TOP
64374>>>>>>>    set object_shadow_state to true
64375>>>>>>>  end_object
64376>>>>>>>  object oFrm4 is a aps.Form label "Root name" abstract AFT_ASCII35 snap SL_RIGHT
64381>>>>>>>    set label_justification_mode to JMODE_TOP
64382>>>>>>>    set object_shadow_state to true
64383>>>>>>>  end_object
64384>>>>>>>  procedure DoUpdateDisplay
64387>>>>>>>    integer oFDX# file#
64387>>>>>>>    get piFDX_Server  to oFDX#
64388>>>>>>>    get piCurrentFile to file#
64389>>>>>>>    set value of (oFrm1(self)) item 0 to file#
64390>>>>>>>    set value of (oFrm2(self)) item 0 to (rtrim(FDX_AttrValue_FILELIST(oFDX#,DF_FILE_DISPLAY_NAME,file#)))
64391>>>>>>>    set value of (oFrm3(self)) item 0 to (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#))
64392>>>>>>>    set value of (oFrm4(self)) item 0 to (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_ROOT_NAME,file#))
64393>>>>>>>  end_procedure
64394>>>>>>>  object oLst is a cFdxSelectOneFieldList snap SL_DOWN relative_to (oFrm1(self))
64402>>>>>>>    on_key kenter send close_panel_ok
64403>>>>>>>  end_object
64404>>>>>>>  procedure close_panel_ok
64407>>>>>>>    set piResult to 1
64408>>>>>>>    send close_panel
64409>>>>>>>  end_procedure
64410>>>>>>>  object oBtn1 is a aps.Multi_Button
64412>>>>>>>    on_item t.btn.ok send close_panel_ok
64413>>>>>>>  end_object
64414>>>>>>>  object oBtn2 is a aps.Multi_Button
64416>>>>>>>    on_item "Change table" send Table_Select
64417>>>>>>>  end_object
64418>>>>>>>  object oBtn3 is a aps.Multi_Button
64420>>>>>>>    on_item t.btn.cancel send close_panel
64421>>>>>>>  end_object
64422>>>>>>>  send aps_locate_multi_buttons
64423>>>>>>>
64423>>>>>>>  procedure Table_Select
64426>>>>>>>    integer file# oFDX#
64426>>>>>>>    get piFDX_Server to oFDX#
64427>>>>>>>    ifnot (piLockFile(self)) begin
64429>>>>>>>      move (iFdxSelectOneFile(oFDX#,piCurrentFile(self))) to file#
64430>>>>>>>      if file# begin
64432>>>>>>>        send fill_list.iiii to (oLst(self)) oFDX# file# 0 0
64433>>>>>>>        set piCurrentFile to file#
64434>>>>>>>        send DoUpdateDisplay
64435>>>>>>>      end
64435>>>>>>>>
64435>>>>>>>    end
64435>>>>>>>>
64435>>>>>>>  end_procedure
64436>>>>>>>
64436>>>>>>>  function iPopup.iii integer oFDX# integer lock_file# integer suggest# returns integer
64439>>>>>>>    integer rval# suggest_file# suggest_field# file# field#
64439>>>>>>>    move (hi(suggest#)) to suggest_file#
64440>>>>>>>    move (low(suggest#)) to suggest_field#
64441>>>>>>>    set piResult to 0
64442>>>>>>>
64442>>>>>>>    if (lock_file# and suggest_file#) if lock_file# ne suggest_file# move 0 to suggest_file#
64447>>>>>>>    ifnot suggest_file# move 0 to suggest_field#
64450>>>>>>>
64450>>>>>>>    set piFDX_Server to oFDX#
64451>>>>>>>    set piLockFile   to lock_file#
64452>>>>>>>
64452>>>>>>>    if lock_file# move lock_file# to file#
64455>>>>>>>    else begin
64456>>>>>>>      if suggest_file# move suggest_file# to file#
64459>>>>>>>      else get FDX_NextFileThatCanOpen oFDX# 0 to file# // Find first#
64461>>>>>>>    end
64461>>>>>>>>
64461>>>>>>>
64461>>>>>>>    if file# begin
64463>>>>>>>      send fill_list.iiii to (oLst(self)) oFDX# file# suggest_file# suggest_field#
64464>>>>>>>      set piCurrentFile to file#
64465>>>>>>>      send DoUpdateDisplay
64466>>>>>>>      send popup
64467>>>>>>>      if (piResult(self)) begin
64469>>>>>>>        get piCurrentFile to file#
64470>>>>>>>        move (iCurrentField(oLst(self))) to field#
64471>>>>>>>        move (file#*65536+field#) to rval#
64472>>>>>>>      end
64472>>>>>>>>
64472>>>>>>>      else move 0 to rval#
64474>>>>>>>    end
64474>>>>>>>>
64474>>>>>>>    else begin
64475>>>>>>>      send obs "Sorry, no tables to select"
64476>>>>>>>      move 0 to rval#
64477>>>>>>>    end
64477>>>>>>>>
64477>>>>>>>    function_return rval#
64478>>>>>>>  end_function
64479>>>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
64482>>>>>>>    send aps_resize (oLst(self)) delta_rw# 0
64483>>>>>>>    send aps_register_multi_button (oBtn1(self))
64484>>>>>>>    send aps_register_multi_button (oBtn2(self))
64485>>>>>>>    send aps_register_multi_button (oBtn3(self))
64486>>>>>>>    send aps_register_max_rc (oFrm4(self))
64487>>>>>>>    send aps_locate_multi_buttons
64488>>>>>>>    send aps_auto_size_container
64489>>>>>>>  end_procedure
64490>>>>>>>  procedure aps_beautify
64493>>>>>>>    send aps_align_by_moving (oFrm2(self)) (oFrm1(self)) SL_ALIGN_BOTTOM
64494>>>>>>>    send aps_align_by_moving (oFrm3(self)) (oFrm2(self)) SL_ALIGN_BOTTOM
64495>>>>>>>    send aps_align_by_moving (oFrm4(self)) (oFrm3(self)) SL_ALIGN_BOTTOM
64496>>>>>>>    send aps_align_inside_container_by_moving (oLst(self)) SL_ALIGN_CENTER
64497>>>>>>>  end_procedure
64498>>>>>>>end_object // oFdxSelectOneField
64499>>>>>>>
64499>>>>>>>//> Function iFdxSelectOneField returns selected file multiplied by 65536
64499>>>>>>>//> plus the number of the selected field. If the user cancels the dialog
64499>>>>>>>//> 0 will be returned. If a file# is passed as the first parameter the
64499>>>>>>>//> dialog will be locked to that file.
64499>>>>>>>function iFdxSelectOneField global integer oFDX# integer file# integer suggest# returns integer
64501>>>>>>>  function_return (iPopup.iii(oFdxSelectOneField(self),oFDX#,file#,suggest#))
64502>>>>>>>end_function
64503>>>>>>>
64503>>>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
64503>>>>>>>class cFdxSelectFieldsList is a aps.Grid
64504>>>>>>>  procedure construct_object integer img#
64506>>>>>>>    forward send construct_object img#
64508>>>>>>>    send GridPrepare_AddColumn ""           AFT_ASCII3
64509>>>>>>>    send GridPrepare_AddColumn "Name"       AFT_ASCII25
64510>>>>>>>    send GridPrepare_AddColumn "Type"       AFT_ASCII6
64511>>>>>>>    send GridPrepare_AddColumn "Length"     AFT_ASCII8
64512>>>>>>>    send GridPrepare_AddColumn "Relates to" AFT_ASCII12
64513>>>>>>>    send GridPrepare_Apply self
64514>>>>>>>    set select_mode to MULTI_SELECT
64515>>>>>>>    on_key kswitch send switch
64516>>>>>>>    on_key kswitch_back send switch_back
64517>>>>>>>  end_procedure
64518>>>>>>>  procedure select_toggling integer itm# integer i#
64520>>>>>>>    forward send select_toggling (Grid_BaseItem(self)) i# // Redirect to first column
64522>>>>>>>  end_procedure
64523>>>>>>>  procedure fill_list.iii integer oFDX# integer file# integer set#
64525>>>>>>>    integer field# max_field# base# rel_file#
64525>>>>>>>    set dynamic_update_state to DFFALSE
64526>>>>>>>    send delete_data
64527>>>>>>>    move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,file#)) to max_field#
64528>>>>>>>    for field# from 0 to max_field#
64534>>>>>>>>
64534>>>>>>>      get item_count to base#
64535>>>>>>>      send add_item msg_none ""
64536>>>>>>>      set checkbox_item_state item base# to true
64537>>>>>>>      if (iFindField.ii(set#,file#,field#)<>-1) set select_state item base# to true
64540>>>>>>>      send add_item msg_none (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_NAME,file#,field#))
64541>>>>>>>      send add_item msg_none (StringFieldType(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,file#,field#)))
64542>>>>>>>      send add_item msg_none (FDX_FieldLength(oFDX#,file#,field#))
64543>>>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FILE,file#,field#)) to rel_file#
64544>>>>>>>      if rel_file# send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,rel_file#))
64547>>>>>>>      else send add_item msg_none ""
64549>>>>>>>    loop
64550>>>>>>>>
64550>>>>>>>    send Grid_SetEntryState self 0
64551>>>>>>>    set dynamic_update_state to DFTRUE
64552>>>>>>>  end_procedure
64553>>>>>>>  procedure rebuild_set integer set# integer file#
64555>>>>>>>    integer row# max# fld# base# columns#
64555>>>>>>>    send reset to set#
64556>>>>>>>    get Grid_Columns self to columns#
64557>>>>>>>    get Grid_RowCount self to max#
64558>>>>>>>    for row# from 0 to (max#-1)
64564>>>>>>>>
64564>>>>>>>      move (row#*columns#) to base#
64565>>>>>>>      if (select_state(self,base#)) send add_field to set# file# row#
64568>>>>>>>    loop
64569>>>>>>>>
64569>>>>>>>  end_procedure
64570>>>>>>>  procedure select_help integer st#
64572>>>>>>>    integer row# max# base# columns#
64572>>>>>>>    get Grid_Columns self to columns#
64573>>>>>>>    get Grid_RowCount self to max#
64574>>>>>>>    for row# from 0 to (max#-1)
64580>>>>>>>>
64580>>>>>>>      move (row#*columns#) to base#
64581>>>>>>>      set select_state item base# to st#
64582>>>>>>>    loop
64583>>>>>>>>
64583>>>>>>>    set dynamic_update_state to true
64584>>>>>>>  end_procedure
64585>>>>>>>  procedure select_all
64587>>>>>>>    send select_help 1
64588>>>>>>>  end_procedure
64589>>>>>>>  procedure select_none
64591>>>>>>>    send select_help 0
64592>>>>>>>  end_procedure
64593>>>>>>>end_class // cFdxSelectFieldsList
64594>>>>>>>
64594>>>>>>>object oFdxSelectFields is a aps.ModalPanel
64596>>>>>>>  set locate_mode to CENTER_ON_SCREEN
64597>>>>>>>  on_key ksave_record send close_panel_ok
64598>>>>>>>  on_key kcancel send close_panel
64599>>>>>>>  property integer piResult public 0
64601>>>>>>>  set pMinimumSize to 150 0
64602>>>>>>>  object oLst is a cFdxSelectFieldsList
64604>>>>>>>    on_key kenter send next
64605>>>>>>>    set size to 200 0
64606>>>>>>>  end_object
64607>>>>>>>  object oBtn1 is a aps.Multi_Button
64609>>>>>>>    on_item "Select all" send select_all to (oLst(self))
64610>>>>>>>  end_object
64611>>>>>>>  object oBtn2 is a aps.Multi_Button
64613>>>>>>>    on_item "Deselect all" send select_none to (oLst(self))
64614>>>>>>>  end_object
64615>>>>>>>  object oBtn3 is a aps.Multi_Button
64617>>>>>>>    on_item t.btn.ok send close_panel_ok
64618>>>>>>>  end_object
64619>>>>>>>  object oBtn4 is a aps.Multi_Button
64621>>>>>>>    on_item t.btn.cancel send close_panel
64622>>>>>>>  end_object
64623>>>>>>>  send aps_locate_multi_buttons sl_vertical
64624>>>>>>>  procedure close_panel_ok
64627>>>>>>>    set piResult to 1
64628>>>>>>>    send close_panel
64629>>>>>>>  end_procedure
64630>>>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
64631>>>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
64634>>>>>>>    send aps_resize (oLst(self)) delta_rw# 0
64635>>>>>>>    send aps_register_multi_button (oBtn1(self))
64636>>>>>>>    send aps_register_multi_button (oBtn2(self))
64637>>>>>>>    send aps_register_multi_button (oBtn3(self))
64638>>>>>>>    send aps_register_multi_button (oBtn4(self))
64639>>>>>>>    send aps_locate_multi_buttons sl_vertical
64640>>>>>>>    send aps_auto_size_container
64641>>>>>>>  end_procedure
64642>>>>>>>  function iPopup.iii integer oFDX# integer file# integer set# returns integer
64645>>>>>>>    set piResult to 0
64646>>>>>>>    send fill_list.iii to (oLst(self)) oFDX# file# set#
64647>>>>>>>    set label to ("Select fields: "+FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#))
64648>>>>>>>    send popup
64649>>>>>>>    if (piResult(self)) begin
64651>>>>>>>      send rebuild_set to (oLst(self)) set# file#
64652>>>>>>>    end
64652>>>>>>>>
64652>>>>>>>    function_return (piResult(self))
64653>>>>>>>  end_function
64654>>>>>>>end_object // oFdxSelectFields
64655>>>>>>>
64655>>>>>>>//> Function iFdxSelectFields returns 1 if the the user did indeed select a
64655>>>>>>>//> set of fields and 0 if the user cancelled the selection. If 1 is returned
64655>>>>>>>//> the function will modify the set of fields passed to it in parameter
64655>>>>>>>//> set#.
64655>>>>>>>function iFdxSelectFields global integer oFDX# integer file# integer set# returns integer
64657>>>>>>>  integer close# open# rval#
64657>>>>>>>  ifnot oFDX# begin
64659>>>>>>>    if (DBMS_IsOpenFile(file#)) begin
64661>>>>>>>      move 0 to close#
64662>>>>>>>      move 1 to open#
64663>>>>>>>    end
64663>>>>>>>>
64663>>>>>>>    else begin
64664>>>>>>>      if (DBMS_OpenFile(file#,DF_SHARE,0)) begin
64666>>>>>>>        move 1 to close#
64667>>>>>>>        move 1 to open#
64668>>>>>>>      end
64668>>>>>>>>
64668>>>>>>>      else begin
64669>>>>>>>        move 0 to close#
64670>>>>>>>        move 0 to open#
64671>>>>>>>      end
64671>>>>>>>>
64671>>>>>>>    end
64671>>>>>>>>
64671>>>>>>>  end
64671>>>>>>>>
64671>>>>>>>  else begin
64672>>>>>>>    move 0 to close#
64673>>>>>>>    move 1 to open#
64674>>>>>>>  end
64674>>>>>>>>
64674>>>>>>>  move (iPopup.iii(oFdxSelectFields(self),oFDX#,file#,set#)) to rval#
64675>>>>>>>  if close# close file#
64678>>>>>>>  function_return rval#
64679>>>>>>>end_function
64680>>>>>>>
64680>>>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
64680>>>>>>>class cFdxSelectIndexList is a aps.List
64681>>>>>>>  procedure construct_object integer img#
64683>>>>>>>    forward send construct_object img#
64685>>>>>>>    on_key kswitch send switch
64686>>>>>>>    on_key kswitch_back send switch_back
64687>>>>>>>    property integer phFDX public 0
64688>>>>>>>    property integer piFile public 0
64689>>>>>>>  end_procedure
64690>>>>>>>  procedure mouse_click integer liItem integer liGrb
64692>>>>>>>    if ((liItem-1)>>>>>>  end_procedure
64696>>>>>>>  procedure AddIndex integer liFile integer liIndex string lsFields integer liType
64698>>>>>>>    send add_item MSG_NONE (string(liIndex)+": "+FDX_IndexAsFieldNames(phFDX(self),piFile(self),liIndex,0))
64699>>>>>>>    set aux_value item (item_count(self)-1) to liIndex
64700>>>>>>>  end_procedure
64701>>>>>>>  procedure fill_list.ii integer oFDX# integer file#
64703>>>>>>>    integer field# max_field# base# rel_file#
64703>>>>>>>    set phFDX to oFDX#
64704>>>>>>>    set piFile to file#
64705>>>>>>>    set dynamic_update_state to DFFALSE
64706>>>>>>>    send delete_data
64707>>>>>>>    send FDX_IndexCallback oFDX# file# DF_INDEX_TYPE_ONLINE MSG_AddIndex self
64708>>>>>>>    send FDX_IndexCallback oFDX# file# DF_INDEX_TYPE_BATCH MSG_AddIndex self
64709>>>>>>>    set dynamic_update_state to DFTRUE
64710>>>>>>>  end_procedure
64711>>>>>>>end_class // cFdxSelectIndexList
64712>>>>>>>
64712>>>>>>>object oFdxSelectIndex is a aps.ModalPanel
64714>>>>>>>  set locate_mode to CENTER_ON_SCREEN
64715>>>>>>>  on_key ksave_record send close_panel_ok
64716>>>>>>>  on_key kcancel send close_panel
64717>>>>>>>  property integer piResult public 0
64719>>>>>>>  set pMinimumSize to 150 0
64720>>>>>>>  object oLst is a cFdxSelectIndexList
64722>>>>>>>    on_key kenter send close_panel_ok
64723>>>>>>>    set size to 100 300
64724>>>>>>>  end_object
64725>>>>>>>  object oBtn1 is a aps.Multi_Button
64727>>>>>>>    on_item t.btn.ok send close_panel_ok
64728>>>>>>>  end_object
64729>>>>>>>  object oBtn2 is a aps.Multi_Button
64731>>>>>>>    on_item t.btn.cancel send close_panel
64732>>>>>>>  end_object
64733>>>>>>>  send aps_locate_multi_buttons
64734>>>>>>>  procedure close_panel_ok
64737>>>>>>>    set piResult to (aux_value(oLst(self),CURRENT))
64738>>>>>>>    send close_panel
64739>>>>>>>  end_procedure
64740>>>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
64741>>>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
64744>>>>>>>    send aps_resize (oLst(self)) delta_rw# 0
64745>>>>>>>    send aps_register_multi_button (oBtn1(self))
64746>>>>>>>    send aps_register_multi_button (oBtn2(self))
64747>>>>>>>    send aps_locate_multi_buttons
64748>>>>>>>    send aps_auto_size_container
64749>>>>>>>  end_procedure
64750>>>>>>>  function iPopup.ii integer oFDX# integer file# returns integer
64753>>>>>>>    set piResult to 0
64754>>>>>>>    send fill_list.ii to (oLst(self)) oFDX# file#
64755>>>>>>>    set label to ("Select index: "+FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#))
64756>>>>>>>    send popup
64757>>>>>>>    function_return (piResult(self))
64758>>>>>>>  end_function
64759>>>>>>>end_object // oFdxSelectIndex
64760>>>>>>>end_desktop_section
64765>>>>>>>
64765>>>>>>>function iFdxSelectIndex global integer oFDX# integer file# returns integer
64767>>>>>>>  integer close# open# rval#
64767>>>>>>>  ifnot oFDX# begin
64769>>>>>>>    if (DBMS_IsOpenFile(file#)) begin
64771>>>>>>>      move 0 to close#
64772>>>>>>>      move 1 to open#
64773>>>>>>>    end
64773>>>>>>>>
64773>>>>>>>    else begin
64774>>>>>>>      if (DBMS_OpenFile(file#,DF_SHARE,0)) begin
64776>>>>>>>        move 1 to close#
64777>>>>>>>        move 1 to open#
64778>>>>>>>      end
64778>>>>>>>>
64778>>>>>>>      else begin
64779>>>>>>>        move 0 to close#
64780>>>>>>>        move 0 to open#
64781>>>>>>>      end
64781>>>>>>>>
64781>>>>>>>    end
64781>>>>>>>>
64781>>>>>>>  end
64781>>>>>>>>
64781>>>>>>>  else begin
64782>>>>>>>    move 0 to close#
64783>>>>>>>    move 1 to open#
64784>>>>>>>  end
64784>>>>>>>>
64784>>>>>>>  move (iPopup.ii(oFdxSelectIndex(self),oFDX#,file#)) to rval#
64785>>>>>>>  if close# close file#
64788>>>>>>>  function_return rval#
64789>>>>>>>end_function
64790>>>>>Use API_Attr.pkg // UI objects for use with API_Attr.utl
Including file: api_attr.pkg    (C:\Apps\VDFQuery\AppSrc\api_attr.pkg)
64790>>>>>>>// Use API_Attr     // UI objects for use with API_Attr.utl
64790>>>>>>>Use API_Attr.utl // Functions for querying API attributes
64790>>>>>>>
64790>>>>>>>//register_procedure FdxSet_Comp_CallBack global integer attr# integer msg# integer obj#
64790>>>>>>>
64790>>>>>>>class Api_Attr.ComboFormAux is a aps.ComboFormAux
64791>>>>>>>  procedure contruct_object
64793>>>>>>>    forward send contruct_object
64795>>>>>>>    on_key kenter send next
64796>>>>>>>    set allow_blank_state to false
64797>>>>>>>  end_procedure
64798>>>>>>>  procedure fill_list_attrtype_help integer attr#
64800>>>>>>>    send combo_add_item (API_Attr_DisplayName(attr#)) attr#
64801>>>>>>>  end_procedure
64802>>>>>>>  procedure fill_list_attrtype integer type#
64804>>>>>>>    send API_AttrType_Callback type# msg_fill_list_attrtype_help self
64805>>>>>>>    set entry_state item 0 to false
64806>>>>>>>  end_procedure
64807>>>>>>>  procedure fill_list_attrtypes
64809>>>>>>>    integer max# attrtype#
64809>>>>>>>    move (API_AttrType_Count()) to max#
64810>>>>>>>    for attrtype# from 0 to (max#-1)
64816>>>>>>>>
64816>>>>>>>      send combo_add_item (API_AttrType_Name(attrtype#)) attrtype#
64817>>>>>>>    loop
64818>>>>>>>>
64818>>>>>>>    set entry_state item 0 to false
64819>>>>>>>  end_procedure
64820>>>>>>>  procedure prepare_attr_values_help integer value# string codename# string displayname#
64822>>>>>>>    send combo_add_item displayname# value#
64823>>>>>>>  end_procedure
64824>>>>>>>  procedure prepare_attr_values integer attr#
64826>>>>>>>    send Combo_Delete_Data
64827>>>>>>>    if (API_AttrDiscreteValues(attr#)) begin
64829>>>>>>>      send API_AttrValue_Callback attr# msg_prepare_attr_values_help self
64830>>>>>>>      set entry_state item 0 to false
64831>>>>>>>    end
64831>>>>>>>>
64831>>>>>>>    else begin
64832>>>>>>>      set entry_state item 0 to true
64833>>>>>>>      set value item 0 to ""
64834>>>>>>>    end
64834>>>>>>>>
64834>>>>>>>  end_procedure
64835>>>>>>>  procedure comparison_modes_help integer comp# string str#
64837>>>>>>>    send combo_add_item str# comp#
64838>>>>>>>  end_procedure
64839>>>>>>>  procedure prepare_comparison_modes integer attr#
64841>>>>>>>    send Combo_Delete_Data
64842>>>>>>>    send FdxSet_Comp_CallBack attr# msg_comparison_modes_help self
64843>>>>>>>    set entry_state item 0 to false
64844>>>>>>>  end_procedure
64845>>>>>>>end_class // Api_Attr.ComboFormAux
64846>>>>>>>
64846>>>>>>>
64846>>>>>
64846>>>>>class cFdxSetReport is a cDFMatrixSimpleReport
64847>>>>>  procedure construct_object integer img#
64849>>>>>    forward send construct_object img#
64851>>>>>    property integer piSOT_Server public 0
64852>>>>>  end_procedure
64853>>>>>  procedure DoReport
64855>>>>>  end_procedure
64856>>>>>  procedure run
64858>>>>>    set piFDX_Server to (piFDX_Server(piSOT_Server(self)))
64859>>>>>    if (iStartReport(self)) begin
64861>>>>>      send DoReport
64862>>>>>      send EndReport
64863>>>>>    end
64863>>>>>>
64863>>>>>  end_procedure
64864>>>>>end_class // cFdxSetReport
64865>>>>>
/FDXSETTABLEREPORT.HDR
Image 6, FDXSETTABLEREPORT.HDR
       # Display name                   DF name         Root name
/FdxSetTableReport.body
Image 7, FDXSETTABLEREPORT.BODY
    ___. ______________________________ _______________ _______________
/*
64865>>>>>class cFdxSetTableReport is a cFdxSetReport
64866>>>>>  procedure construct_object integer img#
64868>>>>>    forward send construct_object img#
64870>>>>>    set psTitle to "Set of tables"
64871>>>>>  end_procedure
64872>>>>>  procedure DoReport
64874>>>>>    integer oFDX# oSOT# max# row# file#
64874>>>>>    send obs "DoReport"
64875>>>>>    get piSOT_Server to oSOT#
64876>>>>>    get piFDX_Server of oSOT# to oFDX#
64877>>>>>    set pSubHeader_image  of seq.object# to FdxSetTableReport.hdr.N
64878>>>>>    set pSubHeader_height of seq.object# to FdxSetTableReport.hdr.LINES
64879>>>>>    get row_count of oSOT# to max#
64880>>>>>    for row# from 0 to (max#-1)
64886>>>>>>
64886>>>>>      get piFile.i of oSOT# row# to file#
64887>>>>>      print file# to FdxSetTableReport.body.1
64888>>>>>      print (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_DISPLAY_NAME,file#)) to FdxSetTableReport.body.2
64889>>>>>      print (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#)) to FdxSetTableReport.body.3
64890>>>>>      print (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_ROOT_NAME,file#))    to FdxSetTableReport.body.4
64891>>>>>      send obs "Before output"
64892>>>>>      seq.output FdxSetTableReport.body
64893>>>>>      send obs "After output"
64894>>>>>    loop
64895>>>>>>
64895>>>>>    send obs "End-DoReport"
64896>>>>>  end_procedure
64897>>>>>end_class // cFdxSetTableReport
64898>>>>>
64898>>>>>
64898>>>>>enumeration_list // Database meta entities
64898>>>>>  define DME_TABLE
64898>>>>>  define DME_FIELD
64898>>>>>  define DME_INDEX
64898>>>>>end_enumeration_list
64898>>>>>
64898>>>>>function sDME_Title.i global integer dme# returns string
64900>>>>>  if dme# eq DME_TABLE function_return "Select tables"
64903>>>>>  if dme# eq DME_FIELD function_return "Select fields"
64906>>>>>  if dme# eq DME_INDEX function_return "Select indices"
64909>>>>>end_function
64910>>>>>
64910>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
64910>>>>>Use Buttons.utl  // Button texts
64910>>>>>object oFdxSetAttributeSelector is a aps.ModalPanel label ""
64913>>>>>  set locate_mode to CENTER_ON_SCREEN
64914>>>>>  on_key ksave_record send close_panel_ok
64915>>>>>  on_key kcancel send close_panel
64916>>>>>  property integer piResult public 0
64918>>>>>  set p_auto_column to 1
64919>>>>>  object oAttribute is a Api_Attr.ComboFormAux label "Attribute"
64922>>>>>    set form_margin item 0 to 20
64923>>>>>    procedure OnChange
64926>>>>>      send DoUpdate (Combo_Current_Aux_Value(self))
64927>>>>>    end_procedure
64928>>>>>  end_object
64929>>>>>  object oComperator is a Api_Attr.ComboFormAux label "Comperator"
64932>>>>>    set form_margin item 0 to 2
64933>>>>>  end_object
64934>>>>>  object oDiscreteValue is a Api_Attr.ComboFormAux label "Discrete value"
64937>>>>>    set form_margin item 0 to 20
64938>>>>>  end_object
64939>>>>>  object oUserValue is a aps.Form label "User value"
64942>>>>>    set form_margin item 0 to 20
64943>>>>>  end_object
64944>>>>>  procedure DoUpdate integer attr#
64947>>>>>    send prepare_comparison_modes to (oComperator(self)) attr#
64948>>>>>    send prepare_attr_values to (oDiscreteValue(self)) attr#
64949>>>>>    if (API_AttrDiscreteValues(attr#)) begin
64951>>>>>      set object_shadow_state of (oDiscreteValue(self)) to false
64952>>>>>      set object_shadow_state of (oUserValue(self)) to true
64953>>>>>      set value of (oUserValue(self)) item 0 to ""
64954>>>>>    end
64954>>>>>>
64954>>>>>    else begin
64955>>>>>      set object_shadow_state of (oDiscreteValue(self)) to true
64956>>>>>      set object_shadow_state of (oUserValue(self)) to false
64957>>>>>    end
64957>>>>>>
64957>>>>>  end_procedure
64958>>>>>  object oBtn1 is a aps.Multi_Button
64960>>>>>    on_item t.btn.ok send close_panel_ok
64961>>>>>  end_object
64962>>>>>  object oBtn2 is a aps.Multi_Button
64964>>>>>    on_item t.btn.cancel send close_panel
64965>>>>>  end_object
64966>>>>>  send aps_locate_multi_buttons
64967>>>>>  procedure close_panel_ok
64970>>>>>    set piResult to 1
64971>>>>>    send close_panel
64972>>>>>  end_procedure
64973>>>>>  function iAttribute returns integer
64976>>>>>    function_return (Combo_Current_Aux_Value(oAttribute(self)))
64977>>>>>  end_function
64978>>>>>  function iComperator returns integer
64981>>>>>    function_return (Combo_Current_Aux_Value(oComperator(self)))
64982>>>>>  end_function
64983>>>>>  function sValue returns string
64986>>>>>    if (API_AttrDiscreteValues(iAttribute(self))) function_return (Combo_Current_Aux_Value(oDiscreteValue(self)))
64989>>>>>    function_return (value(oUserValue(self),0))
64990>>>>>  end_function
64991>>>>>  function iPopup.i integer dme# returns integer
64994>>>>>    set piResult to 0
64995>>>>>    set label to (sDME_Title.i(dme#))
64996>>>>>    send Combo_Delete_Data to (oAttribute(self))
64997>>>>>    send Combo_Delete_Data to (oComperator(self))
64998>>>>>    send Combo_Delete_Data to (oDiscreteValue(self))
64999>>>>>    if dme# eq DME_TABLE begin
65001>>>>>      send fill_list_attrtype to (oAttribute(self)) ATTRTYPE_FILELIST
65002>>>>>      send fill_list_attrtype to (oAttribute(self)) ATTRTYPE_FILE
65003>>>>>    end
65003>>>>>>
65003>>>>>    if dme# eq DME_FIELD begin
65005>>>>>      send fill_list_attrtype to (oAttribute(self)) ATTRTYPE_FIELD
65006>>>>>    end
65006>>>>>>
65006>>>>>    if dme# eq DME_INDEX begin
65008>>>>>      send fill_list_attrtype to (oAttribute(self)) ATTRTYPE_INDEX
65009>>>>>      send fill_list_attrtype to (oAttribute(self)) ATTRTYPE_IDXSEG
65010>>>>>    end
65010>>>>>>
65010>>>>>    send DoUpdate (Combo_Current_Aux_Value(oAttribute(self)))
65011>>>>>    send popup
65012>>>>>    function_return (piResult(self))
65013>>>>>  end_function
65014>>>>>end_object // oFdxSetAttributeSelector
65015>>>>>
65015>>>>>object oSelectAttributesContainer is a cArray
65017>>>>>  object oSetOfTables is a cFdxSetOfTables no_image
65019>>>>>    set psTitle to "Table search result"
65020>>>>>  end_object
65021>>>>>  object oSetOfFields is a cFdxSetOfFields no_image
65023>>>>>    set psTitle to "Field search result"
65024>>>>>  end_object
65025>>>>>  object oSetOfIndices is a cFdxSetOfIndices no_image
65027>>>>>    set psTitle to "Index search result"
65028>>>>>  end_object
65029>>>>>  procedure PopupSelector integer dme#
65032>>>>>    integer rval# set# attr# comp# panel#
65032>>>>>    string value#
65032>>>>>    move (oFdxSetAttributeSelector(self)) to panel#
65033>>>>>    if dme# eq DME_TABLE move (oSetOfTables(self)) to set#
65036>>>>>    if dme# eq DME_FIELD move (oSetOfFields(self)) to set#
65039>>>>>    if dme# eq DME_INDEX move (oSetOfIndices(self)) to set#
65042>>>>>    get iPopup.i of panel# dme# to rval#
65043>>>>>    if rval# begin
65045>>>>>      set piFDX_Server of set# to (fdx.object_id(0))
65046>>>>>      set piTestAttribute of set# to (iAttribute(panel#))
65047>>>>>      set piTestCompMode  of set# to (iComperator(panel#))
65048>>>>>      set psTestValue     of set# to (sValue(panel#))
65049>>>>>      send Traverse_All to set#
65050>>>>>      if dme# eq DME_TABLE send Display_FdxSetOfTables set#
65053>>>>>      if dme# eq DME_FIELD send Display_FdxSetOfFields set#
65056>>>>>      if dme# eq DME_INDEX send Display_FdxSetOfIndices set#
65059>>>>>    end
65059>>>>>>
65059>>>>>  end_procedure
65060>>>>>end_object // oSelectAttributesContainer
65061>>>>>
65061>>>>>procedure PopupFdxTableSearch
65064>>>>>  send PopupSelector to (oSelectAttributesContainer(self)) DME_TABLE
65065>>>>>end_procedure
65066>>>>>procedure PopupFdxFieldSearch
65069>>>>>  send PopupSelector to (oSelectAttributesContainer(self)) DME_FIELD
65070>>>>>end_procedure
65071>>>>>procedure PopupFdxIndicesSearch
65074>>>>>  send PopupSelector to (oSelectAttributesContainer(self)) DME_INDEX
65075>>>>>end_procedure
65076>>>>>
65076>>>>>object oSelectFieldsAdvanced is a aps.ModalPanel label "Select 'connected' fields"
65079>>>>>  set locate_mode to CENTER_ON_SCREEN
65080>>>>>  property integer piField public 0
65082>>>>>  property integer piFile  public 0
65084>>>>>  on_key ksave_record send close_panel_ok
65085>>>>>  on_key kcancel send close_panel
65086>>>>>  property integer piResult public 0
65088>>>>>  object oFrm is a aps.Form abstract AFT_ASCII30 label "Select fields connected to:"
65092>>>>>    on_key kprompt send prompt
65093>>>>>    set entry_state item 0 to false
65094>>>>>    procedure prompt
65097>>>>>      integer file# field# oFDX#
65097>>>>>      get piFile to file#
65098>>>>>      get piField to field#
65099>>>>>      move (fdx.object_id(0)) to oFDX#
65100>>>>>      get iFdxSelectOneField oFDX# 0 (file#*65536+field#) to field#
65101>>>>>      if field# begin
65103>>>>>        move (field#/65536) to file#
65104>>>>>        move (field#-(file#*65536)) to field#
65105>>>>>        set value item 0 to (FDX_FieldName(oFDX#,file#,field#,1))
65106>>>>>        set piFile to file#
65107>>>>>        set piField to field#
65108>>>>>      end
65108>>>>>>
65108>>>>>    end_procedure
65109>>>>>  end_object
65110>>>>>  object oBtn1 is a aps.Multi_Button
65112>>>>>    on_item t.btn.ok send close_panel_ok
65113>>>>>  end_object
65114>>>>>  object oBtn2 is a aps.Multi_Button
65116>>>>>    on_item t.btn.prompt send prompt to (oFrm(self))
65117>>>>>  end_object
65118>>>>>  object oBtn3 is a aps.Multi_Button
65120>>>>>    on_item t.btn.cancel send close_panel
65121>>>>>  end_object
65122>>>>>  send aps_locate_multi_buttons
65123>>>>>  procedure close_panel_ok
65126>>>>>    set piResult to 1
65127>>>>>    send close_panel
65128>>>>>  end_procedure
65129>>>>>  function iPopup returns integer
65132>>>>>    set piResult to 0
65133>>>>>    send popup
65134>>>>>    function_return (piResult(self) and piFile(self))
65135>>>>>  end_function
65136>>>>>end_object // oSelectFieldsAdvanced
65137>>>>>
65137>>>>>object oSetOfFields is a cFdxSetOfFields no_image
65139>>>>>  set psTitle to "Advanced search result"
65140>>>>>  procedure PopupAdv
65143>>>>>    integer rval# panel# co#
65143>>>>>    set piFDX_Server to (fdx.object_id(0))
65144>>>>>    move (oSelectFieldsAdvanced(self)) to panel#
65145>>>>>    get iPopup of panel# to rval#
65146>>>>>    if rval# begin
65148>>>>>      send Traverse_ConnectedFields (piFile(panel#)) (piField(panel#))
65149>>>>>      move self to co#
65150>>>>>      send Display_FdxSetOfFields co#
65151>>>>>    end
65151>>>>>>
65151>>>>>  end_procedure
65152>>>>>end_object // oSetOfFields
65153>>>>>
65153>>>>>procedure Popup_SelectFieldsAdvanced
65156>>>>>  if (DFMatrix_Primary_Origin()) ne FDX_EMPTY send PopupAdv to (oSetOfFields(self))
65159>>>>>end_procedure
65160>>>>>
65160>>>>>register_object oTxt
65160>>>>>object oFdxSetOfTables_Vw is a aps.View label "Set of tables"
65163>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65164>>>>>  on_key kcancel send close_panel
65165>>>>>  on_key kprompt send DoSelect
65166>>>>>  on_key kclear  send DoReset
65167>>>>>  object oLst is a cFdxSetOfTablesList
65169>>>>>    set piAllowDelete to dfTrue
65170>>>>>    set size to 180 0
65171>>>>>    procedure update_display_counter integer files#
65174>>>>>      string str#
65174>>>>>      if files# move (string(files#)+" tables") to str#
65177>>>>>      else move "(empty)" to str#
65179>>>>>      move (RightShift(str#,30)) to str#
65180>>>>>      set value of (oTxt(self)) item 0 to str#
65181>>>>>    end_procedure
65182>>>>>  end_object
65183>>>>>  object oTxt is a aps.TextBox snap SL_DOWN
65186>>>>>  end_object
65187>>>>>  set auto_size_state of (oTxt(self)) to true
65188>>>>>  object oBtn1 is a aps.Multi_Button
65190>>>>>    on_item "Select tables" send DoSelect
65191>>>>>  end_object
65192>>>>>  object oBtn2 is a aps.Multi_Button
65194>>>>>    on_item "Export" send DoExport
65195>>>>>  end_object
65196>>>>>  object oBtn3 is a aps.Multi_Button
65198>>>>>    on_item t.btn.reset  send DoReset
65199>>>>>  end_object
65200>>>>>  object oBtn4 is a aps.Multi_Button
65202>>>>>    on_item t.btn.close  send close_panel
65203>>>>>  end_object
65204>>>>>  send aps_locate_multi_buttons
65205>>>>>  object oReport is a cFdxSetTableReport no_image
65207>>>>>    procedure run
65210>>>>>      set piSOT_Server to (piSOT_Server(oLst(self)))
65211>>>>>      forward send run
65213>>>>>    end_procedure
65214>>>>>  end_object
65215>>>>>  procedure DoPrint
65218>>>>>    send run to (oReport(self))
65219>>>>>  end_procedure
65220>>>>>  procedure DoExport
65223>>>>>    send PopupFdxSetExport WAY_SET_OF_TABLES_VW
65224>>>>>  end_procedure
65225>>>>>  procedure DoSelect
65228>>>>>    send PopupFdxTableSearch
65229>>>>>  end_procedure
65230>>>>>  procedure DoReset
65233>>>>>    send reset to (oFdxSetOfTables(self))
65234>>>>>    send update_display
65235>>>>>  end_procedure
65236>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
65239>>>>>    send aps_resize (oLst(self)) delta_rw# 0
65240>>>>>    send aps_auto_locate_control (oTxt(self)) sl_down (oLst(self))
65241>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65242>>>>>    send aps_register_multi_button (oBtn1(self))
65243>>>>>    send aps_register_multi_button (oBtn2(self))
65244>>>>>    send aps_register_multi_button (oBtn3(self))
65245>>>>>    send aps_register_multi_button (oBtn4(self))
65246>>>>>    send aps_locate_multi_buttons
65247>>>>>    send aps_auto_size_container
65248>>>>>  end_procedure
65249>>>>>  procedure update_display
65252>>>>>    send fill_list.i to (oLst(self)) (oFdxSetOfTables(self))
65253>>>>>  end_procedure
65254>>>>>  procedure OnChangeFdx
65257>>>>>    send reset to (oFdxSetOfTables(self))
65258>>>>>    send update_display
65259>>>>>  end_procedure
65260>>>>>  procedure aps_beautify
65263>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65264>>>>>  end_procedure
65265>>>>>  send DFMatrix_Vw_Register WAY_SET_OF_TABLES_VW self
65266>>>>>end_object // oFdxSetOfTables_Vw
65267>>>>>
65267>>>>>procedure Activate_SetOfTables
65270>>>>>  send popup to (oFdxSetOfTables_Vw(self))
65271>>>>>end_procedure
65272>>>>>
65272>>>>>register_object oTxt
65272>>>>>object oFdxSetOfTablesModal is a aps.ModalPanel
65274>>>>>  set locate_mode to CENTER_ON_SCREEN
65275>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65276>>>>>  on_key kcancel send close_panel
65277>>>>>  on_key ksave_record send none
65278>>>>>  on_key key_ctrl+key_u send DoUnion
65279>>>>>  on_key key_ctrl+key_i send DoIntersection
65280>>>>>  property integer piFdxSetOfTables public 0
65282>>>>>  object oLst is a cFdxSetOfTablesList
65284>>>>>    set size to 180 0
65285>>>>>    procedure update_display_counter integer files#
65288>>>>>      string str#
65288>>>>>      if files# move (string(files#)+" tables") to str#
65291>>>>>      else move "" to str#
65293>>>>>      move (RightShift(str#,30)) to str#
65294>>>>>      set value of (oTxt(self)) item 0 to str#
65295>>>>>    end_procedure
65296>>>>>  end_object
65297>>>>>  object oTxt is a aps.TextBox snap SL_DOWN
65300>>>>>  end_object
65301>>>>>  set auto_size_state of (oTxt(self)) to true
65302>>>>>  object oBtn1 is a aps.Multi_Button
65304>>>>>    on_item "Union"        send DoUnion
65305>>>>>  end_object
65306>>>>>  object oBtn2 is a aps.Multi_Button
65308>>>>>    on_item "Intersection" send DoIntersection
65309>>>>>  end_object
65310>>>>>  object oBtn3 is a aps.Multi_Button
65312>>>>>    on_item "Complement"   send DoComplement
65313>>>>>  end_object
65314>>>>>  object oBtn4 is a aps.Multi_Button
65316>>>>>    on_item t.btn.cancel send close_panel
65317>>>>>  end_object
65318>>>>>  send aps_locate_multi_buttons
65319>>>>>  procedure DoIntersection
65322>>>>>    send DoIntersection.i to (oFdxSetOfTables(self)) (piFdxSetOfTables(self))
65323>>>>>    send update_display to (oFdxSetOfTables_Vw(self))
65324>>>>>    send close_panel
65325>>>>>  end_procedure
65326>>>>>  procedure DoUnion
65329>>>>>    send DoUnion.i to (oFdxSetOfTables(self)) (piFdxSetOfTables(self))
65330>>>>>    send update_display to (oFdxSetOfTables_Vw(self))
65331>>>>>    send close_panel
65332>>>>>  end_procedure
65333>>>>>  procedure DoComplement
65336>>>>>    send DoComplement.i to (oFdxSetOfTables(self)) (piFdxSetOfTables(self))
65337>>>>>    send update_display to (oFdxSetOfTables_Vw(self))
65338>>>>>    send close_panel
65339>>>>>  end_procedure
65340>>>>>  procedure update_display integer oFdxSetOfTables#
65343>>>>>    set label to (psTitle(oFdxSetOfTables#))
65344>>>>>    set piFdxSetOfTables to oFdxSetOfTables#
65345>>>>>    send fill_list.i to (oLst(self)) oFdxSetOfTables#
65346>>>>>  end_procedure
65347>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
65350>>>>>    send aps_resize (oLst(self)) delta_rw# 0
65351>>>>>    send aps_auto_locate_control (oTxt(self)) sl_down (oLst(self))
65352>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65353>>>>>    send aps_register_multi_button (oBtn1(self))
65354>>>>>    send aps_register_multi_button (oBtn2(self))
65355>>>>>    send aps_register_multi_button (oBtn3(self))
65356>>>>>    send aps_register_multi_button (oBtn4(self))
65357>>>>>    send aps_locate_multi_buttons
65358>>>>>    send aps_auto_size_container
65359>>>>>  end_procedure
65360>>>>>  procedure aps_beautify
65363>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65364>>>>>  end_procedure
65365>>>>>end_object
65366>>>>>
65366>>>>>procedure Display_FdxSetOfTables global integer oFdxSetOfTables#
65368>>>>>  send update_display to (oFdxSetOfTablesModal(self)) oFdxSetOfTables#
65369>>>>>  send popup to (oFdxSetOfTablesModal(self))
65370>>>>>end_procedure
65371>>>>>
65371>>>>>register_object oTxt
65371>>>>>object oFdxSetOfFields_Vw is a aps.View label "Set of fields"
65374>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65375>>>>>  on_key kcancel send close_panel
65376>>>>>  on_key kprompt send DoSelect
65377>>>>>  on_key kclear  send DoReset
65378>>>>>  object oLst is a cFdxSetOfFieldsList
65380>>>>>    set piAllowDelete to dfTrue
65381>>>>>    set size to 180 0
65382>>>>>    procedure update_display_counter integer files# integer fields#
65385>>>>>      string str#
65385>>>>>      if fields# move (string(fields#)+" fields from "+string(files#)+" tables") to str#
65388>>>>>      else move "(empty)" to str#
65390>>>>>      move (RightShift(str#,30)) to str#
65391>>>>>      set value of (oTxt(self)) item 0 to str#
65392>>>>>    end_procedure
65393>>>>>  end_object
65394>>>>>  object oTxt is a aps.TextBox snap SL_DOWN
65397>>>>>  end_object
65398>>>>>  set auto_size_state of (oTxt(self)) to true
65399>>>>>  object oBtn1 is a aps.Multi_Button
65401>>>>>    on_item "Select fields" send DoSelect
65402>>>>>  end_object
65403>>>>>  object oBtn2 is a aps.Multi_Button
65405>>>>>    on_item "Spec. select"  send Popup_SelectFieldsAdvanced
65406>>>>>  end_object
65407>>>>>  object oBtn3 is a aps.Multi_Button
65409>>>>>    on_item "Export" send DoExport
65410>>>>>  end_object
65411>>>>>  object oBtn4 is a aps.Multi_Button
65413>>>>>    on_item t.btn.reset  send DoReset
65414>>>>>  end_object
65415>>>>>  object oBtn5 is a aps.Multi_Button
65417>>>>>    on_item t.btn.close  send close_panel
65418>>>>>  end_object
65419>>>>>  send aps_locate_multi_buttons
65420>>>>>  procedure DoExport
65423>>>>>    send PopupFdxSetExport WAY_SET_OF_FIELDS_VW
65424>>>>>  end_procedure
65425>>>>>  procedure DoSelect
65428>>>>>    send PopupFdxFieldSearch
65429>>>>>  end_procedure
65430>>>>>  procedure DoReset
65433>>>>>    send reset to (oFdxSetOfFields(self))
65434>>>>>    send update_display
65435>>>>>  end_procedure
65436>>>>>  procedure DoPrint
65439>>>>>  end_procedure
65440>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
65443>>>>>    send aps_resize (oLst(self)) delta_rw# 0
65444>>>>>    send aps_auto_locate_control (oTxt(self)) sl_down (oLst(self))
65445>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65446>>>>>    send aps_register_multi_button (oBtn1(self))
65447>>>>>    send aps_register_multi_button (oBtn2(self))
65448>>>>>    send aps_register_multi_button (oBtn3(self))
65449>>>>>    send aps_register_multi_button (oBtn4(self))
65450>>>>>    send aps_register_multi_button (oBtn5(self))
65451>>>>>    send aps_locate_multi_buttons
65452>>>>>    send aps_auto_size_container
65453>>>>>  end_procedure
65454>>>>>  procedure update_display
65457>>>>>    send fill_list.i to (oLst(self)) (oFdxSetOfFields(self))
65458>>>>>  end_procedure
65459>>>>>  procedure OnChangeFdx
65462>>>>>    send reset to (oFdxSetOfFields(self))
65463>>>>>    send update_display
65464>>>>>  end_procedure
65465>>>>>  procedure aps_beautify
65468>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65469>>>>>  end_procedure
65470>>>>>  send DFMatrix_Vw_Register WAY_SET_OF_FIELDS_VW self
65471>>>>>end_object // oFdxSetOfFields_Vw
65472>>>>>
65472>>>>>procedure Activate_SetOfFields
65475>>>>>  send popup to (oFdxSetOfFields_Vw(self))
65476>>>>>end_procedure
65477>>>>>
65477>>>>>register_object oTxt
65477>>>>>object oFdxSetOfFieldsModal is a aps.ModalPanel
65479>>>>>  set locate_mode to CENTER_ON_SCREEN
65480>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65481>>>>>  on_key kcancel send close_panel
65482>>>>>  on_key ksave_record send none
65483>>>>>  on_key key_ctrl+key_u send DoUnion
65484>>>>>  on_key key_ctrl+key_i send DoIntersection
65485>>>>>  property integer piFdxSetOfFields public 0
65487>>>>>  object oLst is a cFdxSetOfFieldsList
65489>>>>>    set size to 180 0
65490>>>>>    procedure update_display_counter integer files# integer fields#
65493>>>>>      string str#
65493>>>>>      if fields# move (string(fields#)+" fields from "+string(files#)+" tables") to str#
65496>>>>>      else move "" to str#
65498>>>>>      move (RightShift(str#,30)) to str#
65499>>>>>      set value of (oTxt(self)) item 0 to str#
65500>>>>>    end_procedure
65501>>>>>  end_object
65502>>>>>  object oTxt is a aps.TextBox snap SL_DOWN
65505>>>>>  end_object
65506>>>>>  set auto_size_state of (oTxt(self)) to true
65507>>>>>  object oBtn1 is a aps.Multi_Button
65509>>>>>    on_item "Union"        send DoUnion
65510>>>>>  end_object
65511>>>>>  object oBtn2 is a aps.Multi_Button
65513>>>>>    on_item "Intersection" send DoIntersection
65514>>>>>  end_object
65515>>>>>  object oBtn3 is a aps.Multi_Button
65517>>>>>    on_item "Complement"   send DoComplement
65518>>>>>  end_object
65519>>>>>  object oBtn4 is a aps.Multi_Button
65521>>>>>    on_item t.btn.cancel send close_panel
65522>>>>>  end_object
65523>>>>>  send aps_locate_multi_buttons
65524>>>>>  procedure DoIntersection
65527>>>>>    send DoIntersection.i to (oFdxSetOfFields(self)) (piFdxSetOfFields(self))
65528>>>>>    send update_display to (oFdxSetOfFields_Vw(self))
65529>>>>>    send close_panel
65530>>>>>  end_procedure
65531>>>>>  procedure DoUnion
65534>>>>>    send DoUnion.i to (oFdxSetOfFields(self)) (piFdxSetOfFields(self))
65535>>>>>    send update_display to (oFdxSetOfFields_Vw(self))
65536>>>>>    send close_panel
65537>>>>>  end_procedure
65538>>>>>  procedure DoComplement
65541>>>>>    send DoComplement.i to (oFdxSetOfFields(self)) (piFdxSetOfFields(self))
65542>>>>>    send update_display to (oFdxSetOfFields_Vw(self))
65543>>>>>    send close_panel
65544>>>>>  end_procedure
65545>>>>>  procedure update_display integer oFdxSetOfFields#
65548>>>>>    set label to (psTitle(oFdxSetOfFields#))
65549>>>>>    set piFdxSetOfFields to oFdxSetOfFields#
65550>>>>>    send fill_list.i to (oLst(self)) oFdxSetOfFields#
65551>>>>>  end_procedure
65552>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
65555>>>>>    send aps_resize (oLst(self)) delta_rw# 0
65556>>>>>    send aps_auto_locate_control (oTxt(self)) sl_down (oLst(self))
65557>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65558>>>>>    send aps_register_multi_button (oBtn1(self))
65559>>>>>    send aps_register_multi_button (oBtn2(self))
65560>>>>>    send aps_register_multi_button (oBtn3(self))
65561>>>>>    send aps_register_multi_button (oBtn4(self))
65562>>>>>    send aps_locate_multi_buttons
65563>>>>>    send aps_auto_size_container
65564>>>>>  end_procedure
65565>>>>>  procedure aps_beautify
65568>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65569>>>>>  end_procedure
65570>>>>>end_object
65571>>>>>
65571>>>>>procedure Display_FdxSetOfFields global integer oFdxSetOfFields#
65573>>>>>  send update_display to (oFdxSetOfFieldsModal(self)) oFdxSetOfFields#
65574>>>>>  send popup to (oFdxSetOfFieldsModal(self))
65575>>>>>end_procedure
65576>>>>>
65576>>>>>register_object oTxt
65576>>>>>object oFdxSetOfIndices_Vw is a aps.View label "Set of Indices"
65579>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65580>>>>>  on_key kcancel send close_panel
65581>>>>>  on_key kprompt send DoSelect
65582>>>>>  on_key kclear  send DoReset
65583>>>>>  object oLst is a cFdxSetOfIndicesList
65585>>>>>    set piAllowDelete to dfTrue
65586>>>>>    set size to 180 0
65587>>>>>    procedure update_display_counter integer files# integer indices#
65590>>>>>      string str#
65590>>>>>      if indices# move (string(indices#)+" Indices in "+string(files#)+" tables") to str#
65593>>>>>      else move "(empty)" to str#
65595>>>>>      move (RightShift(str#,30)) to str#
65596>>>>>      set value of (oTxt(self)) item 0 to str#
65597>>>>>    end_procedure
65598>>>>>  end_object
65599>>>>>  object oTxt is a aps.TextBox snap SL_DOWN
65602>>>>>  end_object
65603>>>>>  set auto_size_state of (oTxt(self)) to true
65604>>>>>  object oBtn1 is a aps.Multi_Button
65606>>>>>    on_item "Select Indices" send DoSelect
65607>>>>>  end_object
65608>>>>>  object oBtn2 is a aps.Multi_Button
65610>>>>>    on_item "Export" send DoExport
65611>>>>>  end_object
65612>>>>>  object oBtn3 is a aps.Multi_Button
65614>>>>>    on_item t.btn.reset  send DoReset
65615>>>>>  end_object
65616>>>>>  object oBtn4 is a aps.Multi_Button
65618>>>>>    on_item t.btn.close  send close_panel
65619>>>>>  end_object
65620>>>>>  send aps_locate_multi_buttons
65621>>>>>  procedure DoExport
65624>>>>>    send PopupFdxSetExport WAY_SET_OF_INDICES_VW
65625>>>>>  end_procedure
65626>>>>>  procedure DoSelect
65629>>>>>    send PopupFdxIndicesSearch
65630>>>>>  end_procedure
65631>>>>>  procedure DoReset
65634>>>>>    send reset to (oFdxSetOfIndices(self))
65635>>>>>    send update_display
65636>>>>>  end_procedure
65637>>>>>  procedure DoPrint
65640>>>>>  end_procedure
65641>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
65644>>>>>    send aps_resize (oLst(self)) delta_rw# 0
65645>>>>>    send aps_auto_locate_control (oTxt(self)) sl_down (oLst(self))
65646>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65647>>>>>    send aps_register_multi_button (oBtn1(self))
65648>>>>>    send aps_register_multi_button (oBtn2(self))
65649>>>>>    send aps_register_multi_button (oBtn3(self))
65650>>>>>    send aps_register_multi_button (oBtn4(self))
65651>>>>>    send aps_locate_multi_buttons
65652>>>>>    send aps_auto_size_container
65653>>>>>  end_procedure
65654>>>>>  procedure update_display
65657>>>>>    send fill_list.i to (oLst(self)) (oFdxSetOfIndices(self))
65658>>>>>  end_procedure
65659>>>>>  procedure OnChangeFdx
65662>>>>>    send reset to (oFdxSetOfIndices(self))
65663>>>>>    send update_display
65664>>>>>  end_procedure
65665>>>>>  procedure aps_beautify
65668>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65669>>>>>  end_procedure
65670>>>>>  send DFMatrix_Vw_Register WAY_SET_OF_INDICES_VW self
65671>>>>>end_object // oFdxSetOfIndices_Vw
65672>>>>>
65672>>>>>register_object oTxt
65672>>>>>object oFdxSetOfIndicesModal is a aps.ModalPanel
65674>>>>>  set locate_mode to CENTER_ON_SCREEN
65675>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65676>>>>>  on_key kcancel send close_panel
65677>>>>>  on_key ksave_record send none
65678>>>>>  on_key key_ctrl+key_u send DoUnion
65679>>>>>  on_key key_ctrl+key_i send DoIntersection
65680>>>>>  property integer piFdxSetOfIndices public 0
65682>>>>>  object oLst is a cFdxSetOfIndicesList
65684>>>>>    set size to 180 0
65685>>>>>    procedure update_display_counter integer files# integer indices#
65688>>>>>      string str#
65688>>>>>      if indices# move (string(indices#)+" Indices in "+string(files#)+" tables") to str#
65691>>>>>      else move "" to str#
65693>>>>>      move (RightShift(str#,30)) to str#
65694>>>>>      set value of (oTxt(self)) item 0 to str#
65695>>>>>    end_procedure
65696>>>>>  end_object
65697>>>>>  object oTxt is a aps.TextBox snap SL_DOWN
65700>>>>>  end_object
65701>>>>>  set auto_size_state of (oTxt(self)) to true
65702>>>>>  object oBtn1 is a aps.Multi_Button
65704>>>>>    on_item "Union"        send DoUnion
65705>>>>>  end_object
65706>>>>>  object oBtn2 is a aps.Multi_Button
65708>>>>>    on_item "Intersection" send DoIntersection
65709>>>>>  end_object
65710>>>>>  object oBtn3 is a aps.Multi_Button
65712>>>>>    on_item "Complement"   send DoComplement
65713>>>>>  end_object
65714>>>>>  object oBtn4 is a aps.Multi_Button
65716>>>>>    on_item t.btn.cancel send close_panel
65717>>>>>  end_object
65718>>>>>  send aps_locate_multi_buttons
65719>>>>>  procedure DoIntersection
65722>>>>>    send DoIntersection.i to (oFdxSetOfIndices(self)) (piFdxSetOfIndices(self))
65723>>>>>    send update_display to (oFdxSetOfIndices_Vw(self))
65724>>>>>    send close_panel
65725>>>>>  end_procedure
65726>>>>>  procedure DoUnion
65729>>>>>    send DoUnion.i to (oFdxSetOfIndices(self)) (piFdxSetOfIndices(self))
65730>>>>>    send update_display to (oFdxSetOfIndices_Vw(self))
65731>>>>>    send close_panel
65732>>>>>  end_procedure
65733>>>>>  procedure DoComplement
65736>>>>>    send DoComplement.i to (oFdxSetOfIndices(self)) (piFdxSetOfIndices(self))
65737>>>>>    send update_display to (oFdxSetOfIndices_Vw(self))
65738>>>>>    send close_panel
65739>>>>>  end_procedure
65740>>>>>  procedure update_display integer oFdxSetOfIndices#
65743>>>>>    set label to (psTitle(oFdxSetOfIndices#))
65744>>>>>    set piFdxSetOfIndices to oFdxSetOfIndices#
65745>>>>>    send fill_list.i to (oLst(self)) oFdxSetOfIndices#
65746>>>>>  end_procedure
65747>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
65750>>>>>    send aps_resize (oLst(self)) delta_rw# 0
65751>>>>>    send aps_auto_locate_control (oTxt(self)) sl_down (oLst(self))
65752>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65753>>>>>    send aps_register_multi_button (oBtn1(self))
65754>>>>>    send aps_register_multi_button (oBtn2(self))
65755>>>>>    send aps_register_multi_button (oBtn3(self))
65756>>>>>    send aps_register_multi_button (oBtn4(self))
65757>>>>>    send aps_locate_multi_buttons
65758>>>>>    send aps_auto_size_container
65759>>>>>  end_procedure
65760>>>>>  procedure aps_beautify
65763>>>>>    send aps_align_inside_container_by_moving (oTxt(self)) SL_ALIGN_CENTER
65764>>>>>  end_procedure
65765>>>>>end_object
65766>>>>>
65766>>>>>procedure Display_FdxSetOfIndices global integer oFdxSetOfIndices#
65768>>>>>  send update_display to (oFdxSetOfIndicesModal(self)) oFdxSetOfIndices#
65769>>>>>  send popup to (oFdxSetOfIndicesModal(self))
65770>>>>>end_procedure
65771>>>>>
65771>>>>>procedure Activate_SetOfIndices
65774>>>>>  send popup to (oFdxSetOfIndices_Vw(self))
65775>>>>>end_procedure
65776>>>>>
65776>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
65776>>>>>Use Buttons.utl  // Button texts
65776>>>>>object oFdxSetTransfer is a aps.ModalPanel label "Export set to"
65779>>>>>  set locate_mode to CENTER_ON_SCREEN
65780>>>>>  on_key kcancel send close_panel
65781>>>>>  property integer piOrigin public 0
65783>>>>>  property integer piResult public 0
65785>>>>>  object oRadio is a aps.RadioContainer
65787>>>>>    object oRad1 is a aps.Radio label "Table selector"
65790>>>>>    end_object
65791>>>>>    object oRad2 is a aps.Radio label "Set of tables" snap sl_right_space
65795>>>>>    end_object
65796>>>>>    object oRad3 is a aps.Radio label "Set of fields" snap sl_right_space
65800>>>>>    end_object
65801>>>>>  end_object
65802>>>>>  object oBtn1 is a aps.Multi_Button
65804>>>>>    on_item "Union" send close_panel_ok1
65805>>>>>  end_object
65806>>>>>  object oBtn2 is a aps.Multi_Button
65808>>>>>    on_item "Intersection" send close_panel_ok2
65809>>>>>  end_object
65810>>>>>  object oBtn3 is a aps.Multi_Button
65812>>>>>    on_item t.btn.cancel send close_panel
65813>>>>>  end_object
65814>>>>>  send aps_locate_multi_buttons
65815>>>>>  function private.target returns integer
65818>>>>>    if (current_radio(oRadio(self))) eq 0 function_return WAY_TABLE_SELECTOR_VW
65821>>>>>    if (current_radio(oRadio(self))) eq 1 function_return WAY_SET_OF_TABLES_VW
65824>>>>>    if (current_radio(oRadio(self))) eq 2 function_return WAY_SET_OF_FIELDS_VW
65827>>>>>  end_function
65828>>>>>  procedure DoUnion
65831>>>>>    send DFMatrix_Transfer_Set (piOrigin(self)) (private.target(self)) 0
65832>>>>>  end_procedure
65833>>>>>  procedure DoIntersection
65836>>>>>    send DFMatrix_Transfer_Set (piOrigin(self)) (private.target(self)) 1
65837>>>>>  end_procedure
65838>>>>>  procedure DoPrepare.i integer origin#
65841>>>>>    integer rad#
65841>>>>>    set piOrigin to origin#
65842>>>>>    move (oRadio(self)) to rad#
65843>>>>>    set current_radio of rad# to 0
65844>>>>>    set object_shadow_state of (oRad2(rad#)) to false
65845>>>>>    set object_shadow_state of (oRad3(rad#)) to false
65846>>>>>    if origin# eq WAY_SET_OF_TABLES_VW begin
65848>>>>>      set object_shadow_state of (oRad2(rad#)) to true
65849>>>>>      set object_shadow_state of (oRad3(rad#)) to true
65850>>>>>    end
65850>>>>>>
65850>>>>>    if origin# eq WAY_SET_OF_FIELDS_VW begin
65852>>>>>      set object_shadow_state of (oRad3(rad#)) to true
65853>>>>>    end
65853>>>>>>
65853>>>>>  end_procedure
65854>>>>>  procedure close_panel_ok1
65857>>>>>    set piResult to 1
65858>>>>>    send close_panel
65859>>>>>  end_procedure
65860>>>>>  procedure close_panel_ok2
65863>>>>>    set piResult to 2
65864>>>>>    send close_panel
65865>>>>>  end_procedure
65866>>>>>  procedure popup
65869>>>>>    set piResult to 0
65870>>>>>    forward send popup
65872>>>>>    if (piResult(self)) eq 1 send DoUnion
65875>>>>>    if (piResult(self)) eq 2 send DoIntersection
65878>>>>>  end_procedure
65879>>>>>end_object // oFdxSetTransfer
65880>>>>>
65880>>>>>procedure PopupFdxSetExport global integer origin#
65882>>>>>  send DoPrepare.i to (oFdxSetTransfer(self)) origin#
65883>>>>>  send popup to (oFdxSetTransfer(self))
65884>>>>>end_procedure
65885>>>>>
65885>>>
65885>>>object oFdxDisplayGlobalAttributes is a aps.View label "Global attributes"
65888>>>  on_key kcancel send close_panel
65889>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65890>>>  object oLst is a cFdxGlobalAttrGrid
65892>>>  set peAnchors to (anTop+anLeft+anBottom+anRight)
65893>>>  set peResizeColumn to rcAll
65894>>>  end_object
65895>>>  object oBtn1 is a aps.Multi_Button
65897>>>    on_item "Folders" send Activate_Directory_Contents
65898>>>  set peAnchors to (anBottom+anRight)
65899>>>  end_object
65900>>>  object oBtn2 is a aps.Multi_Button
65902>>>    on_item t.btn.close send close_panel
65903>>>  set peAnchors to (anBottom+anRight)
65904>>>  end_object
65905>>>  send aps_locate_multi_buttons
65906>>>  procedure OnChangeFDX
65909>>>    integer oFDX#
65909>>>    move (fdx.object_id(0)) to oFDX#
65910>>>    send fill_list.i to (oLst(self)) oFDX#
65911>>>    set dynamic_update_state of (oLst(self)) to true
65912>>>  end_procedure
65913>>>  send DFMatrix_Vw_Register WAY_GLOBAL_ATTRIBUTES_VW self
65914>>>end_object // oFdxDisplayGlobalAttributes
65915>>> send aps_SetMinimumDialogSize (oFdxDisplayGlobalAttributes(self))
65916>>>procedure Activate_Global_Attributes
65919>>>  send popup to (oFdxDisplayGlobalAttributes(self))
65920>>>end_procedure
65921>>>
65921>>>object oFdxDisplayFileAttributes is a aps.View label "Table definition"
65924>>>  property integer piFDX_Server public 0
65926>>>  property integer piMain_File  public 0
65928>>>  property integer piIndex      public 1
65930>>>  on_key kcancel send close_panel
65931>>>  on_key key_ctrl+key_d send DoDisplaySelector
65932>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
65933>>>  procedure DoDisplaySelector
65936>>>    send Activate_Table_Selector
65937>>>  end_procedure
65938>>>  object oTabs is a aps.TabDialog
65940>>>    set peAnchors to (anTop+anLeft+anBottom+anRight)
65941>>>    object oTab1 is a aps.TabPage label "Fields"
65944>>>      set p_Auto_Column to false
65945>>>      object oFields is a cFDX.Display.FieldList
65947>>>        set size to 160 0
65948>>>        set peAnchors to (anTop+anLeft+anBottom+anRight)
65949>>>        set peResizeColumn to rcAll
65950>>>      end_object
65951>>>    end_object
65952>>>    register_object oIndexFields
65952>>>    object oTab2 is a aps.TabPage label "Indices"
65955>>>      object oIndexNo is a cFDX.Display.IndexList
65957>>>        set size to 160 0
65958>>>        set peAnchors to (anTop+anBottom)
65959>>>        set peResizeColumn to rcAll
65960>>>        procedure item_change integer from# integer to# returns integer
65963>>>          integer rval#
65963>>>          forward get msg_item_change from# to# to rval#
65965>>>          set piIndex to (rval#+1)
65966>>>          send fill_list to (oIndexFields(self))
65967>>>          send display_info
65968>>>          procedure_return rval#
65969>>>        end_procedure
65970>>>      end_object
65971>>>      set p_auto_column to false
65972>>>      object oIndexFields is a cFDX.Display.IndexSegmentList
65974>>>        set peAnchors to (anTop+anLeft+anBottom+anRight)
65975>>>        set peResizeColumn to rcAll
65976>>>        set size to 160 0
65977>>>      end_object
65978>>>      object oFrm1 is a aps.Form label "Key length:" abstract aft_numeric4.0 snap sl_right_space
65983>>>        set peAnchors to (anTop+anRight)
65984>>>        set object_shadow_state to true
65985>>>      end_object
65986>>>      object oFrm2 is a aps.Form label "Levels:" abstract aft_numeric4.0 snap sl_down
65991>>>        set peAnchors to (anTop+anRight)
65992>>>        set object_shadow_state to true
65993>>>        set label_offset to 0 0
65994>>>        set label_justification_mode to jmode_right
65995>>>      end_object
65996>>>      object oFrm3 is a aps.Form label "Batch:" abstract aft_ascii4 snap sl_down
66001>>>        set peAnchors to (anTop+anRight)
66002>>>        set object_shadow_state to true
66003>>>        set label_offset to 0 0
66004>>>        set label_justification_mode to jmode_right
66005>>>      end_object
66006>>>      procedure display_info
66009>>>        integer idx# attr#
66009>>>        integer file# fdx#
66009>>>        get piMain_File to file#
66010>>>        get piFDX_Server to fdx#
66011>>>        get piIndex to idx#
66012>>>        move (FDX_AttrValue_INDEX(fdx#,DF_INDEX_KEY_LENGTH,file#,idx#)) to attr#
66013>>>        set value of (oFrm1(self)) item 0 to attr#
66014>>>        move (FDX_AttrValue_INDEX(fdx#,DF_INDEX_LEVELS,file#,idx#)) to attr#
66015>>>        set value of (oFrm2(self)) item 0 to attr#
66016>>>        move (FDX_AttrValue_INDEX(fdx#,DF_INDEX_TYPE,file#,idx#)) to attr#
66017>>>        if attr# eq DF_INDEX_TYPE_ONLINE set value of (oFrm3(self)) item 0 to "No"
66020>>>        else                             set value of (oFrm3(self)) item 0 to "Yes"
66022>>>      end_procedure
66023>>>    end_object
66024>>>    object oTab3 is a aps.TabPage label "Attributes"
66027>>>      object oOther is a cFDX.Display.FileOtherList
66029>>>        set size to 160 0
66030>>>        set peAnchors to (anTop+anLeft+anBottom+anRight)
66031>>>        set peResizeColumn to rcAll
66032>>>      end_object
66033>>>    end_object
66034>>>  end_object
66035>>>  object oBtn is a aps.Multi_Button
66037>>>    on_item t.btn.close send close_panel
66038>>>    set peAnchors to (anBottom+anRight)
66039>>>  end_object
66040>>>  send aps_locate_multi_buttons
66041>>>  procedure OnChangeFdxFile
66044>>>    integer oFDX# file#
66044>>>    move (fdx.object_id(0)) to oFDX#
66045>>>    get DFMatrix_Current_File to file#
66046>>>    set piFDX_Server to oFDX#
66047>>>    set piMain_File  to file#
66048>>>    if (active_state(self)) begin // Only if on screen
66050>>>      if (file# and piDataOrigin(oFDX#)<>FDX_EMPTY) begin
66052>>>        send fill_list to (oFields(oTab1(oTabs(self))))
66053>>>        set piIndex to 1
66054>>>        send fill_list to (oIndexNo(oTab2(oTabs(self))))
66055>>>        send fill_list to (oIndexFields(oTab2(oTabs(self))))
66056>>>        send display_info to (oTab2(oTabs(self)))
66057>>>        send fill_list to (oOther(oTab3(oTabs(self)))) oFDX#
66058>>>      end
66058>>>>
66058>>>      else begin
66059>>>        send delete_data to (oFields(oTab1(oTabs(self))))
66060>>>        send delete_data to (oOther(oTab3(oTabs(self))))
66061>>>        send delete_data to (oIndexNo(oTab2(oTabs(self))))
66062>>>        send delete_data to (oIndexFields(oTab2(oTabs(self))))
66063>>>      end
66063>>>>
66063>>>    end
66063>>>>
66063>>>  end_procedure
66064>>>  procedure popup
66067>>>    forward send popup
66069>>>    send OnChangeFdxFile
66070>>>  end_procedure
66071>>>  procedure OnChangeFDX
66074>>>    send OnChangeFdxFile
66075>>>  end_procedure
66076>>>  send DFMatrix_Vw_Register WAY_TABLE_DEFINITION_VW self
66077>>>end_object // oFdxDisplayFileAttributes
66078>>>send aps_SetMinimumDialogSize (oFdxDisplayFileAttributes(self))
66079>>>
66079>>>procedure Activate_Table_Definition
66082>>>  send popup to (oFdxDisplayFileAttributes(self))
66083>>>end_procedure
66084>>>
66084>>>object oDFMatrix_AdvancedSelect_FM is a FloatingPopupMenu
66086>>>  send add_item msg_Activate_SetOfTables "Build set of &tables"
66087>>>  send add_item msg_Activate_SetOfFields "Build set of &fields"
66088>>>  send add_item msg_Activate_SetOfIndices "Build set of &indices"
66089>>>end_object
66090>>>
66090>>>object oUserSelectTables is a aps.View label "Table selector"
66093>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
66094>>>  set pMinimumSize to 225 0 // Size no less than this
66095>>>  on_key kCancel send close_panel
66096>>>  procedure DoDisplayDefinition
66099>>>    integer vw# sz#
66099>>>    move (oFdxDisplayFileAttributes(self)) to vw#
66100>>>    ifnot (active_state(vw#)) begin
66102>>>      send Activate_Table_Definition
66103>>>      set location to 5 5
66104>>>      get size to sz#
66105>>>      move (hi(sz#)) to sz#
66106>>>      send aps_onResize (230-sz#) 0
66107>>>      set location of vw# to 235 5
66108>>>    end
66108>>>>
66108>>>    else send Activate_Table_Definition
66110>>>  end_procedure
66111>>>  register_object oLst
66111>>>  on_key key_ctrl+key_a send select_all_not_bad to (oLst(self))
66112>>>  on_key key_ctrl+key_c send select_none        to (oLst(self))
66113>>>  on_key key_ctrl+key_d send DoDisplayDefinition
66114>>>  on_key key_ctrl+key_h send select_children    to (oLst(self))
66115>>>  on_key key_ctrl+key_i send select_invert      to (oLst(self))
66116>>>  on_key key_ctrl+key_l send load_current_selection.browse to (oLst(self))
66117>>>  on_key key_ctrl+key_m send select_master      to (oLst(self))
66118>>>  on_key key_ctrl+key_p send select_parents     to (oLst(self))
66119>>>  on_key key_ctrl+key_s send save_current_selection.browse to (oLst(self))
66120>>>  on_key key_ctrl+key_g send Activate_Global_Attributes
66121>>>  object oLst is a cFdxFileMultiSelector
66123>>>    set size to 180 0
66124>>>    set piNo_Alias_State to false
66125>>>    set piBad_Entries_State to BAD_ENTRIES_SHADOW
66126>>>    set piGeneric_Display_Name_State to true
66127>>>    on_key key_ctrl+key_d send DoDisplayDefinition
66128>>>    set peAnchors to (anTop+anLeft+anBottom+anRight)
66129>>>    set peResizeColumn to rcAll
66130>>>    procedure sort.i integer by#
66133>>>      forward send sort.i by#
66135>>>      send OnChangeFile 0
66136>>>    end_procedure
66137>>>    procedure OnChangeFile integer row#
66140>>>      if (item_count(self)) begin
66142>>>        if (Row_Shadow_State(self,row#)) send DFMatrix_NewFileInSelector 0
66145>>>        else send DFMatrix_NewFileInSelector (Row_File(self,row#))
66147>>>      end
66147>>>>
66147>>>    end_procedure
66148>>>    procedure row_change integer row_from# integer row_to#
66151>>>      send OnChangeFile row_to#
66152>>>    end_procedure
66153>>>    procedure re_order
66156>>>    end_procedure
66157>>>    procedure update_select_display // This is called automatically by the class
66160>>>      integer selected# total#
66160>>>      get File_Select_Count to selected#
66161>>>      get Row_Count to total#
66162>>>      send select_display selected# total#
66163>>>    end_procedure
66164>>>  end_object // oLst
66165>>>
66165>>>  object oSelectTxt is a aps.TextBox snap sl_right
66168>>>    set peAnchors to (anBottom+anRight)
66169>>>  end_object
66170>>>  set auto_size_state of (oSelectTxt(self)) to true
66171>>>  send aps_align_by_moving (oSelectTxt(self)) (oLst(self)) SL_ALIGN_BOTTOM
66172>>>  procedure select_display integer selected# integer total#
66175>>>    set value of (oSelectTxt(self)) to ("Selected: "+string(selected#)+"/"+string(total#))
66176>>>  end_procedure
66177>>>
66177>>>  object oBtn11 is a aps.multi_button
66179>>>    on_item "&All"      send select_all_not_bad to (oLst(self))
66180>>>    set peAnchors to (anTop+anRight)
66181>>>  end_object
66182>>>  object oBtn12 is a aps.multi_button
66184>>>    on_item "&Clear"    send select_none        to (oLst(self))
66185>>>    set peAnchors to (anTop+anRight)
66186>>>  end_object
66187>>>  object oBtn13 is a aps.multi_button
66189>>>    on_item "&Invert"   send select_invert      to (oLst(self))
66190>>>    set peAnchors to (anTop+anRight)
66191>>>  end_object
66192>>>  object oBtn14 is a aps.multi_button
66194>>>    on_item "&Master"   send select_master      to (oLst(self))
66195>>>    set peAnchors to (anTop+anRight)
66196>>>  end_object
66197>>>  object oBtn15 is a aps.multi_button
66199>>>    on_item "&Parents"  send select_parents     to (oLst(self))
66200>>>    set peAnchors to (anTop+anRight)
66201>>>  end_object
66202>>>  object oBtn16 is a aps.multi_button
66204>>>    on_item "C&hildren" send select_children    to (oLst(self))
66205>>>    set peAnchors to (anTop+anRight)
66206>>>  end_object
66207>>>  object oBtn17 is a aps.multi_button
66209>>>    procedure DoAction
66212>>>      send popup to (oDFMatrix_AdvancedSelect_FM(self))
66213>>>    end_procedure
66214>>>    on_item "Advanced" send DoAction
66215>>>    set peAnchors to (anTop+anRight)
66216>>>  end_object
66217>>>  object oBtn18 is a aps.multi_button
66219>>>    on_item "Show &definition" send DoDisplayDefinition
66220>>>    set peAnchors to (anTop+anRight)
66221>>>  end_object
66222>>>  send aps_register_multi_button (oBtn18(self))
66223>>>
66223>>>  object oBtn19 is a aps.multi_button
66225>>>    on_item "&Global attr." send Activate_Global_Attributes
66226>>>    set peAnchors to (anTop+anRight)
66227>>>  end_object
66228>>>  send aps_locate_multi_buttons sl_vertical
66229>>>  send aps_goto_max_row
66230>>>  send aps_make_row_space 3
66231>>>  object oLine is a aps.LineControl
66233>>>    set peAnchors to (anBottom+anRight+anLeft)
66234>>>  end_object
66235>>>  object oBtn1 is a aps.multi_button
66237>>>    on_item "&Load selection" send load_current_selection.browse to (oLst(self))
66238>>>    set peAnchors to (anBottom+anRight)
66239>>>  end_object
66240>>>  object oBtn2 is a aps.multi_button
66242>>>    on_item "&Save selection" send save_current_selection.browse to (oLst(self))
66243>>>    set peAnchors to (anBottom+anRight)
66244>>>  end_object
66245>>>  object oBtn3 is a aps.multi_button
66247>>>    on_item "Close"          send close_panel
66248>>>    set peAnchors to (anBottom+anRight)
66249>>>  end_object
66250>>>  send aps_locate_multi_buttons
66251>>>  function iCallback_Selected_Files integer get# integer obj# returns integer
66254>>>    integer rval#
66254>>>    get iCallback_Selected_Files_Server of (oLst(self)) get# obj# to rval#
66255>>>    function_return rval#
66256>>>  end_function
66257>>>  procedure OnChangeFdx
66260>>>    integer oFDX# lst#
66260>>>    move (oLst(self)) to lst#
66261>>>    move (fdx.object_id(0)) to oFDX#
66262>>>    set piFDX_Server of lst# to oFDX#
66263>>>    send fill_list_all_files to lst#
66264>>>    set dynamic_update_state of lst# to true
66265>>>    send OnChangeFile to lst# 0
66266>>>  end_procedure
66267>>>  procedure aps_beautify
66270>>>    send APS_ALIGN_INSIDE_CONTAINER_BY_SIZING (oLine(self)) SL_ALIGN_RIGHT
66271>>>  end_procedure
66272>>>  send DFMatrix_Vw_Register WAY_TABLE_SELECTOR_VW self
66273>>>end_object // oUserSelectTables
66274>>>send aps_SetMinimumDialogSize (oUserSelectTables(self))
66275>>>
66275>>>procedure Activate_Table_Selector
66278>>>  send popup to (oUserSelectTables(self))
66279>>>end_procedure
66280>>>register_object oList
66280>>>object oListDirectoryContents is a aps.View label "Directory contents"
66283>>>  on_key kcancel send close_panel
66284>>>  property integer piFDX_Server public 0
66286>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
66287>>>  object oPaths is a aps.ComboFormAux label "Constrain directory:"
66290>>>    set combo_sort_state to false
66291>>>    set form_margin item 0 to 60
66292>>>    set entry_state item 0 to false
66293>>>    procedure fill
66296>>>      integer obj# itm# max#
66296>>>      send Combo_Delete_Data
66297>>>      send combo_add_item "All" 0
66298>>>      move (oListDir_SnapShot(piFDX_Server(self))) to obj#
66299>>>      get iPath_Count of obj# to max#
66300>>>      for itm# from 0 to (max#-1)
66306>>>>
66306>>>        send combo_add_item (sPath.i(obj#,itm#)) (itm#+1)
66307>>>      loop
66308>>>>
66308>>>    end_procedure
66309>>>    procedure OnChange
66312>>>      string path#
66312>>>      get value item 0 to path#
66313>>>      if path# eq "All" move "" to path#
66316>>>      set psConstrainPath of (oList(self)) to path#
66317>>>      send fill_list to (oList(self))
66318>>>    end_procedure
66319>>>  end_object
66320>>>  send aps_goto_max_row
66321>>>  object oList is a cSetOfFilesList
66323>>>    set size to 196 0
66324>>>    procedure fill_list_start
66327>>>      set piSetOfFilesObject to (oListDir_SnapShot(piFDX_Server(self)))
66328>>>      send fill_list
66329>>>      send fill_other
66330>>>    end_procedure
66331>>>    procedure display_totals number file_count# number total_bytes#
66334>>>      send total_display (SEQ_FileSizeToString(total_bytes#)+" in "+string(file_count#)+" files")
66335>>>    end_procedure
66336>>>  end_object
66337>>>  send aps_goto_max_row
66338>>>
66338>>>  object oSelectTxt is a aps.TextBox
66340>>>  end_object
66341>>>  set auto_size_state of (oSelectTxt(self)) to true
66342>>>  procedure total_display string str#
66345>>>    set value of (oSelectTxt(self)) to str#
66346>>>  end_procedure
66347>>>  procedure fill_other // is called from oList object
66350>>>    send fill to (oPaths(self))
66351>>>  end_procedure
66352>>>  set multi_button_size to 14 80
66353>>>  object oBtn1 is a aps.Multi_Button
66355>>>    on_item "Read folders" send DFMatrix_OpenDirectoryContents
66356>>>  end_object
66357>>>  object oBtn2 is a aps.Multi_Button
66359>>>    on_item t.btn.close send close_panel
66360>>>  end_object
66361>>>  send aps_locate_multi_buttons
66362>>>  procedure OnChangeFdx
66365>>>    integer oFDX#
66365>>>    move (fdx.object_id(0)) to oFDX#
66366>>>    set piFDX_Server to oFDX#
66367>>>    send fill_list_start to (oList(self))
66368>>>  end_procedure
66369>>>  send DFMatrix_Vw_Register WAY_DIRECTORY_CONTENTS_VW self
66370>>>end_object // oListDirectoryContents
66371>>>procedure Activate_Directory_Contents
66374>>>  send popup to (oListDirectoryContents(self))
66375>>>end_procedure
66376>    Use StrucTrc.vw  // Object for tracing a restructure operation
Including file: structrc.vw    (C:\Apps\VDFQuery\AppSrc\structrc.vw)
66376>>>Use StrucTrc.utl // Object for tracing a restructure operation
66376>>>
66376>>>activate_view Activate_RestructureTracer for oRestructureTracer
66381>>>object oRestructureTracer is a aps.View label "Trace restructure operation"
66384>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
66385>>>  on_key kcancel send close_panel
66386>>>  object oLst is a cRSTraceList
66388>>>    on_key kenter send display_definition
66389>>>    set size to 150 400
66390>>>  end_object
66391>>>  object oBtn1 is a aps.Multi_Button
66393>>>    on_item "Load trace" send load_trace to (oLst(self))
66394>>>  end_object
66395>>>  object oBtn2 is a aps.Multi_Button
66397>>>    on_item t.btn.close send close_panel
66398>>>  end_object
66399>>>  send aps_locate_multi_buttons
66400>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
66403>>>    send aps_resize (oLst(self)) delta_rw# 0
66404>>>    send aps_register_multi_button (oBtn1(self))
66405>>>    send aps_register_multi_button (oBtn2(self))
66406>>>    send aps_locate_multi_buttons
66407>>>    send aps_auto_size_container
66408>>>  end_procedure
66409>>>// procedure popup
66409>>>//   send fill_list to (oLst(self))
66409>>>//   forward send popup
66409>>>// end_procedure
66409>>>end_object
66410>>>
66410>>>procedure Activate_RestructureTracer_With_File string fn#
66413>>>  send load_trace_file to (oFdxTraceArray(self)) fn#
66414>>>  send fill_list to (oLst(oRestructureTracer(self)))
66415>>>  send popup to (oRestructureTracer(self))
66416>>>  send activate_scope to (oRestructureTracer(self))
66417>>>end_procedure
66418>    Use DFScript.vw  // DFScript test
Including file: dfscript.vw    (C:\Apps\VDFQuery\AppSrc\dfscript.vw)
66418>>>// Use DFScript.vw  // DFScript test
66418>>>Use DFScript.utl // DF-Script interpreter
Including file: dfscript.utl    (C:\Apps\VDFQuery\AppSrc\dfscript.utl)
66418>>>>>//**********************************************************************
66418>>>>>// Use DFScript.utl // DF-Script interpreter
66418>>>>>//
66418>>>>>// by Sture Andersen
66418>>>>>//
66418>>>>>// Create: Fri  15-10-1999
66418>>>>>// Update:
66418>>>>>//
66418>>>>>//
66418>>>>>//
66418>>>>>//  ========================= SCRIPT SYNTAX: ===========================
66418>>>>>//
66418>>>>>//
66418>>>>>// INTEGER {symbol}+                      Global variable declaration(s)
66418>>>>>// STRING {symbol}+                       Global variable declaration(s)
66418>>>>>// NUMBER {symbol}+                       Global variable declaration(s)
66418>>>>>// DATE {symbol}+                         Global variable declaration(s)
66418>>>>>// MOVE {value} to {varname}              Assign value to variable
66418>>>>>// #REPLACE {symbol} {value}              Create compiler symbol
66418>>>>>// #NOISY {0|1}                           Toggles interpreter debug state
66418>>>>>// PAUSE                                  Pause program execution
66418>>>>>// GOTO {label}                           Jump to specified label
66418>>>>>// GOSUB {label}                          Execute subrutine
66418>>>>>// RETURN                                 Return from subroutine
66418>>>>>// ABORT                                  Halts program execution
66418>>>>>// INPUT {prompt} {varname}               Lets the operator enter a value
66418>>>>>// DEBUG {ON|OFF|SINGLE_STEP|DISPLAY_VAR} Control debug status
66418>>>>>// GOTOXY {line} {column}                 Positions the cursor (character mode)
66418>>>>>// CLEARSCREEN                            Blanks the screen
66418>>>>>//
66418>>>>>// DELETE_FIELD {field}
66418>>>>>// CREATE_FIELD {field} {name} {type}
66418>>>>>// SET_ATTRIBUTE {}
66418>>>>>// DELETE_INDEX {index}
66418>>>>>//
66418>>>>>//**********************************************************************
66418>>>>>
66418>>>>>
66418>>>>>Use APS         // Auto Positioning and Sizing classes for VDF
66418>>>>>Use vMachine.utl // Virtual machine class
Including file: vmachine.utl    (C:\Apps\VDFQuery\AppSrc\vmachine.utl)
66418>>>>>>>//**********************************************************************
66418>>>>>>>// Use vMachine.utl // Virtual machine class (heart of DFScript)
66418>>>>>>>//
66418>>>>>>>// By Sture Andersen
66418>>>>>>>//
66418>>>>>>>// Create: Fri  01-10-1999
66418>>>>>>>// Update: Fri  15-10-1999 - Now handles DBMS field
66418>>>>>>>//                         - Repeat/Until macro added
66418>>>>>>>//
66418>>>>>>>//
66418>>>>>>>//   Functions for dbQuery:
66418>>>>>>>//
66418>>>>>>>//               Strings
66418>>>>>>>//
66418>>>>>>>//     Simple    Left
66418>>>>>>>//               Right
66418>>>>>>>//               Mid
66418>>>>>>>//               Pos
66418>>>>>>>//               Uppercase
66418>>>>>>>//               Lowercase
66418>>>>>>>//
66418>>>>>>>//     Advanced
66418>>>>>>>//
66418>>>>>>>//
66418>>>>>>>//               Dates
66418>>>>>>>//
66418>>>>>>>//     Simple    DateCompose     integer liDay integer liMonth integer liYear returns date
66418>>>>>>>//               StringToDate    string lsDate integer liFormat integer lbLong string lsSep returns date
66418>>>>>>>//               DateToString    date ldDate integer liFormat integer lbLong string lsSep returns string
66418>>>>>>>//               DateIncrement   date ldDate integer liSegment integer liAmount returns date
66418>>>>>>>//               DateSegment     date ldDate integer liSegment returns integer
66418>>>>>>>//               FirstDayInMonth date ldDate returns date
66418>>>>>>>//               LastDayInMonth  date ldDate returns date
66418>>>>>>>//               FirstDayInYear  date ldDate returns date
66418>>>>>>>//               LastDayInYear   date ldDate returns date
66418>>>>>>>//               DateWeekNumber  date ldDate returns integer
66418>>>>>>>//               DayName         integer liWeekDay returns string
66418>>>>>>>//               DateDayNumber   date ldDate returns integer
66418>>>>>>>//               DateDayName     date ldDate returns string
66418>>>>>>>//               WeekToDate      integer liYear integer liWeek returns date
66418>>>>>>>//               MonthName       integer liMonth returns string
66418>>>>>>>//               DateMonthName   date ldDate returns string
66418>>>>>>>//               DateAsText      date ldDate string lsFormat returns string
66418>>>>>>>//               SysDate         returns date
66418>>>>>>>//
66418>>>>>>>//**********************************************************************
66418>>>>>>>
66418>>>>>>>Use Base.nui
66418>>>>>>>Use MsgBox.utl   // obs procedure
66418>>>>>>>Use Strings.nui  // String manipulation for VDF
66418>>>>>>>Use DBMS.utl     // Basic DBMS functions
66418>>>>>>>Use Focus.utl    // Retrieve basic information about object
66418>>>>>>>Use Structur.utl // Object for restructuring table definitions
66418>>>>>>>Use API_Attr.nui // Database API attributes characteristics
66418>>>>>>>Use Spec0006.utl // Function MakeStringConstant and MakeStringConstantMax255
Including file: spec0006.utl    (C:\Apps\VDFQuery\AppSrc\spec0006.utl)
66418>>>>>>>>>// Use Spec0006.utl // Function MakeStringConstant
66418>>>>>>>>>
66418>>>>>>>>>Use Strings.nui  // String manipulation for VDF
66418>>>>>>>>>
66418>>>>>>>>>//> If the length of the return value is two longer than the length of
66418>>>>>>>>>//> the passed argument, the function only put qoutes around it. Otherwise
66418>>>>>>>>>//> the argument has been converted to a concatenation of string constants.
66418>>>>>>>>>//>
66418>>>>>>>>>//>  World tour '99          becomes   "World tour '99"
66418>>>>>>>>>//>  7" nails                becomes   '7" nails'
66418>>>>>>>>>//>  10" reels for an '88    becomes   "10"+'" reels for an '+"'88"
66418>>>>>>>>>//
66418>>>>>>>>>
66418>>>>>>>>>function MakeStringConstant global string str# returns string
66420>>>>>>>>>  integer len# pos#
66420>>>>>>>>>  string char# rval# current_quote#
66420>>>>>>>>>  ifnot "'" in str# function_return ("'"+str#+"'")
66423>>>>>>>>>  ifnot '"' in str# function_return ('"'+str#+'"')
66426>>>>>>>>>  move "" to rval#
66427>>>>>>>>>  move (length(str#)) to len#
66428>>>>>>>>>  if (left(str#,1)) eq '"' move "'" to current_quote#
66431>>>>>>>>>  else move '"' to current_quote#
66433>>>>>>>>>  move current_quote# to rval#
66434>>>>>>>>>  for pos# from 0 to len#
66440>>>>>>>>>>
66440>>>>>>>>>    move (mid(str#,1,pos#)) to char#
66441>>>>>>>>>    if char# eq current_quote# begin
66443>>>>>>>>>      move (rval#+current_quote#+"+") to rval#
66444>>>>>>>>>      if current_quote# eq "'" move '"' to current_quote#
66447>>>>>>>>>      else move "'" to current_quote#
66449>>>>>>>>>      move (rval#+current_quote#) to rval#
66450>>>>>>>>>    end
66450>>>>>>>>>>
66450>>>>>>>>>    move (rval#+char#) to rval#
66451>>>>>>>>>  loop
66452>>>>>>>>>>
66452>>>>>>>>>  move (rval#+current_quote#) to rval#
66453>>>>>>>>>  function_return rval#
66454>>>>>>>>>end_function
66455>>>>>>>>>
66455>>>>>>>>>function MakeStringConstantMax255Help global string str# returns string
66457>>>>>>>>>  integer len# pos#
66457>>>>>>>>>  string char# rval# current_quote#
66457>>>>>>>>>  ifnot "'" in str# function_return ("'"+str#+"'")
66460>>>>>>>>>  ifnot '"' in str# function_return ('"'+str#+'"')
66463>>>>>>>>>  move "" to rval#
66464>>>>>>>>>  move (length(str#)) to len#
66465>>>>>>>>>  if (left(str#,1)) eq '"' move "'" to current_quote#
66468>>>>>>>>>  else move '"' to current_quote#
66470>>>>>>>>>  move current_quote# to rval#
66471>>>>>>>>>  for pos# from 0 to len#
66477>>>>>>>>>>
66477>>>>>>>>>    move (mid(str#,1,pos#)) to char#
66478>>>>>>>>>    if char# eq current_quote# begin
66480>>>>>>>>>      move (rval#+current_quote#+"+") to rval#
66481>>>>>>>>>      if current_quote# eq "'" move '"' to current_quote#
66484>>>>>>>>>      else move "'" to current_quote#
66486>>>>>>>>>      move (rval#+current_quote#) to rval#
66487>>>>>>>>>    end
66487>>>>>>>>>>
66487>>>>>>>>>    move (rval#+char#) to rval#
66488>>>>>>>>>  loop
66489>>>>>>>>>>
66489>>>>>>>>>  move (rval#+current_quote#) to rval#
66490>>>>>>>>>  function_return rval#
66491>>>>>>>>>end_function
66492>>>>>>>>>
66492>>>>>>>>>function MakeStringConstantMax255 global string str# returns string
66494>>>>>>>>>  integer liLen liPos
66494>>>>>>>>>  string lsRval lsChunk
66494>>>>>>>>>  move (length(str#)) to liLen
66495>>>>>>>>>  move "" to lsRval
66496>>>>>>>>>  for liPos from 0 to (liLen-1/250)
66502>>>>>>>>>>
66502>>>>>>>>>    if liPos move (lsRval+"+") to lsRval
66505>>>>>>>>>    move (mid(str#,250,liPos*250+1)) to lsChunk
66506>>>>>>>>>    move (lsRval+MakeStringConstantMax255Help(lsChunk)) to lsRval
66507>>>>>>>>>  loop
66508>>>>>>>>>>
66508>>>>>>>>>  function_return lsRval
66509>>>>>>>>>end_function
66510>>>>>>>>>
66510>>>>>>>Use FdxField.utl // FDX Field things
Including file: fdxfield.utl    (C:\Apps\VDFQuery\AppSrc\fdxfield.utl)
66510>>>>>>>>>Use FdxField.nui // FDX Field things
66510>>>>>>>Use Dates.nui    // Date routines (No User Interface)
66510>>>>>>>Use Output.utl   // Sequential output to whatever
66510>>>>>>>Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface)
66510>>>>>>>//  Use LogFile.nui  // Class for handling a log file (No User Interface)
66510>>>>>>>//
66510>>>>>>>//  object oVMLogFile is a cLogFile
66510>>>>>>>//    set psFileName to "vmachine.log"
66510>>>>>>>//    set piCloseOnWrite to DFTRUE
66510>>>>>>>//    set psPurpose to "Expression evaluation log"
66510>>>>>>>//    send DirectOutput
66510>>>>>>>//  end_object
66510>>>>>>>
66510>>>>>>>
66510>>>>>>>Enumeration_List // Operation codes for Virtual Machine
66510>>>>>>>  define OP_NOP             // Do nothing!
66510>>>>>>>  define OP_ABORT           // Stop program execution
66510>>>>>>>  define OP_CLEARSCREEN     // Clear the screen
66510>>>>>>>  define OP_GOSUB           // Call subrutine
66510>>>>>>>  define OP_GOTO            // Goto label
66510>>>>>>>  define OP_RETURN          // Return from subrutine
66510>>>>>>>  define OP_PAUSE           // Pauses program execution
66510>>>>>>>  define OP_GOTOXY          // Positions the cursor on a character mode screen
66510>>>>>>>  define OP_INPUT           // Input from the keyboard
66510>>>>>>>  define OP_SHOW            // Display on virtual console
66510>>>>>>>  define OP_SHOWLN          // Display on virtual console
66510>>>>>>>  define OP_SEQFILE         // Open/close/append sequential file
66510>>>>>>>  define OP_WRITE           // Write to currently open sequential out file
66510>>>>>>>  define OP_WRITELN         // Write to currently open sequential out file
66510>>>>>>>  define OP_READ            // Read from currently open sequential in file
66510>>>>>>>  define OP_READLN          // Read from currently open sequential in file
66510>>>>>>>  define OP_MSGBOX          // Display a message box
66510>>>>>>>  define OP_ASSIGN          // Assign value to variable or a field
66510>>>>>>>  define OP_GVAR_INCR       // Increment integer variable by amount
66510>>>>>>>  define OP_GVAR_DISPLAY    // Display global variable (debug purposes)
66510>>>>>>>  define OP_IF_GOTO         // Conditioned jump (x<>0)
66510>>>>>>>  define OP_IF_GOSUB        // Conditioned gosub (x<>0)
66510>>>>>>>  define OP_IFTEST_GOTO     // Conditioned jump (x comp y)
66510>>>>>>>  define OP_IFTEST_GOSUB    // Conditioned gosub (x comp y)
66510>>>>>>>  define OP_DEBUG           // Turn debug on and off
66510>>>>>>>  define OP_LOG_OPEN        // Open file for logging
66510>>>>>>>  define OP_LOG_CLOSE       // Close log file
66510>>>>>>>  define OP_LOG_DISPLAY     // Display log file
66510>>>>>>>  define OP_LOG_FLUSH       // Flush log file (momentarily close/open)
66510>>>>>>>  define OP_LOG_WRITE       // Write something to log file
66510>>>>>>>  define OP_LOG_WRITELN     // WriteLn something to log file
66510>>>>>>>  define OP_API_FILELIST    // Set_Attribute (filelist)
66510>>>>>>>  define OP_API_FILE        // Set_Attribute (file)
66510>>>>>>>  define OP_API_FIELD       // Set_Attribute (field)
66510>>>>>>>  define OP_API_INDEX       // Set_Attribute (index)
66510>>>>>>>  define OP_API_IDXSEG      // Set_Attribute (idxseg)
66510>>>>>>>  define OP_API_STRUCTURE_ABORT // Structure abort
66510>>>>>>>  define OP_API_STRUCTURE_END   // Structure end
66510>>>>>>>  define OP_API_PROBE_END       // Probe end
66510>>>>>>>  define OP_API_DELETEINDEX     // Delete index
66510>>>>>>>  define OP_API_DELETEFIELD     // Delete field
66510>>>>>>>  define OP_API_APPENDFIELD     // Append field
66510>>>>>>>  define OP_API_CREATEFIELD     // Create field
66510>>>>>>>  define OP_API_SETFIELDNUMBER  // Set implicit field number
66510>>>>>>>  define cBasicVirtualMachine.NEXT_OP // Augmentation codes starts here
66510>>>>>>>End_Enumeration_List
66510>>>>>>>
66510>>>>>>>Enumeration_List // Variable types
66510>>>>>>>  define VARTYP_VOID     // Return type for procedures
66510>>>>>>>  define VARTYP_INTEGER
66510>>>>>>>  define VARTYP_DATE
66510>>>>>>>  define VARTYP_NUMBER
66510>>>>>>>  define VARTYP_STRING
66510>>>>>>>End_Enumeration_List
66510>>>>>>>
66510>>>>>>>Enumeration_List // Field types
66510>>>>>>>  define FLDTYP_DATE
66510>>>>>>>  define FLDTYP_NUMBER
66510>>>>>>>  define FLDTYP_STRING
66510>>>>>>>  define FLDTYP_BINARY
66510>>>>>>>  define FLDTYP_OVERLAP
66510>>>>>>>  define FLDTYP_TEXT
66510>>>>>>>End_Enumeration_List
66510>>>>>>>
66510>>>>>>>Enumeration_List // Comparison modes
66510>>>>>>>  define COMP_LT
66510>>>>>>>  define COMP_LE
66510>>>>>>>  define COMP_EQ
66510>>>>>>>  define COMP_GE
66510>>>>>>>  define COMP_GT
66510>>>>>>>  define COMP_NE
66510>>>>>>>End_Enumeration_List
66510>>>>>>>
66510>>>>>>>Enumeration_List // Argument types
66510>>>>>>>  define AT_NOT_VALID
66510>>>>>>>  define AT_CINT
66510>>>>>>>  define AT_CSTR
66510>>>>>>>  define AT_CNUM
66510>>>>>>>  define AT_CDAT
66510>>>>>>>  define AT_VAR
66510>>>>>>>  define AT_VARNO
66510>>>>>>>  define AT_EXPR
66510>>>>>>>  define AT_LBL
66510>>>>>>>  define AT_FIELD
66510>>>>>>>  define AT_FIELDNO
66510>>>>>>>  define AT_ARRAY_ID
66510>>>>>>>  define AT_ARRAY_ELEM
66510>>>>>>>End_Enumeration_List
66510>>>>>>>
66510>>>>>>>function iCompStringToInt.s global string lsComp returns integer
66512>>>>>>>  move (uppercase(lsComp)) to lsComp
66513>>>>>>>  if lsComp eq "LT" function_return COMP_LT
66516>>>>>>>  if lsComp eq "LE" function_return COMP_LE
66519>>>>>>>  if lsComp eq "EQ" function_return COMP_EQ
66522>>>>>>>  if lsComp eq "GE" function_return COMP_GE
66525>>>>>>>  if lsComp eq "GT" function_return COMP_GT
66528>>>>>>>  if lsComp eq "NE" function_return COMP_NE
66531>>>>>>>  function_return -1
66532>>>>>>>end_function
66533>>>>>>>
66533>>>>>>>function iArgType_Const.i global integer liType returns integer
66535>>>>>>>  if liType eq AT_CINT function_return 1
66538>>>>>>>  if liType eq AT_CSTR function_return 1
66541>>>>>>>  if liType eq AT_CNUM function_return 1
66544>>>>>>>  if liType eq AT_CDAT function_return 1
66547>>>>>>>  function_return 0
66548>>>>>>>end_function
66549>>>>>>>
66549>>>>>>>function sArgtype_Name.i global integer liType returns string
66551>>>>>>>  if liType eq AT_CINT  function_return "CnstInt"
66554>>>>>>>  if liType eq AT_CSTR  function_return "CnstStr"
66557>>>>>>>  if liType eq AT_CNUM  function_return "CnstNum"
66560>>>>>>>  if liType eq AT_CDAT  function_return "CnstDat"
66563>>>>>>>  if liType eq AT_VAR   function_return "VarName"
66566>>>>>>>  if liType eq AT_VARNO function_return "VarNo"
66569>>>>>>>  if liType eq AT_EXPR  function_return "Expr"
66572>>>>>>>  if liType eq AT_LBL   function_return "Lbl"
66575>>>>>>>  if liType eq AT_FIELD function_return "Field"
66578>>>>>>>  if liType eq AT_FIELDNO function_return "FieldNo"
66581>>>>>>>  if liType eq AT_ARRAY_ID function_return "Array ID"
66584>>>>>>>  if liType eq AT_ARRAY_ELEM function_return "Array Index"
66587>>>>>>>  function_return "Unknown argtype"
66588>>>>>>>end_function
66589>>>>>>>
66589>>>>>>>class cOpCodes is a cArray
66590>>>>>>>  item_property_list
66590>>>>>>>    item_property string  psName.i
66590>>>>>>>    item_property integer piMessage.i
66590>>>>>>>    item_property integer piParameters.i // Number of parameters
66590>>>>>>>    item_property integer psFormat.i     // Format of parameters
66590>>>>>>>    item_property integer piSpecialAddMsg.i
66590>>>>>>>  end_item_property_list cOpCodes
#REM 66631 DEFINE FUNCTION PISPECIALADDMSG.I INTEGER LIROW RETURNS INTEGER
#REM 66635 DEFINE PROCEDURE SET PISPECIALADDMSG.I INTEGER LIROW INTEGER VALUE
#REM 66639 DEFINE FUNCTION PSFORMAT.I INTEGER LIROW RETURNS INTEGER
#REM 66643 DEFINE PROCEDURE SET PSFORMAT.I INTEGER LIROW INTEGER VALUE
#REM 66647 DEFINE FUNCTION PIPARAMETERS.I INTEGER LIROW RETURNS INTEGER
#REM 66651 DEFINE PROCEDURE SET PIPARAMETERS.I INTEGER LIROW INTEGER VALUE
#REM 66655 DEFINE FUNCTION PIMESSAGE.I INTEGER LIROW RETURNS INTEGER
#REM 66659 DEFINE PROCEDURE SET PIMESSAGE.I INTEGER LIROW INTEGER VALUE
#REM 66663 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 66667 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
66672>>>>>>>  procedure add_opcode integer liOpCode string lsName integer lhMsg integer liParams integer lhSpecial_add_msg
66674>>>>>>>    set psName.i          liOpCode to lsName
66675>>>>>>>    set piMessage.i       liOpCode to lhMsg
66676>>>>>>>    set piParameters.i    liOpCode to liParams
66677>>>>>>>    set piSpecialAddMsg.i liOpCode to lhSpecial_add_msg
66678>>>>>>>  end_procedure
66679>>>>>>>end_class // cOpCodes
66680>>>>>>>
66680>>>>>>>function VmIntIf global integer lbCondition integer liTrue integer liFalse returns integer
66682>>>>>>>  if lbCondition function_return liTrue
66685>>>>>>>  function_return liFalse
66686>>>>>>>end_function
66687>>>>>>>function VmNumIf global integer lbCondition number lnTrue number lnFalse returns number
66689>>>>>>>  if lbCondition function_return lnTrue
66692>>>>>>>  function_return lnFalse
66693>>>>>>>end_function
66694>>>>>>>function VmStrIf global integer lbCondition string lsTrue string lsFalse returns string
66696>>>>>>>  if lbCondition function_return lsTrue
66699>>>>>>>  function_return lsFalse
66700>>>>>>>end_function
66701>>>>>>>function VmDatIf global integer lbCondition date ldTrue date ldFalse returns date
66703>>>>>>>  if lbCondition function_return ldTrue
66706>>>>>>>  function_return ldFalse
66707>>>>>>>end_function
66708>>>>>>>
66708>>>>>>>class cDeclaredArrays is a cArray
66709>>>>>>>  item_property_list
66709>>>>>>>    item_property string  psName.i
66709>>>>>>>    item_property integer piObject.i
66709>>>>>>>    item_property integer piType.i // VARTYP_INTEGER, VARTYP_NUMBER, VARTYP_DATE or VARTYP_STRING
66709>>>>>>>  end_item_property_list cDeclaredArrays
#REM 66744 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 66748 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
#REM 66752 DEFINE FUNCTION PIOBJECT.I INTEGER LIROW RETURNS INTEGER
#REM 66756 DEFINE PROCEDURE SET PIOBJECT.I INTEGER LIROW INTEGER VALUE
#REM 66760 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 66764 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
66769>>>>>>>  procedure reset
66771>>>>>>>    integer liRow max# obj#
66771>>>>>>>    get row_count to max#
66772>>>>>>>    for liRow from 0 to (max#-1)
66778>>>>>>>>
66778>>>>>>>      get piObject.i liRow to obj#
66779>>>>>>>      if obj# send request_destroy_object to obj#
66782>>>>>>>    loop
66783>>>>>>>>
66783>>>>>>>    send delete_data
66784>>>>>>>  end_procedure
66785>>>>>>>  function iRowToObjectID.i integer liRow returns integer
66787>>>>>>>    integer obj#
66787>>>>>>>    get piObject.i liRow to obj#
66788>>>>>>>    ifnot obj# begin
66790>>>>>>>      object oArray is an cArray
66792>>>>>>>        move self to obj#
66793>>>>>>>      end_object
66794>>>>>>>    end
66794>>>>>>>>
66794>>>>>>>    function_return obj#
66795>>>>>>>  end_function
66796>>>>>>>  procedure Array_Reset integer liRow
66798>>>>>>>    send delete_data to (iRowToObjectID.i(self,liRow))
66799>>>>>>>  end_procedure
66800>>>>>>>  function iNameToNumber.s string lsName returns integer
66802>>>>>>>    integer liRow liMax
66802>>>>>>>    move (uppercase(lsName)) to lsName
66803>>>>>>>    get row_count to liMax
66804>>>>>>>    for liRow from 0 to (liMax-1)
66810>>>>>>>>
66810>>>>>>>      if lsName eq (psName.i(self,liRow)) function_return liRow
66813>>>>>>>    loop
66814>>>>>>>>
66814>>>>>>>    function_return -1
66815>>>>>>>  end_function
66816>>>>>>>  procedure declare_array string lsName integer liType
66818>>>>>>>    integer liRow
66818>>>>>>>    get row_count to liRow
66819>>>>>>>    set psName.i   liRow to (uppercase(lsName))
66820>>>>>>>    set piObject.i liRow to 0
66821>>>>>>>    set piType.i   liRow to liType
66822>>>>>>>  end_procedure
66823>>>>>>>  procedure Assign_Value integer liRow integer liItem string lsValue
66825>>>>>>>    integer liType lhObj
66825>>>>>>>    get piObject.i liRow to lhObj
66826>>>>>>>    get piType.i   liRow to liType
66827>>>>>>>    if liType eq VARTYP_INTEGER set value of lhObj item liItem to (integer(lsValue))
66830>>>>>>>    if liType eq VARTYP_NUMBER  set value of lhObj item liItem to (number(lsValue))
66833>>>>>>>    if liType eq VARTYP_DATE    set value of lhObj item liItem to (date(lsValue))
66836>>>>>>>    if liType eq VARTYP_STRING  set value of lhObj item liItem to (string(lsValue))
66839>>>>>>>  end_procedure
66840>>>>>>>  function sAssigned_Value.ii integer liRow integer liItem returns string
66842>>>>>>>    function_return (value(piObject.i(self,liRow),liItem))
66843>>>>>>>  end_function
66844>>>>>>>  procedure sort_array integer liRow
66846>>>>>>>    send sort_items to (piObject.i(self,liRow))
66847>>>>>>>  end_procedure
66848>>>>>>>  function iItem_Count.i integer liRow returns integer
66850>>>>>>>    function_return (item_count(piObject.i(self,liRow)))
66851>>>>>>>  end_function
66852>>>>>>>end_class // cDeclaredArrays
66853>>>>>>>
66853>>>>>>>//  Move MyArray(2) to YourArray(4)
66853>>>>>>>//  Move MyArray.Item_Count to WhatEver#
66853>>>>>>>//
66853>>>>>>>//
66853>>>>>>>enumeration_list // Function classes
66853>>>>>>>  define FTYPE.SCRIPT  // Functions declared in the script
66853>>>>>>>  define FTYPE.GET     // Globally declared functions
66853>>>>>>>  define FTYPE.BUILTIN // Predefined DF functions that are called automatically by the eval function
66853>>>>>>>end_enumeration_list
66853>>>>>>>
66853>>>>>>>register_object oParameterStack
66853>>>>>>>class cDeclaredFunctions is a cArray
66854>>>>>>>  procedure construct_object integer liImg
66856>>>>>>>    forward send construct_object liImg
66858>>>>>>>    object oParameterReverse is a cStack NO_IMAGE
66860>>>>>>>    end_object
66861>>>>>>>    object oParameterStack is a cStack NO_IMAGE
66863>>>>>>>    end_object
66864>>>>>>>  end_procedure
66865>>>>>>>  item_property_list
66865>>>>>>>    item_property string  psName.i
66865>>>>>>>    item_property string  psDisplayName.i
66865>>>>>>>    item_property integer piReturnType.i    // VT_Something
66865>>>>>>>    item_property string  psParameterList.i //
66865>>>>>>>    item_property string  psDisplayParameterList.i //
66865>>>>>>>    item_property integer piFuncClass.i     // FTYPE.SCRIPT/FTYPE.GET/FTYPE.EXPR
66865>>>>>>>    item_property integer piLineDeclared.i  // when FTYPE.SCRIPT
66865>>>>>>>    item_property integer piMessage.i       // when FTYPE.GET or FTYPE.EXPR
66865>>>>>>>  end_item_property_list cDeclaredFunctions
#REM 66915 DEFINE FUNCTION PIMESSAGE.I INTEGER LIROW RETURNS INTEGER
#REM 66919 DEFINE PROCEDURE SET PIMESSAGE.I INTEGER LIROW INTEGER VALUE
#REM 66923 DEFINE FUNCTION PILINEDECLARED.I INTEGER LIROW RETURNS INTEGER
#REM 66927 DEFINE PROCEDURE SET PILINEDECLARED.I INTEGER LIROW INTEGER VALUE
#REM 66931 DEFINE FUNCTION PIFUNCCLASS.I INTEGER LIROW RETURNS INTEGER
#REM 66935 DEFINE PROCEDURE SET PIFUNCCLASS.I INTEGER LIROW INTEGER VALUE
#REM 66939 DEFINE FUNCTION PSDISPLAYPARAMETERLIST.I INTEGER LIROW RETURNS STRING
#REM 66943 DEFINE PROCEDURE SET PSDISPLAYPARAMETERLIST.I INTEGER LIROW STRING VALUE
#REM 66947 DEFINE FUNCTION PSPARAMETERLIST.I INTEGER LIROW RETURNS STRING
#REM 66951 DEFINE PROCEDURE SET PSPARAMETERLIST.I INTEGER LIROW STRING VALUE
#REM 66955 DEFINE FUNCTION PIRETURNTYPE.I INTEGER LIROW RETURNS INTEGER
#REM 66959 DEFINE PROCEDURE SET PIRETURNTYPE.I INTEGER LIROW INTEGER VALUE
#REM 66963 DEFINE FUNCTION PSDISPLAYNAME.I INTEGER LIROW RETURNS STRING
#REM 66967 DEFINE PROCEDURE SET PSDISPLAYNAME.I INTEGER LIROW STRING VALUE
#REM 66971 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 66975 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
66980>>>>>>>
66980>>>>>>>  procedure declare_function string lsName integer liRtnType string lsParamList integer liFuncClass integer liLine integer lhMsg
66982>>>>>>>    integer liRow
66982>>>>>>>    get row_count to liRow
66983>>>>>>>    set psName.i          liRow to (uppercase(lsName))
66984>>>>>>>    set psDisplayName.i   liRow to lsName
66985>>>>>>>    set piReturnType.i    liRow to liRtnType
66986>>>>>>>    set psParameterList.i liRow to lsParamList
66987>>>>>>>    set piFuncClass.i     liRow to liFuncClass
66988>>>>>>>    set piLineDeclared.i  liRow to liLine
66989>>>>>>>    set piMessage.i       liRow to lhMsg
66990>>>>>>>  end_function
66991>>>>>>>
66991>>>>>>>  function MidFunction string lsValue integer liLen integer liPos returns string
66993>>>>>>>    function_return (mid(lsValue,liLen,liPos))
66994>>>>>>>  end_function
66995>>>>>>>
66995>>>>>>>  // procedure Handle_Function string lsName integer liReturnType string lsParamList string lsLongParamList
66995>>>>>>>  procedure CallBack_AllFunctions integer lhMsg integer lhObj
66997>>>>>>>    integer liRow liMax lhSelf
66997>>>>>>>    move self to lhSelf
66998>>>>>>>    get row_count to liMax
66999>>>>>>>    decrement liMax
67000>>>>>>>    for liRow from 0 to liMax
67006>>>>>>>>
67006>>>>>>>      send lhMsg to lhObj (psDisplayName.i(lhSelf,liRow)) (piReturnType.i(lhSelf,liRow)) (psParameterList.i(lhSelf,liRow)) (psDisplayParameterList.i(lhSelf,liRow))
67007>>>>>>>    loop
67008>>>>>>>>
67008>>>>>>>  end_procedure
67009>>>>>>>
67009>>>>>>>  enumeration_list // Function groups
67009>>>>>>>    define FG_BEYOND_DESCRIPTION
67009>>>>>>>    define FG_STRING
67009>>>>>>>    define FG_DATETIME
67009>>>>>>>    define FG_LOGIC
67009>>>>>>>    define FG_TYPECONV
67009>>>>>>>    define FG_TRIG
67009>>>>>>>  end_enumeration_list
67009>>>>>>>
67009>>>>>>>  procedure reset
67011>>>>>>>    send delete_data
67012>>>>>>>    // STRINGS
67012>>>>>>>    send declare_function "Mid"             VARTYP_STRING "SII"   FTYPE.GET     0 get_MidFunction FG_STRING
67013>>>>>>>    send declare_function "Left"            VARTYP_STRING "SI"    FTYPE.BUILTIN 0 0               FG_STRING
67014>>>>>>>    send declare_function "Right"           VARTYP_STRING "SI"    FTYPE.BUILTIN 0 0               FG_STRING
67015>>>>>>>    send declare_function "Uppercase"       VARTYP_STRING "S"     FTYPE.BUILTIN 0 0               FG_STRING
67016>>>>>>>    send declare_function "Lowercase"       VARTYP_STRING "S"     FTYPE.BUILTIN 0 0               FG_STRING
67017>>>>>>>    send declare_function "Length"          VARTYP_INTEGER "S"    FTYPE.BUILTIN 0 0               FG_STRING
67018>>>>>>>    send declare_function "Trim"            VARTYP_STRING  "S"    FTYPE.BUILTIN 0 0               FG_STRING
67019>>>>>>>    if DFFALSE begin
67021>>>>>>>      send declare_function "Pad"             VARTYP_STRING "SI"    FTYPE.BUILTIN 0 0               FG_STRING
67022>>>>>>>      send declare_function "NumToStr"        VARTYP_STRING "NI"    FTYPE.GET     0 get_NumToStr    FG_STRING
67023>>>>>>>      send declare_function "NumToStrR"       VARTYP_STRING "NII"   FTYPE.GET     0 get_NumToStrR   FG_STRING
67024>>>>>>>      send declare_function "IntToStrR"       VARTYP_STRING "NI"    FTYPE.GET     0 get_IntToStrR   FG_STRING
67025>>>>>>>      send declare_function "IntToStrRzf"     VARTYP_STRING "NI"    FTYPE.GET     0 get_IntToStrRzf FG_STRING
67026>>>>>>>    end
67026>>>>>>>>
67026>>>>>>>    // DATES
67026>>>>>>>    send declare_function "SysDate"         VARTYP_DATE    ""     FTYPE.GET     0 get_dSysDate        FG_DATETIME
67027>>>>>>>    send declare_function "DateIncrement"   VARTYP_DATE    "DII"  FTYPE.GET     0 get_DateIncrement   FG_DATETIME
67028>>>>>>>    send declare_function "FirstDayInMonth" VARTYP_DATE    "D"    FTYPE.GET     0 get_FirstDayInMonth FG_DATETIME
67029>>>>>>>    if DFFALSE begin
67031>>>>>>>      send declare_function "SysYear"         VARTYP_INTEGER ""     FTYPE.GET     0 get_iSysYear        FG_DATETIME
67032>>>>>>>      send declare_function "SysTime"         VARTYP_STRING  ""     FTYPE.GET     0 get_sSysTime        FG_DATETIME
67033>>>>>>>      send declare_function "DateCompose"     VARTYP_DATE    "III"  FTYPE.GET     0 get_DateCompose     FG_DATETIME
67034>>>>>>>      send declare_function "StringToDate"    VARTYP_DATE    "SIIS" FTYPE.GET     0 get_StringToDate    FG_DATETIME
67035>>>>>>>      send declare_function "DateToString"    VARTYP_STRING  "DIIS" FTYPE.GET     0 get_DateToString    FG_DATETIME
67036>>>>>>>      send declare_function "DateSegment"     VARTYP_INTEGER "DI"   FTYPE.GET     0 get_DateSegment     FG_DATETIME
67037>>>>>>>      send declare_function "LastDayInMonth"  VARTYP_DATE    "D"    FTYPE.GET     0 get_LastDayInMonth  FG_DATETIME
67038>>>>>>>      send declare_function "FirstDayInYear"  VARTYP_DATE    "D"    FTYPE.GET     0 get_FirstDayInYear  FG_DATETIME
67039>>>>>>>      send declare_function "LastDayInYear"   VARTYP_DATE    "D"    FTYPE.GET     0 get_LastDayInYear   FG_DATETIME
67040>>>>>>>    end
67040>>>>>>>>
67040>>>>>>>    send declare_function "DateWeekNumber"  VARTYP_INTEGER "D"    FTYPE.GET     0 get_DateWeekNumber  FG_DATETIME
67041>>>>>>>    send declare_function "DateDayName"     VARTYP_STRING  "D"    FTYPE.GET     0 get_DateDayName     FG_DATETIME
67042>>>>>>>    send declare_function "DateMonthName"   VARTYP_STRING  "D"    FTYPE.GET     0 get_DateMonthName   FG_DATETIME
67043>>>>>>>    send declare_function "DateAsText"      VARTYP_STRING  "DS"   FTYPE.GET     0 get_DateAsText      FG_DATETIME
67044>>>>>>>    if DFFALSE begin
67046>>>>>>>      send declare_function "DayName"         VARTYP_STRING  "I"    FTYPE.GET     0 get_DayName         FG_DATETIME
67047>>>>>>>      send declare_function "DateDayNumber"   VARTYP_INTEGER "D"    FTYPE.GET     0 get_DateDayNumber   FG_DATETIME
67048>>>>>>>      send declare_function "WeekToDate"      VARTYP_DATE    "II"   FTYPE.GET     0 get_WeekToDate      FG_DATETIME
67049>>>>>>>      send declare_function "MonthName"       VARTYP_STRING  "I"    FTYPE.GET     0 get_MonthName       FG_DATETIME
67050>>>>>>>    end
67050>>>>>>>>
67050>>>>>>>//    if DFFALSE begin
67050>>>>>>>      // If
67050>>>>>>>      send declare_function "If_Int"      VARTYP_INTEGER "III" FTYPE.GET     0 get_VmIntIf     FG_LOGIC
67051>>>>>>>      send declare_function "If_Num"      VARTYP_NUMBER  "INN" FTYPE.GET     0 get_VmNumIf     FG_LOGIC
67052>>>>>>>      send declare_function "If_Str"      VARTYP_STRING  "ISS" FTYPE.GET     0 get_VmStrIf     FG_LOGIC
67053>>>>>>>      send declare_function "If_Dat"      VARTYP_DATE    "IDD" FTYPE.GET     0 get_VmDatIf     FG_LOGIC
67054>>>>>>>//    end
67054>>>>>>>    // TYPE CONVERSION
67054>>>>>>>    send declare_function "Integer"     VARTYP_INTEGER "I"   FTYPE.BUILTIN 0 0               FG_TYPECONV
67055>>>>>>>    send declare_function "String"      VARTYP_STRING  "S"   FTYPE.BUILTIN 0 0               FG_TYPECONV
67056>>>>>>>    send declare_function "Number"      VARTYP_NUMBER  "N"   FTYPE.BUILTIN 0 0               FG_TYPECONV
67057>>>>>>>    send declare_function "Date"        VARTYP_DATE    "D"   FTYPE.BUILTIN 0 0               FG_TYPECONV
67058>>>>>>>    // GEOMETRY (just for fun, shouldn't be here really)
67058>>>>>>>    if DFFALSE begin
67060>>>>>>>      send declare_function "sin"         VARTYP_NUMBER  "N"   FTYPE.BUILTIN 0 0               FG_TRIG
67061>>>>>>>      send declare_function "cos"         VARTYP_NUMBER  "N"   FTYPE.BUILTIN 0 0               FG_TRIG
67062>>>>>>>      send declare_function "tan"         VARTYP_NUMBER  "N"   FTYPE.BUILTIN 0 0               FG_TRIG
67063>>>>>>>    end
67063>>>>>>>>
67063>>>>>>>    // LOGICAL
67063>>>>>>>    send declare_function "not"         VARTYP_INTEGER "I"   FTYPE.BUILTIN 0 0               FG_LOGIC
67064>>>>>>>
67064>>>>>>>    if DFFALSE begin
67066>>>>>>>      // DBMS
67066>>>>>>>      send declare_function "OpenFile" VARTYP_INTEGER "III" FTYPE.GET 0 get_DBMS_OpenFile FG_BEYOND_DESCRIPTION
67067>>>>>>>      // Restructuring
67067>>>>>>>      send declare_function "RS_TableOpenNumber"      VARTYP_INTEGER "I"    FTYPE.GET 0 get_RS_TableOpenNumber      FG_BEYOND_DESCRIPTION
67068>>>>>>>      send declare_function "RS_TableProbeNumber"     VARTYP_INTEGER "I"    FTYPE.GET 0 get_RS_TableProbeNumber     FG_BEYOND_DESCRIPTION
67069>>>>>>>      send declare_function "RS_TableCreateName"      VARTYP_INTEGER "S"    FTYPE.GET 0 get_RS_TableCreateName      FG_BEYOND_DESCRIPTION
67070>>>>>>>      send declare_function "RS_TableDropName"        VARTYP_INTEGER "S"    FTYPE.GET 0 get_RS_TableDropName        FG_BEYOND_DESCRIPTION
67071>>>>>>>      send declare_function "RS_TableExistsName"      VARTYP_INTEGER "S"    FTYPE.GET 0 get_RS_TableExistsName      FG_BEYOND_DESCRIPTION
67072>>>>>>>      send declare_function "RS_CurrentFieldCount"    VARTYP_INTEGER ""     FTYPE.GET 0 get_RS_CurrentFieldCount    FG_BEYOND_DESCRIPTION
67073>>>>>>>      send declare_function "RS_GetFileAttr"          VARTYP_STRING  "I"    FTYPE.GET 0 get_RS_GetFileAttr          FG_BEYOND_DESCRIPTION
67074>>>>>>>      send declare_function "RS_GetFieldAttr"         VARTYP_STRING  "II"   FTYPE.GET 0 get_RS_GetFieldAttr         FG_BEYOND_DESCRIPTION
67075>>>>>>>      send declare_function "RS_GetIndexAttr"         VARTYP_STRING  "II"   FTYPE.GET 0 get_RS_GetIndexAttr         FG_BEYOND_DESCRIPTION
67076>>>>>>>      send declare_function "RS_GetIndexSegAttr"      VARTYP_STRING  "III"  FTYPE.GET 0 get_RS_GetIndexSegAttr      FG_BEYOND_DESCRIPTION
67077>>>>>>>      send declare_function "RS_GetFileListAttr"      VARTYP_STRING  "I"    FTYPE.GET 0 get_RS_GetFileListAttr      FG_BEYOND_DESCRIPTION
67078>>>>>>>
67078>>>>>>>      send declare_function "API_AttrValue_GLOBAL"    VARTYP_STRING  "I"    FTYPE.GET 0 get_API_AttrValue_GLOBAL    FG_BEYOND_DESCRIPTION
67079>>>>>>>      send declare_function "API_AttrValue_FILELIST"  VARTYP_STRING  "II"   FTYPE.GET 0 get_API_AttrValue_FILELIST  FG_BEYOND_DESCRIPTION
67080>>>>>>>      send declare_function "API_AttrValue_FILE"      VARTYP_STRING  "II"   FTYPE.GET 0 get_API_AttrValue_FILE      FG_BEYOND_DESCRIPTION
67081>>>>>>>      send declare_function "API_AttrValue_FIELD"     VARTYP_STRING  "III"  FTYPE.GET 0 get_API_AttrValue_FIELD     FG_BEYOND_DESCRIPTION
67082>>>>>>>      send declare_function "API_AttrValue_INDEX"     VARTYP_STRING  "III"  FTYPE.GET 0 get_API_AttrValue_INDEX     FG_BEYOND_DESCRIPTION
67083>>>>>>>      send declare_function "API_AttrValue_IDXSEG"    VARTYP_STRING  "IIII" FTYPE.GET 0 get_API_AttrValue_IDXSEG    FG_BEYOND_DESCRIPTION
67084>>>>>>>      send declare_function "API_AttrValue_SPECIAL1"  VARTYP_STRING  "IIII" FTYPE.GET 0 get_API_AttrValue_SPECIAL1  FG_BEYOND_DESCRIPTION
67085>>>>>>>      send declare_function "API_AttrValue_FLSTNAV"   VARTYP_STRING  "II"   FTYPE.GET 0 get_API_AttrValue_FLSTNAV   FG_BEYOND_DESCRIPTION
67086>>>>>>>      send declare_function "API_AttrValue_DRIVER"    VARTYP_STRING  "II"   FTYPE.GET 0 get_API_AttrValue_DRIVER    FG_BEYOND_DESCRIPTION
67087>>>>>>>      send declare_function "API_AttrValue_DRVSRV"    VARTYP_STRING  "III"  FTYPE.GET 0 get_API_AttrValue_DRVSRV    FG_BEYOND_DESCRIPTION
67088>>>>>>>
67088>>>>>>>      send declare_function "API_Attr_ValueName"      VARTYP_STRING  "IS"   FTYPE.GET 0 get_API_Attr_ValueName      FG_BEYOND_DESCRIPTION
67089>>>>>>>    end
67089>>>>>>>>
67089>>>>>>>    send delete_data to (oParameterStack(self))
67090>>>>>>>  end_procedure
67091>>>>>>>  procedure reverse_stack integer how_many#
67093>>>>>>>    integer obj1# obj2# itm#
67093>>>>>>>    move (oParameterStack(self))   to obj1#
67094>>>>>>>    move (oParameterReverse(self)) to obj2#
67095>>>>>>>    for itm# from 1 to how_many#
67101>>>>>>>>
67101>>>>>>>      send push.s to obj2# (sPop(obj1#))
67102>>>>>>>    loop
67103>>>>>>>>
67103>>>>>>>  end_procedure
67104>>>>>>>  function sExec_Function.i integer liRow returns string
67106>>>>>>>    integer msg# params# obj#
67106>>>>>>>    string rval#
67106>>>>>>>    get piMessage.i liRow to msg#
67107>>>>>>>    // Apparently the parameters to the get command are evaluated
67107>>>>>>>    // in reverse order, thus eliminating the need for me to reverse
67107>>>>>>>    // the parameters. What luck.
67107>>>>>>>  //move (oParameterReverse(self)) to obj#
67107>>>>>>>  //move (length(psParameterList.i(self,liRow))) to params#
67107>>>>>>>  //send reverse_stack params#
67107>>>>>>>    move (oParameterStack(self)) to obj#
67108>>>>>>>    move (length(psParameterList.i(self,liRow))) to params#
67109>>>>>>>    //send reverse_stack params#
67109>>>>>>>    if msg# begin //
67111>>>>>>>      if params# eq 0 get msg# to rval#
67114>>>>>>>      if params# eq 1 get msg# (sPop(obj#)) to rval#
67117>>>>>>>      if params# eq 2 get msg# (sPop(obj#)) (sPop(obj#)) to rval#
67120>>>>>>>      if params# eq 3 get msg# (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) to rval#
67123>>>>>>>      if params# eq 4 get msg# (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) to rval#
67126>>>>>>>      if params# eq 5 get msg# (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) to rval#
67129>>>>>>>      if params# eq 6 get msg# (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) (sPop(obj#)) to rval#
67132>>>>>>>      if (piReturnType.i(self,liRow)=VARTYP_DATE) begin
67134>>>>>>>//      showln "XXX: " rval#
67134>>>>>>>        function_return (date(rval#))
67135>>>>>>>      end
67135>>>>>>>>
67135>>>>>>>    end
67135>>>>>>>>
67135>>>>>>>    else begin // Script defined function
67136>>>>>>>    end
67136>>>>>>>>
67136>>>>>>>    function_return rval#
67137>>>>>>>  end_function
67138>>>>>>>  function iNameToNumber.s string name# returns integer
67140>>>>>>>    integer liRow max#
67140>>>>>>>    move (uppercase(name#)) to name#
67141>>>>>>>    get row_count to max#
67142>>>>>>>    for liRow from 0 to (max#-1)
67148>>>>>>>>
67148>>>>>>>      if name# eq (psName.i(self,liRow)) function_return liRow
67151>>>>>>>    loop
67152>>>>>>>>
67152>>>>>>>    function_return -1
67153>>>>>>>  end_function
67154>>>>>>>  procedure push_param string param#
67156>>>>>>>    send Push.s to (oParameterStack(self)) param#
67157>>>>>>>  end_procedure
67158>>>>>>>end_class // cDeclaredFunctions
67159>>>>>>>
67159>>>>>>>class cResolvedLabels is a cArray // Help class for cLabels class below
67160>>>>>>>  item_property_list
67160>>>>>>>    item_property string  psLabelName.i
67160>>>>>>>    item_property integer piLabelLine.i
67160>>>>>>>  end_item_property_list cResolvedLabels
#REM 67192 DEFINE FUNCTION PILABELLINE.I INTEGER LIROW RETURNS INTEGER
#REM 67196 DEFINE PROCEDURE SET PILABELLINE.I INTEGER LIROW INTEGER VALUE
#REM 67200 DEFINE FUNCTION PSLABELNAME.I INTEGER LIROW RETURNS STRING
#REM 67204 DEFINE PROCEDURE SET PSLABELNAME.I INTEGER LIROW STRING VALUE
67209>>>>>>>  function iFindLabel.s string labelid# returns integer // Has label already been defined?
67211>>>>>>>    integer max# liRow
67211>>>>>>>    get row_count to max#
67212>>>>>>>    move 0 to liRow
67213>>>>>>>    while liRow lt max#
67217>>>>>>>      if labelid# eq (psLabelName.i(self,liRow)) function_return liRow
67220>>>>>>>      increment liRow
67221>>>>>>>    end
67222>>>>>>>>
67222>>>>>>>    function_return -1 // Not found
67223>>>>>>>  end_function
67224>>>>>>>  function iLabelidToLine.s string labelid# returns integer
67226>>>>>>>    integer liRow line#
67226>>>>>>>    get iFindLabel.s labelid# to liRow
67227>>>>>>>    move -1 to line#
67228>>>>>>>    if liRow ne -1 get piLabelLine.i liRow to line#
67231>>>>>>>    function_return line#
67232>>>>>>>  end_function
67233>>>>>>>  procedure add_resolved_label string labelid# integer line#
67235>>>>>>>    integer liRow
67235>>>>>>>    if (iFindLabel.s(self,labelid#)=-1) begin
67237>>>>>>>      get row_count to liRow
67238>>>>>>>      set psLabelName.i liRow to labelid#
67239>>>>>>>      set piLabelLine.i liRow to line#
67240>>>>>>>    end
67240>>>>>>>>
67240>>>>>>>    else send add_ct_error line# ("ERROR! Label already defined: "+labelid#)
67242>>>>>>>  end_procedure
67243>>>>>>>  procedure add_resolved_label_no_error string labelid# integer line#
67245>>>>>>>    integer liRow
67245>>>>>>>    if (iFindLabel.s(self,labelid#)=-1) begin
67247>>>>>>>      get row_count to liRow
67248>>>>>>>      set psLabelName.i liRow to labelid#
67249>>>>>>>      set piLabelLine.i liRow to line#
67250>>>>>>>    end
67250>>>>>>>>
67250>>>>>>>  end_procedure
67251>>>>>>>end_class // cResolvedLabels
67252>>>>>>>
67252>>>>>>>class cLabels is a cArray
67253>>>>>>>  procedure construct_object integer img#
67255>>>>>>>    forward send construct_object img#
67257>>>>>>>    object oResolvedLabels is a cResolvedLabels
67259>>>>>>>    end_object
67260>>>>>>>    object oReferredLabels is a cSet
67262>>>>>>>    end_object
67263>>>>>>>  end_procedure
67264>>>>>>>  procedure reset
67266>>>>>>>    send delete_data
67267>>>>>>>    send delete_data to (oResolvedLabels(self))
67268>>>>>>>    send delete_data to (oReferredLabels(self))
67269>>>>>>>  end_procedure
67270>>>>>>>  procedure add_resolved_label string labelid# integer line#
67272>>>>>>>    send add_resolved_label to (oResolvedLabels(self)) labelid# line#
67273>>>>>>>  end_procedure
67274>>>>>>>  procedure add_resolved_label_no_error string labelid# integer line#
67276>>>>>>>    send add_resolved_label_no_error to (oResolvedLabels(self)) labelid# line#
67277>>>>>>>  end_procedure
67278>>>>>>>  procedure add_label_reference string labelid# integer obj# integer line#
67280>>>>>>>    integer labelno#
67280>>>>>>>    set value item (item_count(self)) to line#
67281>>>>>>>    get iAddOrFind_Element of (oReferredLabels(self)) labelid# to labelno#
67282>>>>>>>    set value of obj# item line# to labelno#
67283>>>>>>>  end_procedure
67284>>>>>>>  function sResolve_Labels.i integer obj# returns string // Obj# is the program array
67286>>>>>>>    integer itm# max# line# labelno# reflabels# reslabels# labelline#
67286>>>>>>>    string labelid# rval#
67286>>>>>>>    move "" to rval# // All is OK!
67287>>>>>>>    move (oResolvedLabels(self)) to reslabels#
67288>>>>>>>    move (oReferredLabels(self)) to reflabels#
67289>>>>>>>    get item_count to max#
67290>>>>>>>    for itm# from 0 to (max#-1)
67296>>>>>>>>
67296>>>>>>>      get value item itm# to line#
67297>>>>>>>      get value of obj# item line# to labelno#
67298>>>>>>>      get value of reflabels# item labelno# to labelid#
67299>>>>>>>      get iLabelidToLine.s of reslabels# labelid# to labelline#
67300>>>>>>>      set value of obj# item line# to labelline#
67301>>>>>>>      if labelline# eq -1 move labelid# to rval#
67304>>>>>>>    loop
67305>>>>>>>>
67305>>>>>>>    function_return rval#
67306>>>>>>>  end_function
67307>>>>>>>  function iIsLabelNameUsed.s string label# returns integer
67309>>>>>>>    integer rval#
67309>>>>>>>    get element_find of (oReferredLabels(self)) label# to rval#
67310>>>>>>>    if rval# eq -1 get iFindLabel.s of (oResolvedLabels(self)) label# to rval#
67313>>>>>>>    if rval# eq -1 function_return 0
67316>>>>>>>    function_return 1
67317>>>>>>>  end_function
67318>>>>>>>end_class // cLabels
67319>>>>>>>
67319>>>>>>>class cVariables is a cArray
67320>>>>>>>  item_property_list
67320>>>>>>>    item_property string  psName.i
67320>>>>>>>    item_property string  psValue.i
67320>>>>>>>    item_property integer piType.i
67320>>>>>>>  end_item_property_list cVariables
#REM 67355 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 67359 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
#REM 67363 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 67367 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 67371 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 67375 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
67380>>>>>>>  function iVarNameToVarNo string name# returns integer
67382>>>>>>>    integer liRow max# rval#
67382>>>>>>>    move (uppercase(name#)) to name#
67383>>>>>>>    get row_count to max#
67384>>>>>>>    move -1 to rval#
67385>>>>>>>    move 0 to liRow
67386>>>>>>>    while (liRow>>>>>>      if name# eq (psName.i(self,liRow)) move liRow to rval#
67393>>>>>>>      increment liRow
67394>>>>>>>    end
67395>>>>>>>>
67395>>>>>>>    function_return rval#
67396>>>>>>>  end_function
67397>>>>>>>  register_function piProgramCounter returns integer
67397>>>>>>>  procedure VarNameDeclare string name# integer type#
67399>>>>>>>    integer liRow
67399>>>>>>>    move (uppercase(name#)) to name#
67400>>>>>>>    get iVarNameToVarNo name# to liRow
67401>>>>>>>    if liRow eq -1 begin
67403>>>>>>>      get row_count to liRow
67404>>>>>>>      set psName.i  liRow to name#
67405>>>>>>>      set psValue.i liRow to ""
67406>>>>>>>      set piType.i  liRow to type#
67407>>>>>>>    end
67407>>>>>>>>
67407>>>>>>>    else send add_ct_error (piProgramCounter(self)) ("Variable already defined ("+name#+")")
67409>>>>>>>  end_procedure
67410>>>>>>>  function sVarValue integer varno# returns string
67412>>>>>>>    function_return (psValue.i(self,varno#))
67413>>>>>>>  end_function
67414>>>>>>>  procedure VarIncrement integer varno# integer amount#
67416>>>>>>>    set psValue.i varno# to (psValue.i(self,varno#)+amount#)
67417>>>>>>>  end_procedure
67418>>>>>>>  procedure VarAssign integer varno# string value#
67420>>>>>>>    integer type#
67420>>>>>>>    get piType.i varno# to type#
67421>>>>>>>    if type# eq VARTYP_INTEGER set psValue.i varno# to (integer(value#))
67424>>>>>>>    if type# eq VARTYP_NUMBER  set psValue.i varno# to (number(value#))
67427>>>>>>>    if type# eq VARTYP_DATE    set psValue.i varno# to (date(value#))
67430>>>>>>>    if type# eq VARTYP_STRING  set psValue.i varno# to (string(value#))
67433>>>>>>>  end_procedure
67434>>>>>>>  procedure VarDisplay
67436>>>>>>>    integer liRow max#
67436>>>>>>>    string str#
67436>>>>>>>    move "" to str#
67437>>>>>>>    get row_count to max#
67438>>>>>>>    for liRow from 0 to (max#-1)
67444>>>>>>>>
67444>>>>>>>      move (str#+psName.i(self,liRow)+": "+psValue.i(self,liRow)) to str#
67445>>>>>>>      if liRow ne (max#-1) move (str#+character(10)) to str#
67448>>>>>>>    loop
67449>>>>>>>>
67449>>>>>>>    send obs str#
67450>>>>>>>  end_procedure
67451>>>>>>>end_class // cVariables
67452>>>>>>>
67452>>>>>>>
67452>>>>>>>function sExprOp_Text.i global integer op# returns string
67454>>>>>>>  enumeration_list
67454>>>>>>>    define_exprop EXPROP.ERROR           "Error"            //  0
67457>>>>>>>    define_exprop EXPROP.TYPE            "TypeDef"          //  1
67460>>>>>>>    define_exprop EXPROP.APPEND          "Append"           //  2
67463>>>>>>>    define_exprop EXPROP.PUSH_EXPRESSION "PushExpr"         //  3
67466>>>>>>>    define_exprop EXPROP.PUSH_PARAM      "PushParam"        //  4
67469>>>>>>>    define_exprop EXPROP.EXEC_FUNCTION   "Exec&Pop&Append"  //  5
67472>>>>>>>    define_exprop EXPROP.EXEC_SFUNCTION  "Exec&sPop&Append" //  6
67475>>>>>>>    define_exprop EXPROP.GET_IVAR        "Get iVar"         //  7
67478>>>>>>>    define_exprop EXPROP.GET_DVAR        "Get dVar"         //  8
67481>>>>>>>    define_exprop EXPROP.GET_NVAR        "Get nVar"         //  9
67484>>>>>>>    define_exprop EXPROP.GET_SVAR        "Get sVar"         // 10
67487>>>>>>>    define_exprop EXPROP.GET_IFIELD      "Get iField"       // 11
67490>>>>>>>    define_exprop EXPROP.GET_DFIELD      "Get dField"       // 12
67493>>>>>>>    define_exprop EXPROP.GET_NFIELD      "Get nField"       // 13
67496>>>>>>>    define_exprop EXPROP.GET_SFIELD      "Get sField"       // 14
67499>>>>>>>    define_exprop EXPROP.END             "ExprEnd"          // 15
67502>>>>>>>  end_enumeration_list
67502>>>>>>>  function_return "Error"
67503>>>>>>>end_function
67504>>>>>>>
67504>>>>>>>desktop_section
67509>>>>>>>  integer ghExpressionErrorHandler
67509>>>>>>>  object oExpressionErrorHandler is a cErrorHandlerRedirector NO_IMAGE
67511>>>>>>>    item_property_list
67511>>>>>>>      item_property integer piError.i
67511>>>>>>>      item_property string  psErrorText.i
67511>>>>>>>      item_property integer piErrorLine.i
67511>>>>>>>    end_item_property_list
#REM 67551 DEFINE FUNCTION PIERRORLINE.I INTEGER LIROW RETURNS INTEGER
#REM 67556 DEFINE PROCEDURE SET PIERRORLINE.I INTEGER LIROW INTEGER VALUE
#REM 67561 DEFINE FUNCTION PSERRORTEXT.I INTEGER LIROW RETURNS STRING
#REM 67566 DEFINE PROCEDURE SET PSERRORTEXT.I INTEGER LIROW STRING VALUE
#REM 67571 DEFINE FUNCTION PIERROR.I INTEGER LIROW RETURNS INTEGER
#REM 67576 DEFINE PROCEDURE SET PIERROR.I INTEGER LIROW INTEGER VALUE
67582>>>>>>>    procedure OnError integer liError string lsErrorText integer liErrorLine
67585>>>>>>>      integer liRow
67585>>>>>>>//    showln "Error: "  liError " " lsErrorText " " liErrorLine
67585>>>>>>>      get row_count to liRow
67586>>>>>>>      set piError.i     liRow to liError
67587>>>>>>>      set psErrorText.i liRow to lsErrorText
67588>>>>>>>      set piErrorLine.i liRow to liErrorLine
67589>>>>>>>    end_procedure
67590>>>>>>>    move self to ghExpressionErrorHandler
67591>>>>>>>  end_object
67592>>>>>>>end_desktop_section
67597>>>>>>>
67597>>>>>>>class cEvalSequence is a cArray
67598>>>>>>>  procedure construct_object integer img#
67600>>>>>>>    forward send construct_object img#
67602>>>>>>>    object oStack is a cStack no_image
67604>>>>>>>    end_object
67605>>>>>>>    property integer piFunctionObject public 0
67606>>>>>>>  end_procedure
67607>>>>>>>  item_property_list
67607>>>>>>>    item_property integer piOpCode.i
67607>>>>>>>    item_property string  psVar.i
67607>>>>>>>  end_item_property_list cEvalSequence
#REM 67639 DEFINE FUNCTION PSVAR.I INTEGER LIROW RETURNS STRING
#REM 67643 DEFINE PROCEDURE SET PSVAR.I INTEGER LIROW STRING VALUE
#REM 67647 DEFINE FUNCTION PIOPCODE.I INTEGER LIROW RETURNS INTEGER
#REM 67651 DEFINE PROCEDURE SET PIOPCODE.I INTEGER LIROW INTEGER VALUE
67656>>>>>>>  function insert_and_append_quotes string str# returns string
67658>>>>>>>    function_return (MakeStringConstantMax255(str#))
67659>>>>>>>  end_function
67660>>>>>>>  register_function iVarValue integer varno# returns integer
67660>>>>>>>  register_function dVarValue integer varno# returns integer // date
67660>>>>>>>  register_function nVarValue integer varno# returns number
67660>>>>>>>  register_function sVarValue integer varno# returns string
67660>>>>>>>  function iFieldValue integer liFileField returns integer
67662>>>>>>>    integer liRval
67662>>>>>>>    get_field_value (liFileField/65536) (mod(liFileField,65536)) to liRval
67665>>>>>>>    function_return liRval
67666>>>>>>>  end_function
67667>>>>>>>  function dFieldValue integer liFileField returns integer //date
67669>>>>>>>    date ldRval
67669>>>>>>>    get_field_value (liFileField/65536) (mod(liFileField,65536)) to ldRval
67672>>>>>>>    function_return ldRval
67673>>>>>>>  end_function
67674>>>>>>>  function nFieldValue integer liFileField returns number
67676>>>>>>>    number lnRval
67676>>>>>>>    get_field_value (liFileField/65536) (mod(liFileField,65536)) to lnRval
67679>>>>>>>    function_return lnRval
67680>>>>>>>  end_function
67681>>>>>>>  function sFieldValue integer liFileField returns string
67683>>>>>>>    string lsRval
67683>>>>>>>    get_field_value (liFileField/65536) (mod(liFileField,65536)) to lsRval
67686>>>>>>>    function_return (rtrim(lsRval))
67687>>>>>>>  end_function
67688>>>>>>>  procedure Handle_ExprEvalError integer liExprId string lsExpr
67690>>>>>>>    integer liMax liRow
67690>>>>>>>    string lsValue
67690>>>>>>>    get row_count of ghExpressionErrorHandler to liMax
67691>>>>>>>    decrement liMax
67692>>>>>>>    showln ""
67694>>>>>>>    showln "DataFlex reported this error:"
67696>>>>>>>    for liRow from 0 to liMax
67702>>>>>>>>
67702>>>>>>>      show (piError.i(ghExpressionErrorHandler,liRow)) ", "
67704>>>>>>>      get psErrorText.i of ghExpressionErrorHandler liRow to lsValue
67705>>>>>>>      show lsValue " on line "
67707>>>>>>>      showln (piErrorLine.i(ghExpressionErrorHandler,liRow))
67709>>>>>>>    loop
67710>>>>>>>>
67710>>>>>>>    showln "while executing this expression:"
67712>>>>>>>    showln lsExpr
67714>>>>>>>  end_procedure
67715>>>>>>>  function sExec_Expression.i integer liExprId returns string
67717>>>>>>>    integer op# stack# funcobj# liDec liType liRow
67717>>>>>>>    string expression# lsRval
67717>>>>>>>    send DoReset to ghExpressionErrorHandler
67718>>>>>>>    send DoActivate to ghExpressionErrorHandler
67719>>>>>>>    move liExprId to liRow
67720>>>>>>>    get_attribute DF_DECIMAL_SEPARATOR to liDec
67723>>>>>>>    set_attribute DF_DECIMAL_SEPARATOR to 46 // "."
67726>>>>>>>    move (oStack(self)) to stack#
67727>>>>>>>    move (piFunctionObject(self)) to funcobj#
67728>>>>>>> // showln "Hello "  liRow " " (value(self,liRow-1))
67728>>>>>>> //
67728>>>>>>> // direct_output channel 1 "c:\cc.ccc"
67728>>>>>>> // for windowindex from 0 to (item_count(self)-1)
67728>>>>>>> //   writeln channel 1 (value(self,windowindex))
67728>>>>>>> // loop
67728>>>>>>> // close_output channel 1
67728>>>>>>> // send obs "OK!"
67728>>>>>>>
67728>>>>>>>    move "" to expression#
67729>>>>>>>    get psVar.i (liRow-1) to liType
67730>>>>>>>    repeat
67730>>>>>>>>
67730>>>>>>>      get piOpCode.i liRow to op#
67731>>>>>>>      //showln (sExprOp_Text.i(op#)) " " (psVar.i(self,liRow)) " Expr: " expression#
67731>>>>>>>      if op# ne EXPROP.END begin
67733>>>>>>>        if op# eq EXPROP.GET_IVAR move (expression#+string(iVarValue(self,psVar.i(self,liRow)))) to expression#
67736>>>>>>>        if op# eq EXPROP.GET_DVAR move (expression#+string(dVarValue(self,psVar.i(self,liRow)))) to expression#
67739>>>>>>>        if op# eq EXPROP.GET_NVAR move (expression#+string(nVarValue(self,psVar.i(self,liRow)))) to expression#
67742>>>>>>>        if op# eq EXPROP.GET_SVAR move (expression#+MakeStringConstantMax255(sVarValue(self,psVar.i(self,liRow)))) to expression#
67745>>>>>>>        if op# eq EXPROP.GET_IFIELD move (expression#+string(iFieldValue(self,psVar.i(self,liRow)))) to expression#
67748>>>>>>>        if op# eq EXPROP.GET_DFIELD move (expression#+string(dFieldValue(self,psVar.i(self,liRow)))) to expression#
67751>>>>>>>        if op# eq EXPROP.GET_NFIELD move (expression#+string(nFieldValue(self,psVar.i(self,liRow)))) to expression#
67754>>>>>>>        if op# eq EXPROP.GET_SFIELD move (expression#+MakeStringConstantMax255(sFieldValue(self,psVar.i(self,liRow)))) to expression#
67757>>>>>>>        if op# eq EXPROP.APPEND move (expression#+psVar.i(self,liRow)) to expression#
67760>>>>>>>        if op# eq EXPROP.PUSH_EXPRESSION begin
67762>>>>>>>          send push.s to stack# expression#
67763>>>>>>>          move "" to expression#
67764>>>>>>>        end
67764>>>>>>>>
67764>>>>>>>        if op# eq EXPROP.PUSH_PARAM begin
67766>>>>>>>          send push_param to funcobj# (eval(expression#))
67767>>>>>>>          move "" to expression#
67768>>>>>>>        end
67768>>>>>>>>
67768>>>>>>>        if op# eq EXPROP.EXEC_FUNCTION begin // Exec, Pop Expr and Append
67770>>>>>>>          get sExec_Function.i of funcobj# (integer(psVar.i(self,liRow))) to expression#
67771>>>>>>>          move (sPop(stack#)+expression#) to expression#
67772>>>>>>>        end
67772>>>>>>>>
67772>>>>>>>        if op# eq EXPROP.EXEC_SFUNCTION begin // Exec, Pop Expr and Append
67774>>>>>>>          // In this case we have to insert and append quotes
67774>>>>>>>          get sExec_Function.i of funcobj# (integer(psVar.i(self,liRow))) to expression#
67775>>>>>>>          get insert_and_append_quotes expression# to expression#
67776>>>>>>>          move (sPop(stack#)+expression#) to expression#
67777>>>>>>>        end
67777>>>>>>>>
67777>>>>>>>      end
67777>>>>>>>>
67777>>>>>>>      increment liRow
67778>>>>>>>//      showln ": " expression#
67778>>>>>>>    until op# eq EXPROP.END
67780>>>>>>>    if (expression#="()") move "" to lsRval
67783>>>>>>>    else move (eval(expression#)) to lsRval
67785>>>>>>>//  showln expression#
67785>>>>>>>    set_attribute DF_DECIMAL_SEPARATOR to liDec
67788>>>>>>>//  showln "After expr1: " liDec " " liType " Value: " lsRval
67788>>>>>>>
67788>>>>>>>    if (liType=VARTYP_DATE) begin
67790>>>>>>>      move (date(lsRval)) to lsRval
67791>>>>>>>    end
67791>>>>>>>>
67791>>>>>>>    if (liType=VARTYP_NUMBER or liType=VARTYP_INTEGER) begin
67793>>>>>>>//    showln "Was number or integer " lsRval
67793>>>>>>>      if (liDec<>46) move (replace(".",lsRval,",")) to lsRval
67796>>>>>>>    end
67796>>>>>>>>
67796>>>>>>>//    showln "After expr2: " liDec " " liType " Value: " lsRval
67796>>>>>>>    send DoDeactivate to ghExpressionErrorHandler
67797>>>>>>>    if (row_count(ghExpressionErrorHandler)) begin
67799>>>>>>>      // Af this point we know that there was an error while evaluating
67799>>>>>>>      // the expression.
67799>>>>>>>      send Handle_ExprEvalError liExprId expression#
67800>>>>>>>    end
67800>>>>>>>>
67800>>>>>>>    function_return lsRval
67801>>>>>>>  end_function
67802>>>>>>>  procedure add_expr_instruction integer op# string item#
67804>>>>>>>    integer liRow
67804>>>>>>>    get row_count to liRow
67805>>>>>>>    set piOpCode.i liRow to op#
67806>>>>>>>    set psVar.i    liRow to item#
67807>>>>>>>  end_procedure
67808>>>>>>>  procedure RemoveSuperfluosPar
67810>>>>>>>//  integer max#
67810>>>>>>>//  get row_count to max#
67810>>>>>>>//  decrement max#
67810>>>>>>>//  decrement max#
67810>>>>>>>//  if (piOpCode.i(self,1)=EXPROP.APPEND and psVar.i(self,1)="(" and piOpCode.i(self,max#)=EXPROP.APPEND and psVar.i(self,max#)=")") begin
67810>>>>>>>//    send delete_row max#
67810>>>>>>>//    send delete_row 1
67810>>>>>>>//    send RemoveSuperfluosPar
67810>>>>>>>//  end
67810>>>>>>>  end_procedure
67811>>>>>>>  procedure Optimize
67813>>>>>>>    integer liRow
67813>>>>>>>    send RemoveSuperfluosPar
67814>>>>>>>    move 0 to liRow
67815>>>>>>>    while (liRow>>>>>>      if (piOpCode.i(self,liRow)=EXPROP.APPEND and piOpCode.i(self,liRow+1)=EXPROP.APPEND) begin
67821>>>>>>>        set psVar.i liRow to (psVar.i(self,liRow)+psVar.i(self,liRow+1))
67822>>>>>>>        send delete_row (liRow+1)
67823>>>>>>>      end
67823>>>>>>>>
67823>>>>>>>      else increment liRow
67825>>>>>>>    end
67826>>>>>>>>
67826>>>>>>>  end_procedure
67827>>>>>>>  procedure reset
67829>>>>>>>    send delete_data
67830>>>>>>>    send delete_data to (oStack(self))
67831>>>>>>>  end_procedure
67832>>>>>>>  function iAppendToOtherSequence integer target_obj# returns integer
67834>>>>>>>    integer liRow remote_row# max#
67834>>>>>>>    get row_count of target_obj# to remote_row#
67835>>>>>>>    get row_count to max#
67836>>>>>>>    decrement max#
67837>>>>>>>    for liRow from 0 to max#
67843>>>>>>>>
67843>>>>>>>      send add_expr_instruction to target_obj# (piOpCode.i(self,liRow)) (psVar.i(self,liRow))
67844>>>>>>>    loop
67845>>>>>>>>
67845>>>>>>>    function_return remote_row#
67846>>>>>>>  end_function
67847>>>>>>>end_class // cEvalSequence
67848>>>>>>>
67848>>>>>>>register_procedure mthd_Nop
67848>>>>>>>register_procedure mthd_ClearScreen
67848>>>>>>>register_procedure mthd_Abort
67848>>>>>>>register_procedure mthd_Gosub
67848>>>>>>>register_procedure mthd_Goto
67848>>>>>>>register_procedure mthd_Return
67848>>>>>>>register_procedure mthd_ShowLn
67848>>>>>>>register_procedure mthd_Show
67848>>>>>>>register_procedure mthd_SeqFile
67848>>>>>>>register_procedure mthd_WriteLn
67848>>>>>>>register_procedure mthd_MsgBox
67848>>>>>>>register_procedure mthd_GotoXY
67848>>>>>>>register_procedure mthd_Input
67848>>>>>>>register_procedure mthd_Pause
67848>>>>>>>register_procedure mthd_Assign
67848>>>>>>>register_procedure mthd_gVar_Incr
67848>>>>>>>register_procedure mthd_gVar_Display
67848>>>>>>>register_procedure mthd_if_goto
67848>>>>>>>register_procedure mthd_if_gosub
67848>>>>>>>register_procedure mthd_iftest_goto
67848>>>>>>>register_procedure mthd_iftest_gosub
67848>>>>>>>register_procedure mthd_debug
67848>>>>>>>register_procedure mthd_log_open
67848>>>>>>>register_procedure mthd_log_close
67848>>>>>>>register_procedure mthd_log_display
67848>>>>>>>register_procedure mthd_log_flush
67848>>>>>>>register_procedure mthd_log_write
67848>>>>>>>register_procedure mthd_log_writeln
67848>>>>>>>register_procedure mthd_api_filelist
67848>>>>>>>register_procedure mthd_api_file
67848>>>>>>>register_procedure mthd_api_field
67848>>>>>>>register_procedure mthd_api_index
67848>>>>>>>register_procedure mthd_api_idxseg
67848>>>>>>>register_procedure mthd_api_structure_abort
67848>>>>>>>register_procedure mthd_api_structure_end
67848>>>>>>>register_procedure mthd_api_probe_end
67848>>>>>>>register_procedure mthd_api_deleteindex
67848>>>>>>>register_procedure mthd_api_deletefield
67848>>>>>>>register_procedure mthd_api_appendfield
67848>>>>>>>register_procedure mthd_api_createfield
67848>>>>>>>register_procedure mthd_api_setfieldnumber
67848>>>>>>>
67848>>>>>>>integer oVM_CurrentlyExecuting#
67848>>>>>>>class cBasicVirtualMachine is an cArray
67849>>>>>>>  procedure construct_object integer img#
67851>>>>>>>    forward send construct_object img#
67853>>>>>>>    property integer piProgramCounter      public 0
67854>>>>>>>    property integer piInvalidProgram      public 0
67855>>>>>>>    property integer piDebugState          public 0
67856>>>>>>>    property integer piDebugSingleStep     public 0
67857>>>>>>>    property string  psDebugLine           public ""
67858>>>>>>>    property integer pCurrentOpCodeLine    public 0
67859>>>>>>>    property integer pProgramEnded         public 0
67860>>>>>>>    property integer private.piLogChannel  public -1
67861>>>>>>>    property string  private.psLogFileName public ""
67862>>>>>>>    property integer phFDX_Server       public 0
67863>>>>>>>    object oOpcodes is a cOpCodes // OpCodes -> messages id's
67865>>>>>>>      send add_opcode OP_NOP                 "No operation"    msg_mthd_Nop                 0 0
67866>>>>>>>      send add_opcode OP_ABORT               "EndProgram."     msg_mthd_Abort               0 0
67867>>>>>>>      send add_opcode OP_CLEARSCREEN         "ClearScreen"     msg_mthd_ClearScreen         0 0
67868>>>>>>>      send add_opcode OP_GOSUB               "Gosub"           msg_mthd_Gosub               1 0
67869>>>>>>>      send add_opcode OP_GOTO                "Goto"            msg_mthd_Goto                1 0
67870>>>>>>>      send add_opcode OP_RETURN              "Return"          msg_mthd_Return              0 0
67871>>>>>>>      send add_opcode OP_SHOWLN              "ShowLn"          msg_mthd_ShowLn              1 0
67872>>>>>>>      send add_opcode OP_SHOW                "Show"            msg_mthd_Show                1 0
67873>>>>>>>      send add_opcode OP_SEQFILE             "SeqFile"         msg_mthd_SeqFile             2 0
67874>>>>>>>      send add_opcode OP_WRITELN             "WriteLn"         msg_mthd_WriteLn             1 0
67875>>>>>>>      send add_opcode OP_MSGBOX              "MsgBox"          msg_mthd_MsgBox              1 0
67876>>>>>>>      send add_opcode OP_INPUT               "Input"           msg_mthd_Input               2 0
67877>>>>>>>      send add_opcode OP_GOTOXY              "GotoXY"          msg_mthd_GotoXY              2 0
67878>>>>>>>      send add_opcode OP_PAUSE               "Pause"           msg_mthd_Pause               0 0
67879>>>>>>>      send add_opcode OP_ASSIGN              "Assign"          msg_mthd_Assign              2 0
67880>>>>>>>      send add_opcode OP_GVAR_INCR           "gVarIncrement"   msg_mthd_gVar_Incr           2 0
67881>>>>>>>      send add_opcode OP_GVAR_DISPLAY        "gVarDisplay"     msg_mthd_gVar_Display        0 0
67882>>>>>>>      send add_opcode OP_IF_GOTO             "IfGoto"          msg_mthd_if_goto             2 0
67883>>>>>>>      send add_opcode OP_IF_GOSUB            "IfGoSub"         msg_mthd_if_gosub            2 0
67884>>>>>>>      send add_opcode OP_IFTEST_GOTO         "IfTestGoto"      msg_mthd_iftest_goto         4 0
67885>>>>>>>      send add_opcode OP_IFTEST_GOSUB        "IfTestGoSub"     msg_mthd_iftest_gosub        4 0
67886>>>>>>>      send add_opcode OP_DEBUG               "Debug"           msg_mthd_debug               1 0
67887>>>>>>>      send add_opcode OP_LOG_OPEN            "LogOpen"         msg_mthd_log_open            2 0
67888>>>>>>>      send add_opcode OP_LOG_CLOSE           "LogClose"        msg_mthd_log_close           0 0
67889>>>>>>>      send add_opcode OP_LOG_DISPLAY         "LogDisplay"      msg_mthd_log_display         0 0
67890>>>>>>>      send add_opcode OP_LOG_FLUSH           "LogFlush"        msg_mthd_log_flush           0 0
67891>>>>>>>      send add_opcode OP_LOG_WRITE           "LogWrite"        msg_mthd_log_write           1 0
67892>>>>>>>      send add_opcode OP_LOG_WRITELN         "LogWriteLn"      msg_mthd_log_writeln         1 0
67893>>>>>>>      send add_opcode OP_API_FILELIST        "SetAttrFileList" msg_mthd_api_filelist        3 0
67894>>>>>>>      send add_opcode OP_API_FILE            "SetAttrFile"     msg_mthd_api_file            2 0
67895>>>>>>>      send add_opcode OP_API_FIELD           "SetAttrField"    msg_mthd_api_field           3 0
67896>>>>>>>      send add_opcode OP_API_INDEX           "SetAttrIndex"    msg_mthd_api_index           3 0
67897>>>>>>>      send add_opcode OP_API_IDXSEG          "SetAttrIdxSeg"   msg_mthd_api_idxseg          4 0
67898>>>>>>>      send add_opcode OP_API_STRUCTURE_ABORT "StructureAbort"  msg_mthd_api_structure_abort 0 0
67899>>>>>>>      send add_opcode OP_API_STRUCTURE_END   "StructureEnd"    msg_mthd_api_structure_end   0 0
67900>>>>>>>      send add_opcode OP_API_PROBE_END       "ProbeEnd"        msg_mthd_api_probe_end       0 0
67901>>>>>>>      send add_opcode OP_API_DELETEINDEX     "DeleteIndex"     msg_mthd_api_deleteindex     1 0
67902>>>>>>>      send add_opcode OP_API_DELETEFIELD     "DeleteField"     msg_mthd_api_deletefield     1 0
67903>>>>>>>      send add_opcode OP_API_APPENDFIELD     "AppendField"     msg_mthd_api_appendfield     2 0
67904>>>>>>>      send add_opcode OP_API_CREATEFIELD     "CreateField"     msg_mthd_api_createfield     3 0
67905>>>>>>>      send add_opcode OP_API_SETFIELDNUMBER  "SetFieldNumber"  msg_mthd_api_setfieldnumber  1 0
67906>>>>>>>    end_object
67907>>>>>>>    object oLabels is a cLabels no_image // Used during program entry
67909>>>>>>>    end_object
67910>>>>>>>    object oReturnAddressStack is a cStack no_image // Return addresses (Gosub's)
67912>>>>>>>    end_object
67913>>>>>>>    object oVariables is a cVariables no_image
67915>>>>>>>    end_object
67916>>>>>>>    object oDeclaredArrays is a cDeclaredArrays no_image
67918>>>>>>>    end_object
67919>>>>>>>    object oDeclaredFunctions is a cDeclaredFunctions no_image
67921>>>>>>>    end_object
67922>>>>>>>    object oExprEvalSequences is a cEvalSequence no_image
67924>>>>>>>      set piFunctionObject to (oDeclaredFunctions(self))
67925>>>>>>>    end_object
67926>>>>>>>  end_procedure
67927>>>>>>>
67927>>>>>>>  procedure add_opcode integer opcode# string name# integer msg# integer params# integer special_add_msg#
67929>>>>>>>    send add_opcode to (oOpcodes(self)) opcode# name# msg# params# special_add_msg#
67930>>>>>>>  end_procedure
67931>>>>>>>
67931>>>>>>>  function sEvalExpression integer id# returns string
67933>>>>>>>    function_return (sExec_Expression.i(oExprEvalSequences(self),id#))
67934>>>>>>>  end_function
67935>>>>>>>
67935>>>>>>>  function sArgValue.is integer type# string arg# returns string
67937>>>>>>>    if type# eq AT_VARNO get sVarValue arg# to arg#
67940>>>>>>>    if type# eq AT_EXPR  get sEvalExpression arg# to arg#
67943>>>>>>>    if type# eq AT_FIELDNO get_field_value (hi(integer(arg#))) (low(integer(arg#))) to arg#
67948>>>>>>>    if type# eq AT_ARRAY_ELEM get sAssigned_Value.ii of (oDeclaredArrays(self)) (hi(integer(arg#))) (low(integer(arg#))) to arg#
67951>>>>>>>    function_return arg#
67952>>>>>>>  end_function
67953>>>>>>>
67953>>>>>>>  function sArgType.is integer type# string arg# returns string
67955>>>>>>>    integer rval#
67955>>>>>>>    move -1 to rval# // Unknown type
67956>>>>>>>    if type# eq AT_CINT move VARTYP_INTEGER to rval#
67959>>>>>>>    if type# eq AT_CSTR move VARTYP_STRING to rval#
67962>>>>>>>    if type# eq AT_CNUM move VARTYP_NUMBER to rval#
67965>>>>>>>    if type# eq AT_CDAT move VARTYP_DATE to rval#
67968>>>>>>>    if type# eq AT_FIELDNO begin
67970>>>>>>>      get_attribute DF_FIELD_TYPE of (hi(integer(arg#))) (low(integer(arg#))) to type#
67973>>>>>>>      if type# eq DF_ASCII   move VARTYP_STRING to type#
67976>>>>>>>      if type# eq DF_BCD     move VARTYP_NUMBER to type#
67979>>>>>>>      if type# eq DF_DATE    move VARTYP_DATE   to type#
67982>>>>>>>      if type# eq DF_OVERLAP move VARTYP_STRING to type#
67985>>>>>>>      if type# eq DF_TEXT    move VARTYP_STRING to type#
67988>>>>>>>      if type# eq DF_BINARY  move VARTYP_STRING to type#
67991>>>>>>>    end
67991>>>>>>>>
67991>>>>>>>    if type# eq AT_VARNO begin
67993>>>>>>>      get piType.i of (oVariables(self)) arg# to rval#
67994>>>>>>>      function_return rval#
67995>>>>>>>    end
67995>>>>>>>>
67995>>>>>>>    if type# eq AT_EXPR function_return (psVar.i(oExprEvalSequences(self),integer(arg#)-1))
67998>>>>>>>    if type# eq AT_ARRAY_ELEM function_return (piType.i(oDeclaredArrays(self),hi(integer(arg#))))
68001>>>>>>>    function_return rval#
68002>>>>>>>  end_function
68003>>>>>>>
68003>>>>>>>  function iVarType.i integer varno# returns integer
68005>>>>>>>    function_return (piType.i(oVariables(self),varno#))
68006>>>>>>>  end_function
68007>>>>>>>  function iVarType.s string name# returns integer
68009>>>>>>>    integer varno#
68009>>>>>>>    get iVarNameToVarNo name# to varno#
68010>>>>>>>    if varno# eq -1 function_return -1
68013>>>>>>>    function_return (piType.i(oVariables(self),varno#))
68014>>>>>>>  end_function
68015>>>>>>>
68015>>>>>>>  // -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
68015>>>>>>>  // These procedures are used when EXECUTING each valid OP-code
68015>>>>>>>  procedure mthd_Nop
68017>>>>>>>  end_procedure
68018>>>>>>>  procedure mthd_ClearScreen
68020>>>>>>>    clearscreen
68021>>>>>>>>
68021>>>>>>>  end_procedure
68022>>>>>>>  procedure mthd_Abort
68024>>>>>>>    send reset // Clean up variables and arrays
68025>>>>>>>    set pProgramEnded to 1
68026>>>>>>>  end_procedure
68027>>>>>>>  procedure mthd_Gosub integer type# integer line#
68029>>>>>>>    get sArgValue.is type# line# to line#
68030>>>>>>>    integer pc#
68030>>>>>>>    get piProgramCounter to pc#
68031>>>>>>>    send Push.i to (oReturnAddressStack(self)) pc#
68032>>>>>>>    set piProgramCounter to line#
68033>>>>>>>  end_procedure
68034>>>>>>>  procedure mthd_Goto integer type# integer line#
68036>>>>>>>    get sArgValue.is type# line# to line#
68037>>>>>>>    set piProgramCounter to line#
68038>>>>>>>  end_procedure
68039>>>>>>>  procedure mthd_Return
68041>>>>>>>    set piProgramCounter to (iPop(oReturnAddressStack(self)))
68042>>>>>>>  end_procedure
68043>>>>>>>  procedure mthd_ShowLn integer type# string str#
68045>>>>>>>    get sArgValue.is type# str# to str#
68046>>>>>>>    showln str#
68048>>>>>>>  end_procedure
68049>>>>>>>  procedure mthd_Show integer type# string str#
68051>>>>>>>    get sArgValue.is type# str# to str#
68052>>>>>>>    show str#
68053>>>>>>>  end_procedure
68054>>>>>>>  procedure mthd_SeqFile integer type1# integer op# integer type2# string fn#
68056>>>>>>>  end_procedure
68057>>>>>>>  procedure mthd_WriteLn integer type# string str#
68059>>>>>>>  end_procedure
68060>>>>>>>  procedure mthd_MsgBox integer type# string str#
68062>>>>>>>    get sArgValue.is type# str# to str#
68063>>>>>>>    send obs str#
68064>>>>>>>  end_procedure
68065>>>>>>>  procedure mthd_GotoXY integer t1# integer v1# integer t2# integer v2#
68067>>>>>>>    get sArgValue.is t1# v1# to v1#
68068>>>>>>>    get sArgValue.is t2# v2# to v2#
68069>>>>>>>    gotoxy v1# v2#
68070>>>>>>>>
68070>>>>>>>  end_procedure
68071>>>>>>>  procedure mthd_Input integer type# integer varno# integer type2# string label#
68073>>>>>>>    string value#
68073>>>>>>>    get sArgValue.is type2# label# to label#
68074>>>>>>>    show label#
68075>>>>>>>    input value#
68076>>>>>>>>
68076>>>>>>>    send VarAssign to (oVariables(self)) varno# value#
68077>>>>>>>  end_procedure
68078>>>>>>>  procedure mthd_Pause
68080>>>>>>>    string grb#
68080>>>>>>>    inkey grb#
68081>>>>>>>>
68081>>>>>>>  end_procedure
68082>>>>>>>  procedure mthd_Assign integer type# string varno# integer type2# string value#
68084>>>>>>>//    send obs "mthd_Assign" type# varno# type2# value#
68084>>>>>>>    get sArgValue.is type2# value# to value# // Source value
68085>>>>>>>    if type# eq AT_FIELDNO set_field_value (hi(integer(varno#))) (low(integer(varno#))) to value#
68090>>>>>>>    else if type# eq AT_ARRAY_ELEM send Assign_Value to (oDeclaredArrays(self)) (hi(integer(varno#))) (low(integer(varno#))) value#
68094>>>>>>>    else send VarAssign to (oVariables(self)) varno# value#
68096>>>>>>>  end_procedure
68097>>>>>>>  procedure mthd_gVar_Incr integer type# integer varno# integer type2# integer amount#
68099>>>>>>>    get sArgValue.is type2# amount# to amount#
68100>>>>>>>    send VarIncrement to (oVariables(self)) varno# amount#
68101>>>>>>>  end_procedure
68102>>>>>>>  procedure mthd_gVar_Display
68104>>>>>>>    send VarDisplay to (oVariables(self))
68105>>>>>>>  end_procedure
68106>>>>>>>  procedure mthd_if_goto integer type# integer varno# integer type2# integer line#
68108>>>>>>>    integer bool#
68108>>>>>>>    get sArgValue.is type2# line# to line#
68109>>>>>>>    get psValue.i of (oVariables(self)) varno# to bool#
68110>>>>>>>    if bool# set piProgramCounter to line#
68113>>>>>>>  end_procedure
68114>>>>>>>  procedure mthd_if_gosub integer type# integer varno# integer type2# integer line#
68116>>>>>>>    integer bool# pc#
68116>>>>>>>    get sArgValue.is type2# line# to line#
68117>>>>>>>    get psValue.i of (oVariables(self)) varno# to bool#
68118>>>>>>>    if bool# begin
68120>>>>>>>      get piProgramCounter to pc#
68121>>>>>>>      send Push.i to (oReturnAddressStack(self)) pc#
68122>>>>>>>      set piProgramCounter to line#
68123>>>>>>>    end
68123>>>>>>>>
68123>>>>>>>  end_procedure
68124>>>>>>>  function iIfTest_Help.iiiiii integer t1# string arg1# ;                               integer t2# integer comp# ;                               integer t3# string arg2# returns integer
68126>>>>>>>    integer vcomp# type# i1# i2# bool#
68126>>>>>>>    number n1# n2#
68126>>>>>>>    date   d1# d2#
68126>>>>>>>    move -1 to bool#
68127>>>>>>>    get sArgType.is t1# arg1# to type#
68128>>>>>>>    get sArgValue.is t1# arg1# to arg1#
68129>>>>>>>    get sArgValue.is t3# arg2# to arg2#
68130>>>>>>>    if type# eq VARTYP_INTEGER begin
68132>>>>>>>      move 0 to bool#
68133>>>>>>>      move arg1# to i1#
68134>>>>>>>      move arg2# to i2#
68135>>>>>>>      if comp# eq COMP_LT move (i1#>>>>>>      if comp# eq COMP_LE move (i1#<=i2#) to bool#
68141>>>>>>>      if comp# eq COMP_EQ move (i1#=i2#)  to bool#
68144>>>>>>>      if comp# eq COMP_GE move (i1#>=i2#) to bool#
68147>>>>>>>      if comp# eq COMP_GT move (i1#>i2#)  to bool#
68150>>>>>>>      if comp# eq COMP_NE move (i1#<>i2#) to bool#
68153>>>>>>>    end
68153>>>>>>>>
68153>>>>>>>    if type# eq VARTYP_NUMBER begin
68155>>>>>>>      move 0 to bool#
68156>>>>>>>      move arg1# to n1#
68157>>>>>>>      move arg2# to n2#
68158>>>>>>>      if comp# eq COMP_LT move (n1#>>>>>>      if comp# eq COMP_LE move (n1#<=n2#) to bool#
68164>>>>>>>      if comp# eq COMP_EQ move (n1#=n2#)  to bool#
68167>>>>>>>      if comp# eq COMP_GE move (n1#>=n2#) to bool#
68170>>>>>>>      if comp# eq COMP_GT move (n1#>n2#)  to bool#
68173>>>>>>>      if comp# eq COMP_NE move (n1#<>n2#) to bool#
68176>>>>>>>    end
68176>>>>>>>>
68176>>>>>>>    if type# eq VARTYP_DATE begin
68178>>>>>>>      move 0 to bool#
68179>>>>>>>      move arg1# to d1#
68180>>>>>>>      move arg2# to d2#
68181>>>>>>>      if comp# eq COMP_LT move (d1#>>>>>>      if comp# eq COMP_LE move (d1#<=d2#) to bool#
68187>>>>>>>      if comp# eq COMP_EQ move (d1#=d2#)  to bool#
68190>>>>>>>      if comp# eq COMP_GE move (d1#>=d2#) to bool#
68193>>>>>>>      if comp# eq COMP_GT move (d1#>d2#)  to bool#
68196>>>>>>>      if comp# eq COMP_NE move (d1#<>d2#) to bool#
68199>>>>>>>    end
68199>>>>>>>>
68199>>>>>>>    if type# eq VARTYP_STRING begin
68201>>>>>>>      move 0 to bool#
68202>>>>>>>      if comp# eq COMP_LT if arg1# LT arg2# move 1 to bool#
68207>>>>>>>      if comp# eq COMP_LE if arg1# LE arg2# move 1 to bool#
68212>>>>>>>      if comp# eq COMP_EQ if arg1# EQ arg2# move 1 to bool#
68217>>>>>>>      if comp# eq COMP_GE if arg1# GE arg2# move 1 to bool#
68222>>>>>>>      if comp# eq COMP_GT if arg1# GT arg2# move 1 to bool#
68227>>>>>>>      if comp# eq COMP_NE if arg1# NE arg2# move 1 to bool#
68232>>>>>>>    end
68232>>>>>>>>
68232>>>>>>>    if bool# eq -1 send obs "Bad comparison, if-test failed"
68235>>>>>>>    function_return bool#
68236>>>>>>>  end_function
68237>>>>>>>  procedure mthd_iftest_goto integer t1# string varno1# integer t2# integer comp# integer t3# string varno2# integer t4# integer line#
68239>>>>>>>    integer bool# pc#
68239>>>>>>>    get sArgValue.is t4# line# to line#
68240>>>>>>>    get iIfTest_Help.iiiiii t1# varno1# t2# comp# t3# varno2# to bool#
68241>>>>>>>    if bool# set piProgramCounter to line#
68244>>>>>>>  end_procedure
68245>>>>>>>  procedure mthd_iftest_gosub integer t1# string varno1# integer t2# integer comp# integer t3# string varno2# integer t4# integer line#
68247>>>>>>>    integer bool# pc#
68247>>>>>>>    get sArgValue.is t4# line# to line#
68248>>>>>>>    get iIfTest_Help.iiiiii t1# varno1# t2# comp# t3# varno2# to bool#
68249>>>>>>>    if bool# begin
68251>>>>>>>      get piProgramCounter to pc#
68252>>>>>>>      send Push.i to (oReturnAddressStack(self)) pc#
68253>>>>>>>      set piProgramCounter to line#
68254>>>>>>>    end
68254>>>>>>>>
68254>>>>>>>  end_procedure
68255>>>>>>>  enumeration_list
68255>>>>>>>    define DBG.OFF
68255>>>>>>>    define DBG.ON
68255>>>>>>>    define DBG.SINGLESTEP
68255>>>>>>>    define DBG.VARDISPLAY
68255>>>>>>>  end_enumeration_list
68255>>>>>>>  procedure mthd_debug integer t1# string value#
68257>>>>>>>    get sArgValue.is t1# value# to value#
68258>>>>>>>    if (integer(value#)) eq DBG.OFF begin
68260>>>>>>>      set piDebugState to 0
68261>>>>>>>      set piDebugSingleStep to 0
68262>>>>>>>    end
68262>>>>>>>>
68262>>>>>>>    if (integer(value#)) eq DBG.ON begin
68264>>>>>>>      set piDebugState to 1
68265>>>>>>>      set piDebugSingleStep to 0
68266>>>>>>>    end
68266>>>>>>>>
68266>>>>>>>    if (integer(value#)) eq DBG.SINGLESTEP begin
68268>>>>>>>      set piDebugState to 1
68269>>>>>>>      set piDebugSingleStep to 1
68270>>>>>>>    end
68270>>>>>>>>
68270>>>>>>>    if (integer(value#)) eq DBG.VARDISPLAY send VarDisplay to (oVariables(self))
68273>>>>>>>  end_procedure
68274>>>>>>>  procedure mthd_log_open integer t1# string fn# integer t2# string append#
68276>>>>>>>    integer ch#
68276>>>>>>>    get sArgValue.is t1# fn# to fn#
68277>>>>>>>    get sArgValue.is t2# append# to append#
68278>>>>>>>    get private.piLogChannel to ch#
68279>>>>>>>    if ch# eq -1 begin
68281>>>>>>>      if (integer(append#)) move (SEQ_AppendOutput(fn#)) to ch#
68284>>>>>>>      else move (SEQ_DirectOutput(fn#)) to ch#
68286>>>>>>>      set private.piLogChannel  to ch#
68287>>>>>>>      set private.psLogFileName to fn#
68288>>>>>>>    end
68288>>>>>>>>
68288>>>>>>>    // else some kind of runtime error
68288>>>>>>>  end_procedure
68289>>>>>>>  procedure mthd_log_close
68291>>>>>>>    integer ch#
68291>>>>>>>    get private.piLogChannel to ch#
68292>>>>>>>    if (ch#>=0) begin
68294>>>>>>>      send SEQ_CloseOutput ch#
68295>>>>>>>      set private.piLogChannel to -1
68296>>>>>>>    end
68296>>>>>>>>
68296>>>>>>>    // else some kind of runtime error
68296>>>>>>>  end_procedure
68297>>>>>>>  procedure mthd_log_display
68299>>>>>>>    send output.display_file (private.psLogFileName(self))
68300>>>>>>>  end_procedure
68301>>>>>>>  procedure mthd_log_flush
68303>>>>>>>    integer ch#
68303>>>>>>>    get private.piLogChannel to ch#
68304>>>>>>>    if (ch#>=0) begin
68306>>>>>>>      close_output channel ch#
68308>>>>>>>      append_output channel ch# (private.psLogFileName(self))
68310>>>>>>>    end
68310>>>>>>>>
68310>>>>>>>    // else some kind of runtime error
68310>>>>>>>  end_procedure
68311>>>>>>>  procedure mthd_log_write integer type# string str#
68313>>>>>>>    integer ch#
68313>>>>>>>    get sArgValue.is type# str# to str#
68314>>>>>>>    get private.piLogChannel to ch#
68315>>>>>>>    if (ch#>=0) write channel ch# str#
68319>>>>>>>  end_procedure
68320>>>>>>>  procedure mthd_log_writeln integer type# string str#
68322>>>>>>>    integer ch#
68322>>>>>>>    get sArgValue.is type# str# to str#
68323>>>>>>>    get private.piLogChannel to ch#
68324>>>>>>>    if (ch#>=0) writeln channel ch# str#
68329>>>>>>>  end_procedure
68330>>>>>>>  procedure mthd_api_filelist integer t1# string a1# integer t2# string a2# integer t3# string a3#
68332>>>>>>>    get sArgValue.is t1# a1# to a1#
68333>>>>>>>    get sArgValue.is t2# a2# to a2#
68334>>>>>>>    get sArgValue.is t3# a3# to a3#
68335>>>>>>>    send RS_SetFileListAttr a1# a2# a3#
68336>>>>>>>  end_procedure
68337>>>>>>>  procedure mthd_api_file integer t1# string a1# integer t2# string a2#
68339>>>>>>>    get sArgValue.is t1# a1# to a1#
68340>>>>>>>    get sArgValue.is t2# a2# to a2#
68341>>>>>>>    send RS_SetFileAttr a1# a2#
68342>>>>>>>  end_procedure
68343>>>>>>>  procedure mthd_api_field integer t1# string a1# integer t2# string a2# integer t3# string a3#
68345>>>>>>>    get sArgValue.is t1# a1# to a1#
68346>>>>>>>    get sArgValue.is t2# a2# to a2#
68347>>>>>>>    get sArgValue.is t3# a3# to a3#
68348>>>>>>>    send RS_SetFieldAttr a1# a2# a3#
68349>>>>>>>  end_procedure
68350>>>>>>>  procedure mthd_api_index integer t1# string a1# integer t2# string a2# integer t3# string a3#
68352>>>>>>>    get sArgValue.is t1# a1# to a1#
68353>>>>>>>    get sArgValue.is t2# a2# to a2#
68354>>>>>>>    get sArgValue.is t3# a3# to a3#
68355>>>>>>>    send RS_SetIndexAttr a1# a2# a3#
68356>>>>>>>  end_procedure
68357>>>>>>>  procedure mthd_api_idxseg integer t1# string a1# integer t2# string a2# integer t3# string a3# integer t4# string a4#
68359>>>>>>>    get sArgValue.is t1# a1# to a1#
68360>>>>>>>    get sArgValue.is t2# a2# to a2#
68361>>>>>>>    get sArgValue.is t3# a3# to a3#
68362>>>>>>>    get sArgValue.is t4# a4# to a4#
68363>>>>>>>    send RS_SetIndexSegAttr a1# a2# a3# a4#
68364>>>>>>>  end_procedure
68365>>>>>>>  procedure mthd_api_structure_abort
68367>>>>>>>    send RS_Structure_Abort
68368>>>>>>>  end_procedure
68369>>>>>>>  procedure mthd_api_structure_end
68371>>>>>>>    send RS_Structure_End
68372>>>>>>>  end_procedure
68373>>>>>>>  procedure mthd_api_probe_end
68375>>>>>>>    send RS_Probe_End
68376>>>>>>>  end_procedure
68377>>>>>>>  procedure mthd_api_DeleteIndex integer t1# string a1#
68379>>>>>>>    get sArgValue.is t1# a1# to a1#
68380>>>>>>>    send RS_DeleteIndex a1#
68381>>>>>>>  end_procedure
68382>>>>>>>  procedure mthd_api_DeleteField integer t1# string a1#
68384>>>>>>>    get sArgValue.is t1# a1# to a1#
68385>>>>>>>    send RS_DeleteField a1#
68386>>>>>>>  end_procedure
68387>>>>>>>  procedure mthd_api_AppendField integer t1# string a1# integer t2# string a2#
68389>>>>>>>    get sArgValue.is t1# a1# to a1#
68390>>>>>>>    get sArgValue.is t2# a2# to a2#
68391>>>>>>>    send RS_AppendField a1# a2#
68392>>>>>>>  end_procedure
68393>>>>>>>  procedure mthd_api_CreateField integer t1# string a1# integer t2# string a2# integer t3# string a3#
68395>>>>>>>    get sArgValue.is t1# a1# to a1#
68396>>>>>>>    get sArgValue.is t2# a2# to a2#
68397>>>>>>>    get sArgValue.is t3# a3# to a3#
68398>>>>>>>    send RS_CreateField a1# a2# a3#
68399>>>>>>>  end_procedure
68400>>>>>>>  procedure mthd_api_SetFieldNumber integer t1# string a1#
68402>>>>>>>    get sArgValue.is t1# a1# to a1#
68403>>>>>>>    send RS_SetFieldNumber a1#
68404>>>>>>>  end_procedure
68405>>>>>>>  // -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
68405>>>>>>>  procedure add_ct_error integer line# string msg#
68407>>>>>>>    send obs ("Error in line "+string(line#)) msg#
68408>>>>>>>    set piInvalidProgram to true
68409>>>>>>>  end_procedure
68410>>>>>>>  procedure reset
68412>>>>>>>    send delete_data
68413>>>>>>>    send reset to (oLabels(self))
68414>>>>>>>    send reset to (oDeclaredArrays(self))
68415>>>>>>>    send reset to (oDeclaredFunctions(self))
68416>>>>>>>    send reset to (oExprEvalSequences(self))
68417>>>>>>>    send delete_data to (oReturnAddressStack(self))
68418>>>>>>>    send delete_data to (oVariables(self))
68419>>>>>>>    set piProgramCounter to 0
68420>>>>>>>    set piInvalidProgram to 0
68421>>>>>>>    set pCurrentOpCodeLine to 0
68422>>>>>>>    set pProgramEnded to 0
68423>>>>>>>    set private.piLogChannel  to -1
68424>>>>>>>    set private.psLogFileName to ""
68425>>>>>>>  end_procedure
68426>>>>>>>  procedure increment_pc integer tmp_amount#
68428>>>>>>>    integer amount#
68428>>>>>>>    if num_arguments move tmp_amount# to amount#
68431>>>>>>>    else move 1 to amount#
68433>>>>>>>    set piProgramCounter to (piProgramCounter(self)+amount#)
68434>>>>>>>  end_procedure
68435>>>>>>>  function sGetData returns string
68437>>>>>>>    string rval#
68437>>>>>>>    get value item (piProgramCounter(self)) to rval#
68438>>>>>>>    send increment_pc
68439>>>>>>>    function_return rval#
68440>>>>>>>  end_function
68441>>>>>>>  // -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
68441>>>>>>>  // These procedures are used for EXECUTING a program
68441>>>>>>>  procedure add_debug_line integer display# integer opcode# integer typ1# string arg1# integer typ2# string arg2# integer typ3# string arg3# integer typ4# string arg4# integer typ5# string arg5# integer typ6# string arg6#
68443>>>>>>>    integer num_arguments#
68443>>>>>>>    string grb# str#
68443>>>>>>>    get piParameters.i of (oOpcodes(self)) item opcode# to num_arguments#
68444>>>>>>>    move "Line #: #" to str#
68445>>>>>>>    replace "#" in str# with (IntToStrRzf(pCurrentOpCodeLine(self),length(string(item_count(self)-1))))
68447>>>>>>>    replace "#" in str# with (psName.i(oOpcodes(self),opcode#))
68449>>>>>>>    if num_arguments# ge 1 move (str#+" "+sArgtype_Name.i(typ1#)+"["+arg1#+"]") to str#
68452>>>>>>>    if num_arguments# ge 2 move (str#+" "+sArgtype_Name.i(typ2#)+"["+arg2#+"]") to str#
68455>>>>>>>    if num_arguments# ge 3 move (str#+" "+sArgtype_Name.i(typ3#)+"["+arg3#+"]") to str#
68458>>>>>>>    if num_arguments# ge 4 move (str#+" "+sArgtype_Name.i(typ4#)+"["+arg4#+"]") to str#
68461>>>>>>>    if num_arguments# ge 5 move (str#+" "+sArgtype_Name.i(typ5#)+"["+arg5#+"]") to str#
68464>>>>>>>    if num_arguments# ge 6 move (str#+" "+sArgtype_Name.i(typ6#)+"["+arg6#+"]") to str#
68467>>>>>>>    set psDebugLine to str#
68468>>>>>>>    if display# begin
68470>>>>>>>      showln str#
68472>>>>>>>      if (piDebugSingleStep(self)) inkey grb#
68475>>>>>>>    end
68475>>>>>>>>
68475>>>>>>>  end_procedure
68476>>>>>>>  procedure illegal_opcode integer opcode#
68478>>>>>>>    send add_ct_error (piProgramCounter(self)-1) ("Illegal OPCODE ("+string(opcode#)+")")
68479>>>>>>>  end_procedure
68480>>>>>>>  procedure exec_instruction integer opcode# integer exec#
68482>>>>>>>    integer msg# num_arguments# oOpCodes#
68482>>>>>>>    integer typ1# typ2# typ3# typ4# typ5# typ6#
68482>>>>>>>    string arg1# arg2# arg3# arg4# arg5# arg6#
68482>>>>>>>    //send obs (psName.i(oOpCodes(self),opcode#))
68482>>>>>>>    move (oOpCodes(self)) to oOpCodes#
68483>>>>>>>    get piMessage.i    of oOpCodes# opcode# to msg#
68484>>>>>>>    get piParameters.i of oOpCodes# opcode# to num_arguments#
68485>>>>>>>    if num_arguments# ge 1 get sGetData to typ1#
68488>>>>>>>    if num_arguments# ge 1 get sGetData to arg1#
68491>>>>>>>    if num_arguments# ge 2 get sGetData to typ2#
68494>>>>>>>    if num_arguments# ge 2 get sGetData to arg2#
68497>>>>>>>    if num_arguments# ge 3 get sGetData to typ3#
68500>>>>>>>    if num_arguments# ge 3 get sGetData to arg3#
68503>>>>>>>    if num_arguments# ge 4 get sGetData to typ4#
68506>>>>>>>    if num_arguments# ge 4 get sGetData to arg4#
68509>>>>>>>    if num_arguments# ge 5 get sGetData to typ5#
68512>>>>>>>    if num_arguments# ge 5 get sGetData to arg5#
68515>>>>>>>    if num_arguments# ge 6 get sGetData to typ6#
68518>>>>>>>    if num_arguments# ge 6 get sGetData to arg6#
68521>>>>>>>    if (piDebugState(self)) ;      send add_debug_line exec# opcode# typ1# arg1# typ2# arg2# typ3# arg3# typ4# arg4# typ5# arg5# typ6# arg6#
68524>>>>>>>    if exec# begin
68526>>>>>>>      if num_arguments# eq 0 send msg#
68529>>>>>>>      if num_arguments# eq 1 send msg# typ1# arg1#
68532>>>>>>>      if num_arguments# eq 2 send msg# typ1# arg1# typ2# arg2#
68535>>>>>>>      if num_arguments# eq 3 send msg# typ1# arg1# typ2# arg2# typ3# arg3#
68538>>>>>>>      if num_arguments# eq 4 send msg# typ1# arg1# typ2# arg2# typ3# arg3# typ4# arg4#
68541>>>>>>>      if num_arguments# eq 5 send msg# typ1# arg1# typ2# arg2# typ3# arg3# typ4# arg4# typ5# arg5#
68544>>>>>>>      if num_arguments# eq 6 send msg# typ1# arg1# typ2# arg2# typ3# arg3# typ4# arg4# typ5# arg5# typ6# arg6#
68547>>>>>>>    end
68547>>>>>>>>
68547>>>>>>>  end_procedure
68548>>>>>>>  function sExecutingLine returns string
68550>>>>>>>    integer opcode# st#
68550>>>>>>>    get piDebugState to st#
68551>>>>>>>    set piDebugState to true
68552>>>>>>>    set piProgramCounter to (pCurrentOpCodeLine(self))
68553>>>>>>>    get value item (pCurrentOpCodeLine(self)) to opcode#
68554>>>>>>>    send increment_pc
68555>>>>>>>    send exec_instruction opcode# 0
68556>>>>>>>    set piDebugState to st#
68557>>>>>>>    function_return (psDebugLine(self))
68558>>>>>>>  end_function
68559>>>>>>>  procedure run_script
68561>>>>>>>    integer pc# max# opcode# max_line#
68561>>>>>>>    ifnot (piInvalidProgram(self)) begin
68563>>>>>>>      set piProgramCounter to 0
68564>>>>>>>      set pProgramEnded to 0
68565>>>>>>>      move self to oVM_CurrentlyExecuting#
68566>>>>>>>      send delete_data to (oReturnAddressStack(self))
68567>>>>>>>      move 0 to max_line#
68568>>>>>>>      send DFScriptError_On
68569>>>>>>>      get piProgramCounter to pc#
68570>>>>>>>      get item_count to max#
68571>>>>>>>      screenmode 1
68572>>>>>>>      while (pc#>>>>>>        get value item pc# to opcode#
68577>>>>>>>        set pCurrentOpCodeLine to pc#
68578>>>>>>>        send increment_pc
68579>>>>>>>        send exec_instruction opcode# 1
68580>>>>>>>        get piProgramCounter to pc#
68581>>>>>>>        increment max_line#
68582>>>>>>>        if max_line# gt 10000 begin
68584>>>>>>>          if (MB_Verify4("","Max lines encountered!","Execute another "+string(10000)+" instructions?","",1)) move 0 to max_line#
68587>>>>>>>          else set pProgramEnded to true
68589>>>>>>>        end
68589>>>>>>>>
68589>>>>>>>      end
68590>>>>>>>>
68590>>>>>>>      if (private.piLogChannel(self)<>-1) begin // Close log file and release channel
68592>>>>>>>        send SEQ_CloseOutput (private.piLogChannel(self))
68593>>>>>>>        set private.piLogChannel to -1
68594>>>>>>>      end
68594>>>>>>>>
68594>>>>>>>      send DFScriptError_Off
68595>>>>>>>    end
68595>>>>>>>>
68595>>>>>>>    else send obs "Errors where found during" "script interpretation." "The program will not execute!"
68597>>>>>>>    move 0 to oVM_CurrentlyExecuting#
68598>>>>>>>  end_procedure
68599>>>>>>>
68599>>>>>>>  procedure program_init
68601>>>>>>>    set private.piLogChannel  to -1
68602>>>>>>>    //intended for augmentation (Define SCREENEND and the like)
68602>>>>>>>  end_procedure
68603>>>>>>>
68603>>>>>>>  procedure AddOpcode.i integer opcode#
68605>>>>>>>    set value item (piProgramCounter(self)) to opcode#
68606>>>>>>>    send increment_pc
68607>>>>>>>  end_procedure
68608>>>>>>>  procedure script_begin
68610>>>>>>>    send reset
68611>>>>>>>    send program_init
68612>>>>>>>  end_procedure
68613>>>>>>>  procedure private.resolve_labels
68615>>>>>>>    integer self#
68615>>>>>>>    string unresolved_label#
68615>>>>>>>    move self to self#
68616>>>>>>>    get sResolve_Labels.i of (oLabels(self)) self# to unresolved_label#
68617>>>>>>>    if unresolved_label# ne "" send add_ct_error (piProgramCounter(self)-1) ("Unresolved label ("+unresolved_label#+")")
68620>>>>>>>  end_procedure
68621>>>>>>>  procedure script_end
68623>>>>>>>    send private.resolve_labels
68624>>>>>>>  end_procedure
68625>>>>>>>  procedure declare_label string name#
68627>>>>>>>    integer self#
68627>>>>>>>    move self to self#
68628>>>>>>>    send add_resolved_label to (oLabels(self)) name# (piProgramCounter(self#))
68629>>>>>>>  end_procedure
68630>>>>>>>  procedure declare_label_no_error string name# // Makes no error if label is already defined
68632>>>>>>>    integer self#
68632>>>>>>>    move self to self#
68633>>>>>>>    send add_resolved_label_no_error to (oLabels(self)) name# (piProgramCounter(self#))
68634>>>>>>>  end_procedure
68635>>>>>>>  function iIsLabelNameUsed.s string name# returns integer
68637>>>>>>>    function_return (iIsLabelNameUsed.s(oLabels(self),name#))
68638>>>>>>>  end_function
68639>>>>>>>  // ====== Variable procedures =======================================
68639>>>>>>>  function iVarValue integer varno# returns integer
68641>>>>>>>    function_return (psValue.i(oVariables(self),varno#))
68642>>>>>>>  end_function
68643>>>>>>>  function dVarValue integer varno# returns integer
68645>>>>>>>    function_return (psValue.i(oVariables(self),varno#))
68646>>>>>>>  end_function
68647>>>>>>>  function nVarValue integer varno# returns number
68649>>>>>>>    function_return (psValue.i(oVariables(self),varno#))
68650>>>>>>>  end_function
68651>>>>>>>  function sVarValue integer varno# returns string
68653>>>>>>>    function_return (psValue.i(oVariables(self),varno#))
68654>>>>>>>  end_function
68655>>>>>>>  procedure declare_var string varid# integer type#
68657>>>>>>>    send VarNameDeclare to (oVariables(self)) varid# type#
68658>>>>>>>  end_procedure
68659>>>>>>>  function iIsVarDeclared.s string varid# returns integer
68661>>>>>>>    integer rval#
68661>>>>>>>    get iVarNameToVarNo of (oVariables(self)) varid# to rval#
68662>>>>>>>    function_return (rval#<>-1)
68663>>>>>>>  end_function
68664>>>>>>>  procedure declare_var_cond string varid# integer type# // Declare if not already declared
68666>>>>>>>    ifnot (iIsVarDeclared.s(self,varid#)) send declare_var varid# type#
68669>>>>>>>  end_procedure
68670>>>>>>>  function iVarNameToVarNo string varid# returns integer
68672>>>>>>>    integer rval#
68672>>>>>>>    get iVarNameToVarNo of (oVariables(self)) varid# to rval#
68673>>>>>>>    function_return rval#
68674>>>>>>>  end_function
68675>>>>>>>  // ====== Field stuff ============================================
68675>>>>>>>  function iFileField.s string lsSymbol returns integer
68677>>>>>>>    string lsFile lsField
68677>>>>>>>    integer liFile liField lhFdx
68677>>>>>>>    move (uppercase(ExtractWord(lsSymbol,".",1))) to lsFile
68678>>>>>>>    move (uppercase(ExtractWord(lsSymbol,".",2))) to lsField
68679>>>>>>>    get phFDX_Server to lhFdx
68680>>>>>>>    if (lsFile<>"" and lsField<>"") begin
68682>>>>>>>      get FDX_FindLogicalName lhFdx lsFile 0 to liFile
68683>>>>>>>      if (liFile>-1) get FDX_FindField lhFdx liFile lsField to liField
68686>>>>>>>      else move -1 to liField
68688>>>>>>>      if (liField>-1) function_return (liFile*65536+liField)
68691>>>>>>>    end
68691>>>>>>>>
68691>>>>>>>    function_return 0
68692>>>>>>>  end_function
68693>>>>>>>  function iFieldType.i integer liFileField returns integer
68695>>>>>>>    integer lhFdx liType
68695>>>>>>>    get phFDX_Server to lhFdx
68696>>>>>>>    get FDX_AttrValue_FIELD lhFdx DF_FIELD_TYPE (liFileField/65536) (mod(liFileField,65536)) to liType
68697>>>>>>>    if liType eq DF_ASCII   function_return FLDTYP_STRING
68700>>>>>>>    if liType eq DF_BCD     function_return FLDTYP_NUMBER
68703>>>>>>>    if liType eq DF_DATE    function_return FLDTYP_DATE
68706>>>>>>>    if liType eq DF_TEXT    function_return FLDTYP_STRING
68709>>>>>>>    if liType eq DF_BINARY  function_return FLDTYP_STRING
68712>>>>>>>    if liType eq DF_OVERLAP function_return FLDTYP_STRING
68715>>>>>>>  end_function
68716>>>>>>>
68716>>>>>>>  // ====== Function stuff ============================================
68716>>>>>>>  function iFuncNameToFuncNo.s string name# returns integer
68718>>>>>>>    function_return (iNameToNumber.s(oDeclaredFunctions(self),name#))
68719>>>>>>>  end_function
68720>>>>>>>  function iFuncType.i integer id# returns integer
68722>>>>>>>    function_return (piReturnType.i(oDeclaredFunctions(self),id#))
68723>>>>>>>  end_function
68724>>>>>>>  function sFuncParams.i integer id# returns string
68726>>>>>>>    function_return (psParameterList.i(oDeclaredFunctions(self),id#))
68727>>>>>>>  end_function
68728>>>>>>>  function sFuncClass.i integer id# returns string
68730>>>>>>>    function_return (piFuncClass.i(oDeclaredFunctions(self),id#))
68731>>>>>>>  end_function
68732>>>>>>>  // ====== Array stuff ===============================================
68732>>>>>>>  procedure declare_array string name# integer type#
68734>>>>>>>    send declare_array (oDeclaredArrays(self)) name# type#
68735>>>>>>>  end_procedure
68736>>>>>>>  // ====== Procedures used for entering a program ====================
68736>>>>>>>  procedure add_argument_label string labelid#
68738>>>>>>>    integer self# line#
68738>>>>>>>    move self to self#
68739>>>>>>>    send add_label_reference to (oLabels(self)) labelid# self# (piProgramCounter(self#))
68740>>>>>>>    send increment_pc
68741>>>>>>>  end_procedure
68742>>>>>>>  procedure add_argument_gvar string varid#
68744>>>>>>>    integer varno#
68744>>>>>>>    get iVarNameToVarNo of (oVariables(self)) varid# to varno#
68745>>>>>>>    if varno# eq -1 send add_ct_error (piProgramCounter(self)) ("Undefined variable name: "+varid#)
68748>>>>>>>    set value item (piProgramCounter(self)) to varno#
68749>>>>>>>    send increment_pc
68750>>>>>>>  end_procedure
68751>>>>>>>  procedure add_argument_field string lsFieldName
68753>>>>>>>    integer liFileField
68753>>>>>>>    get iFileField.s lsFieldName to liFileField
68754>>>>>>>    if liFileField eq 0 send add_ct_error (piProgramCounter(self)) ("Undefined field name: "+lsFieldName)
68757>>>>>>>    set value item (piProgramCounter(self)) to liFileField
68758>>>>>>>    send increment_pc
68759>>>>>>>  end_procedure
68760>>>>>>>  procedure AddData.s integer arg_type# string data#
68762>>>>>>>    if arg_type# eq AT_VAR begin
68764>>>>>>>      set value item (piProgramCounter(self)) to AT_VARNO
68765>>>>>>>      send increment_pc
68766>>>>>>>      send add_argument_gvar data#
68767>>>>>>>    end
68767>>>>>>>>
68767>>>>>>>    if arg_type# eq AT_LBL begin
68769>>>>>>>      set value item (piProgramCounter(self)) to AT_LBL
68770>>>>>>>      send increment_pc
68771>>>>>>>      send add_argument_label data#
68772>>>>>>>    end
68772>>>>>>>>
68772>>>>>>>    if (iArgType_Const.i(arg_type#)) begin
68774>>>>>>>      set value item (piProgramCounter(self)) to arg_type#
68775>>>>>>>      send increment_pc
68776>>>>>>>      set value item (piProgramCounter(self)) to data#
68777>>>>>>>      send increment_pc
68778>>>>>>>    end
68778>>>>>>>>
68778>>>>>>>    if arg_type# eq AT_EXPR begin
68780>>>>>>>      set value item (piProgramCounter(self)) to arg_type#
68781>>>>>>>      send increment_pc
68782>>>>>>>      set value item (piProgramCounter(self)) to data#
68783>>>>>>>      send increment_pc
68784>>>>>>>    end
68784>>>>>>>>
68784>>>>>>>    if arg_type# eq AT_FIELD begin
68786>>>>>>>      set value item (piProgramCounter(self)) to AT_FIELDNO
68787>>>>>>>      send increment_pc
68788>>>>>>>      send add_argument_field data#
68789>>>>>>>    end
68789>>>>>>>>
68789>>>>>>>    if arg_type# eq AT_ARRAY_ELEM begin
68791>>>>>>>      set value item (piProgramCounter(self)) to AT_ARRAY_ELEM
68792>>>>>>>    end
68792>>>>>>>>
68792>>>>>>>  end_procedure
68793>>>>>>>  procedure add_instruction integer opcode# string arg#
68795>>>>>>>    integer iArg num_arguments# special_add_msg# oOpCodes# argtype# count#
68795>>>>>>>    string data#
68795>>>>>>>    string arg1# arg2# arg3# arg4# arg5# arg6# arg7# arg8# arg9# arg10# arg11# arg12#
68795>>>>>>>    move (oOpcodes(self)) to oOpCodes#
68796>>>>>>>    get piParameters.i of oOpCodes# item opcode# to num_arguments#
68797>>>>>>>    if num_arguments# ne (num_arguments-1/2) begin
68799>>>>>>>      send add_ct_error (piProgramCounter(self)) "Wrong number of arguments"
68800>>>>>>>      send add_ct_error (piProgramCounter(self)) ("Command: "+psName.i(oOpcodes#,opcode#)+"(Gets "+string(num_arguments-1/2)+", expects "+string(num_arguments#)+")")
68801>>>>>>>    end
68801>>>>>>>>
68801>>>>>>>    else begin
68802>>>>>>>      get piSpecialAddMsg.i of oOpCodes# item opcode# to special_add_msg#
68803>>>>>>>      if special_add_msg# begin
68805>>>>>>>        for iArg from 2 to num_arguments
68811>>>>>>>>
68811>>>>>>>          if iArg eq  2 MoveStr iArg& to arg1#
68814>>>>>>>          if iArg eq  3 MoveStr iArg& to arg2#
68817>>>>>>>          if iArg eq  4 MoveStr iArg& to arg3#
68820>>>>>>>          if iArg eq  5 MoveStr iArg& to arg4#
68823>>>>>>>          if iArg eq  6 MoveStr iArg& to arg5#
68826>>>>>>>          if iArg eq  7 MoveStr iArg& to arg6#
68829>>>>>>>          if iArg eq  8 MoveStr iArg& to arg7#
68832>>>>>>>          if iArg eq  9 MoveStr iArg& to arg8#
68835>>>>>>>          if iArg eq 10 MoveStr iArg& to arg9#
68838>>>>>>>          if iArg eq 11 MoveStr iArg& to arg10#
68841>>>>>>>          if iArg eq 12 MoveStr iArg& to arg11#
68844>>>>>>>          if iArg eq 13 MoveStr iArg& to arg12#
68847>>>>>>>        loop
68848>>>>>>>>
68848>>>>>>>        if num_arguments eq  1 send special_add_msg# opcode#
68851>>>>>>>        if num_arguments eq  2 send special_add_msg# opcode# arg1#
68854>>>>>>>        if num_arguments eq  3 send special_add_msg# opcode# arg1# arg2#
68857>>>>>>>        if num_arguments eq  4 send special_add_msg# opcode# arg1# arg2# arg3#
68860>>>>>>>        if num_arguments eq  5 send special_add_msg# opcode# arg1# arg2# arg3# arg4#
68863>>>>>>>        if num_arguments eq  6 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5#
68866>>>>>>>        if num_arguments eq  7 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5# arg6#
68869>>>>>>>        if num_arguments eq  8 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5# arg6# arg7#
68872>>>>>>>        if num_arguments eq  9 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5# arg6# arg7# arg8#
68875>>>>>>>        if num_arguments eq 10 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5# arg6# arg7# arg8# arg9#
68878>>>>>>>        if num_arguments eq 11 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5# arg6# arg7# arg8# arg9# arg10#
68881>>>>>>>        if num_arguments eq 12 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5# arg6# arg7# arg8# arg9# arg10# arg11#
68884>>>>>>>        if num_arguments eq 13 send special_add_msg# opcode# arg1# arg2# arg3# arg4# arg5# arg6# arg7# arg8# arg9# arg10# arg11# arg12#
68887>>>>>>>      end
68887>>>>>>>>
68887>>>>>>>      else begin
68888>>>>>>>        send AddOpcode.i opcode#
68889>>>>>>>        for count# from 1 to num_arguments#
68895>>>>>>>>
68895>>>>>>>          move (count#-1*2+2) to iArg
68896>>>>>>>          MoveStr iArg& to argtype# // tricky way to parse passed arguments
68897>>>>>>>>
68897>>>>>>>          increment iArg
68898>>>>>>>          MoveStr iArg& to data# // tricky way to parse passed arguments
68899>>>>>>>>
68899>>>>>>>          send AddData.s argtype# data#
68900>>>>>>>        loop
68901>>>>>>>>
68901>>>>>>>      end
68901>>>>>>>>
68901>>>>>>>    end
68901>>>>>>>>
68901>>>>>>>    //send display_array
68901>>>>>>>  end_procedure
68902>>>>>>>  // ==================================================================
68902>>>>>>>  procedure display_array
68904>>>>>>>    integer max# itm#
68904>>>>>>>    get item_count to max#
68905>>>>>>>    showln
68906>>>>>>>    show ">> "
68907>>>>>>>    for itm# from 0 to (max#-1)
68913>>>>>>>>
68913>>>>>>>      show ("["+value(self,itm#)+"]")
68914>>>>>>>    loop
68915>>>>>>>>
68915>>>>>>>    inkey itm#
68916>>>>>>>>
68916>>>>>>>  end_procedure
68917>>>>>>>end_class // cBasicVirtualMachine
68918>>>>>>>
68918>>>>>>>// ========================================================================
68918>>>>>>>//  SEC2: =================================================================
68918>>>>>>>// ========================================================================
68918>>>>>>>
68918>>>>>>>Enumeration_List // Operation codes
68918>>>>>>>  Enumeration_List_Set_Enum_Value cBasicVirtualMachine.NEXT_OP
68918>>>>>>>  define OP_WHILE
68918>>>>>>>  define OP_FOR
68918>>>>>>>  define OP_LOOP
68918>>>>>>>  define OP_IF_BEGIN
68918>>>>>>>  define OP_ELSE
68918>>>>>>>  define OP_ENDIF
68918>>>>>>>  define OP_REPEAT
68918>>>>>>>  define OP_UNTIL
68918>>>>>>>  define cVirtualMachine.NEXT_OP // Augmentation codes starts here
68918>>>>>>>End_Enumeration_List
68918>>>>>>>
68918>>>>>>>register_procedure add_macro_while
68918>>>>>>>register_procedure add_macro_for
68918>>>>>>>register_procedure add_macro_loop
68918>>>>>>>register_procedure add_macro_if_begin
68918>>>>>>>register_procedure add_macro_else
68918>>>>>>>register_procedure add_macro_endif
68918>>>>>>>register_procedure add_macro_repeat
68918>>>>>>>register_procedure add_macro_until
68918>>>>>>>
68918>>>>>>>class cVirtualMachine is an cBasicVirtualMachine
68919>>>>>>>  procedure construct_object integer img#
68921>>>>>>>    forward send construct_object img#
68923>>>>>>>    send add_opcode OP_WHILE    "While"  0 3 msg_add_macro_while    //
68924>>>>>>>    send add_opcode OP_FOR      "For"    0 3 msg_add_macro_for      //
68925>>>>>>>    send add_opcode OP_LOOP     "Loop"   0 0 msg_add_macro_loop     //
68926>>>>>>>    send add_opcode OP_IF_BEGIN "If"     0 3 msg_add_macro_if_begin //
68927>>>>>>>    send add_opcode OP_ELSE     "Else"   0 0 msg_add_macro_else     //
68928>>>>>>>    send add_opcode OP_ENDIF    "End"    0 0 msg_add_macro_endif    //
68929>>>>>>>    send add_opcode OP_REPEAT   "Repeat" 0 0 msg_add_macro_repeat   //
68930>>>>>>>    send add_opcode OP_UNTIL    "Until"  0 3 msg_add_macro_until    //
68931>>>>>>>    object oIfStack is a cStack
68933>>>>>>>    end_object
68934>>>>>>>    property integer pUniqueLabelID public 0 // Used for generating unique labels
68935>>>>>>>  end_procedure
68936>>>>>>>  procedure reset
68938>>>>>>>    forward send reset
68940>>>>>>>    set pUniqueLabelID to 0
68941>>>>>>>    send delete_data to (oIfStack(self))
68942>>>>>>>  end_procedure
68943>>>>>>>  function sNextUniqueLabel returns string // Returns next unique label
68945>>>>>>>    integer UniqueLabelID#
68945>>>>>>>    string rval#
68945>>>>>>>    get pUniqueLabelID to UniqueLabelID#
68946>>>>>>>    move ("Label$"+string(UniqueLabelID#)) to rval#
68947>>>>>>>    set pUniqueLabelID to (UniqueLabelID#+1)
68948>>>>>>>    function_return rval#
68949>>>>>>>  end_function
68950>>>>>>>
68950>>>>>>>  // Repeat/Until structure:
68950>>>>>>>  //
68950>>>>>>>  // Repeat:      LoopStart:
68950>>>>>>>  //
68950>>>>>>>  // Until:       If Var1 Comp Var2 Goto Loopend:
68950>>>>>>>  //              Goto LoopStart:
68950>>>>>>>  //              LoopEnd:
68950>>>>>>>  //
68950>>>>>>>  procedure add_macro_repeat
68952>>>>>>>    string lbl_LoopStart#
68952>>>>>>>    get sNextUniqueLabel to lbl_LoopStart#
68953>>>>>>>    send declare_label lbl_LoopStart#
68954>>>>>>>    send push.s to (oIfStack(self)) lbl_LoopStart#
68955>>>>>>>  end_procedure
68956>>>>>>>
68956>>>>>>>  procedure add_macro_until integer opcode# integer t1# integer varno1# integer t2# integer comp# integer t3# integer varno2#
68958>>>>>>>    string lbl_LoopStart# lbl_LoopEnd#
68958>>>>>>>    get sNextUniqueLabel to lbl_LoopEnd#
68959>>>>>>>    get sPop of (oIfStack(self)) to lbl_LoopStart#
68960>>>>>>>    send add_instruction OP_IFTEST_GOTO t1# varno1# t2# comp# t3# varno2# AT_LBL lbl_LoopEnd#
68961>>>>>>>    send add_instruction OP_GOTO AT_LBL lbl_LoopStart#
68962>>>>>>>    send declare_label lbl_LoopEnd#
68963>>>>>>>  end_procedure
68964>>>>>>>
68964>>>>>>>  // For/Loop structure:
68964>>>>>>>  //
68964>>>>>>>  // For:         VarAssign CtrlId VarFrom
68964>>>>>>>  //              Goto LoopStart
68964>>>>>>>  //              CtrlIncrement:
68964>>>>>>>  //              VarIncr CtrlId 1
68964>>>>>>>  //              LoopStart:
68964>>>>>>>  //              If CtrlId gt VarTo goto LoopEnd
68964>>>>>>>  //
68964>>>>>>>  // Loop:        Goto CtrlIncrement
68964>>>>>>>  //              LoopEnd:
68964>>>>>>>  //
68964>>>>>>>  procedure add_macro_for integer opcode# integer t1# string ctrlid# integer t2# string varfrom# integer t3# string varto#
68966>>>>>>>    string lbl_LoopStart# lbl_CtrlIncrement# lbl_LoopEnd#
68966>>>>>>>    get sNextUniqueLabel to lbl_LoopStart#
68967>>>>>>>    get sNextUniqueLabel to lbl_CtrlIncrement#
68968>>>>>>>    get sNextUniqueLabel to lbl_LoopEnd#
68969>>>>>>>    send add_instruction OP_ASSIGN AT_VAR ctrlid# t2# varfrom#
68970>>>>>>>    send add_instruction OP_GOTO AT_LBL lbl_LoopStart#
68971>>>>>>>    send declare_label lbl_CtrlIncrement#
68972>>>>>>>    send add_instruction OP_GVAR_INCR AT_VAR ctrlid# AT_CINT 1
68973>>>>>>>    send declare_label lbl_LoopStart#
68974>>>>>>>    send add_instruction OP_IFTEST_GOTO AT_VAR ctrlid# AT_CINT COMP_GT t3# varto# AT_LBL lbl_LoopEnd#
68975>>>>>>>    send push.s to (oIfStack(self)) lbl_CtrlIncrement#
68976>>>>>>>    send push.s to (oIfStack(self)) lbl_LoopEnd#
68977>>>>>>>  end_procedure
68978>>>>>>>  procedure add_macro_loop
68980>>>>>>>    string lbl_CtrlIncrement# lbl_LoopEnd#
68980>>>>>>>    get sPop of (oIfStack(self)) to lbl_LoopEnd#
68981>>>>>>>    get sPop of (oIfStack(self)) to lbl_CtrlIncrement#
68982>>>>>>>    send add_instruction OP_GOTO AT_LBL lbl_CtrlIncrement#
68983>>>>>>>    send declare_label lbl_LoopEnd#
68984>>>>>>>  end_procedure
68985>>>>>>>
68985>>>>>>>  // While/Loop structure:
68985>>>>>>>  //
68985>>>>>>>  // While:       LoopStart:
68985>>>>>>>  //              If Var1 Comp Var2 Goto Continue
68985>>>>>>>  //              Goto LoopEnd
68985>>>>>>>  //              Continue:
68985>>>>>>>  //
68985>>>>>>>  // Loop:        Goto LoopStart
68985>>>>>>>  //              LoopEnd:
68985>>>>>>>  //
68985>>>>>>>  procedure add_macro_while integer opcode# integer t1# integer varno1# integer t2# integer comp# integer t3# integer varno2#
68987>>>>>>>    string lbl_LoopStart# lbl_Continue# lbl_LoopEnd#
68987>>>>>>>    get sNextUniqueLabel to lbl_LoopStart#
68988>>>>>>>    get sNextUniqueLabel to lbl_Continue#
68989>>>>>>>    get sNextUniqueLabel to lbl_LoopEnd#
68990>>>>>>>    send declare_label lbl_LoopStart#
68991>>>>>>>    send add_instruction OP_IFTEST_GOTO t1# varno1# t2# comp# t3# varno2# AT_LBL lbl_Continue#
68992>>>>>>>    send add_instruction OP_GOTO AT_LBL lbl_LoopEnd#
68993>>>>>>>    send declare_label lbl_Continue#
68994>>>>>>>    send push.s to (oIfStack(self)) lbl_LoopStart#
68995>>>>>>>    send push.s to (oIfStack(self)) lbl_LoopEnd#
68996>>>>>>>  end_procedure
68997>>>>>>>
68997>>>>>>>  // If/Else/Endif structure:
68997>>>>>>>  //
68997>>>>>>>  // If:          If Var1 Comp Var2 Goto IfBranch
68997>>>>>>>  //              Goto ElseBranch
68997>>>>>>>  //              IfBranch:
68997>>>>>>>  //
68997>>>>>>>  // Else:        Goto EndIf
68997>>>>>>>  //              ElseBranch:
68997>>>>>>>  //
68997>>>>>>>  // EndIf:       EndIf:
68997>>>>>>>  //             (ElseBranch:)
68997>>>>>>>  procedure add_macro_if_begin integer opcode# integer t1# integer varno1# integer t2# integer comp# integer t3# integer varno2#
68999>>>>>>>    string lbl_IfBranch# lbl_ElseBranch# lbl_EndIf#
68999>>>>>>>    get sNextUniqueLabel to lbl_IfBranch#
69000>>>>>>>    get sNextUniqueLabel to lbl_ElseBranch#
69001>>>>>>>    get sNextUniqueLabel to lbl_EndIf#
69002>>>>>>>    send add_instruction OP_IFTEST_GOTO t1# varno1# t2# comp# t3# varno2# AT_LBL lbl_IfBranch#
69003>>>>>>>    send add_instruction OP_GOTO AT_LBL lbl_ElseBranch#
69004>>>>>>>    send declare_label lbl_IfBranch#
69005>>>>>>>    send push.s to (oIfStack(self)) lbl_ElseBranch#
69006>>>>>>>    send push.s to (oIfStack(self)) lbl_EndIf#
69007>>>>>>>  end_procedure
69008>>>>>>>  procedure add_macro_else integer opcode#
69010>>>>>>>    string lbl_ElseBranch# lbl_EndIf#
69010>>>>>>>    get sPop of (oIfStack(self)) to lbl_EndIf#
69011>>>>>>>    get sPop of (oIfStack(self)) to lbl_ElseBranch#
69012>>>>>>>    send add_instruction OP_GOTO AT_LBL lbl_EndIf#
69013>>>>>>>    send declare_label lbl_ElseBranch#
69014>>>>>>>    send push.s to (oIfStack(self)) lbl_ElseBranch#
69015>>>>>>>    send push.s to (oIfStack(self)) lbl_EndIf#
69016>>>>>>>  end_procedure
69017>>>>>>>  procedure add_macro_endif integer opcode#
69019>>>>>>>    string lbl_ElseBranch# lbl_EndIf#
69019>>>>>>>    get sPop of (oIfStack(self)) to lbl_EndIf#
69020>>>>>>>    get sPop of (oIfStack(self)) to lbl_ElseBranch#
69021>>>>>>>    send declare_label lbl_EndIf#
69022>>>>>>>    send declare_label_no_error lbl_ElseBranch# // Only ifnot already declared!
69023>>>>>>>  end_procedure
69024>>>>>>>end_class // cVirtualMachine
69025>>>>>>>
69025>>>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
69025>>>>>>>object oScriptError is a aps.ModalPanel label "DFScript runtime error"
69028>>>>>>>  set Locate_Mode to CENTER_ON_SCREEN
69029>>>>>>>  on_key kcancel send close_panel
69030>>>>>>>  property integer piOriginalErrorObject public 0
69032>>>>>>>
69032>>>>>>>  object oTb1 is a aps.TextBox label "DataFlex reported this error:"
69035>>>>>>>  end_object
69036>>>>>>>  object oFrm1 is a aps.Form abstract AFT_ASCII50 snap sl_down
69040>>>>>>>    set object_shadow_state to true
69041>>>>>>>  end_object
69042>>>>>>>  object oFrm2 is a aps.Form abstract AFT_ASCII50 snap sl_down
69046>>>>>>>    set object_shadow_state to true
69047>>>>>>>  end_object
69048>>>>>>>  object oTb2 is a aps.TextBox label "While executing this DFScript instruction:" snap sl_down
69052>>>>>>>  end_object
69053>>>>>>>  object oFrm3 is a aps.Form abstract AFT_ASCII50 snap sl_down
69057>>>>>>>    set object_shadow_state to true
69058>>>>>>>  end_object
69059>>>>>>>  object oFrm4 is a aps.Form abstract AFT_ASCII50 snap sl_down
69063>>>>>>>    set object_shadow_state to true
69064>>>>>>>  end_object
69065>>>>>>>  object oFrm5 is a aps.Form abstract AFT_ASCII50 snap sl_down
69069>>>>>>>    set object_shadow_state to true
69070>>>>>>>  end_object
69071>>>>>>>  object oBtn1 is a aps.Multi_Button
69073>>>>>>>      on_item "End script"  send end_script
69074>>>>>>>  end_object
69075>>>>>>>  object oBtn2 is a aps.Multi_Button
69077>>>>>>>      on_item "Display def" send display_definition
69078>>>>>>>  end_object
69079>>>>>>>  object oBtn3 is a aps.Multi_Button
69081>>>>>>>      on_item "Continue" send close_panel
69082>>>>>>>  end_object
69083>>>>>>>  send aps_locate_multi_buttons
69084>>>>>>>  procedure Error_Report integer ErrNum integer Err_Line string str#
69087>>>>>>>    integer grb#
69087>>>>>>>    string str1# str2#
69087>>>>>>>    set value of (oFrm1(self)) item 0 to (Error_Description(self,ErrNum,str#))
69088>>>>>>>    set value of (oFrm2(self)) item 0 to ("(Error "+string(ErrNum)+" on line "+string(Err_Line)+")")
69089>>>>>>>    move (sExecutingLine(oVM_CurrentlyExecuting#)) to str1#
69090>>>>>>>    move (StringRightBut(str1#,64)) to str2#
69091>>>>>>>    set value of (oFrm3(self)) item 0 to str1#
69092>>>>>>>    set value of (oFrm4(self)) item 0 to str2#
69093>>>>>>>    set value of (oFrm5(self)) item 0 to Struc$ErrDescr
69094>>>>>>>    send popup
69095>>>>>>>  end_procedure
69096>>>>>>>
69096>>>>>>>  // Stolen right out of error.pkg:
69096>>>>>>>  //*** Build complete error description from Flexerrs and user error message.
69096>>>>>>>  function Error_Description integer Error# string ErrMsg returns string
69099>>>>>>>    string Full_Error_Text
69099>>>>>>>    trim ErrMsg to ErrMsg
69100>>>>>>>>
69100>>>>>>>    move (trim(error_text(DESKTOP,Error#))) to Full_Error_Text
69101>>>>>>>    if ErrMsg ne "" begin
69103>>>>>>>      if ((Full_Error_Text ne "") AND error_text_available(DESKTOP,Error#)) append Full_Error_Text " " ErrMsg
69107>>>>>>>      else move ErrMsg to Full_Error_Text
69109>>>>>>>    end
69109>>>>>>>>
69109>>>>>>>    function_return Full_Error_Text
69110>>>>>>>  end_function
69111>>>>>>>
69111>>>>>>>  procedure end_script
69114>>>>>>>    set pProgramEnded of oVM_CurrentlyExecuting# to true
69115>>>>>>>    send close_panel
69116>>>>>>>  end_procedure
69117>>>>>>>
69117>>>>>>>  procedure display_definition
69120>>>>>>>    send RS_DisplayDef
69121>>>>>>>  end_procedure
69122>>>>>>>end_object
69123>>>>>>>
69123>>>>>>>procedure DFScriptError_On global // Set error trapping mode to DFScript
69125>>>>>>>  integer obj#
69125>>>>>>>  move (oScriptError(self)) to obj#
69126>>>>>>>  if Error_Object_Id ne obj# begin
69128>>>>>>>    set piOriginalErrorObject of obj# to Error_Object_Id
69129>>>>>>>    move obj# to Error_Object_Id
69130>>>>>>>  end
69130>>>>>>>>
69130>>>>>>>end_procedure
69131>>>>>>>procedure DFScriptError_Off global // Set error trapping mode back to normal
69133>>>>>>>  integer obj#
69133>>>>>>>  move (oScriptError(self)) to obj#
69134>>>>>>>  if Error_Object_Id eq obj# ;    get piOriginalErrorObject of obj# to Error_Object_Id
69137>>>>>>>end_procedure
69138>>>>>>>
69138>>>>>>>
69138>>>>>>>//
69138>>>>>>>//  This is what the interface looks like if you don't put an interpreter
69138>>>>>>>//  object in front of the Virtual Machine
69138>>>>>>>//
69138>>>>>>>//  object oVM is a cVirtualMachine
69138>>>>>>>//    set piDebugState      to DFFALSE
69138>>>>>>>//    set piDebugSingleStep to DFFALSE
69138>>>>>>>//    send script_begin // Optag program
69138>>>>>>>//    send declare_var "i" VARTYP_INTEGER
69138>>>>>>>//    send declare_var "j" VARTYP_INTEGER
69138>>>>>>>//    send add_instruction OP_FOR AT_VAR "i" AT_CINT 1 AT_CINT 2
69138>>>>>>>//      send add_instruction OP_FOR AT_VAR "j" AT_CINT 1 AT_CINT 10
69138>>>>>>>//      send add_instruction   OP_SHOWLN AT_VAR "j"
69138>>>>>>>//      send add_instruction OP_LOOP
69138>>>>>>>//    send add_instruction OP_LOOP
69138>>>>>>>//    send declare_var "A" VARTYP_INTEGER
69138>>>>>>>//    send declare_var "B" VARTYP_INTEGER
69138>>>>>>>//    send declare_var "C" VARTYP_INTEGER
69138>>>>>>>//    send declare_var "D" VARTYP_INTEGER
69138>>>>>>>//    send add_instruction OP_ASSIGN AT_VAR "A" AT_CINT 7878
69138>>>>>>>//    send add_instruction OP_ASSIGN AT_VAR "B" AT_VAR "A"
69138>>>>>>>//    send add_instruction OP_GVAR_DISPLAY
69138>>>>>>>//    send add_instruction OP_GVAR_INCR   AT_VAR "B" AT_CINT 1
69138>>>>>>>//    send add_instruction OP_ASSIGN AT_VAR "C" AT_VAR "B"
69138>>>>>>>//    send add_instruction OP_GVAR_INCR   AT_VAR "C" AT_CINT 1
69138>>>>>>>//    send add_instruction OP_ASSIGN AT_VAR "D" AT_VAR "C"
69138>>>>>>>//    send add_instruction OP_GVAR_INCR   AT_VAR "D" AT_CINT 1
69138>>>>>>>//    send add_instruction OP_GVAR_DISPLAY
69138>>>>>>>//    send add_instruction OP_INPUT AT_VAR "D" AT_CSTR "Enter something: "
69138>>>>>>>//    send add_instruction OP_NOP // NOP means No OPeration (= do nothing)
69138>>>>>>>//    send add_instruction OP_NOP
69138>>>>>>>//    send add_instruction OP_NOP
69138>>>>>>>//    send add_instruction OP_GOSUB AT_LBL "MyFirstLabel"
69138>>>>>>>//    send add_instruction OP_ABORT // End program!
69138>>>>>>>//    send declare_label "MyFirstLabel"
69138>>>>>>>//    send add_instruction OP_NOP
69138>>>>>>>//    send add_instruction OP_NOP
69138>>>>>>>//    send add_instruction OP_IF_GOTO AT_VAR "A" AT_LBL "MySecondLabel"
69138>>>>>>>//    send add_instruction OP_SHOWLN AT_CSTR "Didn't jump"
69138>>>>>>>//    send declare_label "MySecondLabel"
69138>>>>>>>//    send add_instruction OP_SHOWLN AT_CSTR "Jumped"
69138>>>>>>>//    send add_instruction OP_RETURN
69138>>>>>>>//    send script_end
69138>>>>>>>//  end_object
69138>>>>>>>//
69138>>>>>>>//  send obs "Begin"
69138>>>>>>>//  send run_script to (oVM(self))
69138>>>>>>>//  inkey windowindex
69138>>>>>Use Set.utl      // cArray, cSet and cStack classes
69138>>>>>Use Array.nui    // Item_Property command
69138>>>>>Use Strings.nui  // String manipulation for VDF
69138>>>>>Use Files.utl    // Utilities for handling file related stuff
69138>>>>>Use API_Attr.utl // Database API attributes characteristics
69138>>>>>
69138>>>>>//  /DFScript.RS_Program.hdr
69138>>>>>//  __ Program generated on __/__/____ ________ by ___________________
69138>>>>>//
69138>>>>>//  integer iFile     __
69138>>>>>//  integer iField    __
69138>>>>>//  integer iError    __
69138>>>>>//  integer iPrecond  __
69138>>>>>//  integer iWarning  __
69138>>>>>//  string  sFileName __
69138>>>>>//
69138>>>>>//  log_open "dfscript.log" 0
69138>>>>>//
69138>>>>>//  /DFScript.RS_Program.ftr
69138>>>>>//  log_close
69138>>>>>//  log_display
69138>>>>>//  system
69138>>>>>//  /*
69138>>>>>//
69138>>>>>//  object oScriptSource is an cArray
69138>>>>>//    property integer piRS_Header_Inserted public 0
69138>>>>>//    procedure reset
69138>>>>>//      send delete_data
69138>>>>>//      set piRS_Header_Inserted to false
69138>>>>>//    end_procedure
69138>>>>>//    procedure append_line string str#
69138>>>>>//      set value item (item_count(self)) to str#
69138>>>>>//    end_procedure
69138>>>>>//    procedure Insert_Image integer img#
69138>>>>>//      integer ch# seqeof#
69138>>>>>//      string str#
69138>>>>>//      move (SEQ_DirectInput("image:"+string(img#))) to ch#
69138>>>>>//      if (ch#>=0) begin
69138>>>>>//        repeat
69138>>>>>//          readln channel ch# str#
69138>>>>>//          move (seqeof) to seqeof#
69138>>>>>//          ifnot seqeof# send append_line str#
69138>>>>>//        until seqeof#
69138>>>>>//        send SEQ_CloseInput ch#
69138>>>>>//      end
69138>>>>>//    end_procedure
69138>>>>>//    procedure Insert_RS_Header string author#
69138>>>>>//      ifnot (piRS_Header_Inserted(self)) begin
69138>>>>>//        autopage DFScript.RS_Program.hdr
69138>>>>>//        print ("/"+"/")
69138>>>>>//        print (dSysDate())
69138>>>>>//        print (sSysTime())
69138>>>>>//        print author#
69138>>>>>//        print ("/"+"/")
69138>>>>>//        print ("/"+"/")
69138>>>>>//        print ("/"+"/")
69138>>>>>//        print ("/"+"/")
69138>>>>>//        print ("/"+"/")
69138>>>>>//        send Insert_Image DFScript.RS_Program.hdr.N
69138>>>>>//        set piRS_Header_Inserted to true
69138>>>>>//      end
69138>>>>>//    end_procedure
69138>>>>>//  end_object
69138>>>>>
69138>>>>>
69138>>>>>function ScriptError_Text global integer error# returns string
69140>>>>>  enumeration_list
69140>>>>>    define_script_error ERR.SCRIPT.NO_ERROR           "No error"
69143>>>>>    define_script_error ERR.SCRIPT.ERROR_ILLEGAL_CHAR "Illegal character"
69146>>>>>    define_script_error ERR.SCRIPT.COMMAND_NOT_FOUND  "Command not found"
69149>>>>>    define_script_error ERR.SCRIPT.ILLEGAL_VARNAME    "Illegal variable name"
69152>>>>>    define_script_error ERR.SCRIPT.SYMBOL_ALREADY_DEF "Symbol already defined"
69155>>>>>    define_script_error ERR.SCRIPT.TOO_MANY_ARGUMENTS "Too many arguments for command"
69158>>>>>    define_script_error ERR.SCRIPT.MISSING_ARGUMENT   "Missing argument(s)"
69161>>>>>    define_script_error ERR.SCRIPT.UNDEFINED_SYMBOL   "Undefined symbol"
69164>>>>>    define_script_error ERR.SCRIPT.CIRCULAR_REFERENCE "Circular reference in symbol replace"
69167>>>>>    define_script_error ERR.SCRIPT.ARGUMENT_TYPED     "Argument may not be typed"
69170>>>>>    define_script_error ERR.SCRIPT.CLASS_CHECK_ERROR  "Unknown symbol" //"Class check error"
69173>>>>>    define_script_error ERR.SCRIPT.TYPE_CHECK_ERROR   "Type check error"
69176>>>>>    define_script_error ERR.SCRIPT.KEYWORD_EXPECTED   "Keyword expected"
69179>>>>>    define_script_error ERR.SCRIPT.KEYWORD_DEBUG      "Keyword must be ON, OFF, SINGLE_STEP or DISPLAY_VAR"
69182>>>>>    define_script_error ERR.SCRIPT.SHOULD_BE_END      "END command expected"
69185>>>>>    define_script_error ERR.SCRIPT.SHOULD_BE_ENDIF    "ENDIF command expected"
69188>>>>>    define_script_error ERR.SCRIPT.SHOULD_BE_LOOP     "LOOP command expected"
69191>>>>>    define_script_error ERR.SCRIPT.SHOULD_BE_UNTIL    "UNTIL command expected"
69194>>>>>    define_script_error ERR.SCRIPT.UNINITIATED_END    "Un-initiated END command"
69197>>>>>    define_script_error ERR.SCRIPT.UNINITIATED_ELSE   "Un-initiated ELSE command"
69200>>>>>    define_script_error ERR.SCRIPT.UNINITIATED_ENDIF  "Un-initiated ENDIF command"
69203>>>>>    define_script_error ERR.SCRIPT.UNINITIATED_LOOP   "Un-initiated LOOP command"
69206>>>>>    define_script_error ERR.SCRIPT.UNINITIATED_UNTIL  "Un-initiated UNTIL command"
69209>>>>>    define_script_error ERR.SCRIPT.UNFINISHED_STRUCT  "Missing END/UNTIL or LOOP"
69212>>>>>    define_script_error ERR.SCRIPT.ILLEGAL_SYMBNAME   "Illegal symbol name"
69215>>>>>    define_script_error ERR.SCRIPT.MISSING_END_QUOTE  "Missing end quote"
69218>>>>>    define_script_error ERR.SCRIPT.BAD_PARAM_COUNT    "Wrong number of parameters for function"
69221>>>>>    define_script_error ERR.SCRIPT.FUNC_MISSING_PAR   "Function name must be followed by left parenthesis"
69224>>>>>    define_script_error ERR.SCRIPT.UNMOTIVATED_PARAM  "Unmotivated parameter"
69227>>>>>    define_script_error ERR.SCRIPT.MISSING_CONTENTS   "No contents in ()"
69230>>>>>    define_script_error ERR.SCRIPT.UNMOTIVATED_SYMBOL "Unmotivated symbol"
69233>>>>>    define_script_error ERR.SCRIPT.MISSING_OPERATOR   "Missing operator or comma"
69236>>>>>    define_script_error ERR.SCRIPT.ONE_OPERATOR_TO_M  "One operator too many"
69239>>>>>    define_script_error ERR.SCRIPT.OPERATOR_NEEDS_OPE "Operator must be followed by operand"
69242>>>>>    define_script_error ERR.SCRIPT.ATTR_NO_CHANGING   "Changing of API attribute not supported"
69245>>>>>    define_script_error ERR.SCRIPT.ATTR_IMPLICIT      "Setting of implicit API attributes not supported yet"
69248>>>>>    define_script_error ERR.SCRIPT.ATTR_NO_SET        "This attribute can only be read, not set"
69251>>>>>  end_enumeration_list
69251>>>>>end_function
69252>>>>>
69252>>>>>
69252>>>>>function ExprItemType_Text global integer liType returns string
69254>>>>>  enumeration_list
69254>>>>>    define_expr_item_type EIT.ERROR    "Error"
69257>>>>>    define_expr_item_type EIT.LEFT     "LftP"
69260>>>>>    define_expr_item_type EIT.RIGHT    "RgtP"
69263>>>>>    define_expr_item_type EIT.OPERATOR "Oper"
69266>>>>>    define_expr_item_type EIT.SYMBOL   "Symbol"
69269>>>>>    define_expr_item_type EIT.COMMA    "Comma"
69272>>>>>  end_enumeration_list
69272>>>>>end_function
69273>>>>>
69273>>>>>
69273>>>>>define TYPE.UNKNOWN for  0   // Argument types (UNKNOWN *must* be 0)
69273>>>>>define TYPE.UNTYPED for  1
69273>>>>>define TYPE.INTEGER for  2
69273>>>>>define TYPE.DATE    for  4
69273>>>>>define TYPE.NUMBER  for  8
69273>>>>>define TYPE.STRING  for 16
69273>>>>>
69273>>>>>function iTypeToVT.i global integer liType returns integer
69275>>>>>  if liType eq TYPE.INTEGER function_return VARTYP_INTEGER
69278>>>>>  if liType eq TYPE.DATE    function_return VARTYP_DATE
69281>>>>>  if liType eq TYPE.NUMBER  function_return VARTYP_NUMBER
69284>>>>>  if liType eq TYPE.STRING  function_return VARTYP_STRING
69287>>>>>  function_return VARTYP_VOID
69288>>>>>end_function
69289>>>>>
69289>>>>>define CLASS.UNKNOWN        for   0   // Argument classes (UNKNOWN *must* be 0)
69289>>>>>define CLASS.LABEL          for   1
69289>>>>>define CLASS.VAR            for   2
69289>>>>>define CLASS.CONST          for   4
69289>>>>>define CLASS.EXPR           for   8
69289>>>>>define CLASS.KEYWORD        for  16
69289>>>>>define CLASS.COMMAND        for  32
69289>>>>>define CLASS.REPLACE_SYMBOL for  64
69289>>>>>define CLASS.FIELD          for 128
69289>>>>>define CLASS.FUNCTION       for 256
69289>>>>>
69289>>>>>string charlist.all.legal 100
69289>>>>>move ('!"#$%&'+"'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~") to charlist.all.legal
69290>>>>>
69290>>>>>
69290>>>>>function iOperatorNameToID.s global string lsName returns integer
69292>>>>>  enumeration_list
69292>>>>>    define_operator OPERATOR.NONE     ""
69295>>>>>    define_operator OPERATOR.PLUS     "+"
69298>>>>>    define_operator OPERATOR.MINUS    "-"
69301>>>>>    define_operator OPERATOR.MULTIPLY "*"
69304>>>>>    define_operator OPERATOR.DIVIDE   "/"
69307>>>>>    define_operator OPERATOR.LT       "<"
69310>>>>>    define_operator OPERATOR.LE       "<="
69313>>>>>    define_operator OPERATOR.EQ       "="
69316>>>>>    define_operator OPERATOR.NE       "<>"
69319>>>>>    define_operator OPERATOR.GE       ">="
69322>>>>>    define_operator OPERATOR.GT       ">"
69325>>>>>    define_operator OPERATOR.MIN      "MIN"
69328>>>>>    define_operator OPERATOR.MAX      "MAX"
69331>>>>>    define_operator OPERATOR.AND      "AND"
69334>>>>>    define_operator OPERATOR.OR       "OR"
69337>>>>>  end_enumeration_list
69337>>>>>end_function
69338>>>>>function sOperatorSymbol.i global integer op# returns string
69340>>>>>  if op# eq OPERATOR.NONE     function_return ""
69343>>>>>  if op# eq OPERATOR.PLUS     function_return "+"
69346>>>>>  if op# eq OPERATOR.MINUS    function_return "-"
69349>>>>>  if op# eq OPERATOR.MULTIPLY function_return "*"
69352>>>>>  if op# eq OPERATOR.DIVIDE   function_return "/"
69355>>>>>  if op# eq OPERATOR.LT       function_return "<"
69358>>>>>  if op# eq OPERATOR.LE       function_return "<="
69361>>>>>  if op# eq OPERATOR.EQ       function_return "="
69364>>>>>  if op# eq OPERATOR.NE       function_return "<>"
69367>>>>>  if op# eq OPERATOR.GE       function_return ">="
69370>>>>>  if op# eq OPERATOR.GT       function_return ">"
69373>>>>>  if op# eq OPERATOR.MIN      function_return "MIN"
69376>>>>>  if op# eq OPERATOR.MAX      function_return "MAX"
69379>>>>>  if op# eq OPERATOR.AND      function_return "AND"
69382>>>>>  if op# eq OPERATOR.OR       function_return "OR"
69385>>>>>end_function
69386>>>>>
69386>>>>>register_function pVM_Object returns integer
69386>>>>>class cExpressionParser is an cArray
69387>>>>>  procedure construct_object integer img#
69389>>>>>    forward send construct_object img#
69391>>>>>    property integer piExprType public TYPE.UNKNOWN
69392>>>>>    object oParamCountStack is a cStack NO_IMAGE
69394>>>>>    end_object
69395>>>>>    object oImpliedTypesStack is a cStack NO_IMAGE
69397>>>>>    end_object
69398>>>>>    object oEvalSequence is a cEvalSequence NO_IMAGE
69400>>>>>    end_object
69401>>>>>  end_procedure
69402>>>>>  item_property_list
69402>>>>>    item_property string  psItem.i       // The item in clear text
69402>>>>>    item_property integer piStructType.i // What part of the expression is this?
69402>>>>>    item_property integer piPos.i        // What is the starting position?
69402>>>>>    item_property integer piClass.i      // If item, what is item class?
69402>>>>>    item_property integer piType.i       // If item, what is item type?
69402>>>>>    item_property integer piEvalLevel.i  // When evaluating
69402>>>>>    item_property integer piFuncParams.i // Number of parameters
69402>>>>>    item_property integer piOperator.i   // Type of operator
69402>>>>>    item_property integer piAux.i        //
69402>>>>>    item_property integer piEvalOrder.i  //
69402>>>>>  end_item_property_list cExpressionParser
#REM 69458 DEFINE FUNCTION PIEVALORDER.I INTEGER LIROW RETURNS INTEGER
#REM 69462 DEFINE PROCEDURE SET PIEVALORDER.I INTEGER LIROW INTEGER VALUE
#REM 69466 DEFINE FUNCTION PIAUX.I INTEGER LIROW RETURNS INTEGER
#REM 69470 DEFINE PROCEDURE SET PIAUX.I INTEGER LIROW INTEGER VALUE
#REM 69474 DEFINE FUNCTION PIOPERATOR.I INTEGER LIROW RETURNS INTEGER
#REM 69478 DEFINE PROCEDURE SET PIOPERATOR.I INTEGER LIROW INTEGER VALUE
#REM 69482 DEFINE FUNCTION PIFUNCPARAMS.I INTEGER LIROW RETURNS INTEGER
#REM 69486 DEFINE PROCEDURE SET PIFUNCPARAMS.I INTEGER LIROW INTEGER VALUE
#REM 69490 DEFINE FUNCTION PIEVALLEVEL.I INTEGER LIROW RETURNS INTEGER
#REM 69494 DEFINE PROCEDURE SET PIEVALLEVEL.I INTEGER LIROW INTEGER VALUE
#REM 69498 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 69502 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
#REM 69506 DEFINE FUNCTION PICLASS.I INTEGER LIROW RETURNS INTEGER
#REM 69510 DEFINE PROCEDURE SET PICLASS.I INTEGER LIROW INTEGER VALUE
#REM 69514 DEFINE FUNCTION PIPOS.I INTEGER LIROW RETURNS INTEGER
#REM 69518 DEFINE PROCEDURE SET PIPOS.I INTEGER LIROW INTEGER VALUE
#REM 69522 DEFINE FUNCTION PISTRUCTTYPE.I INTEGER LIROW RETURNS INTEGER
#REM 69526 DEFINE PROCEDURE SET PISTRUCTTYPE.I INTEGER LIROW INTEGER VALUE
#REM 69530 DEFINE FUNCTION PSITEM.I INTEGER LIROW RETURNS STRING
#REM 69534 DEFINE PROCEDURE SET PSITEM.I INTEGER LIROW STRING VALUE
69539>>>>>  procedure add_item integer liType string item# integer pos#
69541>>>>>    integer liRow
69541>>>>>    get row_count to liRow
69542>>>>>    set psItem.i       liRow to item#
69543>>>>>    set piStructType.i liRow to liType
69544>>>>>    set piPos.i        liRow to pos#
69545>>>>>    set piClass.i      liRow to 0
69546>>>>>    set piType.i       liRow to 0
69547>>>>>    set piEvalLevel.i  liRow to 0
69548>>>>>    set piFuncParams.i liRow to 0
69549>>>>>    set piOperator.i   liRow to 0
69550>>>>>    set piAux.i        liRow to 0
69551>>>>>  end_procedure
69552>>>>>  procedure reset
69554>>>>>    send delete_data
69555>>>>>    send delete_data to (oParamCountStack(self))
69556>>>>>    send delete_data to (oImpliedTypesStack(self))
69557>>>>>    set piExprType to TYPE.UNKNOWN
69558>>>>>  end_procedure
69559>>>>>  procedure split_expression_in_items string str# integer pos_offset#
69561>>>>>    integer pos# len# in_item# in_string# oper_type# start_pos#
69561>>>>>    string char# char2# item# quote# quotes#
69561>>>>>    send reset
69562>>>>>    move (length(str#)) to len#
69563>>>>>    move 0 to in_string#
69564>>>>>    move "" to item#
69565>>>>>    move 0 to in_item#
69566>>>>>    move ("'"+'"') to quotes#
69567>>>>>    for pos# from 1 to len#
69573>>>>>>
69573>>>>>      move (mid(str#,1,pos#)) to char#
69574>>>>>      if in_item# begin
69576>>>>>        if in_string# begin
69578>>>>>          move (item#+char#) to item#
69579>>>>>          if char# eq quote# begin
69581>>>>>            send add_item EIT.SYMBOL item# (start_pos#+pos_offset#)
69582>>>>>            move 0 to in_string#
69583>>>>>            move 0 to in_item#
69584>>>>>            move "" to item#
69585>>>>>          end
69585>>>>>>
69585>>>>>        end
69585>>>>>>
69585>>>>>        else begin // We're not in a string
69586>>>>>          if char# eq "(" begin
69588>>>>>            send add_item EIT.SYMBOL item# (start_pos#+pos_offset#)
69589>>>>>            send add_item EIT.LEFT char# (pos#+pos_offset#)
69590>>>>>            move 0 to in_item#
69591>>>>>            move "" to item#
69592>>>>>          end
69592>>>>>>
69592>>>>>          else if char# eq ")" begin
69595>>>>>            send add_item EIT.SYMBOL item# (start_pos#+pos_offset#)
69596>>>>>            send add_item EIT.RIGHT char# (pos#+pos_offset#)
69597>>>>>            move 0 to in_item#
69598>>>>>            move "" to item#
69599>>>>>          end
69599>>>>>>
69599>>>>>          else if char# eq " " begin
69602>>>>>            send add_item EIT.SYMBOL item# (start_pos#+pos_offset#)
69603>>>>>            move 0 to in_item#
69604>>>>>            move "" to item#
69605>>>>>          end
69605>>>>>>
69605>>>>>          else if char# eq "," begin
69608>>>>>            send add_item EIT.SYMBOL item# (start_pos#+pos_offset#)
69609>>>>>            send add_item EIT.COMMA char# (pos#+pos_offset#)
69610>>>>>            move 0 to in_item#
69611>>>>>            move "" to item#
69612>>>>>          end
69612>>>>>>
69612>>>>>          else if char# in "=+-*/<>" begin
69615>>>>>            send add_item EIT.SYMBOL item# (start_pos#+pos_offset#)
69616>>>>>            move 0 to in_item#
69617>>>>>            move "" to item#
69618>>>>>            move (mid(str#,1,pos#+1)) to char2#
69619>>>>>            get iOperatorNameToID.s (char#+char2#) to oper_type#
69620>>>>>            if oper_type# ne OPERATOR.NONE begin
69622>>>>>              increment pos# // Dirty trick to handle two-character operators
69623>>>>>              send add_item EIT.OPERATOR (char#+char2#) (pos#+pos_offset#)
69624>>>>>            end
69624>>>>>>
69624>>>>>            else begin
69625>>>>>              get iOperatorNameToID.s char# to oper_type#
69626>>>>>              send add_item EIT.OPERATOR char# (pos#+pos_offset#)
69627>>>>>            end
69627>>>>>>
69627>>>>>            set piOperator.i (row_count(self)-1) to oper_type#
69628>>>>>          end
69628>>>>>>
69628>>>>>          else move (item#+char#) to item#
69630>>>>>        end
69630>>>>>>
69630>>>>>      end
69630>>>>>>
69630>>>>>      else begin // We're not in an item
69631>>>>>        if char# ne " " begin // Ignore blanks
69633>>>>>          if char# in quotes# begin // Now we're in a string
69635>>>>>            move 1 to in_string#
69636>>>>>            move 1 to in_item#
69637>>>>>            move pos# to start_pos#
69638>>>>>            move char# to item#
69639>>>>>            move char# to quote#
69640>>>>>          end
69640>>>>>>
69640>>>>>          else if char# in "=<>+-*/" begin
69643>>>>>            move (mid(str#,1,pos#+1)) to char2#
69644>>>>>            get iOperatorNameToID.s (char#+char2#) to oper_type#
69645>>>>>            if oper_type# ne OPERATOR.NONE begin
69647>>>>>              increment pos# // Dirty trick to handle two-character operators
69648>>>>>              send add_item EIT.OPERATOR (char#+char2#) (pos#+pos_offset#)
69649>>>>>            end
69649>>>>>>
69649>>>>>            else begin
69650>>>>>              get iOperatorNameToID.s char# to oper_type#
69651>>>>>              send add_item EIT.OPERATOR char# (pos#+pos_offset#)
69652>>>>>            end
69652>>>>>>
69652>>>>>            set piOperator.i (row_count(self)-1) to oper_type#
69653>>>>>          end
69653>>>>>>
69653>>>>>          else if char# eq "(" send add_item EIT.LEFT "(" (pos#+pos_offset#)
69657>>>>>          else if char# eq ")" send add_item EIT.RIGHT ")" (pos#+pos_offset#)
69661>>>>>          else if char# eq "," send add_item EIT.COMMA "," pos#
69665>>>>>          else begin
69666>>>>>            move 1 to in_item#
69667>>>>>            move pos# to start_pos#
69668>>>>>            move char# to item#
69669>>>>>          end
69669>>>>>>
69669>>>>>        end
69669>>>>>>
69669>>>>>      end
69669>>>>>>
69669>>>>>    loop
69670>>>>>>
69670>>>>>    if in_string# send ScriptError ERR.SCRIPT.MISSING_END_QUOTE (start_pos#+pos_offset#)
69673>>>>>    if in_item# send add_item EIT.SYMBOL item# (start_pos#+pos_offset#)
69676>>>>>  end_procedure
69677>>>>>  function iErrorOccured returns integer
69679>>>>>    integer error#
69679>>>>>    get piErrorCode to error#
69680>>>>>    function_return (error#<>ERR.SCRIPT.NO_ERROR)
69681>>>>>  end_function
69682>>>>>  procedure DoReplaces // Perform symbol replaces
69684>>>>>    integer liRow max#
69684>>>>>    string name#
69684>>>>>    get row_count to max#
69685>>>>>    for liRow from 0 to (max#-1)
69691>>>>>>
69691>>>>>      move (psItem.i(self,liRow)) to name#
69692>>>>>      get sReplaceNameToNo.s name# to name#
69693>>>>>      set psItem.i liRow to name#
69694>>>>>    loop
69695>>>>>>
69695>>>>>  end_procedure
69696>>>>>  procedure DoClassColumn // Identify the classes
69698>>>>>    integer liRow max# class# stype#
69698>>>>>    string item#
69698>>>>>    get row_count to max#
69699>>>>>    for liRow from 0 to (max#-1)
69705>>>>>>
69705>>>>>      move (piStructType.i(self,liRow)) to stype#
69706>>>>>      if (stype#=EIT.SYMBOL) begin
69708>>>>>        move (psItem.i(self,liRow)) to item#
69709>>>>>        if ("|"+uppercase(item#)+"|") in "|AND|OR|MIN|MAX|" begin
69711>>>>>          set piStructType.i liRow to EIT.OPERATOR
69712>>>>>          set piOperator.i liRow to (iOperatorNameToID.s(uppercase(item#)))
69713>>>>>        end
69713>>>>>>
69713>>>>>        else begin
69714>>>>>          get iSymbolClass.s item# to class#
69715>>>>>          set piClass.i liRow to class#
69716>>>>>        end
69716>>>>>>
69716>>>>>      end
69716>>>>>>
69716>>>>>    loop
69717>>>>>>
69717>>>>>  end_procedure
69718>>>>>  procedure DoTypeColumn // Identify the types
69720>>>>>    integer liRow liMax liClass liType liStructType
69720>>>>>    string lsItem
69720>>>>>    get row_count to liMax
69721>>>>>    for liRow from 0 to (liMax-1)
69727>>>>>>
69727>>>>>      move (piStructType.i(self,liRow)) to liStructType
69728>>>>>      if (liStructType=EIT.SYMBOL) begin
69730>>>>>        move (psItem.i(self,liRow)) to lsItem
69731>>>>>        get piClass.i liRow to liClass
69732>>>>>        get iSymbolType.si lsItem liClass to liType
69733>>>>>        set piType.i liRow to liType
69734>>>>>        if liClass eq CLASS.UNKNOWN    send ScriptError ERR.SCRIPT.CLASS_CHECK_ERROR (piPos.i(self,liRow)) ("Symbol: "+lsItem)
69737>>>>>        else if liType eq TYPE.UNKNOWN send ScriptError ERR.SCRIPT.TYPE_CHECK_ERROR (piPos.i(self,liRow)) ("Symbol: "+lsItem)
69741>>>>>      end
69741>>>>>>
69741>>>>>    loop
69742>>>>>>
69742>>>>>  end_procedure
69743>>>>>  procedure DoFuncParams
69745>>>>>    integer liRow max# func_row# level# stack# stype# id#
69745>>>>>    integer current_left_pos# param_count# gets# expects#
69745>>>>>    string params#
69745>>>>>    get row_count to max#
69746>>>>>    move 0 to level#
69747>>>>>    move 0 to func_row#
69748>>>>>    move -1 to current_left_pos#
69749>>>>>    move 0 to param_count#
69750>>>>>    move (oParamCountStack(self)) to stack#
69751>>>>>    send delete_data to stack#
69752>>>>>    for liRow from 0 to (max#-1)
69758>>>>>>
69758>>>>>      move (piStructType.i(self,liRow)) to stype#
69759>>>>>      if (piClass.i(self,liRow)=CLASS.FUNCTION) begin
69761>>>>>        get iFuncNameToFuncNo.s of (pVM_Object(self)) (psItem.i(self,liRow)) to id#
69762>>>>>        get sFuncParams.i of (pVM_Object(self)) id# to params#
69763>>>>>        set piAux.i liRow to id#
69764>>>>>        set piFuncParams.i liRow to (length(params#))
69765>>>>>      end
69765>>>>>>
69765>>>>>      if (stype#=EIT.LEFT) begin
69767>>>>>        send push.i to stack# param_count#
69768>>>>>        send push.i to stack# current_left_pos#
69769>>>>>        move liRow to current_left_pos#
69770>>>>>        move 0 to param_count#
69771>>>>>        increment level#
69772>>>>>      end
69772>>>>>>
69772>>>>>      if (stype#=EIT.RIGHT) begin
69774>>>>>        set piFuncParams.i current_left_pos# to param_count#
69775>>>>>        decrement level#
69776>>>>>        move (iPop(stack#)) to current_left_pos#
69777>>>>>        move (iPop(stack#)) to param_count#
69778>>>>>        if param_count# eq 0 increment param_count#
69781>>>>>      end
69781>>>>>>
69781>>>>>      if (stype#=EIT.SYMBOL) if param_count# eq 0 increment param_count#
69786>>>>>      if (stype#=EIT.COMMA) increment param_count#
69789>>>>>      set piEvalLevel.i liRow to level#
69790>>>>>    loop
69791>>>>>>
69791>>>>>    // Now check that all function gets the expected number of parameters
69791>>>>>    for liRow from 0 to (max#-1)
69797>>>>>>
69797>>>>>      ifnot (iErrorOccured(self)) begin
69799>>>>>        if (piClass.i(self,liRow)=CLASS.FUNCTION) begin
69801>>>>>          move (piStructType.i(self,liRow+1)) to stype#
69802>>>>>          if stype# eq EIT.LEFT begin
69804>>>>>            move (piFuncParams.i(self,liRow)) to expects#
69805>>>>>            move (piFuncParams.i(self,liRow+1)) to gets#
69806>>>>>            if expects# ne gets# send ScriptError ERR.SCRIPT.BAD_PARAM_COUNT (piPos.i(self,liRow)) ("Function "+uppercase(psItem.i(self,liRow))+" expects "+string(expects#)+" parameters, "+string(gets#)+" is being passed")
69809>>>>>          end
69809>>>>>>
69809>>>>>          else begin
69810>>>>>            if (liRow+1) ge max# send ScriptError ERR.SCRIPT.FUNC_MISSING_PAR (piPos.i(self,liRow))
69813>>>>>            else send ScriptError ERR.SCRIPT.FUNC_MISSING_PAR (piPos.i(self,liRow+1))
69815>>>>>          end
69815>>>>>>
69815>>>>>        end
69815>>>>>>
69815>>>>>      end
69815>>>>>>
69815>>>>>    loop
69816>>>>>>
69816>>>>>  end_procedure
69817>>>>>  procedure DoFinalChecks
69819>>>>>    integer liRow max# stype# next_stype# params#
69819>>>>>    get row_count to max#
69820>>>>>    for liRow from 0 to (max#-1)
69826>>>>>>
69826>>>>>      ifnot (iErrorOccured(self)) begin
69828>>>>>        move (piStructType.i(self,liRow)) to stype#
69829>>>>>        move (piStructType.i(self,liRow+1)) to next_stype#
69830>>>>>
69830>>>>>        // If left parenthesis and the previous row is not a function
69830>>>>>        // then there must be exactly 1 parameter in the p-pair:
69830>>>>>        if stype# eq EIT.LEFT begin
69832>>>>>          if (piClass.i(self,liRow-1)<>CLASS.FUNCTION) begin
69834>>>>>            get piFuncParams.i liRow to params#
69835>>>>>            if params# gt 1 send ScriptError ERR.SCRIPT.UNMOTIVATED_PARAM (piPos.i(self,liRow+1))
69838>>>>>            if params# lt 1 send ScriptError ERR.SCRIPT.MISSING_CONTENTS (piPos.i(self,liRow))
69841>>>>>          end
69841>>>>>>
69841>>>>>        end
69841>>>>>>
69841>>>>>
69841>>>>>        // If SYMBOL there can not be a symbols next to it:
69841>>>>>        ifnot (iErrorOccured(self)) if (stype#=EIT.SYMBOL and next_stype#=EIT.SYMBOL) send ScriptError ERR.SCRIPT.UNMOTIVATED_SYMBOL (piPos.i(self,liRow+1))
69846>>>>>
69846>>>>>        // If right paranthesis it cannot be followed by a left paranthesis:
69846>>>>>        ifnot (iErrorOccured(self)) if (stype#=EIT.RIGHT and next_stype#=EIT.LEFT) send ScriptError ERR.SCRIPT.MISSING_OPERATOR (piPos.i(self,liRow+1))
69851>>>>>
69851>>>>>        // If OPERATOR there can not be an operator next to it (unless it's monadic minus)
69851>>>>>        ifnot (iErrorOccured(self)) if (stype#=EIT.OPERATOR and next_stype#=EIT.OPERATOR and piOperator.i(self,liRow+1) <> OPERATOR.MINUS) send ScriptError ERR.SCRIPT.ONE_OPERATOR_TO_M (piPos.i(self,liRow+1))
69856>>>>>
69856>>>>>        // In fact, if operator it MUST be followed by a symbol (operand)
69856>>>>>        ifnot (iErrorOccured(self)) begin
69858>>>>>          if (stype#=EIT.OPERATOR and (next_stype#<>EIT.SYMBOL and next_stype#<>EIT.LEFT) and piOperator.i(self,liRow+1) <> OPERATOR.MINUS) send ScriptError ERR.SCRIPT.OPERATOR_NEEDS_OPE (piPos.i(self,liRow+1))
69861>>>>>        end
69861>>>>>>
69861>>>>>      end
69861>>>>>>
69861>>>>>    loop
69862>>>>>>
69862>>>>>  end_procedure
69863>>>>>
69863>>>>>  function iNewType.iii integer t1# integer op# integer t2# returns integer
69865>>>>>    if op# eq OPERATOR.NONE     function_return t2#
69868>>>>>    if op# eq OPERATOR.PLUS     function_return (t1# max t2#)
69871>>>>>    if op# eq OPERATOR.MINUS    function_return (t1# max t2#)
69874>>>>>    if op# eq OPERATOR.MULTIPLY function_return (t1# max t2#)
69877>>>>>    if op# eq OPERATOR.DIVIDE   function_return (t1# max t2#)
69880>>>>>    if op# eq OPERATOR.LT       function_return TYPE.INTEGER
69883>>>>>    if op# eq OPERATOR.LE       function_return TYPE.INTEGER
69886>>>>>    if op# eq OPERATOR.EQ       function_return TYPE.INTEGER
69889>>>>>    if op# eq OPERATOR.NE       function_return TYPE.INTEGER
69892>>>>>    if op# eq OPERATOR.GE       function_return TYPE.INTEGER
69895>>>>>    if op# eq OPERATOR.GT       function_return TYPE.INTEGER
69898>>>>>    if op# eq OPERATOR.MIN      function_return (t1# max t2#)
69901>>>>>    if op# eq OPERATOR.MAX      function_return (t1# max t2#)
69904>>>>>    if op# eq OPERATOR.AND      function_return TYPE.INTEGER
69907>>>>>    if op# eq OPERATOR.OR       function_return TYPE.INTEGER
69910>>>>>    function_return t2#
69911>>>>>  end_function
69912>>>>>
69912>>>>>  function PreceededByFunction integer liRow returns integer
69914>>>>>    integer class#
69914>>>>>    get piClass.i (liRow-1) to class#
69915>>>>>    function_return (class#=CLASS.FUNCTION)
69916>>>>>  end_function
69917>>>>>  procedure DoImpliedTypes
69919>>>>>    integer stack# liRow max# current_type# stype# class# liType
69919>>>>>    integer current_operator# otype#
69919>>>>>    integer current_left_pos#
69919>>>>>    string item#
69919>>>>>    move (oImpliedTypesStack(self)) to stack#
69920>>>>>    send delete_data to stack#
69921>>>>>    get row_count to max#
69922>>>>>    move -1 to current_left_pos#
69923>>>>>    move OPERATOR.NONE to current_operator#
69924>>>>>    move TYPE.UNKNOWN to current_type#
69925>>>>>    for liRow from 0 to (max#-1)
69931>>>>>>
69931>>>>>      get psItem.i       liRow to item#
69932>>>>>      get piStructType.i liRow to stype#
69933>>>>>      get piClass.i      liRow to class#
69934>>>>>      get piType.i       liRow to liType
69935>>>>>      get piOperator.i   liRow to otype#
69936>>>>>      if stype# eq EIT.LEFT begin
69938>>>>>        send push.i to stack# current_left_pos#
69939>>>>>        send push.i to stack# current_operator#
69940>>>>>        send push.i to stack# current_type#
69941>>>>>        move liRow to current_left_pos#
69942>>>>>        move OPERATOR.NONE to current_operator#
69943>>>>>        move TYPE.UNKNOWN to current_type#
69944>>>>>      end
69944>>>>>>
69944>>>>>      if stype# eq EIT.RIGHT begin
69946>>>>>        if (PreceededByFunction(self,current_left_pos#)) move (ipop(stack#)) to current_type#
69949>>>>>        else move (ipop(stack#)) to current_operator# // Through away liType // current_type#
69951>>>>>        set piType.i current_left_pos# to current_type#
69952>>>>>        move (ipop(stack#)) to current_operator#
69953>>>>>        move (ipop(stack#)) to current_left_pos#
69954>>>>>      end
69954>>>>>>
69954>>>>>      if stype# eq EIT.COMMA begin
69956>>>>>        set piType.i current_left_pos# to current_type#
69957>>>>>        move OPERATOR.NONE to current_operator#
69958>>>>>        move TYPE.UNKNOWN to current_type#
69959>>>>>        //move liRow to current_left_pos#
69959>>>>>      end
69959>>>>>>
69959>>>>>      if stype# eq EIT.OPERATOR move otype# to current_operator#
69962>>>>>      if stype# eq EIT.SYMBOL move (iNewType.iii(self,current_type#,current_operator#,liType)) to current_type#
69965>>>>>    loop
69966>>>>>>
69966>>>>>    set piExprType to (piType.i(self,0))
69967>>>>>  end_procedure
69968>>>>>
69968>>>>>  procedure add_expr_op integer op# string var#
69970>>>>>    send add_expr_instruction to (oEvalSequence(self)) op# var#
69971>>>>>  end_procedure
69972>>>>>
69972>>>>>  function iFuncEvalSeparately.i integer liRow returns integer
69974>>>>>    integer rval# funcclass#
69974>>>>>    if (piClass.i(self,liRow)=CLASS.FUNCTION) get sFuncClass.i of (pVM_Object(self)) (piAux.i(self,liRow)) to funcclass#
69977>>>>>    else move FTYPE.BUILTIN to funcclass#
69979>>>>>    function_return (funcclass#<>FTYPE.BUILTIN)
69980>>>>>  end_function
69981>>>>>
69981>>>>>  function iCreateExprEvaluator.ii integer liRow integer level# returns integer
69983>>>>>    integer emergency_stop# balance# funcclass# sType# class# id# prev_stype#
69983>>>>>    integer oType# max# vType# funcid# oVar# fType# liType liFileField
69983>>>>>    get row_count to max#
69984>>>>>    move -1 to prev_stype#
69985>>>>>    move (oVariables(pVM_Object(self))) to oVar#
69986>>>>>    if level# begin // then we are sure to be evaluating parameters for a function
69988>>>>>      move EIT.LEFT to prev_stype#
69989>>>>>      increment liRow // Skip parenthesis
69990>>>>>      move 1 to balance# // Because we just skipped a (
69991>>>>>    end
69991>>>>>>
69991>>>>>    repeat
69991>>>>>>
69991>>>>>      if (iFuncEvalSeparately.i(self,liRow)) begin
69993>>>>>        send add_expr_op EXPROP.PUSH_EXPRESSION ""
69994>>>>>        get piAux.i liRow to funcid#
69995>>>>>        get iFuncType.i of (pVM_Object(self)) funcid# to fType#
69996>>>>>        get iCreateExprEvaluator.ii (liRow+1) (level#+1) to liRow
69997>>>>>        if fType# eq VARTYP_STRING send add_expr_op EXPROP.EXEC_SFUNCTION funcid#
70000>>>>>        else send add_expr_op EXPROP.EXEC_FUNCTION funcid#
70002>>>>>      end
70002>>>>>>
70002>>>>>      else begin
70003>>>>>        get piStructType.i liRow to sType#
70004>>>>>        if sType# eq EIT.LEFT begin
70006>>>>>          increment balance#
70007>>>>>          send add_expr_op EXPROP.APPEND "("
70008>>>>>        end
70008>>>>>>
70008>>>>>        if sType# eq EIT.RIGHT begin
70010>>>>>          decrement balance#
70011>>>>>          if balance# eq 0 begin
70013>>>>>            if level# begin
70015>>>>>              if prev_stype# ne EIT.LEFT send add_expr_op EXPROP.PUSH_PARAM ""
70018>>>>>            end
70018>>>>>>
70018>>>>>            else send add_expr_op EXPROP.APPEND ")"
70020>>>>>            function_return liRow // Skip right parenthesis
70021>>>>>          end
70021>>>>>>
70021>>>>>          send add_expr_op EXPROP.APPEND ")"
70022>>>>>        end
70022>>>>>>
70022>>>>>        if sType# eq EIT.OPERATOR begin
70024>>>>>          // Operators may just be added except that AND OR MIN and MAX
70024>>>>>          // must have blanks around them:
70024>>>>>          get piOperator.i liRow to oType#
70025>>>>>          if (oType#=OPERATOR.MIN or oType#=OPERATOR.MAX or oType#=OPERATOR.AND or oType#=OPERATOR.OR) send add_expr_op EXPROP.APPEND (" "+psItem.i(self,liRow)+" ")
70028>>>>>          else send add_expr_op EXPROP.APPEND (psItem.i(self,liRow))
70030>>>>>        end
70030>>>>>>
70030>>>>>        if sType# eq EIT.SYMBOL begin
70032>>>>>          get piClass.i liRow to class#
70033>>>>>          // Constants may just be added:
70033>>>>>          if class# eq CLASS.CONST send add_expr_op EXPROP.APPEND (psItem.i(self,liRow))
70036>>>>>          // If it's a function we can safely just add it. Would it have been
70036>>>>>          // a function that we were supposed to handle manually it would
70036>>>>>          // have been filtered out by the iFuncEvalSeparately test in the
70036>>>>>          // beginning of this function:
70036>>>>>          if class# eq CLASS.FUNCTION send add_expr_op EXPROP.APPEND (psItem.i(self,liRow))
70039>>>>>          // For variables we dare inserting a (local) function call and let
70039>>>>>          // the EVAL function retrieve the value:
70039>>>>>          if class# eq CLASS.VAR begin
70041>>>>>            get iVarNameToVarNo of (pVM_Object(self)) (psItem.i(self,liRow)) to id#
70042>>>>>            get iVarType.i of (pVM_Object(self)) id# to vType#
70043>>>>>            if vType# eq VARTYP_INTEGER send add_expr_op EXPROP.GET_IVAR id#
70046>>>>>            if vType# eq VARTYP_DATE    send add_expr_op EXPROP.GET_DVAR id#
70049>>>>>            if vType# eq VARTYP_NUMBER  send add_expr_op EXPROP.GET_NVAR id#
70052>>>>>            if vType# eq VARTYP_STRING  send add_expr_op EXPROP.GET_SVAR id#
70055>>>>>          end
70055>>>>>>
70055>>>>>          if class# eq CLASS.FIELD begin
70057>>>>>            get piType.i liRow to liType
70058>>>>>            get iFileField.s of (pVM_Object(self)) (psItem.i(self,liRow)) to liFileField
70059>>>>>            if liType eq TYPE.STRING send add_expr_op EXPROP.GET_SFIELD liFileField
70062>>>>>            if liType eq TYPE.NUMBER send add_expr_op EXPROP.GET_NFIELD liFileField
70065>>>>>            if liType eq TYPE.DATE   send add_expr_op EXPROP.GET_DFIELD liFileField
70068>>>>>          end
70068>>>>>>
70068>>>>>        end
70068>>>>>>
70068>>>>>        if sType# eq EIT.COMMA begin
70070>>>>>          // Level>0 means: We are in a "manual" function
70070>>>>>          // Under that assumption balance=1 MUST mean that we are dealing
70070>>>>>          // with a parameter to that function.
70070>>>>>          if (level#>0 and balance#=1) send add_expr_op EXPROP.PUSH_PARAM ""
70073>>>>>          else send add_expr_op EXPROP.APPEND ","
70075>>>>>        end
70075>>>>>>
70075>>>>>        move stype# to prev_stype#
70076>>>>>      end
70076>>>>>>
70076>>>>>      increment liRow
70077>>>>>    until (balance#=0 or liRow>=max#)
70079>>>>>    send add_expr_op EXPROP.ERROR ""
70080>>>>>    function_return 1000
70081>>>>>  end_function
70082>>>>>
70082>>>>>  procedure DoCreateEvaluator
70084>>>>>    integer grb#
70084>>>>>    send delete_data to (oEvalSequence(self))
70085>>>>>    send add_expr_op EXPROP.TYPE (iTypeToVT.i(piExprType(self)))
70086>>>>>    get iCreateExprEvaluator.ii 0 0 to grb#
70087>>>>>    send add_expr_op EXPROP.END ""
70088>>>>>  end_procedure
70089>>>>>
70089>>>>>  function iParse_expression.si string lsExpression integer liPosOffset returns integer
70091>>>>>    integer lhObj liExprId
70091>>>>>    if liPosOffset decrement liPosOffset
70094>>>>>    send split_expression_in_items lsExpression liPosOffset
70095>>>>>    ifnot (iErrorOccured(self)) send DoReplaces
70098>>>>>    ifnot (iErrorOccured(self)) send DoClassColumn
70101>>>>>    ifnot (iErrorOccured(self)) send DoTypeColumn
70104>>>>>    ifnot (iErrorOccured(self)) send DoFuncParams
70107>>>>>    ifnot (iErrorOccured(self)) send DoFinalChecks
70110>>>>>    ifnot (iErrorOccured(self)) send DoImpliedTypes
70113>>>>>    ifnot (iErrorOccured(self)) send DoCreateEvaluator
70116>>>>>    if (piDebugState(self)) send DisplayExpressionDebugInfo self
70119>>>>>    if (piDebugState(self)) send DisplayEvalSequence (oEvalSequence(self))
70122>>>>>    send Optimize to (oEvalSequence(self))
70123>>>>>    if (piDebugState(self)) send DisplayEvalSequence (oEvalSequence(self))
70126>>>>>    // Add to VM's expression array:
70126>>>>>    move (oExprEvalSequences(pVM_Object(self))) to lhObj
70127>>>>>    get iAppendToOtherSequence of (oEvalSequence(self)) lhObj to liExprId
70128>>>>>//    send obs "Kopierer program"   (oEvalSequence(self)) lhObj (name(lhObj))
70128>>>>>    function_return (liExprId+1) // Skip typedef
70129>>>>>  end_function
70130>>>>>end_class // cExpressionParser
70131>>>>>
70131>>>>>class cScriptErrors is a cArray
70132>>>>>  procedure construct_object integer img#
70134>>>>>    forward send construct_object img#
70136>>>>>    property string  piListingFN   public "dfscript.err"
70137>>>>>    property integer piListingFile public 0
70138>>>>>    property integer piOnScreen    public 1
70139>>>>>  end_procedure
70140>>>>>  item_property_list
70140>>>>>    item_property integer piError.i
70140>>>>>    item_property integer piLine.i
70140>>>>>    item_property integer piPosition.i
70140>>>>>    item_property string  psFileName.i
70140>>>>>    item_property string  psMessage.i
70140>>>>>  end_item_property_list cScriptErrors
#REM 70181 DEFINE FUNCTION PSMESSAGE.I INTEGER LIROW RETURNS STRING
#REM 70185 DEFINE PROCEDURE SET PSMESSAGE.I INTEGER LIROW STRING VALUE
#REM 70189 DEFINE FUNCTION PSFILENAME.I INTEGER LIROW RETURNS STRING
#REM 70193 DEFINE PROCEDURE SET PSFILENAME.I INTEGER LIROW STRING VALUE
#REM 70197 DEFINE FUNCTION PIPOSITION.I INTEGER LIROW RETURNS INTEGER
#REM 70201 DEFINE PROCEDURE SET PIPOSITION.I INTEGER LIROW INTEGER VALUE
#REM 70205 DEFINE FUNCTION PILINE.I INTEGER LIROW RETURNS INTEGER
#REM 70209 DEFINE PROCEDURE SET PILINE.I INTEGER LIROW INTEGER VALUE
#REM 70213 DEFINE FUNCTION PIERROR.I INTEGER LIROW RETURNS INTEGER
#REM 70217 DEFINE PROCEDURE SET PIERROR.I INTEGER LIROW INTEGER VALUE
70222>>>>>  procedure display_error.i integer liRow
70224>>>>>    integer pos#
70224>>>>>    string msg#
70224>>>>>    get piPosition.i liRow to pos#
70225>>>>>    get psMessage.i liRow to msg#
70226>>>>>    move (trim(msg#)) to msg#
70227>>>>>    send obs ("Error in "+psFileName.i(self,liRow)+" on line "+string(piLine.i(self,liRow))) (ScriptError_Text(piError.i(self,liRow))+if(pos#," in position "+string(pos#),"")) msg#
70228>>>>>  end_procedure
70229>>>>>  procedure add_error integer Error# integer Line# integer Position# string FileName# string Message#
70231>>>>>    integer liRow
70231>>>>>    get row_count to liRow
70232>>>>>    set piError.i    liRow to Error#
70233>>>>>    set piLine.i     liRow to Line#
70234>>>>>    set piPosition.i liRow to Position#
70235>>>>>    set psFileName.i liRow to FileName#
70236>>>>>    set psMessage.i  liRow to Message#
70237>>>>>    if (piOnScreen(self)) send display_error.i liRow
70240>>>>>  end_procedure
70241>>>>>end_class
70242>>>>>class cStructuralStack is a cArray
70243>>>>>  procedure construct_object integer img#
70245>>>>>    forward send construct_object img#
70247>>>>>  end_procedure
70248>>>>>  item_property_list
70248>>>>>    item_property integer piStackingCmd.i // WHILE, BEGIN, REPEAT etc.
70248>>>>>    item_property integer piPendingCmd.i  // END, LOOP, UNTIL
70248>>>>>    item_property string  psFileName.i    // Name of source file
70248>>>>>    item_property integer piLine.i        // In which line was the structure initiated?
70248>>>>>  end_item_property_list cStructuralStack
#REM 70286 DEFINE FUNCTION PILINE.I INTEGER LIROW RETURNS INTEGER
#REM 70290 DEFINE PROCEDURE SET PILINE.I INTEGER LIROW INTEGER VALUE
#REM 70294 DEFINE FUNCTION PSFILENAME.I INTEGER LIROW RETURNS STRING
#REM 70298 DEFINE PROCEDURE SET PSFILENAME.I INTEGER LIROW STRING VALUE
#REM 70302 DEFINE FUNCTION PIPENDINGCMD.I INTEGER LIROW RETURNS INTEGER
#REM 70306 DEFINE PROCEDURE SET PIPENDINGCMD.I INTEGER LIROW INTEGER VALUE
#REM 70310 DEFINE FUNCTION PISTACKINGCMD.I INTEGER LIROW RETURNS INTEGER
#REM 70314 DEFINE PROCEDURE SET PISTACKINGCMD.I INTEGER LIROW INTEGER VALUE
70319>>>>>  function iTopStackingCmd returns integer
70321>>>>>    function_return (piStackingCmd.i(self,row_count(self)-1))
70322>>>>>  end_function
70323>>>>>  function iTopPendingCmd returns integer
70325>>>>>    function_return (piPendingCmd.i(self,row_count(self)-1))
70326>>>>>  end_function
70327>>>>>  procedure push_struct integer cmd1# integer cmd2# string fn# integer line#
70329>>>>>    integer liRow
70329>>>>>    get row_count to liRow
70330>>>>>    set piStackingCmd.i liRow to cmd1#
70331>>>>>    set piPendingCmd.i  liRow to cmd2#
70332>>>>>    set psFileName.i    liRow to fn#
70333>>>>>    set piLine.i        liRow to line#
70334>>>>>  end_procedure
70335>>>>>  procedure pop_struct
70337>>>>>    send delete_row (row_count(self)-1)
70338>>>>>  end_procedure
70339>>>>>end_class // cStructuralStack
70340>>>>>
70340>>>>>register_procedure Interpret_Date
70340>>>>>register_procedure Interpret_Else
70340>>>>>register_procedure Interpret_End
70340>>>>>register_procedure Interpret_EndIf
70340>>>>>register_procedure Interpret_For
70340>>>>>register_procedure Interpret_Gosub
70340>>>>>register_procedure Interpret_Goto
70340>>>>>register_procedure Interpret_If
70340>>>>>register_procedure Interpret_Pause
70340>>>>>register_procedure Interpret_GotoXY
70340>>>>>register_procedure Interpret_Input
70340>>>>>register_procedure Interpret_Integer
70340>>>>>register_procedure Interpret_Loop
70340>>>>>register_procedure Interpret_Move
70340>>>>>register_procedure Interpret_Number
70340>>>>>register_procedure Interpret_Return
70340>>>>>register_procedure Interpret_Showln
70340>>>>>register_procedure Interpret_Show
70340>>>>>register_procedure Interpret_String
70340>>>>>register_procedure Interpret_Abort
70340>>>>>register_procedure Interpret_ClearScreen
70340>>>>>register_procedure Interpret_While
70340>>>>>register_procedure Interpret_#use
70340>>>>>register_procedure Interpret_#include
70340>>>>>register_procedure Interpret_#replace
70340>>>>>register_procedure Interpret_#noisy
70340>>>>>register_procedure Interpret_Increment
70340>>>>>register_procedure Interpret_Decrement
70340>>>>>register_procedure Interpret_Debug
70340>>>>>register_procedure Interpret_Repeat
70340>>>>>register_procedure Interpret_Until
70340>>>>>register_procedure Interpret_Log_Open
70340>>>>>register_procedure Interpret_Log_Close
70340>>>>>register_procedure Interpret_Log_Display
70340>>>>>register_procedure Interpret_Log_Flush
70340>>>>>register_procedure Interpret_Log_Write
70340>>>>>register_procedure Interpret_Log_Writeln
70340>>>>>register_procedure Interpret_Set_Attribute
70340>>>>>register_procedure Interpret_Create_Field
70340>>>>>register_procedure Interpret_Append_Field
70340>>>>>register_procedure Interpret_Delete_Field
70340>>>>>register_procedure Interpret_Delete_Index
70340>>>>>register_procedure Interpret_Structure_Abort
70340>>>>>register_procedure Interpret_Structure_End
70340>>>>>register_procedure Interpret_Probe_End
70340>>>>>register_procedure Interpret_Set_Field
70340>>>>>register_procedure Interpret_InfoBox
70340>>>>>
70340>>>>>// Support commands:
70340>>>>>
70340>>>>>
70340>>>>>class cCommandList is a cArray
70341>>>>>  item_property_list
70341>>>>>    item_property string  psName.i
70341>>>>>    item_property integer piCompileMsg.i
70341>>>>>  end_item_property_list cCommandList
#REM 70373 DEFINE FUNCTION PICOMPILEMSG.I INTEGER LIROW RETURNS INTEGER
#REM 70377 DEFINE PROCEDURE SET PICOMPILEMSG.I INTEGER LIROW INTEGER VALUE
#REM 70381 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 70385 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
70390>>>>>  procedure add_command integer cmd# string name# integer msg#
70392>>>>>    set psName.i       cmd# to (uppercase(name#))
70393>>>>>    set piCompileMsg.i cmd# to msg#
70394>>>>>  end_procedure
70395>>>>>  procedure construct_object integer img#
70397>>>>>    forward send construct_object img#
70399>>>>>    enumeration_list
70399>>>>>      define_cmd CMD_DATE        "DATE"        msg_Interpret_Date
70400>>>>>      define_cmd CMD_ELSE        "ELSE"        msg_Interpret_Else
70401>>>>>      define_cmd CMD_END         "END"         msg_Interpret_End
70402>>>>>      define_cmd CMD_ENDIF       "ENDIF"       msg_Interpret_EndIf
70403>>>>>      define_cmd CMD_FOR         "FOR"         msg_Interpret_For
70404>>>>>      define_cmd CMD_GOSUB       "GOSUB"       msg_Interpret_Gosub
70405>>>>>      define_cmd CMD_GOTO        "GOTO"        msg_Interpret_Goto
70406>>>>>      define_cmd CMD_IF          "IF"          msg_Interpret_If
70407>>>>>      define_cmd CMD_PAUSE       "PAUSE"       msg_Interpret_Pause
70408>>>>>      define_cmd CMD_INPUT       "INPUT"       msg_Interpret_Input
70409>>>>>      define_cmd CMD_GOTOXY      "GOTOXY"      msg_Interpret_GotoXY
70410>>>>>      define_cmd CMD_INTEGER     "INTEGER"     msg_Interpret_Integer
70411>>>>>      define_cmd CMD_LOOP        "LOOP"        msg_Interpret_Loop
70412>>>>>      define_cmd CMD_MOVE        "MOVE"        msg_Interpret_Move
70413>>>>>      define_cmd CMD_NUMBER      "NUMBER"      msg_Interpret_Number
70414>>>>>      define_cmd CMD_RETURN      "RETURN"      msg_Interpret_Return
70415>>>>>      define_cmd CMD_SHOWLN      "SHOWLN"      msg_Interpret_Showln
70416>>>>>      define_cmd CMD_SHOW        "SHOW"        msg_Interpret_Show
70417>>>>>      define_cmd CMD_STRING      "STRING"      msg_Interpret_String
70418>>>>>      define_cmd CMD_ABORT       "ABORT"       msg_Interpret_Abort
70419>>>>>      define_cmd CMD_CLEARSCREEN "CLEARSCREEN" msg_Interpret_ClearScreen
70420>>>>>      define_cmd CMD_WHILE       "WHILE"       msg_Interpret_While
70421>>>>>      define_cmd CMD_#USE        "#USE"        msg_Interpret_#use     // Not implemented
70422>>>>>      define_cmd CMD_#INCLUDE    "#INCLUDE"    msg_Interpret_#include // Not implemented
70423>>>>>      define_cmd CMD_#REPLACE    "#REPLACE"    msg_Interpret_#replace
70424>>>>>      define_cmd CMD_#NOISY      "#NOISY"      msg_Interpret_#noisy
70425>>>>>      define_cmd CMD_INCREMENT   "INCREMENT"   msg_Interpret_Increment
70426>>>>>      define_cmd CMD_DECREMENT   "DECREMENT"   msg_Interpret_DeCrement
70427>>>>>      define_cmd CMD_DEBUG       "DEBUG"       msg_Interpret_Debug
70428>>>>>      define_cmd CMD_REPEAT      "REPEAT"      msg_Interpret_Repeat
70429>>>>>      define_cmd CMD_UNTIL       "UNTIL"       msg_Interpret_Until
70430>>>>>      define_cmd CMD_LOG_OPEN    "LOG_OPEN"    msg_Interpret_Log_Open
70431>>>>>      define_cmd CMD_LOG_CLOSE   "LOG_CLOSE"   msg_Interpret_Log_Close
70432>>>>>      define_cmd CMD_LOG_DISPLAY "LOG_DISPLAY" msg_Interpret_Log_Display
70433>>>>>      define_cmd CMD_LOG_FLUSH   "LOG_FLUSH"   msg_Interpret_Log_Flush
70434>>>>>      define_cmd CMD_LOG_WRITE   "LOG_WRITE"   msg_Interpret_Log_Write
70435>>>>>      define_cmd CMD_LOG_WRITELN "LOG_WRITELN" msg_Interpret_Log_Writeln
70436>>>>>      define_cmd CMD_SET_ATTRIBUTE   "SET_ATTRIBUTE"   msg_Interpret_Set_Attribute
70437>>>>>      define_cmd CMD_CREATE_FIELD    "CREATE_FIELD"    msg_Interpret_Create_Field
70438>>>>>      define_cmd CMD_APPEND_FIELD    "APPEND_FIELD"    msg_Interpret_Append_Field
70439>>>>>      define_cmd CMD_DELETE_FIELD    "DELETE_FIELD"    msg_Interpret_Delete_Field
70440>>>>>      define_cmd CMD_DELETE_INDEX    "DELETE_INDEX"    msg_Interpret_Delete_Index
70441>>>>>      define_cmd CMD_STRUCTURE_ABORT "STRUCTURE_ABORT" msg_Interpret_Structure_Abort
70442>>>>>      define_cmd CMD_STRUCTURE_END   "STRUCTURE_END"   msg_Interpret_Structure_End
70443>>>>>      define_cmd CMD_PROBE_END       "PROBE_END"       msg_Interpret_Probe_End
70444>>>>>      define_cmd CMD_SET_FIELD       "SET_FIELD"       msg_Interpret_Set_Field
70445>>>>>      define_cmd CMD_INFOBOX         "INFOBOX"         msg_Interpret_InfoBox
70446>>>>>    end_enumeration_list
70446>>>>>  end_procedure
70447>>>>>  function iCommand.s string command# returns integer
70449>>>>>    integer liRow max#
70449>>>>>    move (uppercase(command#)) to command#
70450>>>>>    get row_count to max#
70451>>>>>    for liRow from 0 to (max#-1)
70457>>>>>>
70457>>>>>      if command# eq (psName.i(self,liRow)) function_return liRow
70460>>>>>    loop
70461>>>>>>
70461>>>>>    function_return -1 // Not found
70462>>>>>  end_function
70463>>>>>end_class // cCommandList
70464>>>>>
70464>>>>>class cReplaces is a cArray
70465>>>>>  item_property_list
70465>>>>>    item_property string psName.i
70465>>>>>    item_property string psValue.i
70465>>>>>  end_item_property_list cReplaces
#REM 70497 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 70501 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 70505 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 70509 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
70514>>>>>
70514>>>>>  procedure construct_object integer img#
70516>>>>>    forward send construct_object img#
70518>>>>>    property integer piFlexInit_Count public 0
70519>>>>>    send initial_replaces
70520>>>>>  end_procedure
70521>>>>>
70521>>>>>  procedure reset
70523>>>>>    integer max# liRow max_flexinit#
70523>>>>>    get piFlexInit_Count to max_flexinit#
70524>>>>>    get row_count to max#
70525>>>>>    for_ex liRow from (max#-1) down_to max_flexinit#
70532>>>>>      send delete_row liRow
70533>>>>>    loop
70534>>>>>>
70534>>>>>  end_procedure
70535>>>>>
70535>>>>>  function iNameToNo.s string name# returns integer
70537>>>>>    integer liRow max# rval#
70537>>>>>    move (uppercase(name#)) to name#
70538>>>>>    get row_count to max#
70539>>>>>    move -1 to rval#
70540>>>>>    move 0 to liRow
70541>>>>>    while (liRow>>>>      if name# eq (psName.i(self,liRow)) move liRow to rval#
70548>>>>>      increment liRow
70549>>>>>    end
70550>>>>>>
70550>>>>>    function_return rval#
70551>>>>>  end_function
70552>>>>>
70552>>>>>  function sNameToValue.s string name# returns string
70554>>>>>    integer liRow
70554>>>>>    get iNameToNo.s name# to liRow
70555>>>>>    if liRow eq -1 function_return name#
70558>>>>>    function_return (sNameToValue.s(self,psValue.i(self,liRow)))
70559>>>>>  end_function
70560>>>>>
70560>>>>>  function iCircular.ss string name# string symbol_list# returns integer
70562>>>>>    integer liRow rval#
70562>>>>>    move 0 to rval#
70563>>>>>    if symbol_list# eq "" move "" to symbol_list#
70566>>>>>    if (""+name#+"") in symbol_list# function_return 1 // Circular ref!
70569>>>>>    get iNameToNo.s name# to liRow
70570>>>>>    if liRow ne -1 get iCircular.ss (psValue.i(self,liRow)) (symbol_list#+name#+"") to rval#
70573>>>>>    function_return rval#
70574>>>>>  end_function
70575>>>>>
70575>>>>>  function iNameDeclare.ss string name# string value# returns integer
70577>>>>>    integer liRow rval#
70577>>>>>    move ERR.SCRIPT.NO_ERROR to rval#
70578>>>>>    move (uppercase(name#)) to name#
70579>>>>>    get iNameToNo.s name# to liRow
70580>>>>>    if liRow eq -1 begin
70582>>>>>      get row_count to liRow
70583>>>>>      set psName.i  liRow to name#
70584>>>>>      set psValue.i liRow to value#
70585>>>>>    end
70585>>>>>>
70585>>>>>    else move ERR.SCRIPT.SYMBOL_ALREADY_DEF to rval#
70587>>>>>    ifnot rval# if (iCircular.ss(self,name#,value#)) begin
70591>>>>>      move ERR.SCRIPT.CIRCULAR_REFERENCE to rval#
70592>>>>>      send delete_row liRow
70593>>>>>    end
70593>>>>>>
70593>>>>>    function_return rval#
70594>>>>>  end_function
70595>>>>>  procedure add_initial_replace string name# string value#
70597>>>>>    integer liRow
70597>>>>>    get row_count to liRow
70598>>>>>    set psName.i  liRow to name#
70599>>>>>    set psValue.i liRow to value#
70600>>>>>  end_procedure
70601>>>>>  procedure initial_replaces
70603>>>>>    send add_initial_replace "FALSE"                               0
70604>>>>>    send add_initial_replace "TRUE"                                1
70605>>>>>    send add_initial_replace "DFTRUE"                              DFTRUE
70606>>>>>    send add_initial_replace "DFFALSE"                             DFFALSE
70607>>>>>    if DFTRUE begin // DATE STUFF
70609>>>>>      send add_initial_replace "DS_DAY"                 DS_DAY
70610>>>>>      send add_initial_replace "DS_WEEK"                DS_WEEK
70611>>>>>      send add_initial_replace "DS_MONTH"               DS_MONTH
70612>>>>>      send add_initial_replace "DS_YEAR"                DS_YEAR
70613>>>>>      send add_initial_replace "LargestPossibleDate"    LargestPossibleDate
70614>>>>>      send add_initial_replace "Jan1st1900"             Jan1st1900
70615>>>>>      send add_initial_replace "Jan1st2000"             Jan1st2000
70616>>>>>      send add_initial_replace "Jan1st1930"             Jan1st1930
70617>>>>>      send add_initial_replace "Jan1st1000"             Jan1st1000
70618>>>>>      send add_initial_replace "Jan1st105"              Jan1st105
70619>>>>>      send add_initial_replace "Jan1st100"              Jan1st100
70620>>>>>    end
70620>>>>>>
70620>>>>>    if DFFALSE begin
70622>>>>>      send add_initial_replace "IMPLICIT_FIELD"                      -1
70623>>>>>      send add_initial_replace "DF_LOCK_DELAY"                       DF_LOCK_DELAY
70624>>>>>      send add_initial_replace "DF_LOCK_TIMEOUT"                     DF_LOCK_TIMEOUT
70625>>>>>      send add_initial_replace "DF_OPEN_PATH"                        DF_OPEN_PATH
70626>>>>>      send add_initial_replace "DF_DATE_FORMAT"                      DF_DATE_FORMAT
70627>>>>>      send add_initial_replace "DF_DATE_SEPARATOR"                   DF_DATE_SEPARATOR
70628>>>>>      send add_initial_replace "DF_DECIMAL_SEPARATOR"                DF_DECIMAL_SEPARATOR
70629>>>>>      send add_initial_replace "DF_THOUSANDS_SEPARATOR"              DF_THOUSANDS_SEPARATOR
70630>>>>>      send add_initial_replace "DF_ALL_FILES_TOUCHED"                DF_ALL_FILES_TOUCHED
70631>>>>>      send add_initial_replace "DF_HIGH_DATA_INTEGRITY"              DF_HIGH_DATA_INTEGRITY
70632>>>>>      send add_initial_replace "DF_TRAN_COUNT"                       DF_TRAN_COUNT
70633>>>>>      send add_initial_replace "DF_TRANSACTION_ABORT"                DF_TRANSACTION_ABORT
70634>>>>>      send add_initial_replace "DF_REREAD_REQUIRED"                  DF_REREAD_REQUIRED
70635>>>>>      send add_initial_replace "DF_FILELIST_NAME"                    DF_FILELIST_NAME
70636>>>>>      send add_initial_replace "DF_REPORT_UNSUPPORTED_ATTRIBUTES"    DF_REPORT_UNSUPPORTED_ATTRIBUTES
70637>>>>>      send add_initial_replace "DF_STRICT_ATTRIBUTES"                DF_STRICT_ATTRIBUTES
70638>>>>>      send add_initial_replace "DF_NUMBER_DRIVERS"                   DF_NUMBER_DRIVERS
70639>>>>>      send add_initial_replace "DF_DRIVER_NAME"                      DF_DRIVER_NAME
70640>>>>>      send add_initial_replace "DF_DRIVER_NUMBER_SERVERS"            DF_DRIVER_NUMBER_SERVERS
70641>>>>>      send add_initial_replace "DF_DRIVER_SERVER_NAME"               DF_DRIVER_SERVER_NAME
70642>>>>>      send add_initial_replace "DF_API_DISABLED"                     DF_API_DISABLED
70643>>>>>      send add_initial_replace "DF_API_DISABLED_ERROR"               DF_API_DISABLED_ERROR
70644>>>>>      send add_initial_replace "DF_FILE_STATUS"                      DF_FILE_STATUS
70645>>>>>      send add_initial_replace "DF_FILE_MODE"                        DF_FILE_MODE
70646>>>>>      send add_initial_replace "DF_FILE_MAX_RECORDS"                 DF_FILE_MAX_RECORDS
70647>>>>>      send add_initial_replace "DF_FILE_RECORDS_USED"                DF_FILE_RECORDS_USED
70648>>>>>      send add_initial_replace "DF_FILE_TYPE"                        DF_FILE_TYPE
70649>>>>>      send add_initial_replace "DF_FILE_MULTIUSER"                   DF_FILE_MULTIUSER
70650>>>>>      send add_initial_replace "DF_FILE_REUSE_DELETED"               DF_FILE_REUSE_DELETED
70651>>>>>      send add_initial_replace "DF_FILE_NUMBER"                      DF_FILE_NUMBER
70652>>>>>      send add_initial_replace "DF_FILE_COMPRESSION"                 DF_FILE_COMPRESSION
70653>>>>>      send add_initial_replace "DF_FILE_LAST_INDEX_NUMBER"           DF_FILE_LAST_INDEX_NUMBER
70654>>>>>      send add_initial_replace "DF_FILE_NUMBER_FIELDS"               DF_FILE_NUMBER_FIELDS
70655>>>>>      send add_initial_replace "DF_FILE_LOGICAL_NAME"                DF_FILE_LOGICAL_NAME
70656>>>>>      send add_initial_replace "DF_FILE_ROOT_NAME"                   DF_FILE_ROOT_NAME
70657>>>>>      send add_initial_replace "DF_FILE_CHANGED"                     DF_FILE_CHANGED
70658>>>>>      send add_initial_replace "DF_FILE_ALIAS"                       DF_FILE_ALIAS
70659>>>>>      send add_initial_replace "DF_FILE_TOUCHED"                     DF_FILE_TOUCHED
70660>>>>>      send add_initial_replace "DF_FILE_TRANSACTION"                 DF_FILE_TRANSACTION
70661>>>>>      send add_initial_replace "DF_FILE_OPENED"                      DF_FILE_OPENED
70662>>>>>      send add_initial_replace "DF_FILE_DISPLAY_NAME"                DF_FILE_DISPLAY_NAME
70663>>>>>      send add_initial_replace "DF_FILE_PHYSICAL_NAME"               DF_FILE_PHYSICAL_NAME
70664>>>>>      send add_initial_replace "DF_FILE_NEXT_OPENED"                 DF_FILE_NEXT_OPENED
70665>>>>>      send add_initial_replace "DF_FILE_NEXT_USED"                   DF_FILE_NEXT_USED
70666>>>>>      send add_initial_replace "DF_FILE_NEXT_EMPTY"                  DF_FILE_NEXT_EMPTY
70667>>>>>      send add_initial_replace "DF_FILE_RECORD_LENGTH"               DF_FILE_RECORD_LENGTH
70668>>>>>      send add_initial_replace "DF_FILE_RESTRUCTURE"                 DF_FILE_RESTRUCTURE
70669>>>>>      send add_initial_replace "DF_FILE_OPEN_MODE"                   DF_FILE_OPEN_MODE
70670>>>>>      send add_initial_replace "DF_FILE_INTEGRITY_CHECK"             DF_FILE_INTEGRITY_CHECK
70671>>>>>      send add_initial_replace "DF_FILE_OWNER"                       DF_FILE_OWNER
70672>>>>>      send add_initial_replace "DF_FILE_IS_SYSTEM_FILE"              DF_FILE_IS_SYSTEM_FILE
70673>>>>>      send add_initial_replace "DF_FILE_LOCK_TYPE"                   DF_FILE_LOCK_TYPE
70674>>>>>      send add_initial_replace "DF_FILE_COMMITTED"                   DF_FILE_COMMITTED
70675>>>>>      send add_initial_replace "DF_FILE_DRIVER"                      DF_FILE_DRIVER
70676>>>>>      send add_initial_replace "DF_FILE_RECORD_LENGTH_USED"          DF_FILE_RECORD_LENGTH_USED
70677>>>>>      send add_initial_replace "DF_FILE_HANDLE_TYPE"                 DF_FILE_HANDLE_TYPE
70678>>>>>      send add_initial_replace "DF_FILE_RECORD_IDENTITY"             DF_FILE_RECORD_IDENTITY
70679>>>>>      send add_initial_replace "DF_FILE_LOGIN"                       DF_FILE_LOGIN
70680>>>>>      send add_initial_replace "DF_FILE_RECORD_PRIVILEGE"            DF_FILE_RECORD_PRIVILEGE
70681>>>>>      send add_initial_replace "DF_FILE_PRIVILEGE"                   DF_FILE_PRIVILEGE
70682>>>>>      send add_initial_replace "DF_FILE_CREATION_SERIAL"             DF_FILE_CREATION_SERIAL
70683>>>>>      send add_initial_replace "DF_FILE_REVISION"                    DF_FILE_REVISION
70684>>>>>      send add_initial_replace "DF_FILE_RELATED_COUNT"               DF_FILE_RELATED_COUNT
70685>>>>>      send add_initial_replace "DF_FILE_RELATED_FIELDS"              DF_FILE_RELATED_FIELDS
70686>>>>>      send add_initial_replace "DF_FILE_SYSTEM_FILE"                 DF_FILE_SYSTEM_FILE
70687>>>>>      send add_initial_replace "DF_FILE_SYSTEM_FIELD"                DF_FILE_SYSTEM_FIELD
70688>>>>>      send add_initial_replace "DF_FILE_RECORD_REREAD"               DF_FILE_RECORD_REREAD
70689>>>>>      send add_initial_replace "DF_FIELD_NUMBER"                     DF_FIELD_NUMBER
70690>>>>>      send add_initial_replace "DF_FIELD_TYPE"                       DF_FIELD_TYPE
70691>>>>>      send add_initial_replace "DF_FIELD_LENGTH"                     DF_FIELD_LENGTH
70692>>>>>      send add_initial_replace "DF_FIELD_PRECISION"                  DF_FIELD_PRECISION
70693>>>>>      send add_initial_replace "DF_FIELD_RELATED_FILE"               DF_FIELD_RELATED_FILE
70694>>>>>      send add_initial_replace "DF_FIELD_RELATED_FIELD"              DF_FIELD_RELATED_FIELD
70695>>>>>      send add_initial_replace "DF_FIELD_NAME"                       DF_FIELD_NAME
70696>>>>>      send add_initial_replace "DF_FIELD_INDEX"                      DF_FIELD_INDEX
70697>>>>>      send add_initial_replace "DF_FIELD_OFFSET"                     DF_FIELD_OFFSET
70698>>>>>      send add_initial_replace "DF_FIELD_OLD_NUMBER"                 DF_FIELD_OLD_NUMBER
70699>>>>>      send add_initial_replace "DF_FIELD_OVERLAP"                    DF_FIELD_OVERLAP
70700>>>>>      send add_initial_replace "DF_FIELD_NATIVE_LENGTH"              DF_FIELD_NATIVE_LENGTH
70701>>>>>      send add_initial_replace "DF_INDEX_NUMBER_SEGMENTS"            DF_INDEX_NUMBER_SEGMENTS
70702>>>>>      send add_initial_replace "DF_INDEX_NUMBER_BUFFERS"             DF_INDEX_NUMBER_BUFFERS
70703>>>>>      send add_initial_replace "DF_INDEX_TYPE"                       DF_INDEX_TYPE
70704>>>>>      send add_initial_replace "DF_INDEX_LEVELS"                     DF_INDEX_LEVELS
70705>>>>>      send add_initial_replace "DF_INDEX_KEY_LENGTH"                 DF_INDEX_KEY_LENGTH
70706>>>>>      send add_initial_replace "DF_INDEX_SEGMENT_DIRECTION"          DF_INDEX_SEGMENT_DIRECTION
70707>>>>>      send add_initial_replace "DF_INDEX_SEGMENT_CASE"               DF_INDEX_SEGMENT_CASE
70708>>>>>      send add_initial_replace "DF_INDEX_SEGMENT_FIELD"              DF_INDEX_SEGMENT_FIELD
70709>>>>>      send add_initial_replace "DF_DATE_USA"                         DF_DATE_USA
70710>>>>>      send add_initial_replace "DF_DATE_EUROPEAN"                    DF_DATE_EUROPEAN
70711>>>>>      send add_initial_replace "DF_DATE_MILITARY"                    DF_DATE_MILITARY
70712>>>>>      send add_initial_replace "DF_MESSAGE_TEXT"                     DF_MESSAGE_TEXT
70713>>>>>      send add_initial_replace "DF_MESSAGE_HEADING_1"                DF_MESSAGE_HEADING_1
70714>>>>>      send add_initial_replace "DF_MESSAGE_HEADING_2"                DF_MESSAGE_HEADING_2
70715>>>>>      send add_initial_replace "DF_MESSAGE_HEADING_3"                DF_MESSAGE_HEADING_3
70716>>>>>      send add_initial_replace "DF_MESSAGE_HEADING_4"                DF_MESSAGE_HEADING_4
70717>>>>>      send add_initial_replace "DF_MESSAGE_HEADING_5"                DF_MESSAGE_HEADING_5
70718>>>>>      send add_initial_replace "DF_MESSAGE_WARNING"                  DF_MESSAGE_WARNING
70719>>>>>      send add_initial_replace "DF_MESSAGE_PROGRESS_TITLE"           DF_MESSAGE_PROGRESS_TITLE
70720>>>>>      send add_initial_replace "DF_MESSAGE_PROGRESS_VALUE"           DF_MESSAGE_PROGRESS_VALUE
70721>>>>>      send add_initial_replace "DF_AUX_FILE_FD"                      DF_AUX_FILE_FD
70722>>>>>      send add_initial_replace "DF_AUX_FILE_DEF"                     DF_AUX_FILE_DEF
70723>>>>>      send add_initial_replace "DF_FILE_INACTIVE"                    DF_FILE_INACTIVE
70724>>>>>      send add_initial_replace "DF_FILE_ACTIVE"                      DF_FILE_ACTIVE
70725>>>>>      send add_initial_replace "DF_FILE_ACTIVE_CHANGED"              DF_FILE_ACTIVE_CHANGED
70726>>>>>      send add_initial_replace "DF_FILE_USER_SINGLE"                 DF_FILE_USER_SINGLE
70727>>>>>      send add_initial_replace "DF_FILE_USER_MULTI"                  DF_FILE_USER_MULTI
70728>>>>>      send add_initial_replace "DF_FILE_DELETED_NOREUSE"             DF_FILE_DELETED_NOREUSE
70729>>>>>      send add_initial_replace "DF_FILE_DELETED_REUSE"               DF_FILE_DELETED_REUSE
70730>>>>>      send add_initial_replace "DF_FILE_COMPRESS_NONE"               DF_FILE_COMPRESS_NONE
70731>>>>>      send add_initial_replace "DF_FILE_COMPRESS_FAST"               DF_FILE_COMPRESS_FAST
70732>>>>>      send add_initial_replace "DF_FILE_COMPRESS_STANDARD"           DF_FILE_COMPRESS_STANDARD
70733>>>>>      send add_initial_replace "DF_FILE_COMPRESS_CUSTOM"             DF_FILE_COMPRESS_CUSTOM
70734>>>>>      send add_initial_replace "DF_FILE_ALIAS_DEFAULT"               DF_FILE_ALIAS_DEFAULT
70735>>>>>      send add_initial_replace "DF_FILE_IS_MASTER"                   DF_FILE_IS_MASTER
70736>>>>>      send add_initial_replace "DF_FILE_IS_ALIAS"                    DF_FILE_IS_ALIAS
70737>>>>>      send add_initial_replace "DF_FILE_HANDLE_BAD"                  DF_FILE_HANDLE_BAD
70738>>>>>      send add_initial_replace "DF_FILE_HANDLE_CLOSED"               DF_FILE_HANDLE_CLOSED
70739>>>>>      send add_initial_replace "DF_FILE_HANDLE_OPENED"               DF_FILE_HANDLE_OPENED
70740>>>>>      send add_initial_replace "DF_FILE_HANDLE_EXISTING_RESTRUCTURE" DF_FILE_HANDLE_EXISTING_RESTRUCTURE
70741>>>>>      send add_initial_replace "DF_FILE_HANDLE_NEW_RESTRUCTURE"      DF_FILE_HANDLE_NEW_RESTRUCTURE
70742>>>>>      send add_initial_replace "DF_FILE_TRANSACTION_NONE"            DF_FILE_TRANSACTION_NONE
70743>>>>>      send add_initial_replace "DF_FILE_TRANSACTION_CLIENT_ATOMIC"   DF_FILE_TRANSACTION_CLIENT_ATOMIC
70744>>>>>      send add_initial_replace "DF_FILE_TRANSACTION_SERVER_ATOMIC"   DF_FILE_TRANSACTION_SERVER_ATOMIC
70745>>>>>      send add_initial_replace "DF_FILE_TRANSACTION_SERVER_LOGGED"   DF_FILE_TRANSACTION_SERVER_LOGGED
70746>>>>>      send add_initial_replace "DF_NO_RESTRUCTURE"                   DF_NO_RESTRUCTURE
70747>>>>>      send add_initial_replace "DF_RESTRUCTURE_FILE"                 DF_RESTRUCTURE_FILE
70748>>>>>      send add_initial_replace "DF_RESTRUCTURE_INDEX"                DF_RESTRUCTURE_INDEX
70749>>>>>      send add_initial_replace "DF_RESTRUCTURE_BOTH"                 DF_RESTRUCTURE_BOTH
70750>>>>>      send add_initial_replace "DF_FILE_NOT_TOUCHED"                 DF_FILE_NOT_TOUCHED
70751>>>>>      send add_initial_replace "DF_FILE_TOUCHED_INACTIVE"            DF_FILE_TOUCHED_INACTIVE
70752>>>>>      send add_initial_replace "DF_FILE_TOUCHED_ACTIVE"              DF_FILE_TOUCHED_ACTIVE
70753>>>>>      send add_initial_replace "DF_FILEMODE_ORIGINAL"                DF_FILEMODE_ORIGINAL
70754>>>>>      send add_initial_replace "DF_FILEMODE_DEFAULT"                 DF_FILEMODE_DEFAULT
70755>>>>>      send add_initial_replace "DF_FILEMODE_NO_REREAD"               DF_FILEMODE_NO_REREAD
70756>>>>>      send add_initial_replace "DF_FILEMODE_NO_LOCKS"                DF_FILEMODE_NO_LOCKS
70757>>>>>      send add_initial_replace "DF_FILEMODE_NO_EDITS"                DF_FILEMODE_NO_EDITS
70758>>>>>      send add_initial_replace "DF_FILEMODE_NO_DELETES"              DF_FILEMODE_NO_DELETES
70759>>>>>      send add_initial_replace "DF_FILEMODE_NO_FINDS"                DF_FILEMODE_NO_FINDS
70760>>>>>      send add_initial_replace "DF_FILEMODE_NO_CREATES"              DF_FILEMODE_NO_CREATES
70761>>>>>      send add_initial_replace "DF_FILEMODE_READONLY"                DF_FILEMODE_READONLY
70762>>>>>      send add_initial_replace "DF_FILEMODE_SINGLE_USER"             DF_FILEMODE_SINGLE_USER
70763>>>>>      send add_initial_replace "DF_PERMANENT"                        DF_PERMANENT
70764>>>>>      send add_initial_replace "DF_TEMPORARY"                        DF_TEMPORARY
70765>>>>>      send add_initial_replace "DF_LOCK_TYPE_NONE"                   DF_LOCK_TYPE_NONE
70766>>>>>      send add_initial_replace "DF_LOCK_TYPE_FILE"                   DF_LOCK_TYPE_FILE
70767>>>>>      send add_initial_replace "DF_LOCK_TYPE_RECORD"                 DF_LOCK_TYPE_RECORD
70768>>>>>      send add_initial_replace "DF_SHARE"                            DF_SHARE
70769>>>>>      send add_initial_replace "DF_EXCLUSIVE"                        DF_EXCLUSIVE
70770>>>>>      send add_initial_replace "DF_INDEX_TYPE_ONLINE"                DF_INDEX_TYPE_ONLINE
70771>>>>>      send add_initial_replace "DF_INDEX_TYPE_BATCH"                 DF_INDEX_TYPE_BATCH
70772>>>>>      send add_initial_replace "DF_CASE_USED"                        DF_CASE_USED
70773>>>>>      send add_initial_replace "DF_CASE_IGNORED"                     DF_CASE_IGNORED
70774>>>>>      send add_initial_replace "DF_ASCENDING"                        DF_ASCENDING
70775>>>>>      send add_initial_replace "DF_DESCENDING"                       DF_DESCENDING
70776>>>>>      send add_initial_replace "DF_ASCII"                            DF_ASCII
70777>>>>>      send add_initial_replace "DF_BCD"                              DF_BCD
70778>>>>>      send add_initial_replace "DF_DATE"                             DF_DATE
70779>>>>>      send add_initial_replace "DF_OVERLAP"                          DF_OVERLAP
70780>>>>>      send add_initial_replace "DF_TEXT"                             DF_TEXT
70781>>>>>      send add_initial_replace "DF_BINARY"                           DF_BINARY
70782>>>>>      send add_initial_replace "DF_STRUCTEND_OPT_NONE"               DF_STRUCTEND_OPT_NONE
70783>>>>>      send add_initial_replace "DF_STRUCTEND_OPT_FORCE"              DF_STRUCTEND_OPT_FORCE
70784>>>>>      send add_initial_replace "DF_STRUCTEND_OPT_RECOMPRESS"         DF_STRUCTEND_OPT_RECOMPRESS
70785>>>>>      send add_initial_replace "DF_STRUCTEND_OPT_IN_PLACE"           DF_STRUCTEND_OPT_IN_PLACE
70786>>>>>      send add_initial_replace "DF_SORT_OPTION_NONE"                 DF_SORT_OPTION_NONE
70787>>>>>      send add_initial_replace "DF_SORT_OPTION_NO_DATA_CHECK"        DF_SORT_OPTION_NO_DATA_CHECK
70788>>>>>      send add_initial_replace "DF_SORT_OPTION_BAD_DATA_FIXUP"       DF_SORT_OPTION_BAD_DATA_FIXUP
70789>>>>>      send add_initial_replace "DF_SORT_OPTION_BAD_DATA_FILE"        DF_SORT_OPTION_BAD_DATA_FILE
70790>>>>>      send add_initial_replace "DF_SORT_OPTION_BAD_DATA_ABORT"       DF_SORT_OPTION_BAD_DATA_ABORT
70791>>>>>      send add_initial_replace "DF_SORT_OPTION_DUP_DATA_FILE"        DF_SORT_OPTION_DUP_DATA_FILE
70792>>>>>      send add_initial_replace "DF_SORT_OPTION_DUP_DATA_ABORT"       DF_SORT_OPTION_DUP_DATA_ABORT
70793>>>>>      send add_initial_replace "DF_HIGH"                             DF_HIGH
70794>>>>>      send add_initial_replace "DF_LOW"                              DF_LOW
70795>>>>>    end
70795>>>>>>
70795>>>>>    set piFlexInit_Count to (row_count(self))
70796>>>>>  end_procedure
70797>>>>>end_class // cReplaces
70798>>>>>
70798>>>>>function dfscript_item_type global integer liType returns string
70800>>>>>  ifnot liType function_return "unknown"
70803>>>>>  if liType eq TYPE.UNKNOWN function_return "unknown"
70806>>>>>  if liType eq TYPE.UNTYPED function_return "un-typed"
70809>>>>>  if liType eq TYPE.DATE    function_return "date"
70812>>>>>  if liType eq TYPE.INTEGER function_return "integer"
70815>>>>>  if liType eq TYPE.NUMBER  function_return "number"
70818>>>>>  if liType eq TYPE.STRING  function_return "string"
70821>>>>>  function_return "ERROR"
70822>>>>>end_function
70823>>>>>function dfscript_item_class global integer class# returns string
70825>>>>>  ifnot class# function_return "unknown"
70828>>>>>  if class# eq CLASS.UNKNOWN  function_return "unknown"
70831>>>>>  if class# eq CLASS.LABEL    function_return "label"
70834>>>>>  if class# eq CLASS.VAR      function_return "var"
70837>>>>>  if class# eq CLASS.CONST    function_return "const"
70840>>>>>  if class# eq CLASS.EXPR     function_return "expr"
70843>>>>>  if class# eq CLASS.KEYWORD  function_return "keyword"
70846>>>>>  if class# eq CLASS.COMMAND  function_return "command"
70849>>>>>  if class# eq CLASS.REPLACE_SYMBOL function_return "replacable"
70852>>>>>  if class# eq CLASS.FIELD    function_return "field"
70855>>>>>  if class# eq CLASS.FUNCTION function_return "function"
70858>>>>>  function_return "ERROR"
70859>>>>>end_function
70860>>>>>
70860>>>>>class cScriptInterpreter is a cArray
70861>>>>>  procedure construct_object integer img#
70863>>>>>    forward send construct_object img#
70865>>>>>    property string  psLineBeingParsed  public ""
70866>>>>>    property string  psExprBeingParsed  public ""
70867>>>>>    property integer piErrorCode        public 0
70868>>>>>    property integer piErrorPos         public 0
70869>>>>>    property integer piLine             public 0
70870>>>>>    property integer pVM_Object         public 0 // Virtual Machine object
70871>>>>>    property string  psFileName         public "dfs.src"
70872>>>>>    property integer piDebugState       public 0
70873>>>>>    property string  psListingFile      public "dfscript.prn"
70874>>>>>    property integer piListingFileState public 1
70875>>>>>    property integer piListingFileCh    public 0
70876>>>>>    object oCommandList is a cCommandList
70878>>>>>    end_object
70879>>>>>    object oKeyWords is a cSet
70881>>>>>      send element_add "FROM"
70882>>>>>      send element_add "TO"
70883>>>>>      send element_add "LT"
70884>>>>>      send element_add "LE"
70885>>>>>      send element_add "EQ"
70886>>>>>      send element_add "NE"
70887>>>>>      send element_add "GE"
70888>>>>>      send element_add "GT"
70889>>>>>      send element_add "IN"
70890>>>>>      send element_add "AND"
70891>>>>>      send element_add "OR"
70892>>>>>      send element_add "MIN"
70893>>>>>      send element_add "MAX"
70894>>>>>    end_object
70895>>>>>    object oReplaces is a cReplaces
70897>>>>>    end_object
70898>>>>>    object oScriptErrors is a cScriptErrors
70900>>>>>    end_object
70901>>>>>    object oStructuralStack is a cStructuralStack
70903>>>>>    end_object
70904>>>>>    object oExpressionParser is a cExpressionParser
70906>>>>>    end_object
70907>>>>>    property integer piExprType public 0
70908>>>>>    property integer piExprID   public 0
70909>>>>>  end_procedure
70910>>>>>
70910>>>>>  procedure reset
70912>>>>>    send delete_data to (oScriptErrors(self))
70913>>>>>    send delete_data to (oStructuralStack(self))
70914>>>>>    send reset to (oReplaces(self))
70915>>>>>    send reset to (oExpressionParser(self))
70916>>>>>    set piErrorCode to 0
70917>>>>>    set piErrorPos  to 0
70918>>>>>    set piLine      to 0
70919>>>>>  end_procedure
70920>>>>>
70920>>>>>  function iCommand.s string command# returns integer
70922>>>>>    function_return (iCommand.s(oCommandList(self),command#))
70923>>>>>  end_function
70924>>>>>
70924>>>>>  procedure ScriptError integer error# integer pos# string tmp_str#
70926>>>>>    string str#
70926>>>>>    if num_arguments gt 2 move tmp_str# to str#
70929>>>>>    else move "" to str#
70931>>>>>    send add_error to (oScriptErrors(self)) error# (piLine(self)) pos# (psFileName(self)) str#
70932>>>>>    set piErrorCode to error#
70933>>>>>    set piErrorPos  to pos#
70934>>>>>  end_procedure
70935>>>>>
70935>>>>>  item_property_list
70935>>>>>    item_property string  psItem.i   // The item itself
70935>>>>>    item_property integer piPos.i    // Original starting position in original line
70935>>>>>    item_property integer piClass.i  // Item class
70935>>>>>    item_property integer piType.i   // Item type
70935>>>>>    item_property integer piAuxVal.i // Means different stuff
70935>>>>>  end_item_property_list cScriptInterpreter
#REM 70976 DEFINE FUNCTION PIAUXVAL.I INTEGER LIROW RETURNS INTEGER
#REM 70980 DEFINE PROCEDURE SET PIAUXVAL.I INTEGER LIROW INTEGER VALUE
#REM 70984 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 70988 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
#REM 70992 DEFINE FUNCTION PICLASS.I INTEGER LIROW RETURNS INTEGER
#REM 70996 DEFINE PROCEDURE SET PICLASS.I INTEGER LIROW INTEGER VALUE
#REM 71000 DEFINE FUNCTION PIPOS.I INTEGER LIROW RETURNS INTEGER
#REM 71004 DEFINE PROCEDURE SET PIPOS.I INTEGER LIROW INTEGER VALUE
#REM 71008 DEFINE FUNCTION PSITEM.I INTEGER LIROW RETURNS STRING
#REM 71012 DEFINE PROCEDURE SET PSITEM.I INTEGER LIROW STRING VALUE
71017>>>>>
71017>>>>>  function iIsLabelDeclaration.s string str# returns integer
71019>>>>>    if (right(str#,1)) eq ":" function_return 1
71022>>>>>  end_function
71023>>>>>
71023>>>>>  function iSymbolClass.s string name# returns integer
71025>>>>>    integer rval#
71025>>>>>    move (uppercase(name#)) to name#
71026>>>>>    // Is symbol defined in variable list of VM object?
71026>>>>>    get iVarNameToVarNo of (pVM_Object(self)) name# to rval#
71027>>>>>    if rval# ne -1 function_return CLASS.VAR
71030>>>>>    get iIsLabelNameUsed.s of (pVM_Object(self)) name# to rval#
71031>>>>>    if rval# function_return CLASS.LABEL
71034>>>>> // get iCommand.s name# to rval#
71034>>>>> // if rval# ne -1 function_return CLASS.COMMAND
71034>>>>>    get iNameToNo.s of (oReplaces(self)) name# to rval#
71035>>>>>    if rval# ne -1 function_return CLASS.REPLACE_SYMBOL
71038>>>>>    get iConstType.s name# to rval#
71039>>>>>    if rval# ne TYPE.UNKNOWN function_return CLASS.CONST
71042>>>>>    get element_find of (oKeyWords(self)) name# to rval#
71043>>>>>    if rval# ne -1 function_return CLASS.KEYWORD
71046>>>>>    if (left(name#,1)) eq "(" function_return CLASS.EXPR
71049>>>>>    get iFuncNameToFuncNo.s of (pVM_Object(self)) name# to rval#
71050>>>>>    if rval# ne -1 function_return CLASS.FUNCTION
71053>>>>>    get iFileField.s of (pVM_Object(self)) name# to rval#
71054>>>>>    if rval# function_return CLASS.FIELD
71057>>>>>    function_return CLASS.UNKNOWN // Which is 0
71058>>>>>  end_function // iSymbolClass.s
71059>>>>>
71059>>>>>  function iIsIntegerConstant.s string value# returns integer
71061>>>>>    integer pos# len#
71061>>>>>    if (left(value#,1)="-") move (replace("-",value#,"")) to value# // monadic minus
71064>>>>>    move (length(value#)) to len#
71065>>>>>    if len# eq 0 function_return 1
71068>>>>>    for pos# from 1 to len#
71074>>>>>>
71074>>>>>      ifnot (mid(value#,1,pos#)) in "0123456789" function_return 0
71077>>>>>    loop
71078>>>>>>
71078>>>>>    function_return 1
71079>>>>>  end_function
71080>>>>>  function iIsNumberConstant.s string value# returns integer
71082>>>>>    if "." in value# function_return (iIsIntegerConstant.s(self,replace(".",value#,"")))
71085>>>>>    // function_return 0
71085>>>>>  end_function
71086>>>>>  function iIsStringConstant.s string value# returns integer
71088>>>>>    string quote#
71088>>>>>    move (left(value#,1)) to quote#
71089>>>>>    if quote# in ("'"+'"') if (right(value#,1)) eq quote# if (length(value#)) ge 2 begin
71095>>>>>      move (replace(quote#,value#,"")) to value#
71096>>>>>      move (replace(quote#,value#,"")) to value#
71097>>>>>      ifnot quote# in value# function_return 1
71100>>>>>    end
71100>>>>>>
71100>>>>>    // function_return 0
71100>>>>>  end_function
71101>>>>>  function iIsDateConstant.s string value# returns integer
71103>>>>>    string m# d# y#
71103>>>>>    ifnot " " in value# begin
71105>>>>>      if (HowManyWords(value#,"/")=3) begin
71107>>>>>        move (ExtractWord(value#,"/",1)) to m#
71108>>>>>        move (ExtractWord(value#,"/",2)) to d#
71109>>>>>        move (ExtractWord(value#,"/",3)) to y#
71110>>>>>        if (iIsIntegerConstant.s(self,m#) and iIsIntegerConstant.s(self,d#) and iIsIntegerConstant.s(self,y#)) begin
71112>>>>>          if (integer(m#)>0 and integer(m#)<13 and integer(d#)>0 and integer(d#)<32 and integer(y#)>0 and integer(y#)<2500) function_return 1
71115>>>>>        end
71115>>>>>>
71115>>>>>      end
71115>>>>>>
71115>>>>>    end
71115>>>>>>
71115>>>>>    // function_return 0
71115>>>>>  end_function
71116>>>>>
71116>>>>>  function iConstType.s string value# returns integer
71118>>>>>    // The function returns TRUE if name is a constant. In fact, it returns
71118>>>>>    // the type of the constant IF indeed it is a constant
71118>>>>>    if (iIsIntegerConstant.s(self,value#)) function_return TYPE.INTEGER
71121>>>>>    if (iIsStringConstant.s(self,value#)) function_return TYPE.STRING
71124>>>>>    if (iIsDateConstant.s(self,value#)) function_return TYPE.DATE
71127>>>>>    if (iIsNumberConstant.s(self,value#)) function_return TYPE.NUMBER
71130>>>>>    function_return TYPE.UNKNOWN
71131>>>>>  end_function
71132>>>>>
71132>>>>>  function iSymbolType.si string name# integer class# returns integer
71134>>>>>    integer liType id# liFileField
71134>>>>>    if class# eq CLASS.UNKNOWN get iSymbolClass.s name# to class#
71137>>>>>    if class# eq CLASS.LABEL function_return TYPE.UNTYPED
71140>>>>>    if class# eq CLASS.VAR begin
71142>>>>>      get iVarType.s of (pVM_Object(self)) name# to liType
71143>>>>>      if liType eq VARTYP_INTEGER function_return TYPE.INTEGER
71146>>>>>      if liType eq VARTYP_NUMBER  function_return TYPE.NUMBER
71149>>>>>      if liType eq VARTYP_DATE    function_return TYPE.DATE
71152>>>>>      if liType eq VARTYP_STRING  function_return TYPE.STRING
71155>>>>>    end
71155>>>>>>
71155>>>>>    if class# eq CLASS.CONST   function_return (iConstType.s(self,name#))
71158>>>>>    if class# eq CLASS.EXPR    function_return TYPE.UNKNOWN
71161>>>>>    if class# eq CLASS.KEYWORD function_return TYPE.UNTYPED
71164>>>>>    if class# eq CLASS.COMMAND function_return TYPE.UNTYPED
71167>>>>>    if class# eq CLASS.REPLACE_SYMBOL begin
71169>>>>>    end
71169>>>>>>
71169>>>>>    if class# eq CLASS.FUNCTION begin
71171>>>>>      get iFuncNameToFuncNo.s of (pVM_Object(self)) name# to id#
71172>>>>>      get iFuncType.i of (pVM_Object(self)) id# to liType
71173>>>>>      if liType eq VARTYP_INTEGER function_return TYPE.INTEGER
71176>>>>>      if liType eq VARTYP_NUMBER  function_return TYPE.NUMBER
71179>>>>>      if liType eq VARTYP_DATE    function_return TYPE.DATE
71182>>>>>      if liType eq VARTYP_STRING  function_return TYPE.STRING
71185>>>>>    end
71185>>>>>>
71185>>>>>    if class# eq CLASS.FIELD begin
71187>>>>>      get iFileField.s of (pVM_Object(self)) name# to liFileField
71188>>>>>      get iFieldType.i of (pVM_Object(self)) liFileField to liType
71189>>>>>      if liType eq FLDTYP_STRING function_return TYPE.STRING
71192>>>>>      if liType eq FLDTYP_NUMBER function_return TYPE.NUMBER
71195>>>>>      if liType eq FLDTYP_DATE   function_return TYPE.DATE
71198>>>>>    end
71198>>>>>>
71198>>>>>    function_return TYPE.UNKNOWN
71199>>>>>  end_function
71200>>>>>
71200>>>>>  function iVM_ArgType.ii integer class# integer liType returns integer
71202>>>>>    if class#      eq CLASS.UNKNOWN function_return AT_NOT_VALID
71205>>>>>    else if class# eq CLASS.LABEL   function_return AT_LBL
71209>>>>>    else if class# eq CLASS.VAR     function_return AT_VAR
71213>>>>>    else if class# eq CLASS.CONST begin
71216>>>>>      if liType      eq TYPE.UNKNOWN function_return AT_NOT_VALID
71219>>>>>      else if liType eq TYPE.UNTYPED function_return AT_NOT_VALID
71223>>>>>      else if liType eq TYPE.INTEGER function_return AT_CINT
71227>>>>>      else if liType eq TYPE.STRING  function_return AT_CSTR
71231>>>>>      else if liType eq TYPE.NUMBER  function_return AT_CNUM
71235>>>>>      else if liType eq TYPE.DATE    function_return AT_CDAT
71239>>>>>    end
71239>>>>>>
71239>>>>>    else if class# eq CLASS.EXPR    function_return AT_EXPR
71243>>>>>    else if class# eq CLASS.KEYWORD function_return AT_NOT_VALID
71247>>>>>    else if class# eq CLASS.COMMAND function_return AT_NOT_VALID
71251>>>>>    else if class# eq CLASS.REPLACE_SYMBOL function_return AT_NOT_VALID
71255>>>>>    else if class# eq CLASS.FIELD   function_return AT_FIELD
71259>>>>>    function_return AT_NOT_VALID
71260>>>>>  end_function
71261>>>>>
71261>>>>>  function iVM_ArgType.i integer arg# returns integer
71263>>>>>    function_return (iVM_ArgType.ii(self,piClass.i(self,arg#),piType.i(self,arg#)))
71264>>>>>  end_function
71265>>>>>
71265>>>>>  function sReplaceNameToNo.s string name# returns string
71267>>>>>    function_return (sNameToValue.s(oReplaces(self),name#))
71268>>>>>  end_function
71269>>>>>
71269>>>>>  function iIsLegalVarName.s string name# returns integer
71271>>>>>    integer pos# len#
71271>>>>>    ifnot (left(name#,1)) in CHARLIST.SYMBOL.START function_return 0
71274>>>>>    move (length(name#)) to len#
71275>>>>>    for pos# from 1 to len#
71281>>>>>>
71281>>>>>      ifnot (mid(name#,1,pos#)) in (CHARLIST.SYMBOL.START+CHARLIST.SYMBOL.CHAR) function_return 0
71284>>>>>    loop
71285>>>>>>
71285>>>>>    function_return 1
71286>>>>>  end_function
71287>>>>>
71287>>>>>  function iCheckNumberOfArguments.i integer should_be# returns integer
71289>>>>>    integer max#
71289>>>>>    get row_count to max#
71290>>>>>    decrement max#
71291>>>>>    if max# gt should_be# send ScriptError ERR.SCRIPT.TOO_MANY_ARGUMENTS 0
71294>>>>>    if max# lt should_be# send ScriptError ERR.SCRIPT.MISSING_ARGUMENT 0
71297>>>>>    if max# eq should_be# function_return 1
71300>>>>>  end_function
71301>>>>>
71301>>>>>  procedure declare_variable integer liType
71303>>>>>    integer liRow max#
71303>>>>>    string name#
71303>>>>>    get row_count to max#
71304>>>>>    for liRow from 1 to (max#-1)
71310>>>>>>
71310>>>>>      get psItem.i liRow to name#
71311>>>>>      move (uppercase(name#)) to name#
71312>>>>>      if (iIsLegalVarName.s(self,name#)) begin
71314>>>>>        ifnot (iSymbolClass.s(self,name#)) ;          send declare_var to (pVM_Object(self)) name# liType
71317>>>>>        else send ScriptError ERR.SCRIPT.SYMBOL_ALREADY_DEF (piPos.i(self,liRow)) ("Delaring variable: "+name#)
71319>>>>>      end
71319>>>>>>
71319>>>>>      else send ScriptError ERR.SCRIPT.ILLEGAL_VARNAME (piPos.i(self,liRow)) ("Delaring variable: "+name#)
71321>>>>>    loop
71322>>>>>>
71322>>>>>  end_procedure
71323>>>>>
71323>>>>>  procedure replace_symbol string name# string value#
71325>>>>>    move (uppercase(name#)) to name#
71326>>>>>    if (iIsLegalVarName.s(self,name#)) begin
71328>>>>>      ifnot (iSymbolClass.s(self,name#)) begin
71330>>>>>        if (iNameDeclare.ss(oReplaces(self),name#,value#)) ;          send ScriptError ERR.SCRIPT.CIRCULAR_REFERENCE 0 ("Defining replace: "+name#+" -> "+value#)
71333>>>>>      end
71333>>>>>>
71333>>>>>      else send ScriptError ERR.SCRIPT.SYMBOL_ALREADY_DEF 0 ("Defining replace: "+name#+" -> "+value#)
71335>>>>>    end
71335>>>>>>
71335>>>>>    else send ScriptError ERR.SCRIPT.ILLEGAL_SYMBNAME 0 ("Defining replace: "+name#+" -> "+value#)
71337>>>>>  end_procedure
71338>>>>>
71338>>>>>  // Symbol checking (positive logic):
71338>>>>>  //
71338>>>>>  //    I Integer                   TYPE.INTEGER
71338>>>>>  //    D Date                      TYPE.DATE
71338>>>>>  //    N Number                    TYPE.NUMBER
71338>>>>>  //    S String                    TYPE.STRING
71338>>>>>  //    t Any type                  TYPE.INTEGER TYPE.DATE TYPE.NUMBER TYPE.STRING
71338>>>>>
71338>>>>>  //    C Constant                  CLASS.CONST
71338>>>>>  //    V Variable                  CLASS.VAR
71338>>>>>  //    E Expression                CLASS.EXPR
71338>>>>>  //    F File element              CLASS.FIELD
71338>>>>>  //    c Any of the above classes  CLASS.CONST CLASS.VAR CLASS.EXPR CLASS.FIELD
71338>>>>>
71338>>>>>  //    L Label                     CLASS.LABEL
71338>>>>>
71338>>>>>  //    R Required                  -
71338>>>>>  //    U Untyped                   -
71338>>>>>  //    . No more arguments         -
71338>>>>>
71338>>>>>  function iCheckItemPattern.isi integer quiet# string pattern# integer arg# returns integer
71340>>>>>    integer max# itm# rval# len# pos# liType class#
71340>>>>>    string key_word# char#
71340>>>>>    get piClass.i arg# to class#
71341>>>>>    get piType.i arg# to liType
71342>>>>>    if pattern# eq "L" begin
71344>>>>>      if (class#=CLASS.LABEL or class#=CLASS.UNKNOWN) function_return 1
71347>>>>>      ifnot quiet# send ScriptError ERR.SCRIPT.CLASS_CHECK_ERROR (piPos.i(self,arg#)) ("Symbol: "+psItem.i(self,arg#))
71350>>>>>      function_return 0
71351>>>>>    end
71351>>>>>>
71351>>>>>    if '"' in pattern# begin // Keyword indication(s)
71353>>>>>      move 0 to rval#
71354>>>>>      move (HowManyWords(pattern#,'"')) to max#
71355>>>>>      for itm# from 1 to max#
71361>>>>>>
71361>>>>>        if (uppercase(psItem.i(self,arg#))) eq (uppercase(ExtractWord(pattern#,'"',itm#))) move 1 to rval#
71364>>>>>      loop
71365>>>>>>
71365>>>>>      ifnot rval# ifnot quiet# send ScriptError ERR.SCRIPT.KEYWORD_EXPECTED (piPos.i(self,arg#))
71370>>>>>    end
71370>>>>>>
71370>>>>>    else begin
71371>>>>>      move (length(pattern#)) to len#
71372>>>>>      move 1 to rval#
71373>>>>>      for pos# from 1 to len#
71379>>>>>>
71379>>>>>        move (mid(pattern#,1,pos#)) to char#
71380>>>>>        if (char#=".") begin
71382>>>>>          if (row_count(self)>arg#) begin
71384>>>>>            ifnot quiet# send ScriptError ERR.SCRIPT.TOO_MANY_ARGUMENTS (piPos.i(self,arg#))
71387>>>>>            function_return 0
71388>>>>>          end
71388>>>>>>
71388>>>>>          else function_return 1 // There are no more arguments!
71390>>>>>        end
71390>>>>>>
71390>>>>>        if (char#="R" and row_count(self)>>>>          ifnot quiet# send ScriptError ERR.SCRIPT.MISSING_ARGUMENT 0
71395>>>>>          function_return 0
71396>>>>>        end
71396>>>>>>
71396>>>>>        if (char#="U" and not(piType.i(self,arg#)=TYPE.UNKNOWN or piType.i(self,arg#)=TYPE.UNTYPED)) begin
71398>>>>>          ifnot quiet# send ScriptError ERR.SCRIPT.ARGUMENT_TYPED (piPos.i(self,arg#))
71401>>>>>          function_return 0
71402>>>>>        end
71402>>>>>>
71402>>>>>      loop
71403>>>>>>
71403>>>>>      if rval# begin // If we pass the above testing
71405>>>>>        move 0 to rval#
71406>>>>>        if class# eq CLASS.CONST   if "C" in pattern# move 1 to rval#
71411>>>>>        if class# eq CLASS.CONST   if "c" in pattern# move 1 to rval#
71416>>>>>        if class# eq CLASS.VAR     if "V" in pattern# move 1 to rval#
71421>>>>>        if class# eq CLASS.VAR     if "c" in pattern# move 1 to rval#
71426>>>>>        if class# eq CLASS.EXPR    if "E" in pattern# move 1 to rval#
71431>>>>>        if class# eq CLASS.EXPR    if "c" in pattern# move 1 to rval#
71436>>>>>        if class# eq CLASS.FIELD   if "F" in pattern# move 1 to rval#
71441>>>>>        if class# eq CLASS.FIELD   if "c" in pattern# move 1 to rval#
71446>>>>>        if class# eq CLASS.LABEL   if "L" in pattern# move 1 to rval#
71451>>>>>        if class# eq CLASS.UNKNOWN if "U" in pattern# move 1 to rval#
71456>>>>>        if rval# begin
71458>>>>>          move 0 to rval#
71459>>>>>          if liType eq TYPE.INTEGER if "I" in pattern# move 1 to rval#
71464>>>>>          if liType eq TYPE.INTEGER if "t" in pattern# move 1 to rval#
71469>>>>>          if liType eq TYPE.DATE    if "D" in pattern# move 1 to rval#
71474>>>>>          if liType eq TYPE.DATE    if "t" in pattern# move 1 to rval#
71479>>>>>          if liType eq TYPE.NUMBER  if "N" in pattern# move 1 to rval#
71484>>>>>          if liType eq TYPE.NUMBER  if "t" in pattern# move 1 to rval#
71489>>>>>          if liType eq TYPE.STRING  if "S" in pattern# move 1 to rval#
71494>>>>>          if liType eq TYPE.STRING  if "t" in pattern# move 1 to rval#
71499>>>>>          if liType eq TYPE.UNKNOWN if "U" in pattern# move 1 to rval#
71504>>>>>          if liType eq TYPE.UNTYPED if "U" in pattern# move 1 to rval#
71509>>>>>          ifnot rval# ifnot quiet# send ScriptError ERR.SCRIPT.TYPE_CHECK_ERROR (piPos.i(self,arg#))
71514>>>>>        end
71514>>>>>>
71514>>>>>        else ifnot quiet# send ScriptError ERR.SCRIPT.CLASS_CHECK_ERROR (piPos.i(self,arg#)) ("Symbol: "+psItem.i(self,arg#))
71518>>>>>      end
71518>>>>>>
71518>>>>>    end
71518>>>>>>
71518>>>>>    function_return rval#
71519>>>>>  end_function
71520>>>>>
71520>>>>>  function iCheckPattern.is integer quiet# string pattern# returns integer
71522>>>>>    integer itm# max# rval#
71522>>>>>    move (HowManyWords(pattern#," ")) to max#
71523>>>>>    move 1 to rval#
71524>>>>>    for itm# from 1 to max#
71530>>>>>>
71530>>>>>      if rval# get iCheckItemPattern.isi quiet# (ExtractWord(pattern#," ",itm#)) itm# to rval#
71533>>>>>    loop
71534>>>>>>
71534>>>>>    function_return rval#
71535>>>>>  end_function
71536>>>>>
71536>>>>>  function iStructureCheck.i integer cmd# returns integer
71538>>>>>    integer obj# shouldbe# rval# pos#
71538>>>>>    move (piPos.i(self,0)) to pos#
71539>>>>>    move 1 to rval#
71540>>>>>    move (oStructuralStack(self)) to obj#
71541>>>>>    if (item_count(obj#)) begin
71543>>>>>      get iTopPendingCmd of obj# to shouldbe#
71544>>>>>      send pop_struct to obj#
71545>>>>>      if shouldbe# ne cmd# begin
71547>>>>>        if shouldbe# eq CMD_END send ScriptError ERR.SCRIPT.SHOULD_BE_END pos#
71550>>>>>        if shouldbe# eq CMD_ENDIF send ScriptError ERR.SCRIPT.SHOULD_BE_ENDIF pos#
71553>>>>>        if shouldbe# eq CMD_LOOP send ScriptError ERR.SCRIPT.SHOULD_BE_LOOP pos#
71556>>>>>        if shouldbe# eq CMD_UNTIL send ScriptError ERR.SCRIPT.SHOULD_BE_UNTIL pos#
71559>>>>>        move 0 to rval#
71560>>>>>      end
71560>>>>>>
71560>>>>>    end
71560>>>>>>
71560>>>>>    else begin
71561>>>>>      if cmd# eq CMD_END send ScriptError ERR.SCRIPT.UNINITIATED_END pos#
71564>>>>>      if cmd# eq CMD_ENDIF send ScriptError ERR.SCRIPT.UNINITIATED_ENDIF pos#
71567>>>>>      if cmd# eq CMD_LOOP send ScriptError ERR.SCRIPT.UNINITIATED_LOOP pos#
71570>>>>>      if cmd# eq CMD_UNTIL send ScriptError ERR.SCRIPT.UNINITIATED_UNTIL pos#
71573>>>>>      move 0 to rval#
71574>>>>>    end
71574>>>>>>
71574>>>>>    function_return rval#
71575>>>>>  end_function
71576>>>>>  // ==================== INTERPRETATION METHODS ====================
71576>>>>>  procedure Interpret_Date
71578>>>>>    send declare_variable VARTYP_DATE
71579>>>>>  end_procedure
71580>>>>>  procedure Interpret_If
71582>>>>>    integer comp#
71582>>>>>    send push_struct to (oStructuralStack(self)) CMD_IF CMD_ENDIF (psFileName(self)) (piLine(self))
71583>>>>>    if (iCheckPattern.is(self,1,'ct .')) begin
71585>>>>>      if (iCheckPattern.is(self,0,'cI .')) ;        send add_instruction to (pVM_Object(self)) OP_IF_BEGIN (iVM_ArgType.i(self,1)) (psItem.i(self,1)) AT_CINT COMP_NE AT_CINT 0
71588>>>>>    end
71588>>>>>>
71588>>>>>    else begin
71589>>>>>      if (iCheckPattern.is(self,0,'ct "LT""LE""EQ""NE""GE""GT" ct .')) begin
71591>>>>>        move (iCompStringToInt.s(psItem.i(self,2))) to comp#
71592>>>>>        send add_instruction to (pVM_Object(self)) OP_IF_BEGIN (iVM_ArgType.i(self,1)) (psItem.i(self,1)) AT_CINT comp# (iVM_ArgType.i(self,3)) (psItem.i(self,3))
71593>>>>>      end
71593>>>>>>
71593>>>>>    end
71593>>>>>>
71593>>>>>  end_procedure
71594>>>>>  procedure Interpret_Else
71596>>>>>    integer cmd#
71596>>>>>    if (iCheckPattern.is(self,0,'.')) begin
71598>>>>>      get iTopStackingCmd of (oStructuralStack(self)) to cmd#
71599>>>>>      if cmd# eq CMD_IF send add_instruction to (pVM_Object(self)) OP_ELSE
71602>>>>>      else send ScriptError ERR.SCRIPT.UNINITIATED_ELSE (piPos.i(self,0))
71604>>>>>    end
71604>>>>>>
71604>>>>>  end_procedure
71605>>>>>  procedure Interpret_EndIf
71607>>>>>    if (iStructureCheck.i(self,CMD_ENDIF) and iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_ENDIF
71610>>>>>  end_procedure
71611>>>>>  procedure Interpret_End
71613>>>>>    integer cmd#
71613>>>>>    get iTopStackingCmd of (oStructuralStack(self)) to cmd#
71614>>>>>    if (iStructureCheck.i(self,CMD_END) and iCheckPattern.is(self,0,'.')) begin
71616>>>>>      if cmd# eq CMD_WHILE send add_instruction to (pVM_Object(self)) OP_LOOP
71619>>>>>      else send add_instruction to (pVM_Object(self)) OP_ENDIF
71621>>>>>    end
71621>>>>>>
71621>>>>>  end_procedure
71622>>>>>  procedure Interpret_For // For iVar FROM cI TO
71624>>>>>    send push_struct to (oStructuralStack(self)) CMD_FOR CMD_LOOP (psFileName(self)) (piLine(self))
71625>>>>>    if (iCheckPattern.is(self,0,'IV "FROM" Ic "TO" Ic .')) begin
71627>>>>>      send add_instruction to (pVM_Object(self)) OP_FOR AT_VAR (psItem.i(self,1)) (iVM_ArgType.i(self,3)) (psItem.i(self,3)) (iVM_ArgType.i(self,5)) (psItem.i(self,5))
71628>>>>>    end
71628>>>>>>
71628>>>>>  end_procedure
71629>>>>>  procedure Interpret_While
71631>>>>>    integer comp#
71631>>>>>    send push_struct to (oStructuralStack(self)) CMD_WHILE CMD_END (psFileName(self)) (piLine(self))
71632>>>>>    if (iCheckPattern.is(self,1,'ct .')) begin
71634>>>>>      if (iCheckPattern.is(self,0,'cI .')) ;        send add_instruction to (pVM_Object(self)) OP_WHILE (iVM_ArgType.i(self,1)) (psItem.i(self,1)) AT_CINT COMP_NE AT_CINT 0
71637>>>>>    end
71637>>>>>>
71637>>>>>    else begin
71638>>>>>      if (iCheckPattern.is(self,0,'ct "LT""LE""NE""EQ""GE""GT" ct .')) begin
71640>>>>>        move (iCompStringToInt.s(psItem.i(self,2))) to comp#
71641>>>>>        send add_instruction to (pVM_Object(self)) OP_WHILE (iVM_ArgType.i(self,1)) (psItem.i(self,1)) AT_CINT comp# (iVM_ArgType.i(self,3)) (psItem.i(self,3))
71642>>>>>      end
71642>>>>>>
71642>>>>>    end
71642>>>>>>
71642>>>>>  end_procedure
71643>>>>>  procedure Interpret_Gosub
71645>>>>>    if (iCheckPattern.is(self,0,'L .')) send add_instruction to (pVM_Object(self)) OP_GOSUB AT_LBL (psItem.i(self,1))
71648>>>>>  end_procedure
71649>>>>>  procedure Interpret_Goto
71651>>>>>    if (iCheckPattern.is(self,0,'L .')) send add_instruction to (pVM_Object(self)) OP_GOTO AT_LBL (psItem.i(self,1))
71654>>>>>  end_procedure
71655>>>>>  procedure Interpret_Pause
71657>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_PAUSE
71660>>>>>  end_procedure
71661>>>>>  procedure Interpret_GotoXY
71663>>>>>    if (iCheckPattern.is(self,0,'Ic Ic .')) send add_instruction to (pVM_Object(self)) OP_GOTOXY (iVM_ArgType.i(self,1)) (psItem.i(self,1)) (iVM_ArgType.i(self,2)) (psItem.i(self,2))
71666>>>>>  end_procedure
71667>>>>>  procedure Interpret_Input
71669>>>>>    if (iCheckPattern.is(self,0,'tc tV .')) send add_instruction to (pVM_Object(self)) OP_INPUT AT_VAR (psItem.i(self,2)) (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71672>>>>>  end_procedure
71673>>>>>  procedure Interpret_Integer
71675>>>>>    send declare_variable VARTYP_INTEGER
71676>>>>>  end_procedure
71677>>>>>  procedure Interpret_Loop
71679>>>>>    if (iStructureCheck.i(self,CMD_LOOP) and iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_LOOP
71682>>>>>  end_procedure
71683>>>>>  procedure Interpret_Move
71685>>>>>    integer liClass
71685>>>>>    if (iCheckPattern.is(self,0,'Rtc "TO" RtVF .')) begin
71687>>>>>//      send obs OP_ASSIGN AT_VAR (psItem.i(self,3)) (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71687>>>>>      get piClass.i 3 to liClass // Class of target
71688>>>>>      if liClass eq CLASS.VAR ;        send add_instruction to (pVM_Object(self)) OP_ASSIGN AT_VAR (psItem.i(self,3)) (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71691>>>>>      if liClass eq CLASS.FIELD ;        send add_instruction to (pVM_Object(self)) OP_ASSIGN AT_FIELD (psItem.i(self,3)) (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71694>>>>>    end
71694>>>>>>
71694>>>>>  end_procedure
71695>>>>>  procedure Interpret_Number
71697>>>>>    send declare_variable VARTYP_NUMBER
71698>>>>>  end_procedure
71699>>>>>  procedure Interpret_Return
71701>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_RETURN
71704>>>>>  end_procedure
71705>>>>>  procedure Interpret_Showln
71707>>>>>    send Interpret_Show
71708>>>>>    send add_instruction to (pVM_Object(self)) OP_SHOWLN AT_CSTR ""
71709>>>>>  end_procedure
71710>>>>>  procedure Interpret_Show
71712>>>>>    integer arg# max#
71712>>>>>    get row_count to max#
71713>>>>>    for arg# from 1 to (max#-1)
71719>>>>>>
71719>>>>>      if (iCheckItemPattern.isi(self,0,'ct',arg#)) send add_instruction to (pVM_Object(self)) OP_SHOW (iVM_ArgType.i(self,arg#)) (psItem.i(self,arg#))
71722>>>>>    loop
71723>>>>>>
71723>>>>>  end_procedure
71724>>>>>  procedure Interpret_String
71726>>>>>    send declare_variable VARTYP_STRING
71727>>>>>  end_procedure
71728>>>>>  procedure Interpret_ClearScreen
71730>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_CLEARSCREEN
71733>>>>>  end_procedure
71734>>>>>  procedure Interpret_Abort
71736>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_ABORT
71739>>>>>  end_procedure
71740>>>>>  procedure Interpret_#use
71742>>>>>  end_procedure
71743>>>>>  procedure Interpret_#include
71745>>>>>  end_procedure
71746>>>>>  procedure Interpret_Increment
71748>>>>>    if (iCheckPattern.is(self,0,'VI .')) send add_instruction to (pVM_Object(self)) OP_GVAR_INCR AT_VAR (psItem.i(self,1)) AT_CINT 1
71751>>>>>  end_procedure
71752>>>>>  procedure Interpret_Decrement
71754>>>>>    if (iCheckPattern.is(self,0,'VI .')) send add_instruction to (pVM_Object(self)) OP_GVAR_INCR AT_VAR (psItem.i(self,1)) AT_CINT -1
71757>>>>>  end_procedure
71758>>>>>  procedure Interpret_#noisy
71760>>>>>    if (iCheckPattern.is(self,0,'CI .')) set piDebugState to (integer(psItem.i(self,1)))
71763>>>>>  end_procedure
71764>>>>>  procedure Interpret_#replace
71766>>>>>    if (iCheckNumberOfArguments.i(self,2)) send replace_symbol (psItem.i(self,1)) (psItem.i(self,2))
71769>>>>>  end_procedure
71770>>>>>  procedure Interpret_Debug
71772>>>>>    string mode#
71772>>>>>    if (iCheckPattern.is(self,0,'"ON""OFF""SINGLE_STEP""DISPLAY_VAR" .')) begin
71774>>>>>      move (uppercase(psItem.i(self,1))) to mode#
71775>>>>>      if mode#      eq "ON"          send add_instruction to (pVM_Object(self)) OP_DEBUG AT_CINT DBG.ON
71778>>>>>      else if mode# eq "OFF"         send add_instruction to (pVM_Object(self)) OP_DEBUG AT_CINT DBG.OFF
71782>>>>>      else if mode# eq "SINGLE_STEP" send add_instruction to (pVM_Object(self)) OP_DEBUG AT_CINT DBG.SINGLESTEP
71786>>>>>      else if mode# eq "DISPLAY_VAR" send add_instruction to (pVM_Object(self)) OP_DEBUG AT_CINT DBG.VARDISPLAY
71790>>>>>      else send ScriptError ERR.SCRIPT.KEYWORD_DEBUG (piPos.i(self,1))
71792>>>>>    end
71792>>>>>>
71792>>>>>  end_procedure
71793>>>>>  procedure Interpret_Repeat
71795>>>>>    send push_struct to (oStructuralStack(self)) CMD_REPEAT CMD_UNTIL (psFileName(self)) (piLine(self))
71796>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_REPEAT
71799>>>>>  end_procedure
71800>>>>>  procedure Interpret_Until
71802>>>>>    integer comp#
71802>>>>>    if (iCheckPattern.is(self,1,'ct .')) begin
71804>>>>>      if (iCheckPattern.is(self,0,'cI .')) begin
71806>>>>>        if (iStructureCheck.i(self,CMD_UNTIL)) ;          send add_instruction to (pVM_Object(self)) OP_UNTIL (iVM_ArgType.i(self,1)) (psItem.i(self,1)) AT_CINT COMP_NE AT_CINT 0
71809>>>>>      end
71809>>>>>>
71809>>>>>    end
71809>>>>>>
71809>>>>>    else begin
71810>>>>>      if (iStructureCheck.i(self,CMD_UNTIL) and iCheckPattern.is(self,0,'ct "LT""LE""EQ""NE""GE""GT" ct .')) begin
71812>>>>>        move (iCompStringToInt.s(psItem.i(self,2))) to comp#
71813>>>>>        send add_instruction to (pVM_Object(self)) OP_UNTIL (iVM_ArgType.i(self,1)) (psItem.i(self,1)) AT_CINT comp# (iVM_ArgType.i(self,3)) (psItem.i(self,3))
71814>>>>>      end
71814>>>>>>
71814>>>>>    end
71814>>>>>>
71814>>>>>  end_procedure
71815>>>>>  procedure Interpret_Log_Open
71817>>>>>    if (iCheckPattern.is(self,0,'Sc Ic .')) send add_instruction to (pVM_Object(self)) OP_LOG_OPEN (iVM_ArgType.i(self,1)) (psItem.i(self,1)) (iVM_ArgType.i(self,2)) (psItem.i(self,2))
71820>>>>>  end_procedure
71821>>>>>  procedure Interpret_Log_Close
71823>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_LOG_CLOSE
71826>>>>>  end_procedure
71827>>>>>  procedure Interpret_Log_Display
71829>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_LOG_DISPLAY
71832>>>>>  end_procedure
71833>>>>>  procedure Interpret_Log_Flush
71835>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_LOG_FLUSH
71838>>>>>  end_procedure
71839>>>>>  procedure Interpret_Log_Write
71841>>>>>    integer arg# max#
71841>>>>>    get row_count to max#
71842>>>>>    for arg# from 1 to (max#-1)
71848>>>>>>
71848>>>>>      if (iCheckItemPattern.isi(self,0,'ct',arg#)) send add_instruction to (pVM_Object(self)) OP_LOG_WRITE (iVM_ArgType.i(self,arg#)) (psItem.i(self,arg#))
71851>>>>>    loop
71852>>>>>>
71852>>>>>  end_procedure
71853>>>>>  procedure Interpret_Log_Writeln
71855>>>>>    send Interpret_Log_Write
71856>>>>>    send add_instruction to (pVM_Object(self)) OP_LOG_WRITELN AT_CSTR ""
71857>>>>>  end_procedure
71858>>>>>  procedure Interpret_Set_Attribute // liType
71860>>>>>    integer params# attr# liRow max# attrtype#
71860>>>>>    integer t1# t2# t3# t4# t5# t6#
71860>>>>>    string a1# a2# a3# a4# a5# a6#
71860>>>>>    if (iCheckPattern.is(self,1,'CI')) begin
71862>>>>>      // If we go in this branch an explicit attribute was specified
71862>>>>>      // and we are therefore able to check the number of parameters
71862>>>>>      move (psItem.i(self,1)) to attr#
71863>>>>>      ifnot (API_Attr_WriteAccess(attr#)) send ScriptError ERR.SCRIPT.ATTR_NO_SET (piPos.i(self,1)) (API_Attr_Name(attr#))
71866>>>>>      move (API_Attr_NumberOfParams(attr#)) to params#
71867>>>>>      if (API_AttrWorksOnStructure(attr#)) decrement params# // For these attributes the file handle is implicit
71870>>>>>      if (iCheckItemPattern.isi(self,0,'"TO"',params#+2)) begin
71872>>>>>        move (API_AttrType(attr#)) to attrtype#
71873>>>>>        if (attrtype#=ATTRTYPE_FILELIST or attrtype#=ATTRTYPE_FILE or attrtype#=ATTRTYPE_FIELD or attrtype#=ATTRTYPE_INDEX or attrtype#=ATTRTYPE_IDXSEG) begin
71875>>>>>          if attrtype# eq ATTRTYPE_FILELIST begin
71877>>>>>            move (iVM_ArgType.i(self,2)) to t2#
71878>>>>>            move (psItem.i(self,2)) to a2#
71879>>>>>            move (iVM_ArgType.i(self,4)) to t4#
71880>>>>>            move (psItem.i(self,4)) to a4#
71881>>>>>            send add_instruction to (pVM_Object(self)) OP_API_FILELIST AT_CINT attr# t2# a2# t4# a4#
71882>>>>>          end
71882>>>>>>
71882>>>>>          if attrtype# eq ATTRTYPE_FILE begin
71884>>>>>            move (iVM_ArgType.i(self,3)) to t3#
71885>>>>>            move (psItem.i(self,3)) to a3#
71886>>>>>            send add_instruction to (pVM_Object(self)) OP_API_FILE AT_CINT attr# t3# a3#
71887>>>>>          end
71887>>>>>>
71887>>>>>          if attrtype# eq ATTRTYPE_FIELD begin
71889>>>>>            move (iVM_ArgType.i(self,2)) to t2#
71890>>>>>            move (psItem.i(self,2)) to a2#
71891>>>>>            move (iVM_ArgType.i(self,4)) to t4#
71892>>>>>            move (psItem.i(self,4)) to a4#
71893>>>>>            send add_instruction to (pVM_Object(self)) OP_API_FIELD AT_CINT attr# t2# a2# t4# a4#
71894>>>>>          end
71894>>>>>>
71894>>>>>          if attrtype# eq ATTRTYPE_INDEX begin
71896>>>>>            move (iVM_ArgType.i(self,2)) to t2#
71897>>>>>            move (psItem.i(self,2)) to a2#
71898>>>>>            move (iVM_ArgType.i(self,4)) to t4#
71899>>>>>            move (psItem.i(self,4)) to a4#
71900>>>>>            send add_instruction to (pVM_Object(self)) OP_API_INDEX AT_CINT attr# t2# a2# t4# a4#
71901>>>>>          end
71901>>>>>>
71901>>>>>          if attrtype# eq ATTRTYPE_IDXSEG begin
71903>>>>>            move (iVM_ArgType.i(self,2)) to t2#
71904>>>>>            move (psItem.i(self,2)) to a2#
71905>>>>>            move (iVM_ArgType.i(self,3)) to t3#
71906>>>>>            move (psItem.i(self,3)) to a3#
71907>>>>>            move (iVM_ArgType.i(self,5)) to t5#
71908>>>>>            move (psItem.i(self,5)) to a5#
71909>>>>>            send add_instruction to (pVM_Object(self)) OP_API_IDXSEG AT_CINT attr# t2# a2# t3# a3# t5# a5#
71910>>>>>          end
71910>>>>>>
71910>>>>>        end
71910>>>>>>
71910>>>>>        else begin
71911>>>>>          // OK, it's got to be one of these which we do not support setting:
71911>>>>>          //  ATTRTYPE_GLOBAL     ATTRTYPE_DRIVER   ATTRTYPE_DRVSRV
71911>>>>>          //  ATTRTYPE_SPECIAL1   ATTRTYPE_FLSTNAV
71911>>>>>          send ScriptError ERR.SCRIPT.ATTR_NO_CHANGING (piPos.i(self,1))
71912>>>>>        end
71912>>>>>>
71912>>>>>      end
71912>>>>>>
71912>>>>>    end
71912>>>>>>
71912>>>>>    else begin
71913>>>>>      // If we go in this branch an attribute in the form of a variable was
71913>>>>>      // handed, and we just fill up with parameters. We can't type check it
71913>>>>>      // until we execute it and know which attribute is actually set.
71913>>>>>      send ScriptError ERR.SCRIPT.ATTR_IMPLICIT (piPos.i(self,1))
71914>>>>>    end
71914>>>>>>
71914>>>>>  end_procedure
71915>>>>>  procedure Interpret_Create_Field  // field# name# liType
71917>>>>>    integer t1# t2# t3#
71917>>>>>    string a1# a2# a3#
71917>>>>>    if (iCheckPattern.is(self,0,'cI cS cI .')) begin
71919>>>>>      move (iVM_ArgType.i(self,1)) to t1#
71920>>>>>      move (iVM_ArgType.i(self,2)) to t2#
71921>>>>>      move (iVM_ArgType.i(self,3)) to t3#
71922>>>>>      move (psItem.i(self,1)) to a1#
71923>>>>>      move (psItem.i(self,2)) to a2#
71924>>>>>      move (psItem.i(self,3)) to a3#
71925>>>>>      send add_instruction to (pVM_Object(self)) OP_API_CREATEFIELD t1# a1# t2# a2# t3# a3#
71926>>>>>    end
71926>>>>>>
71926>>>>>  end_procedure
71927>>>>>  procedure Interpret_Append_Field  // name liType
71929>>>>>    if (iCheckPattern.is(self,0,'cS cI .')) send add_instruction to (pVM_Object(self)) OP_API_APPENDFIELD (iVM_ArgType.i(self,1)) (psItem.i(self,1)) (iVM_ArgType.i(self,2)) (psItem.i(self,2))
71932>>>>>  end_procedure
71933>>>>>  procedure Interpret_Delete_Field  //
71935>>>>>    if (iCheckPattern.is(self,0,'cI .')) send add_instruction to (pVM_Object(self)) OP_API_DELETEFIELD (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71938>>>>>  end_procedure
71939>>>>>  procedure Interpret_Delete_Index  //
71941>>>>>    if (iCheckPattern.is(self,0,'cI .')) send add_instruction to (pVM_Object(self)) OP_API_DELETEINDEX (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71944>>>>>  end_procedure
71945>>>>>  procedure Interpret_Structure_Abort
71947>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_API_STRUCTURE_ABORT
71950>>>>>  end_procedure
71951>>>>>  procedure Interpret_Structure_End
71953>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_API_STRUCTURE_END
71956>>>>>  end_procedure
71957>>>>>  procedure Interpret_Probe_End
71959>>>>>    if (iCheckPattern.is(self,0,'.')) send add_instruction to (pVM_Object(self)) OP_API_PROBE_END
71962>>>>>  end_procedure
71963>>>>>  procedure Interpret_Set_Field     //
71965>>>>>    if (iCheckPattern.is(self,0,'cI .')) send add_instruction to (pVM_Object(self)) OP_API_SETFIELDNUMBER (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71968>>>>>  end_procedure
71969>>>>>  procedure Interpret_InfoBox
71971>>>>>    if (iCheckPattern.is(self,0,'ct .')) send add_instruction to (pVM_Object(self)) OP_MSGBOX (iVM_ArgType.i(self,1)) (psItem.i(self,1))
71974>>>>>  end_procedure
71975>>>>>
71975>>>>>  procedure add_item.si string str# integer pos#
71977>>>>>    integer liRow
71977>>>>>    get row_count to liRow
71978>>>>>    set psItem.i  liRow to str#
71979>>>>>    set piPos.i   liRow to pos#
71980>>>>>    set piClass.i liRow to CLASS.UNKNOWN
71981>>>>>    set piType.i  liRow to TYPE.UNKNOWN
71982>>>>>  end_procedure
71983>>>>>
71983>>>>>  enumeration_list
71983>>>>>    define ITEMTYPE.NOT_IN_ITEM
71983>>>>>    define ITEMTYPE.UNKNOWN
71983>>>>>    define ITEMTYPE.STRING_CONSTANT
71983>>>>>    define ITEMTYPE.EXPRESSION
71983>>>>>    define ITEMTYPE.EXPRESSION_STRING_PART
71983>>>>>  end_enumeration_list
71983>>>>>
71983>>>>>  procedure split_line_in_items string str#
71985>>>>>    integer pos# len# start_pos# item_type# error_code# error_pos# balance# comment#
71985>>>>>    string item# char# decr_balance_char# incr_balance_char#
71985>>>>>    string expr_string_const_stopper#
71985>>>>>    move (length(str#)) to len#
71986>>>>>    move 0 to start_pos#
71987>>>>>    move 0 to comment#
71988>>>>>    move "" to item#
71989>>>>>    move ERR.SCRIPT.NO_ERROR to error_code#
71990>>>>>    move 0 to error_pos#
71991>>>>>    move ITEMTYPE.NOT_IN_ITEM to item_type#
71992>>>>>    for pos# from 1 to len#
71998>>>>>>
71998>>>>>      if (error_code#=0 and comment#<>2) begin
72000>>>>>        move (mid(str#,1,pos#)) to char#
72001>>>>>        if start_pos# begin // We are currently in an item
72003>>>>>          if comment# begin
72005>>>>>            if char# eq "/" begin
72007>>>>>              move 0 to start_pos#
72008>>>>>              move 2 to comment#
72009>>>>>            end
72009>>>>>>
72009>>>>>            else move 0 to comment#
72011>>>>>          end
72011>>>>>>
72011>>>>>          if comment# ne 2 begin
72013>>>>>            if item_type# eq ITEMTYPE.EXPRESSION_STRING_PART begin
72015>>>>>              if char# eq expr_string_const_stopper# begin
72017>>>>>                move ITEMTYPE.EXPRESSION to item_type#
72018>>>>>              end
72018>>>>>>
72018>>>>>              move (item#+char#) to item#
72019>>>>>            end
72019>>>>>>
72019>>>>>            else if item_type# eq ITEMTYPE.EXPRESSION begin
72022>>>>>              if char# eq '"' begin
72024>>>>>                move ITEMTYPE.EXPRESSION_STRING_PART to item_type#
72025>>>>>                move char# to expr_string_const_stopper#
72026>>>>>              end
72026>>>>>>
72026>>>>>              if char# eq "'" begin
72028>>>>>                move ITEMTYPE.EXPRESSION_STRING_PART to item_type#
72029>>>>>                move char# to expr_string_const_stopper#
72030>>>>>              end
72030>>>>>>
72030>>>>>              if char# eq decr_balance_char# decrement balance#
72033>>>>>              if char# eq incr_balance_char# increment balance#
72036>>>>>              move (item#+char#) to item#
72037>>>>>              if balance# eq 0 begin
72039>>>>>                send add_item.si item# start_pos#
72040>>>>>                move 0 to start_pos#
72041>>>>>                move "" to item#
72042>>>>>                move ITEMTYPE.NOT_IN_ITEM to item_type#
72043>>>>>              end
72043>>>>>>
72043>>>>>            end
72043>>>>>>
72043>>>>>            else if item_type# eq ITEMTYPE.STRING_CONSTANT begin
72046>>>>>              move (item#+char#) to item#
72047>>>>>              if char# eq decr_balance_char# begin
72049>>>>>                send add_item.si item# start_pos#
72050>>>>>                move 0 to start_pos#
72051>>>>>                move "" to item#
72052>>>>>                move ITEMTYPE.NOT_IN_ITEM to item_type#
72053>>>>>              end
72053>>>>>>
72053>>>>>            end
72053>>>>>>
72053>>>>>            else if item_type# eq ITEMTYPE.UNKNOWN begin
72056>>>>>              if char# eq " " begin
72058>>>>>                send add_item.si item# start_pos#
72059>>>>>                move 0 to start_pos#
72060>>>>>                move "" to item#
72061>>>>>                move ITEMTYPE.NOT_IN_ITEM to item_type#
72062>>>>>              end
72062>>>>>>
72062>>>>>              else begin
72063>>>>>                move (item#+char#) to item#
72064>>>>>                if char# eq ":" begin
72066>>>>>                  send add_item.si item# start_pos#
72067>>>>>                  move 0 to start_pos#
72068>>>>>                  move "" to item#
72069>>>>>                  move ITEMTYPE.NOT_IN_ITEM to item_type#
72070>>>>>                end
72070>>>>>>
72070>>>>>              end
72070>>>>>>
72070>>>>>            end
72070>>>>>>
72070>>>>>          end
72070>>>>>>
72070>>>>>        end
72070>>>>>>
72070>>>>>        else begin // We are currently not in an item
72071>>>>>          if char# eq "/" ifnot comment# increment comment#
72076>>>>>          if char# ne " " begin
72078>>>>>            if char# in CHARLIST.ILLEGAL_ITEM_START begin
72080>>>>>              move ERR.SCRIPT.ERROR_ILLEGAL_CHAR to error_code#
72081>>>>>              move pos# to error_pos#
72082>>>>>            end
72082>>>>>>
72082>>>>>            else begin
72083>>>>>              if char# eq "(" begin
72085>>>>>                move "(" to incr_balance_char#
72086>>>>>                move ")" to decr_balance_char#
72087>>>>>                move 1 to balance#
72088>>>>>                move ITEMTYPE.EXPRESSION to item_type#
72089>>>>>              end
72089>>>>>>
72089>>>>>              else if char# eq "{" begin
72092>>>>>                move "{" to incr_balance_char#
72093>>>>>                move "}" to decr_balance_char#
72094>>>>>                move 1 to balance#
72095>>>>>                move ITEMTYPE.EXPRESSION to item_type#
72096>>>>>              end
72096>>>>>>
72096>>>>>              else if char# eq "[" begin
72099>>>>>                move "[" to incr_balance_char#
72100>>>>>                move "]" to decr_balance_char#
72101>>>>>                move 1 to balance#
72102>>>>>                move ITEMTYPE.EXPRESSION to item_type#
72103>>>>>              end
72103>>>>>>
72103>>>>>              else if char# eq "'" begin
72106>>>>>                move "'" to decr_balance_char#
72107>>>>>                move ITEMTYPE.STRING_CONSTANT to item_type#
72108>>>>>              end
72108>>>>>>
72108>>>>>              else if char# eq '"' begin
72111>>>>>                move '"' to decr_balance_char#
72112>>>>>                move ITEMTYPE.STRING_CONSTANT to item_type#
72113>>>>>              end
72113>>>>>>
72113>>>>>              else move ITEMTYPE.UNKNOWN to item_type#
72115>>>>>              move char# to item#
72116>>>>>              move pos# to start_pos#
72117>>>>>            end
72117>>>>>>
72117>>>>>          end
72117>>>>>>
72117>>>>>        end
72117>>>>>>
72117>>>>>      end
72117>>>>>>
72117>>>>>    loop
72118>>>>>>
72118>>>>>    if start_pos# send add_item.si item# start_pos#
72121>>>>>    if (error_code#=0 and item_type#=ITEMTYPE.STRING_CONSTANT) begin
72123>>>>>      move ERR.SCRIPT.MISSING_END_QUOTE to error_code#
72124>>>>>      move pos# to error_pos#
72125>>>>>    end
72125>>>>>>
72125>>>>>    if error_code# ne ERR.SCRIPT.NO_ERROR send ScriptError error_code# error_pos#
72128>>>>>  end_procedure
72129>>>>>
72129>>>>>  // Label declarations are supposed to be at the beginning of the line.
72129>>>>>  // The DoLabels procedure will declare any such labels in the VM and
72129>>>>>  // remove them from the list of items.
72129>>>>>  procedure DoLabels
72131>>>>>    integer liRow max# islabel#
72131>>>>>    string str#
72131>>>>>    get row_count to max#
72132>>>>>    move 0 to liRow
72133>>>>>    repeat
72133>>>>>>
72133>>>>>      get psItem.i liRow to str#
72134>>>>>      get iIsLabelDeclaration.s str# to islabel#
72135>>>>>      if islabel# begin
72137>>>>>        move (StringLeftBut(str#,1)) to str#
72138>>>>>        ifnot (iSymbolClass.s(self,str#)) send declare_label to (pVM_Object(self)) str#
72141>>>>>        else send ScriptError ERR.SCRIPT.SYMBOL_ALREADY_DEF (piPos.i(self,liRow))
72143>>>>>        increment liRow
72144>>>>>      end
72144>>>>>>
72144>>>>>    until (not(islabel#))
72146>>>>>    // Now, delete the labels from the list:
72146>>>>>    decrement liRow
72147>>>>>    while liRow ge 0
72151>>>>>      send delete_row liRow
72152>>>>>      decrement liRow
72153>>>>>    loop
72154>>>>>>
72154>>>>>  end_procedure
72155>>>>>
72155>>>>>  procedure DoCommand
72157>>>>>    integer cmd#
72157>>>>>    if (row_count(self)) begin
72159>>>>>      // Get Command ID of command in row 0:
72159>>>>>      get iCommand.s (psItem.i(self,0)) to cmd#
72160>>>>>      // Set the aux value of row 0 to the Command ID
72160>>>>>      if cmd# ge 0 set piAuxVal.i 0 to cmd#
72163>>>>>      else send ScriptError ERR.SCRIPT.COMMAND_NOT_FOUND (piPos.i(self,0)) ("Command: "+psItem.i(self,0))
72165>>>>>    end
72165>>>>>>
72165>>>>>  end_procedure
72166>>>>>
72166>>>>>  procedure DoReplaces // Perform symbol replaces
72168>>>>>    integer liRow max#
72168>>>>>    get row_count to max#
72169>>>>>    for liRow from 1 to (max#-1) // We do not replace the command column
72175>>>>>>
72175>>>>>      set psItem.i liRow to (sReplaceNameToNo.s(self,psItem.i(self,liRow)))
72176>>>>>    loop
72177>>>>>>
72177>>>>>  end_procedure
72178>>>>>
72178>>>>>  procedure DoClassColumn // Identify the classes
72180>>>>>    integer liRow max# liClass
72180>>>>>    string lsItem
72180>>>>>    get row_count to max#
72181>>>>>    for liRow from 0 to (max#-1)
72187>>>>>>
72187>>>>>      get psItem.i liRow to lsItem
72188>>>>>      get iSymbolClass.s lsItem to liClass
72189>>>>>      set piClass.i liRow to liClass
72190>>>>>    loop
72191>>>>>>
72191>>>>>  end_procedure
72192>>>>>
72192>>>>>  procedure DoTypeColumn // Identify the types
72194>>>>>    integer liRow max#
72194>>>>>    get row_count to max#
72195>>>>>    for liRow from 0 to (max#-1)
72201>>>>>>
72201>>>>>      set piType.i liRow to (iSymbolType.si(self,psItem.i(self,liRow),piClass.i(self,liRow)))
72202>>>>>    loop
72203>>>>>>
72203>>>>>  end_procedure
72204>>>>>
72204>>>>>  procedure DoExpressions
72206>>>>>    integer liRow max# exprid#
72206>>>>>    get row_count to max#
72207>>>>>    for liRow from 1 to (max#-1)
72213>>>>>>
72213>>>>>      if (piErrorCode(self)=ERR.SCRIPT.NO_ERROR) begin
72215>>>>>        if (piClass.i(self,liRow)=CLASS.EXPR and piType.i(self,liRow)=TYPE.UNKNOWN) begin
72217>>>>>          set psExprBeingParsed to (psItem.i(self,liRow))
72218>>>>>          get iParse_expression.si of (oExpressionParser(self)) (psItem.i(self,liRow)) (piPos.i(self,liRow)) to exprid#
72219>>>>>          set piType.i liRow to (piExprType(oExpressionParser(self)))
72220>>>>>          set psItem.i liRow to exprid#
72221>>>>>          if (piDebugState(self)) send DisplayExpressionDebugInfo (oExpressionParser(self))
72224>>>>>        end
72224>>>>>>
72224>>>>>      end
72224>>>>>>
72224>>>>>    end
72225>>>>>>
72225>>>>>  end_procedure
72226>>>>>
72226>>>>>  procedure DoPrepareArguments
72228>>>>>    integer liRow max#
72228>>>>>    get row_count to max#
72229>>>>>    for liRow from 1 to (max#-1)
72235>>>>>>
72235>>>>>      // Remove quotation characters from string constants:
72235>>>>>      if (piClass.i(self,liRow)=CLASS.CONST and piType.i(self,liRow)=TYPE.STRING) set psItem.i liRow to (StringRightBut(StringLeftBut(psItem.i(self,liRow),1),1))
72238>>>>>    loop
72239>>>>>>
72239>>>>>  end_procedure
72240>>>>>
72240>>>>>  procedure parse_line string str# integer line# string fn#
72242>>>>>    integer msg#
72242>>>>>    set piErrorCode to 0
72243>>>>>    set piErrorPos  to 0
72244>>>>>    set piLine      to line#
72245>>>>>    set psFileName  to fn#
72246>>>>>    set psLineBeingParsed to str#
72247>>>>>    send ListingFileWriteLn (string(piProgramCounter(pVM_Object(self)))+"> "+str#)
72248>>>>>    send delete_data
72249>>>>>    send split_line_in_items str#
72250>>>>>    ifnot (piErrorCode(self)) begin
72252>>>>>      send DoLabels  //
72253>>>>>      send DoCommand
72254>>>>>      ifnot (piErrorCode(self)) begin
72256>>>>>        ifnot (piErrorCode(self)) send DoReplaces
72259>>>>>        ifnot (piErrorCode(self)) send DoClassColumn
72262>>>>>        ifnot (piErrorCode(self)) send DoTypeColumn
72265>>>>>        ifnot (piErrorCode(self)) send DoExpressions
72268>>>>>        ifnot (piErrorCode(self)) send DoPrepareArguments
72271>>>>>        get piCompileMsg.i of (oCommandList(self)) (piAuxVal.i(self,0)) to msg#
72272>>>>>        ifnot (piErrorCode(self)) send msg#
72275>>>>>      end
72275>>>>>>
72275>>>>>    end
72275>>>>>>
72275>>>>>    if (piErrorCode(self)) ne ERR.SCRIPT.NO_ERROR set piInvalidProgram of (pVM_Object(self)) to true
72278>>>>>    if (piDebugState(self) and item_count(self)) send DisplayInterpreterDebugInfo self
72281>>>>>  end_procedure
72282>>>>>  function iParse_Line.sis string str# integer line# string fn# returns integer
72284>>>>>    send parse_line str# line# fn#
72285>>>>>    if (piErrorCode(self)) function_return (piLine(self)*65536+piErrorPos(self))
72288>>>>>    //function_return 0
72288>>>>>  end_function
72289>>>>>  // After having called this function you may query the piExprType
72289>>>>>  // and piExprID properties
72289>>>>>  function iParse_Expr.s string lsExpression returns integer
72291>>>>>    integer lhExpr
72291>>>>>    set piErrorCode to 0
72292>>>>>    set piErrorPos  to 0
72293>>>>>    set piLine      to 0
72294>>>>>    set psFileName  to "Expression"
72295>>>>>//    send obs lsExpression
72295>>>>>    get iParse_expression.si of (oExpressionParser(self)) lsExpression 1 to lhExpr
72296>>>>>    set piExprType to (piExprType(oExpressionParser(self)))
72297>>>>>    set piExprID   to lhExpr
72298>>>>>    if (piDebugState(self)) send DisplayExpressionDebugInfo (oExpressionParser(self))
72301>>>>>    if (piErrorCode(self)) function_return (piLine(self)*65536+piErrorPos(self))
72304>>>>>    //function_return 0
72304>>>>>  end_function
72305>>>>>  procedure ListingFileWriteLn string str#
72307>>>>>    if (piListingFileState(self)) writeln channel (piListingFileCh(self)) str#
72312>>>>>  end_procedure
72313>>>>>  procedure script_begin
72315>>>>>    if (piListingFileState(self)) begin
72317>>>>>      set piListingFileCh to (SEQ_DirectOutput(psListingFile(self)))
72318>>>>>      send ListingFileWriteLn "Script interpreter listing file"
72319>>>>>      send ListingFileWriteLn (string(dSysdate())+", "+sSysTime())
72320>>>>>    end
72320>>>>>>
72320>>>>>    send reset
72321>>>>>    send script_begin to (pVM_Object(self))
72322>>>>>  end_procedure
72323>>>>>  procedure script_end
72325>>>>>    if (item_count(oStructuralStack(self))) send ScriptError ERR.SCRIPT.UNFINISHED_STRUCT 0
72328>>>>>    send script_end to (pVM_Object(self))
72329>>>>>    if (piListingFileState(self)) send SEQ_CloseOutput (piListingFileCh(self))
72332>>>>>  end_procedure
72333>>>>>  procedure run_script
72335>>>>>    send run_script to (pVM_Object(self))
72336>>>>>  end_procedure
72337>>>>>end_class // cScriptInterpreter
72338>>>>>
72338>>>>>object oDFScriptParserTest is a aps.ModalPanel label "Line being parsed"
72341>>>>>  set locate_mode to CENTER_ON_SCREEN
72342>>>>>  object oFrm is a aps.Form abstract AFT_ASCII80
72345>>>>>    set object_shadow_state to true
72346>>>>>  end_object
72347>>>>>  send aps_goto_max_row
72348>>>>>  object oLst is a aps.Grid
72350>>>>>    set highlight_row_state to true
72351>>>>>    set highlight_row_color to (rgb(0,255,255))
72352>>>>>    set current_item_color to (rgb(0,255,255))
72353>>>>>    set select_mode to no_select
72354>>>>>    set size to 196 0
72355>>>>>    set line_width to 5 0
72356>>>>>    set form_margin item 0 to 35
72357>>>>>    set form_margin item 1 to 4
72358>>>>>    set form_margin item 2 to 13
72359>>>>>    set form_margin item 3 to 13
72360>>>>>    set form_margin item 4 to 6
72361>>>>>    set header_label item 0 to "Item"
72362>>>>>    set header_label item 1 to "Pos"
72363>>>>>    set header_label item 2 to "Class"
72364>>>>>    set header_label item 3 to "Type"
72365>>>>>    set header_label item 4 to "Aux"
72366>>>>>    on_key knext_item send switch
72367>>>>>    on_key kprevious_item send switch_back
72368>>>>>    procedure fill_list.i integer obj#
72371>>>>>      integer max# liRow pos# class# liType aux#
72371>>>>>      string str#
72371>>>>>      send delete_data
72372>>>>>      get row_count of obj# to max#
72373>>>>>      for liRow from 0 to (max#-1)
72379>>>>>>
72379>>>>>        get psItem.i   of obj# liRow to str#
72380>>>>>        get piPos.i    of obj# liRow to pos#
72381>>>>>        get piClass.i  of obj# liRow to class#
72382>>>>>        get piType.i   of obj# liRow to liType
72383>>>>>        get piAuxVal.i of obj# liRow to aux#
72384>>>>>        send add_item msg_none str#
72385>>>>>        send add_item msg_none (string(pos#))
72386>>>>>        send add_item msg_none (dfscript_item_class(class#))
72387>>>>>        send add_item msg_none (dfscript_item_type(liType))
72388>>>>>        send add_item msg_none (string(aux#))
72389>>>>>      loop
72390>>>>>>
72390>>>>>      get item_count to max#
72391>>>>>      for liRow from 0 to (max#-1)
72397>>>>>>
72397>>>>>        set entry_state item liRow to false
72398>>>>>      loop
72399>>>>>>
72399>>>>>    end_procedure
72400>>>>>  end_object
72401>>>>>  object oBtn is a aps.Multi_Button
72403>>>>>    on_item t.btn.close send close_panel
72404>>>>>  end_object
72405>>>>>  send aps_locate_multi_buttons
72406>>>>>  procedure run.i integer obj#
72409>>>>>    set value of (oFrm(self)) item 0 to (psLineBeingParsed(obj#))
72410>>>>>    send fill_list.i to (oLst(self)) obj#
72411>>>>>    send popup
72412>>>>>  end_procedure
72413>>>>>end_object
72414>>>>>
72414>>>>>procedure DisplayInterpreterDebugInfo global integer obj#
72416>>>>>  send run.i to (oDFScriptParserTest(self)) obj#
72417>>>>>end_procedure
72418>>>>>
72418>>>>>object oDFScriptExprTest is a aps.ModalPanel label "Expression parsed"
72421>>>>>  set locate_mode to CENTER_ON_SCREEN
72422>>>>>  object oFrm is a aps.Form abstract AFT_ASCII80
72425>>>>>    set object_shadow_state to true
72426>>>>>  end_object
72427>>>>>  send aps_goto_max_row
72428>>>>>  object oLst is a aps.Grid
72430>>>>>    set line_width to 8 0
72431>>>>>    set highlight_row_state to true
72432>>>>>    set highlight_row_color to (rgb(0,255,255))
72433>>>>>    set current_item_color to (rgb(0,255,255))
72434>>>>>    set select_mode to no_select
72435>>>>>    set size to 196 0
72436>>>>>    set form_margin item 0 to 14
72437>>>>>    set form_margin item 1 to 4
72438>>>>>    set form_margin item 2 to 6
72439>>>>>    set form_margin item 3 to 3
72440>>>>>    set form_margin item 4 to 8
72441>>>>>    set form_margin item 5 to 7
72442>>>>>    set form_margin item 6 to 3
72443>>>>>    set form_margin item 7 to 3
72444>>>>>    set header_label item 0 to "Item"
72445>>>>>    set header_label item 1 to "Pos"
72446>>>>>    set header_label item 2 to "EIT"
72447>>>>>    set header_label item 3 to "Opr"
72448>>>>>    set header_label item 4 to "Class"
72449>>>>>    set header_label item 5 to "Type"
72450>>>>>    set header_label item 6 to "Lvl"
72451>>>>>    set header_label item 7 to "Par"
72452>>>>>    on_key kenter send close_panel
72453>>>>>    on_key knext_item send switch
72454>>>>>    on_key kprevious_item send switch_back
72455>>>>>    procedure fill_list.i integer obj#
72458>>>>>      string item#
72458>>>>>      integer pos# class# liType structtype# level# max# liRow params# op_type#
72458>>>>>      send delete_data
72459>>>>>      get row_count of obj# to max#
72460>>>>>      for liRow from 0 to (max#-1)
72466>>>>>>
72466>>>>>        get psItem.i       of obj# liRow to item#       // The item in clear text
72467>>>>>        get piStructType.i of obj# liRow to structtype# // What part of the expression is this?
72468>>>>>        get piPos.i        of obj# liRow to pos#        // What is the starting position?
72469>>>>>        get piClass.i      of obj# liRow to class#      // If item, what is item class?
72470>>>>>        get piType.i       of obj# liRow to liType       // If item, what is item type?
72471>>>>>        get piEvalLevel.i  of obj# liRow to level#      // When evaluating
72472>>>>>        get piFuncParams.i of obj# liRow to params#     // Number of params#
72473>>>>>        get piOperator.i   of obj# liRow to op_type#    // If operator, which one?
72474>>>>>
72474>>>>>        send add_item msg_none item#
72475>>>>>        send add_item msg_none (string(pos#))
72476>>>>>        send add_item msg_none (ExprItemType_Text(structtype#))
72477>>>>>        send add_item msg_none (sOperatorSymbol.i(op_type#))
72478>>>>>        if (structtype#=EIT.SYMBOL or structtype#=EIT.LEFT or structtype#=EIT.COMMA) begin
72480>>>>>          send add_item msg_none (dfscript_item_class(class#))
72481>>>>>          send add_item msg_none (dfscript_item_type(liType))
72482>>>>>        end
72482>>>>>>
72482>>>>>        else begin
72483>>>>>          send add_item msg_none ""
72484>>>>>          send add_item msg_none ""
72485>>>>>        end
72485>>>>>>
72485>>>>>        send add_item msg_none (string(level#))
72486>>>>>        send add_item msg_none (string(params#))
72487>>>>>      loop
72488>>>>>>
72488>>>>>      get item_count to max#
72489>>>>>      for liRow from 0 to (max#-1)
72495>>>>>>
72495>>>>>        set entry_state item liRow to false
72496>>>>>      loop
72497>>>>>>
72497>>>>>    end_procedure
72498>>>>>  end_object
72499>>>>>  object oBtn is a aps.Multi_Button
72501>>>>>    on_item t.btn.close send close_panel
72502>>>>>  end_object
72503>>>>>  send aps_locate_multi_buttons
72504>>>>>  procedure run.i integer obj#
72507>>>>>    set value of (oFrm(self)) item 0 to (psExprBeingParsed(obj#))
72508>>>>>    send fill_list.i to (oLst(self)) obj#
72509>>>>>    send popup
72510>>>>>  end_procedure
72511>>>>>end_object
72512>>>>>
72512>>>>>procedure DisplayExpressionDebugInfo global integer obj#
72514>>>>>  send run.i to (oDFScriptExprTest(self)) obj#
72515>>>>>end_procedure
72516>>>>>
72516>>>>>object oDFScriptExprSequence is a aps.ModalPanel label "Expression evaluation sequence"
72519>>>>>  set locate_mode to CENTER_ON_SCREEN
72520>>>>>  object oLst is a aps.Grid
72522>>>>>    set line_width to 2 0
72523>>>>>    set highlight_row_state to true
72524>>>>>    set highlight_row_color to (rgb(0,255,255))
72525>>>>>    set current_item_color to (rgb(0,255,255))
72526>>>>>    set select_mode to no_select
72527>>>>>    set size to 196 0
72528>>>>>    set form_margin item 0 to 14
72529>>>>>    set form_margin item 1 to 60
72530>>>>>    set header_label item 0 to "OP-Code"
72531>>>>>    set header_label item 1 to "Value"
72532>>>>>    on_key kenter send close_panel
72533>>>>>    on_key knext_item send switch
72534>>>>>    on_key kprevious_item send switch_back
72535>>>>>    procedure fill_list.i integer obj#
72538>>>>>      integer max# liRow class# op# liType
72538>>>>>      string val#
72538>>>>>      send delete_data
72539>>>>>      get row_count of obj# to max#
72540>>>>>      for liRow from 0 to (max#-1)
72546>>>>>>
72546>>>>>        get piOpCode.i  of obj# liRow to op#
72547>>>>>        get psVar.i     of obj# liRow to val#
72548>>>>>        send add_item msg_none (sExprOp_Text.i(op#))
72549>>>>>        send add_item msg_none val#
72550>>>>>      loop
72551>>>>>>
72551>>>>>    end_procedure
72552>>>>>  end_object
72553>>>>>  object oBtn is a aps.Multi_Button
72555>>>>>    on_item t.btn.close send close_panel
72556>>>>>  end_object
72557>>>>>  send aps_locate_multi_buttons
72558>>>>>  procedure run.i integer obj#
72561>>>>>    integer grb#
72561>>>>>    send fill_list.i to (oLst(self)) obj#
72562>>>>>    send popup
72563>>>>>  end_procedure
72564>>>>>end_object
72565>>>>>procedure DisplayEvalSequence global integer obj#
72567>>>>>  send run.i to (oDFScriptExprSequence(self)) obj#
72568>>>>>end_procedure
72569>>>>>
72569>>>Use Edit.utl     // Edit class for character mode DataFlex
Including file: edit.utl    (C:\Apps\VDFQuery\AppSrc\edit.utl)
72569>>>>>// Use Edit.utl     // cEditor class
72569>>>>>
72569>>>>>Use Files.utl    // Utilities for handling file related stuff
72569>>>>>Use Strings.utl  // String manipulation for VDF
72569>>>>>
72569>>>>>class cEditor is an aps.Edit
72570>>>>>  procedure construct_object integer img#
72572>>>>>    if num_arguments gt 0 forward send construct_object img#
72576>>>>>    else forward send construct_object
72579>>>>>    property integer piLeadInKey private 0 // 0=none, 1=cQ, 2=cK
72580>>>>>    on_key key_ctrl+key_right_arrow send word_right
72581>>>>>    on_key key_ctrl+key_left_arrow  send word_left
72582>>>>>  end_procedure
72583>>>>>  procedure word_left
72585>>>>>    send key kword_left
72586>>>>>  end_procedure
72587>>>>>  procedure word_right
72589>>>>>    send key kword_right
72590>>>>>  end_procedure
72591>>>>>  procedure display_position
72593>>>>>  end_procedure
72594>>>>>  procedure block_cut
72596>>>>>    send copy 1 clipboard true
72597>>>>>    set dynamic_update_state to true
72598>>>>>  end_procedure
72599>>>>>  procedure block_copy
72601>>>>>    send copy 0 clipboard true
72602>>>>>    set dynamic_update_state to true
72603>>>>>  end_procedure
72604>>>>>  procedure buffer_insert
72606>>>>>    send beginning_of_data to clipboard
72607>>>>>    send mark_on
72608>>>>>    send end_of_data to clipboard
72609>>>>>    send paste to clipboard 0 self 0
72610>>>>>    set dynamic_update_state to true
72611>>>>>  end_procedure
72612>>>>>  procedure line_mark
72614>>>>>    integer pos#
72614>>>>>    get position to pos#
72615>>>>>    send move_absolute (hi(pos#)) 0
72616>>>>>    send mark_on
72617>>>>>  end_procedure
72618>>>>>  procedure block_delete
72620>>>>>    send cut false clipboard true
72621>>>>>  end_procedure
72622>>>>>  procedure external_edit
72624>>>>>    string path#
72624>>>>>    send write "extedit.tmp" 0
72625>>>>>     runprogram wait "e extedit.tmp"
72626>>>>>    send delete_data
72627>>>>>    send read "extedit.tmp"
72628>>>>>    get SEQ_FindFileAlongDfPath "extedit.tmp" to path#
72629>>>>>    get SEQ_ComposeAbsoluteFileName path# "extedit.tmp" to path#
72630>>>>>    get SEQ_TranslatePathToAbsolute path# to path#
72631>>>>>    erasefile path#
72632>>>>>>
72632>>>>>    send refresh_screen
72633>>>>>    send beginning_of_data
72634>>>>>  end_procedure
72635>>>>>  procedure key integer key#
72637>>>>>    integer LeadInKey#
72637>>>>>    get cEditor.piLeadInKey to LeadInKey#
72638>>>>>    if LeadInKey# eq 1 begin // LeadIn=Q?
72640>>>>>      if key# eq key_ctrl+key_y send delete_to_eol
72643>>>>>      set cEditor.piLeadInKey to 0
72644>>>>>    end
72644>>>>>>
72644>>>>>    else if LeadInKey# eq 2 begin // LeadIn=K?
72647>>>>>      if key# eq key_ctrl+key_h send mark_off
72650>>>>>      if key# eq key_ctrl+key_b send mark_on
72653>>>>>      if key# eq key_ctrl+key_y send block_delete
72656>>>>>      set cEditor.piLeadInKey to 0
72657>>>>>    end
72657>>>>>>
72657>>>>>    else begin
72658>>>>>      if key# eq key_ctrl+key_q set cEditor.piLeadInKey to 1
72661>>>>>      else if key# eq key_ctrl+key_k set cEditor.piLeadInKey to 2
72665>>>>>      else begin
72666>>>>>        set cEditor.piLeadInKey to 0
72667>>>>>        if key# eq key_ctrl+key_y send delete_line
72670>>>>>        else if key# eq key_alt+key_k  send mark_on
72674>>>>>        else if key# eq key_alt+key_l  send line_mark
72678>>>>>        else if key# eq key_ctrl+key_c send block_copy
72682>>>>>        else if key# eq key_ctrl+key_v send buffer_insert
72686>>>>>        else if key# eq key_ctrl+key_x send block_cut
72690>>>>>        else if key# eq key_alt+key_u  send mark_off
72694>>>>>        else if key# eq key_alt+key_e  send external_edit
72698>>>>>        else forward send key key#
72701>>>>>      end
72701>>>>>>
72701>>>>>    end
72701>>>>>>
72701>>>>>    send display_position
72702>>>>>  end_procedure
72703>>>>>  procedure set psValueAsString string str#
72705>>>>>    send Text_SetEditObjectValue self str#
72706>>>>>  end_procedure
72707>>>>>  function psValueAsString returns string // That's a parameter for a global function
72709>>>>>    function_return (Text_EditObjectValue(self))
72710>>>>>  end_function
72711>>>>>end_class
72712>>>
/DFSCRIPT.SAMPLE1
Image 8, DFSCRIPT.SAMPLE1
integer i
move 0 to i
while i le 7
  input "Enter integer value: " i
end
showln "Finally you entered something larger than 7!"
showln "Goodbye"
pause // Pause program to let us see the exit message
/DFScript.Sample2
Image 9, DFSCRIPT.SAMPLE2
integer i
for i from 0 to 99
  show i " "
loop
pause // Pause program to let us see the result
/DFScript.Sample3
Image 10, DFSCRIPT.SAMPLE3
 // The IF command differs from that of standard DATAFLEX
 // in that it does not use BEGIN/END commands to define
 // the range of the branches. Nor is it possible to put
 // a conditioned command on the same command line as the
 // IF statement itself.
integer i
for i from 0 to 10
  show i " is "
  if i gt 5
    show "GT 5"
    if i le 8 // Nested IF command
      show " but it is not GT 8"
    else
      show " and GT 8 too"
    endif
  else
    show "not GT 5"
  endif
  showln
loop
showln
showln "Press any key to continue..."
pause // Pause program to let us see the result
/DFScript.Sample4
Image 11, DFSCRIPT.SAMPLE4
integer i
repeat
  input "Enter integer value: " i
until i gt 7
showln "Finally you entered something larger than 7!"
showln "Goodbye"
pause // Pause program to let us see the exit message
/DFScript.Sample5
Image 12, DFSCRIPT.SAMPLE5
integer guesses
string title
showln "Now, who is he?"
move 1 to guesses
repeat
  input "He's a real " title
  increment guesses
  if (uppercase(title)) ne (uppercase("Nowhere Man"))
    if title eq ""
      showln "You are supposed to make a guess..."
    else
      showln "Maybe, but that's not the song I'm thinking about"
    endif
    if guesses eq 3
      showln "I'll hint you: It's by the Beatles"
    endif
    if guesses eq 4
      showln "I'll hint you (again): Nowhere Man"
    endif
    if guesses eq 5
      showln "My god, you're stupid! Enter 'Nowhere Man'"
    endif
    if guesses eq 6
      showln "I give up. You're out of here!"
      showln
      showln "He's a real NOWHERE MAN"
      move "Nowhere Man" to title
    endif
  endif
until (uppercase(title)) eq (uppercase("Nowhere Man"))
showln "Sitting in his nowhere land"
showln "Making all his nowhere plans for nobody"
showln
showln "Press any key..."
pause
abort // Clean up memory taken up by variables and stuff"
/DFScript.Sample6
Image 13, DFSCRIPT.SAMPLE6
showln "This example shows what happens if a regular DF error"
showln "occurs while a DFScript is running."
showln
showln "Right, are you ready?"
pause
integer i
move "ABC" to i // This generates an error
showln
showln "OK! So the next time, take care not to make such"
showln "stupid mistakes"
pause
abort
/DFScript.Sample7
Image 14, DFSCRIPT.SAMPLE7
integer i
repeat
  move (i+1) to i
  showln i
until i gt 5
pause
/DFScript.Sample8
Image 15, DFSCRIPT.SAMPLE8
integer iFile
move 0 to iFile
showln "Filelist.cfg"
showln "------------"
repeat
  move (API_AttrValue_FLSTNAV(DF_FILE_NEXT_USED,iFile)) to iFile
  if iFile
    show (IntToStrR(iFile,4)) ": "
    showln (API_AttrValue_FILELIST(DF_FILE_DISPLAY_NAME,iFile))
  endif
until (iFile=0)
showln "Press any key..."
pause
/DFScript.Sample9
Image 16, DFSCRIPT.SAMPLE9
integer i
move 399 to i
while (i+2) gt 1
  show i " "
  move (i-1) to i
end
showln "Press any key..."
pause
/DFScript.Sample10
Image 17, DFSCRIPT.SAMPLE10
integer i
log_open "dfscript.log" 0 // 0 means overwrite, 1 means append
move 399 to i
while (i+2) gt 1
  show i " "
  move (i-1) to i
  log_writeln i
end
showln "Press any key..."
log_close
pause
/*
72712>>>
72712>>>
72712>>>Use APS          // Auto Positioning and Sizing classes for VDF
72712>>>object oDFScriptSampleSelector is a aps.ModalPanel label "Load DFScript sample"
72715>>>  set locate_mode to CENTER_ON_SCREEN
72716>>>  on_key kcancel send close_panel
72717>>>  property integer piResult public 0
72719>>>  object oLst is a aps.List
72721>>>    set size to 100 200
72722>>>    on_key kenter send close_panel_ok
72723>>>    procedure add_selection integer img# string str#
72726>>>      send add_item msg_ok str#
72727>>>      set aux_value item (item_count(self)-1) to img#
72728>>>    end_procedure
72729>>>    send add_selection DFScript.Sample1.N "While/End structure"
72730>>>    send add_selection DFScript.Sample2.N "For/Loop structure"
72731>>>    send add_selection DFScript.Sample3.N "If/Else structure"
72732>>>    send add_selection DFScript.Sample4.N "Repeat/Until structure"
72733>>>    send add_selection DFScript.Sample5.N "Nowhere Man"
72734>>>    send add_selection DFScript.Sample6.N "Error handling"
72735>>>    send add_selection DFScript.Sample7.N "Simple expression"
72736>>>    send add_selection DFScript.Sample8.N "Files in Filelist.cfg"
72737>>>    send add_selection DFScript.Sample9.N "Expression in while"
72738>>>    send add_selection DFScript.Sample10.N "Writing to log file"
72739>>>  end_object
72740>>>  procedure close_panel_ok
72743>>>    set piResult to true
72744>>>    send close_panel
72745>>>  end_procedure
72746>>>  object oBtn1 is a aps.Multi_Button
72748>>>      on_item t.btn.ok send close_panel_ok
72749>>>  end_object
72750>>>  object oBtn2 is a aps.Multi_Button
72752>>>      on_item t.btn.cancel send close_panel
72753>>>  end_object
72754>>>  send aps_locate_multi_buttons
72755>>>  function iRun returns integer // Returns the number of the image to load
72758>>>    integer rval#
72758>>>    set piResult to false
72759>>>    send popup
72760>>>    if (piResult(self)) function_return (aux_value(oLst(self),CURRENT))
72763>>>    //function_return 0
72763>>>  end_function
72764>>>end_object
72765>>>
72765>>>object oDFScript_DebugSetup is a aps.ModalPanel label "DFScript Debug Setup"
72768>>>  set locate_mode to CENTER_ON_SCREEN
72769>>>  on_key kcancel send close_panel
72770>>>  property integer piResult public 0
72772>>>  object oGrp is a aps.Group
72774>>>    on_key kenter send next
72775>>>    object oCB1 is a aps.CheckBox label "Debug interpreter"
72778>>>    end_object
72779>>>    object oCB2 is a aps.CheckBox label "Debug while running"
72782>>>    end_object
72783>>>    object oCB3 is a aps.CheckBox label "Single step while running"
72786>>>    end_object
72787>>>  end_object
72788>>>  procedure close_panel_ok
72791>>>    set piResult to true
72792>>>    send close_panel
72793>>>  end_procedure
72794>>>  object oBtn1 is a aps.Multi_Button
72796>>>    on_item t.btn.ok send close_panel_ok
72797>>>  end_object
72798>>>  object oBtn2 is a aps.Multi_Button
72800>>>    on_item t.btn.cancel send close_panel
72801>>>  end_object
72802>>>  send aps_locate_multi_buttons
72803>>>  function iRun.iii integer i1# integer i2# integer i3# returns integer
72806>>>    integer rval#
72806>>>    set piResult to false
72807>>>    set checked_state of (oCB1(oGrp(self))) to i1#
72808>>>    set checked_state of (oCB2(oGrp(self))) to i2#
72809>>>    set checked_state of (oCB3(oGrp(self))) to i3#
72810>>>    send popup
72811>>>    function_return (piResult(self))
72812>>>  end_function
72813>>>  function iDebugInterpreter returns integer
72816>>>    function_return (Checked_State(oCB1(oGrp(self))))
72817>>>  end_function
72818>>>  function iDebugVM returns integer
72821>>>    function_return (Checked_State(oCB2(oGrp(self))))
72822>>>  end_function
72823>>>  function iDebugSingleStepVM returns integer
72826>>>    function_return (Checked_State(oCB3(oGrp(self))))
72827>>>  end_function
72828>>>end_object
72829>>>
72829>>>class cScriptEditor is a cEditor
72830>>>end_class
72831>>>
72831>>>class cScriptIDE_Client is a aps.View
72832>>>  procedure construct_object integer img#
72834>>>    forward send construct_object img#
72836>>>    property integer piDebugInterpreter  public 0
72837>>>    property integer piDebugVM           public 0
72838>>>    property integer piDebugSingleStepVM public 0
72839>>>    property integer piProgramChanged    public 0
72840>>>    property string  psProgramFileName   public ""
72841>>>    property integer piEditObject        public 0
72842>>>    object oVM is a cVirtualMachine no_image
72844>>>    end_object
72845>>>    object oScriptInterpreter is a cScriptInterpreter no_image
72847>>>      // The interpreter needs a Virtual Machine object:
72847>>>      set pVM_Object to (oVM(self))
72848>>>    end_object
72849>>>    on_key key_ctrl+key_a send open_sample
72850>>>    on_key key_ctrl+key_r send run_script
72851>>>    on_key key_ctrl+key_n send new_script
72852>>>    on_key key_ctrl+key_s send save_script
72853>>>    on_key key_ctrl+key_o send open_script
72854>>>    on_key key_ctrl+key_d send setup_debug
72855>>>  end_procedure
72856>>>  procedure open_sample
72858>>>    integer ch# oEdit# itm# seqeof# img#
72858>>>    string str#
72858>>>    move (piEditObject(self)) to oEdit#
72859>>>    get iRun of (oDFScriptSampleSelector(self)) to img#
72860>>>    if img# begin
72862>>>      move 0 to itm#
72863>>>      move (SEQ_DirectInput("image:"+string(img#))) to ch#
72864>>>      if (ch#>=0) begin
72866>>>        send delete_data to oEdit#
72867>>>        repeat
72867>>>>
72867>>>          readln str#
72868>>>          move (seqeof) to seqeof#
72869>>>          ifnot seqeof# begin
72871>>>            set value of oEdit# item itm# to str#
72872>>>            increment itm#
72873>>>          end
72873>>>>
72873>>>        until seqeof#
72875>>>        set dynamic_update_state of oEdit# to true
72876>>>        send SEQ_CloseInput ch#
72877>>>        set piProgramChanged  to 0
72878>>>        set psProgramFileName to "Sample"
72879>>>        send activate to oEdit#
72880>>>        send display_position to oEdit#
72881>>>      end
72881>>>>
72881>>>    end
72881>>>>
72881>>>  end_procedure
72882>>>  procedure open_script
72884>>>    integer ch# oEdit# itm# seqeof#
72884>>>    string fn# str#
72884>>>    move (piEditObject(self)) to oEdit#
72885>>>    move (SEQ_SelectFile("Open DFScript source file","DFScript source file (*.dfs)|*.DFS")) to fn#
72886>>>    if fn# ne "" begin
72888>>>      move 0 to itm#
72889>>>      move (SEQ_DirectInput(fn#)) to ch#
72890>>>      if (ch#>=0) begin
72892>>>        send delete_data to oEdit#
72893>>>        repeat
72893>>>>
72893>>>          readln str#
72894>>>          move (seqeof) to seqeof#
72895>>>          ifnot seqeof# begin
72897>>>            set value of oEdit# item itm# to str#
72898>>>            increment itm#
72899>>>          end
72899>>>>
72899>>>        until seqeof#
72901>>>        set dynamic_update_state of oEdit# to true
72902>>>        send SEQ_CloseInput ch#
72903>>>        set piProgramChanged  to 0
72904>>>        set psProgramFileName to fn#
72905>>>        send activate to oEdit#
72906>>>        send display_position to oEdit#
72907>>>      end
72907>>>>
72907>>>    end
72907>>>>
72907>>>  end_procedure
72908>>>  procedure new_script
72910>>>    send delete_data to (piEditObject(self))
72911>>>    send activate to (piEditObject(self))
72912>>>    set psProgramFileName to ""
72913>>>    send display_position to (piEditObject(self))
72914>>>    set piProgramChanged  to 0
72915>>>  end_procedure
72916>>>  procedure save_script
72918>>>    integer ch# oEdit# itm# seqeof# max#
72918>>>    string fn# str#
72918>>>    move (piEditObject(self)) to oEdit#
72919>>>    move (SEQ_SelectOutFile("Save DFScript source file","*.dfs")) to fn#
72920>>>    if fn# ne "" begin
72922>>>      move (SEQ_DirectOutput(fn#)) to ch#
72923>>>      if (ch#>=0) begin
72925>>>        get line_count of oEdit# to max#
72926>>>        for itm# from 0 to (max#-1)
72932>>>>
72932>>>          get value of oEdit# item itm# to str#
72933>>>          writeln channel ch# str#
72936>>>        loop
72937>>>>
72937>>>        send SEQ_CloseOutput ch#
72938>>>        set piProgramChanged to 0
72939>>>        set psProgramFileName to fn#
72940>>>        send activate to oEdit#
72941>>>        send display_position to oEdit#
72942>>>      end
72942>>>>
72942>>>    end
72942>>>>
72942>>>  end_procedure
72943>>>
72943>>>  procedure run_script
72945>>>    integer oScriptInterpreter# oEdit# itm# max# error# errobj#
72945>>>    string str#
72945>>>    move (piEditObject(self)) to oEdit#
72946>>>    move (oScriptInterpreter(self)) to oScriptInterpreter#
72947>>>    set piDebugState of oScriptInterpreter# to (piDebugInterpreter(self))
72948>>>    send script_begin to oScriptInterpreter#
72949>>>    get line_count of oEdit# to max#
72950>>>    move 0 to error#
72951>>>    send ScreenEndWait_On 0 (max#-1)
72952>>>    for itm# from 0 to (max#-1)
72958>>>>
72958>>>      send ScreenEndWait_SetText ("Parsing line "+string(itm#+1)+" of "+string(max#+1))
72959>>>      send ScreenEndWait_Update itm#
72960>>>      get value of oEdit# item itm# to str#
72961>>>      ifnot error# get iParse_Line.sis of oScriptInterpreter# str# (itm#+1) "Editor contents" to error#
72964>>>    loop
72965>>>>
72965>>>    send ScreenEndWait_Off
72966>>>    if error# begin
72968>>>      send move_absolute to oEdit# (hi(error#)-1) (low(error#)-1)
72969>>>      send activate to oEdit#
72970>>>      send display_position to oEdit#
72971>>>    end
72971>>>>
72971>>>    else begin
72972>>>      set piDebugState      of (oVM(self)) to (piDebugVM(self))
72973>>>      set piDebugSingleStep of (oVM(self)) to (piDebugSingleStepVM(self))
72974>>>      send script_end to oScriptInterpreter#
72975>>>      move Error_Object_Id to errobj#
72976>>>      move 0 to Error_Object_Id
72977>>>      clearscreen
72978>>>>
72978>>>      send run_script to oScriptInterpreter#
72979>>>      move errobj# to Error_Object_Id
72980>>>    end
72980>>>>
72980>>>  end_procedure
72981>>>  procedure setup_debug
72983>>>    if (iRun.iii(oDFScript_DebugSetup(self),piDebugInterpreter(self),piDebugVM(self),piDebugSingleStepVM(self))) begin
72985>>>      set piDebugInterpreter  to (iDebugInterpreter(oDFScript_DebugSetup(self)))
72986>>>      set piDebugVM           to (iDebugVM(oDFScript_DebugSetup(self)))
72987>>>      set piDebugSingleStepVM to (iDebugSingleStepVM(oDFScript_DebugSetup(self)))
72988>>>    end
72988>>>>
72988>>>  end_procedure
72989>>>end_class // cScriptIDE_Client
72990>>>
72990>>>
72990>>>object oDFScript_Vw is a cScriptIDE_Client label "DFScript IDE, RAD and Web enabled 4GL Wonder"
72993>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
72994>>>  set pMinimumSize to 150 100
72995>>>  on_key kcancel send close_panel
72996>>>  object oEdit is a cScriptEditor
72998>>>    set size to 200 400
72999>>>    set typeface to "Courier New"
73000>>>    procedure display_position integer line# integer column#
73003>>>      integer pos#
73003>>>      get position to pos#
73004>>>      send update_cursor_info ("L"+pad(string(hi(pos#)+1),5)+" C"+pad(string(low(pos#)+1),4))
73005>>>    end_procedure
73006>>>  end_object
73007>>>  set piEditObject to (oEdit(self))
73008>>>  object oBtn1 is a aps.Multi_Button
73010>>>    on_item "New"    send new_script
73011>>>  end_object
73012>>>  object oBtn2 is a aps.Multi_Button
73014>>>    on_item "Save"   send save_script
73015>>>  end_object
73016>>>  object oBtn3 is a aps.Multi_Button
73018>>>    on_item "Open"   send open_script
73019>>>  end_object
73020>>>  object oBtn4 is a aps.Multi_Button
73022>>>    on_item "Sample" send open_sample
73023>>>  end_object
73024>>>  object oBtn5 is a aps.Multi_Button
73026>>>    on_item "Debug"  send setup_debug
73027>>>  end_object
73028>>>  object oBtn6 is a aps.Multi_Button
73030>>>    on_item "Run"    send run_script
73031>>>  end_object
73032>>>  object oBtn7 is a aps.Multi_Button
73034>>>    on_item "Close"  send close_panel
73035>>>  end_object
73036>>>  object oLabel is a aps.Form abstract AFT_ASCII10
73039>>>    Set Form_Justification_Mode Item 0 to Form_DisplayCenter
73040>>>     Set TextColor to clRed  //JK - this works, but only in a form
73041>>>    Set Object_Shadow_State to True // Make this form look like a textbox
73042>>>    Set Form_Border Item 0 to Border_None
73043>>>    procedure check_this
73046>>>      integer self#
73046>>>      move self to self#
73047>>>      send aps_register_multi_button self#
73048>>>    end_procedure
73049>>>    send check_this
73050>>>  end_object
73051>>>  send aps_locate_multi_buttons sl_vertical
73052>>>  procedure update_cursor_info string str#
73055>>>    set value of (oLabel(self)) item 0 to str#
73056>>>  end_procedure
73057>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
73060>>>    send aps_resize (oEdit(self)) delta_rw# delta_cl#
73061>>>    send aps_register_multi_button (oBtn1(self))
73062>>>    send aps_register_multi_button (oBtn2(self))
73063>>>    send aps_register_multi_button (oBtn3(self))
73064>>>    send aps_register_multi_button (oBtn4(self))
73065>>>    send aps_register_multi_button (oBtn5(self))
73066>>>    send aps_register_multi_button (oBtn6(self))
73067>>>    send aps_register_multi_button (oBtn7(self))
73068>>>    send aps_register_multi_button (oLabel(self))
73069>>>    send aps_locate_multi_buttons sl_vertical
73070>>>    send aps_auto_size_container
73071>>>  end_procedure
73072>>>end_object
73073>>>
73073>>>procedure activate_dfscript_ide
73076>>>  send popup to (oDFScript_Vw(self))
73077>>>end_procedure
73078>>>
73078>>>function dfscript.Direct_Output global returns integer
73080>>>  send new_script to (oDFScript_Vw(self))
73081>>>  function_return (not(piProgramChanged(oDFScript_Vw(self))))
73082>>>end_function
73083>>>
73083>>>procedure dfscript.WriteLn global string str#
73085>>>  integer oEdit# itm#
73085>>>  move (oEdit(oDFScript_Vw(self))) to oEdit#
73086>>>  get line_count of oEdit# to itm#
73087>>>  set value of oEdit# item itm# to str#
73088>>>end_procedure
73089>//    Use FindFile.vw  // View for finding files along DFPath (Activate_FindFile)
73089>    Use FdxCheck.vw  // View for interfacing validity check of table definitions
Including file: fdxcheck.vw    (C:\Apps\VDFQuery\AppSrc\fdxcheck.vw)
73089>>>// Use FdxCheck.vw  // View for interfacing validity check of table definitions
73089>>>
73089>>>Use FdxCheck.pkg // Classes for displaying validity check of table definitions
Including file: fdxcheck.pkg    (C:\Apps\VDFQuery\AppSrc\fdxcheck.pkg)
73089>>>>>// Use FdxCheck.pkg // Classes for displaying validity check of table definitions
73089>>>>>// NOTE: This view only works within the DFMatrix framework
73089>>>>>Use FdxCheck.utl // Check validity of table definitions
Including file: fdxcheck.utl    (C:\Apps\VDFQuery\AppSrc\fdxcheck.utl)
73089>>>>>>>// Use FdxCheck.utl // Check validity of table definitions
73089>>>>>>>
73089>>>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
73089>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, c
73089>>>>>>>Use Files.utl    // Utilities for handling file related stuff
73089>>>>>>>Use Strings.nui  // String manipulation for VDF
73089>>>>>>>Use FdxSet.nui   // cFdxSetOfTables, cFdxSetOfFields, cFdxSetOfIndices
73089>>>>>>>
73089>>>>>>>enumeration_list
73089>>>>>>>  define TDINFO_INFO
73089>>>>>>>  define TDINFO_WARNING
73089>>>>>>>  define TDINFO_ERROR
73089>>>>>>>end_enumeration_list
73089>>>>>>>
73089>>>>>>>enumeration_list
73089>>>>>>>  define TDERROR_COULD_NOT_CHECK
73089>>>>>>>  define TDERROR_FILE_INCOMPATIBLE_FD1
73089>>>>>>>  define TDERROR_FILE_INCOMPATIBLE_FD2
73089>>>>>>>  define TDERROR_FILE_INCOMPATIBLE_FD3
73089>>>>>>>  define TDERROR_FILE_INCOMPATIBLE_TAG
73089>>>>>>>  define TDERROR_FILE_MISSING_HDR
73089>>>>>>>  define TDERROR_FILE_MISSING_VLD
73089>>>>>>>  define TDERROR_FILE_MISSING_IDX
73089>>>>>>>  define TDERROR_FILE_ENTRY_207
73089>>>>>>>  define TDERROR_FILE_ENTRY_208
73089>>>>>>>  define TDERROR_REL_FILE_NOT_AVAILABLE1
73089>>>>>>>  define TDERROR_REL_FILE_NOT_AVAILABLE2
73089>>>>>>>  define TDERROR_REL_MORE_THAN_ONE
73089>>>>>>>  define TDERROR_REL_MISMATCH1
73089>>>>>>>  define TDERROR_REL_MISMATCH2
73089>>>>>>>  define TDERROR_REL_FIELD_NOT_UNIQUELY_INDEXED
73089>>>>>>>  define TDERROR_REL_FIELD_NO_MAIN_INDEX
73089>>>>>>>  define TDERROR_REL_FIELD_WRONG_MAIN_INDEX
73089>>>>>>>  define TDERROR_REL_RECNUM_BASED
73089>>>>>>>  define TDERROR_REL_TO_SYSTEM_FILE
73089>>>>>>>  define TDERROR_IDX_SAME_FIELD
73089>>>>>>>  define TDERROR_IDX_RECNUM_NOT_AT_END
73089>>>>>>>  define TDERROR_IDX_UPPERCASE_ERROR
73089>>>>>>>  define TDERROR_IDX_MISSING_FILE
73089>>>>>>>  define TDERROR_IDX_SUPERFLOUS
73089>>>>>>>  define TDERROR_IDX_IDENTICAL
73089>>>>>>>  define TDERROR_IDX_LOCATION
73089>>>>>>>end_enumeration_list
73089>>>>>>>desktop_section
73094>>>>>>>  object oTDError_Decoder is a cArray no_image
73096>>>>>>>    item_property_list
73096>>>>>>>      item_property integer piErrorClass.i   // TDINFO_INFO  TDINFO_WARNING  TDINFO_ERROR
73096>>>>>>>      item_property string  psDescription.i
73096>>>>>>>      item_property string  psExplicit.i
73096>>>>>>>    end_item_property_list
#REM 73136 DEFINE FUNCTION PSEXPLICIT.I INTEGER LIROW RETURNS STRING
#REM 73141 DEFINE PROCEDURE SET PSEXPLICIT.I INTEGER LIROW STRING VALUE
#REM 73146 DEFINE FUNCTION PSDESCRIPTION.I INTEGER LIROW RETURNS STRING
#REM 73151 DEFINE PROCEDURE SET PSDESCRIPTION.I INTEGER LIROW STRING VALUE
#REM 73156 DEFINE FUNCTION PIERRORCLASS.I INTEGER LIROW RETURNS INTEGER
#REM 73161 DEFINE PROCEDURE SET PIERRORCLASS.I INTEGER LIROW INTEGER VALUE
73167>>>>>>>    procedure add_error.iss integer Err# integer IsErr# string Descr# string Explicit#
73170>>>>>>>      set piErrorClass.i  err# to IsErr#
73171>>>>>>>      set psDescription.i err# to Descr#
73172>>>>>>>      set psExplicit.i    err# to Explicit#
73173>>>>>>>    end_procedure
73174>>>>>>>    send add_error.iss TDERROR_COULD_NOT_CHECK                TDINFO_INFO    "Could not perform check"                  "#"
73175>>>>>>>    send add_error.iss TDERROR_FILE_INCOMPATIBLE_FD1          TDINFO_ERROR   "Wrong table number in FD file"            "Number in FD file is # when it should be #"
73176>>>>>>>    send add_error.iss TDERROR_FILE_INCOMPATIBLE_FD2          TDINFO_ERROR   "Wrong table name in FD file"              "Name in FD file is # when it should be #"
73177>>>>>>>    send add_error.iss TDERROR_FILE_INCOMPATIBLE_FD3          TDINFO_ERROR   "Incompatible FD file"                     "Fields in FD file is out of synch. with table definition"
73178>>>>>>>    send add_error.iss TDERROR_FILE_INCOMPATIBLE_TAG          TDINFO_ERROR   "Incompatible TAG file"                    "Wrong number of entries in TAG file: # (should be #)"
73179>>>>>>>    send add_error.iss TDERROR_FILE_MISSING_HDR               TDINFO_ERROR   "HDR file not found"                       "File # not found"
73180>>>>>>>    send add_error.iss TDERROR_FILE_MISSING_VLD               TDINFO_ERROR   "VLD file not found"                       "File # not found"
73181>>>>>>>    send add_error.iss TDERROR_FILE_MISSING_IDX               TDINFO_ERROR   "Index file not found"                     "File # not found"
73182>>>>>>>    send add_error.iss TDERROR_FILE_ENTRY_207                 TDINFO_WARNING "Entry 207 normally reserved for CodeType" "Entry 207 used for #"
73183>>>>>>>    send add_error.iss TDERROR_FILE_ENTRY_208                 TDINFO_WARNING "Entry 208 normally reserved for CodeMast" "Entry 208 used for #"
73184>>>>>>>    send add_error.iss TDERROR_REL_FILE_NOT_AVAILABLE1        TDINFO_WARNING "Related table not available"              "Field # relates to table # which is not present in FILELIST.CFG"
73185>>>>>>>    send add_error.iss TDERROR_REL_FILE_NOT_AVAILABLE2        TDINFO_WARNING "Related table not available"              "Field # relates to table # which is not found on system"
73186>>>>>>>    send add_error.iss TDERROR_REL_MORE_THAN_ONE              TDINFO_WARNING "Multiple relations to table"              "More than one relation exists between # and #"
73187>>>>>>>    send add_error.iss TDERROR_REL_MISMATCH1                  TDINFO_ERROR   "Field type mismatch in relation"          "Field # (#) relates to field # (#)"
73188>>>>>>>    send add_error.iss TDERROR_REL_MISMATCH2                  TDINFO_ERROR   "Overlap structure mismatch in relation"   "Field # (#) relates to field # (#)"
73189>>>>>>>    send add_error.iss TDERROR_REL_FIELD_NOT_UNIQUELY_INDEXED TDINFO_ERROR   "Related table not uniquely indexed"       "Field # relates to # that is not uniquely indexed"
73190>>>>>>>    send add_error.iss TDERROR_REL_FIELD_WRONG_MAIN_INDEX     TDINFO_ERROR   "Wrong main index on related field"        "Field # relates to # that has the wrong main index"
73191>>>>>>>    send add_error.iss TDERROR_REL_FIELD_NO_MAIN_INDEX        TDINFO_ERROR   "Missing index on related table"           "Field # relates to # that has no main index"
73192>>>>>>>    send add_error.iss TDERROR_REL_RECNUM_BASED               TDINFO_WARNING "Relation based on RECNUM"                 "Field # relates to #"
73193>>>>>>>    send add_error.iss TDERROR_REL_TO_SYSTEM_FILE             TDINFO_WARNING "Relation to system table"                 "Field # relates to system table #"
73194>>>>>>>    send add_error.iss TDERROR_IDX_SAME_FIELD                 TDINFO_WARNING "Same field appears more than once"        "Field # appears more than once in index #"
73195>>>>>>>    send add_error.iss TDERROR_IDX_RECNUM_NOT_AT_END          TDINFO_WARNING "Recnum not last segment"                  "RECNUM appears as a more significant segment in index #"
73196>>>>>>>    send add_error.iss TDERROR_IDX_UPPERCASE_ERROR            TDINFO_ERROR   "Case ignored on non-ASCII field in index" "Field # (index #)"
73197>>>>>>>    send add_error.iss TDERROR_IDX_MISSING_FILE               TDINFO_ERROR   "Index file not found"                     "File # not found"
73198>>>>>>>    send add_error.iss TDERROR_IDX_SUPERFLOUS                 TDINFO_WARNING "Superflous index"                         "Drop index # and use index # instead"
73199>>>>>>>    send add_error.iss TDERROR_IDX_IDENTICAL                  TDINFO_WARNING "Identical indices"                        "Index # and # are identically defined"
73200>>>>>>>    send add_error.iss TDERROR_IDX_LOCATION                   TDINFO_WARNING "Location of index file"                   "Index file #"
73201>>>>>>>  end_object // oTDError_Decoder
73202>>>>>>>end_desktop_section
73207>>>>>>>
73207>>>>>>>class cFdxCheck is a cArray
73208>>>>>>>  procedure construct_object integer img#
73210>>>>>>>    forward send construct_object img#
73212>>>>>>>    // Currently checking tables with these features:
73212>>>>>>>    property integer piFile         public 0
73213>>>>>>>    property string  psLogicalName  public ""
73214>>>>>>>    property string  psPhysicalName public ""
73215>>>>>>>    property integer piRealData     public 0
73216>>>>>>>    property integer piDataFlex     public 0 // Is it a DF table
73217>>>>>>>    property integer piServer       public 0
73218>>>>>>>    object oCheckIndexSet is a Set no_image
73220>>>>>>>    end_object
73221>>>>>>>    object oFdxSetOfTables is a cFdxSetOfTables no_image
73223>>>>>>>    end_object
73224>>>>>>>  end_procedure
73225>>>>>>>  //> Send this to reset the error list
73225>>>>>>>
73225>>>>>>>  item_property_list
73225>>>>>>>    item_property integer piFile.i
73225>>>>>>>    item_property integer piError.i
73225>>>>>>>    item_property string  psArg1.i
73225>>>>>>>    item_property string  psArg2.i
73225>>>>>>>    item_property string  psArg3.i
73225>>>>>>>    item_property string  psArg4.i
73225>>>>>>>  end_item_property_list cFdxCheck
#REM 73269 DEFINE FUNCTION PSARG4.I INTEGER LIROW RETURNS STRING
#REM 73273 DEFINE PROCEDURE SET PSARG4.I INTEGER LIROW STRING VALUE
#REM 73277 DEFINE FUNCTION PSARG3.I INTEGER LIROW RETURNS STRING
#REM 73281 DEFINE PROCEDURE SET PSARG3.I INTEGER LIROW STRING VALUE
#REM 73285 DEFINE FUNCTION PSARG2.I INTEGER LIROW RETURNS STRING
#REM 73289 DEFINE PROCEDURE SET PSARG2.I INTEGER LIROW STRING VALUE
#REM 73293 DEFINE FUNCTION PSARG1.I INTEGER LIROW RETURNS STRING
#REM 73297 DEFINE PROCEDURE SET PSARG1.I INTEGER LIROW STRING VALUE
#REM 73301 DEFINE FUNCTION PIERROR.I INTEGER LIROW RETURNS INTEGER
#REM 73305 DEFINE PROCEDURE SET PIERROR.I INTEGER LIROW INTEGER VALUE
#REM 73309 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 73313 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
73318>>>>>>>
73318>>>>>>>  procedure reset
73320>>>>>>>    send delete_data
73321>>>>>>>    send delete_data to (oCheckIndexSet(self))
73322>>>>>>>    send delete_data to (oFdxSetOfTables(self))
73323>>>>>>>    set psLogicalName  to ""
73324>>>>>>>    set psPhysicalName to ""
73325>>>>>>>    set piServer   to 0
73326>>>>>>>    set piRealData to 0
73327>>>>>>>    set piDataFlex to 0
73328>>>>>>>    set piServer   to 0
73329>>>>>>>  end_procedure
73330>>>>>>>
73330>>>>>>>  function iFileExists string sFile returns integer
73332>>>>>>>    string sPath
73332>>>>>>>    if (SEQ_ExtractPathFromFileName(sFile)) eq "" begin
73334>>>>>>>      move (SEQ_FindFileAlongDFPath(sFile)) to sPath
73335>>>>>>>      move (SEQ_ComposeAbsoluteFileName(sPath,sFile)) to sFile
73336>>>>>>>    end
73336>>>>>>>>
73336>>>>>>>    function_return (SEQ_FileExists(sFile))
73337>>>>>>>  end_function
73338>>>>>>>
73338>>>>>>>  function iErrorClass.i integer row# returns integer
73340>>>>>>>    integer arr#
73340>>>>>>>    move (oTDError_Decoder(self)) to arr#
73341>>>>>>>    function_return (piErrorClass.i(arr#,piError.i(self,row#)))
73342>>>>>>>  end_function
73343>>>>>>>  function sErrorText1.i integer row# returns string
73345>>>>>>>    integer arr#
73345>>>>>>>    move (oTDError_Decoder(self)) to arr#
73346>>>>>>>    function_return (psDescription.i(arr#,piError.i(self,row#)))
73347>>>>>>>  end_function
73348>>>>>>>  function sErrorText2.i integer row# returns string
73350>>>>>>>    integer err#
73350>>>>>>>    string rval#
73350>>>>>>>    get piError.i row# to err#
73351>>>>>>>    get psExplicit.i of (oTDError_Decoder(self)) err# to rval#
73352>>>>>>>    move (replace("#",rval#,psArg1.i(self,row#))) to rval#
73353>>>>>>>    move (replace("#",rval#,psArg2.i(self,row#))) to rval#
73354>>>>>>>    move (replace("#",rval#,psArg3.i(self,row#))) to rval#
73355>>>>>>>    move (replace("#",rval#,psArg4.i(self,row#))) to rval#
73356>>>>>>>    function_return rval#
73357>>>>>>>  end_function
73358>>>>>>>
73358>>>>>>>  procedure add_error integer err# string a1# string a2# string a3# string a4#
73360>>>>>>>    integer row# file#
73360>>>>>>>    get piFile to file#
73361>>>>>>>    get row_count to row#
73362>>>>>>>    set piFile.i  row# to file#
73363>>>>>>>    set piError.i row# to err#
73364>>>>>>>    set psArg1.i  row# to a1#
73365>>>>>>>    set psArg2.i  row# to a2#
73366>>>>>>>    set psArg3.i  row# to a3#
73367>>>>>>>    set psArg4.i  row# to a4#
73368>>>>>>>  end_procedure
73369>>>>>>>
73369>>>>>>>  function Check_FD_File_Help string str# returns string // Extract the field type
73371>>>>>>>    integer pos#
73371>>>>>>>    pos "|" in str# to pos#
73373>>>>>>>>
73373>>>>>>>    if pos# function_return (mid(str#,1,(pos#+2)))
73376>>>>>>>    function_return ""
73377>>>>>>>  end_function
73378>>>>>>>
73378>>>>>>>  procedure Check_FD_File
73380>>>>>>>    integer oFDX# file# RealData#
73380>>>>>>>    integer ch# max_field# field# fd_file# err# type#
73380>>>>>>>    string fn# str# fd_name# tmp#
73380>>>>>>>    get piServer to oFDX#
73381>>>>>>>    get piFile to file#
73382>>>>>>>    get piRealData to RealData#
73383>>>>>>>    if RealData# begin
73385>>>>>>>      get psLogicalName to fn#
73386>>>>>>>      move (SEQ_DirectInput(fn#+".FD")) to ch#
73387>>>>>>>      if ch# ge 0 begin
73389>>>>>>>        move (SEQ_ReadLn(ch#)) to str#
73390>>>>>>>        move (ExtractInteger(str#,1)) to fd_file#
73391>>>>>>>        if fd_file# eq file# begin
73393>>>>>>>          move (ExtractWord(str#," ",3)) to fd_name#
73394>>>>>>>          if fd_name# eq (psLogicalName(self)) begin
73396>>>>>>>            move (SEQ_ReadLn(ch#)) to str# // Throw away RECNUM replace
73397>>>>>>>            move 0 to err#
73398>>>>>>>            move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,file#)) to max_field#
73399>>>>>>>            for field# from 1 to max_field#
73405>>>>>>>>
73405>>>>>>>              ifnot err# begin
73407>>>>>>>                move (SEQ_ReadLn(ch#)) to str#
73408>>>>>>>                if (ExtractItem(str#,". ",3)) ne (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_NAME,file#,field#)) move 1 to err#
73411>>>>>>>                ifnot err# begin
73413>>>>>>>                  move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,file#,field#)) to type#
73414>>>>>>>                  move "Z" to tmp#
73415>>>>>>>                  if type# eq DF_ASCII   move "S" to tmp#  // ascii   0
73418>>>>>>>                  if type# eq DF_BCD     move "N" to tmp#  // numeric 1
73421>>>>>>>                  if type# eq DF_DATE    move "D" to tmp#  // date    2
73424>>>>>>>                  if type# eq DF_OVERLAP move "S" to tmp#  // overlap 3
73427>>>>>>>                  if type# eq DF_TEXT    move "S" to tmp#  // text    5
73430>>>>>>>                  if type# eq DF_BINARY  move "S" to tmp#  // binary  6
73433>>>>>>>                  if tmp# ne (Check_FD_File_Help(self,str#)) move 1 to err#
73436>>>>>>>                end
73436>>>>>>>>
73436>>>>>>>              end
73436>>>>>>>>
73436>>>>>>>            loop
73437>>>>>>>>
73437>>>>>>>            if err# send add_error TDERROR_FILE_INCOMPATIBLE_FD3 "" "" "" ""
73440>>>>>>>          end
73440>>>>>>>>
73440>>>>>>>          else send add_error TDERROR_FILE_INCOMPATIBLE_FD2 fd_name# (psLogicalName(self)) 0 0
73442>>>>>>>        end
73442>>>>>>>>
73442>>>>>>>        else send add_error TDERROR_FILE_INCOMPATIBLE_FD1 fd_file# file# 0 0
73444>>>>>>>        send SEQ_CloseInput ch#
73445>>>>>>>      end
73445>>>>>>>>
73445>>>>>>>      else send add_error TDERROR_COULD_NOT_CHECK "Could not check FD file (not found)" "" "" ""
73447>>>>>>>    end
73447>>>>>>>>
73447>>>>>>>    else send add_error TDERROR_COULD_NOT_CHECK "Could not check FD file (not live data)" "" "" ""
73449>>>>>>>  end_procedure
73450>>>>>>>
73450>>>>>>>  procedure Check_TAG_File
73452>>>>>>>    integer oFDX# file# RealData#
73452>>>>>>>    integer ch# field_count# fields# eof#
73452>>>>>>>    string fn# field_name#
73452>>>>>>>    get piServer to oFDX#
73453>>>>>>>    get piFile to file#
73454>>>>>>>    get piRealData to RealData#
73455>>>>>>>    if RealData# begin
73457>>>>>>>      get psPhysicalName to fn#
73458>>>>>>>      move (SEQ_DirectInput(fn#+".TAG")) to ch#
73459>>>>>>>      if ch# ge 0 begin
73461>>>>>>>        move 0 to field_count#
73462>>>>>>>        repeat
73462>>>>>>>>
73462>>>>>>>          move (SEQ_ReadLn(ch#)) to field_name#
73463>>>>>>>          move (seqeof) to eof#
73464>>>>>>>          ifnot eof# begin
73466>>>>>>>            // Here we could check for legal field names!
73466>>>>>>>            increment field_count#
73467>>>>>>>          end
73467>>>>>>>>
73467>>>>>>>        until eof#
73469>>>>>>>        send SEQ_CloseInput ch#
73470>>>>>>>        move (FDX_AttrValue_FILE(oFDX#,DF_FILE_NUMBER_FIELDS,file#)) to fields#
73471>>>>>>>        if field_count# ne fields# send add_error TDERROR_FILE_INCOMPATIBLE_TAG field_count# fields# "" ""
73474>>>>>>>      end
73474>>>>>>>>
73474>>>>>>>      else send add_error TDERROR_COULD_NOT_CHECK "Could not check TAG file (not found)" "" "" ""
73476>>>>>>>    end
73476>>>>>>>>
73476>>>>>>>    else send add_error TDERROR_COULD_NOT_CHECK "Could not check TAG file (not live data)" "" "" ""
73478>>>>>>>  end_procedure
73479>>>>>>>
73479>>>>>>>  //> If compression is used check for presence of VLD file.
73479>>>>>>>  //> If integrity check is on check for presence of HDR file.
73479>>>>>>>  procedure Check_Missing_Files
73481>>>>>>>    integer oFDX# file# RealData#
73481>>>>>>>    string fn#
73481>>>>>>>    get piServer to oFDX#
73482>>>>>>>    get piFile to file#
73483>>>>>>>    get piRealData to RealData#
73484>>>>>>>    if (FDX_AttrValue_FILE(oFDX#,DF_FILE_DRIVER,file#)="DATAFLEX") begin
73486>>>>>>>      if RealData# begin
73488>>>>>>>        get psPhysicalName to fn#
73489>>>>>>>        if (integer(FDX_AttrValue_FILE(oFDX#,DF_FILE_COMPRESSION,file#))) ne DF_FILE_COMPRESS_NONE begin
73491>>>>>>>          if (iFileExists(self,fn#+".VLD")) ne SEQIT_FILE send add_error TDERROR_FILE_MISSING_VLD (fn#+".VLD") "" "" ""
73494>>>>>>>        end
73494>>>>>>>>
73494>>>>>>>        if (integer(FDX_AttrValue_FILE(oFDX#,DF_FILE_INTEGRITY_CHECK,file#))) eq DFTRUE begin
73496>>>>>>>          if (iFileExists(self,fn#+".HDR")) ne SEQIT_FILE send add_error TDERROR_FILE_MISSING_HDR (fn#+".HDR") "" "" ""
73499>>>>>>>        end
73499>>>>>>>>
73499>>>>>>>      end
73499>>>>>>>>
73499>>>>>>>      else send add_error TDERROR_COULD_NOT_CHECK "Could not check missing files (not live data)" "" "" ""
73501>>>>>>>    end
73501>>>>>>>>
73501>>>>>>>  end_procedure
73502>>>>>>>
73502>>>>>>>  //> Reports errors/warnings if:
73502>>>>>>>  //> 1. Related file not available
73502>>>>>>>  //> 2. Relation mismatch
73502>>>>>>>  //> 3. Related file not (uniquely) indexed on related field
73502>>>>>>>  //> 4. Related field has got wrong main index
73502>>>>>>>  //> 5. Relation using recnum
73502>>>>>>>
73502>>>>>>>  procedure Check_Relations
73504>>>>>>>    integer file# oFDX# field# rel_file# rel_field# index# max_field#
73504>>>>>>>    integer rel_count#
73504>>>>>>>    integer CanCheckAvailable# Can_Open# type# rel_index#
73504>>>>>>>    integer max_pos# pos#
73504>>>>>>>    string  Files# rel_root# rel_index_fields# rel_fields# index_field#
73504>>>>>>>
73504>>>>>>>    get piServer to oFDX#
73505>>>>>>>    get piFile to file#
73506>>>>>>>
73506>>>>>>>    get iFdxIsEncapsulated of oFDX# to CanCheckAvailable# // Check for availability of related tables
73507>>>>>>>    move "" to files#
73508>>>>>>>    get FDX_AttrValue_FILE oFDX# DF_FILE_NUMBER_FIELDS file# to max_field#
73509>>>>>>>    for field# from 1 to max_field#
73515>>>>>>>>
73515>>>>>>>      get FDX_AttrValue_FIELD oFDX# DF_FIELD_RELATED_FILE file# field# to rel_file#
73516>>>>>>>      get FDX_AttrValue_FIELD oFDX# DF_FIELD_RELATED_FIELD file# field# to rel_field#
73517>>>>>>>
73517>>>>>>>      if rel_file# begin // If there's a relation
73519>>>>>>>
73519>>>>>>>        // Check that there is no more than one relating field to that file:
73519>>>>>>>        move (mid(files#,1,rel_file#)) to rel_count#
73520>>>>>>>        increment rel_count#
73521>>>>>>>        move (overstrike(string(rel_count#),files#,rel_file#)) to files#
73522>>>>>>>        if rel_count# eq 2 send add_error TDERROR_REL_MORE_THAN_ONE rel_file# "" "" ""
73525>>>>>>>
73525>>>>>>>        // Check that related file is avaiable:
73525>>>>>>>        if (rel_count#=1 and CanCheckAvailable#) begin
73527>>>>>>>          get FDX_AttrValue_FILELIST oFDX# DF_FILE_ROOT_NAME file# to rel_root#
73528>>>>>>>          if rel_root# eq "" send add_error TDERROR_REL_FILE_NOT_AVAILABLE1 field# rel_file# "" ""
73531>>>>>>>          else begin
73532>>>>>>>            get iCanOpen.i of oFDX# file# to can_open#
73533>>>>>>>            ifnot can_open# send add_error TDERROR_REL_FILE_NOT_AVAILABLE2 field# rel_file# "" ""
73536>>>>>>>          end
73536>>>>>>>>
73536>>>>>>>        end
73536>>>>>>>>
73536>>>>>>>
73536>>>>>>>        if (CanCheckAvailable# and iCanOpen.i(oFDX#,rel_file#)) begin
73538>>>>>>>
73538>>>>>>>          // Check for field type match:
73538>>>>>>>          ifnot (FDX_FieldIdenticalFieldDefinition(oFDX#,file#,field#,rel_file#,rel_field#)) begin
73540>>>>>>>            // We must filter out the case where recnum is used:
73540>>>>>>>            if rel_field# ne 0 send add_error TDERROR_REL_MISMATCH1 field# rel_file# rel_field# ""
73543>>>>>>>          end
73543>>>>>>>>
73543>>>>>>>          else begin
73544>>>>>>>            move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,file#,field#)) to type#
73545>>>>>>>            // If overlap field we must also check the underlying fields
73545>>>>>>>            if type# eq DF_OVERLAP begin
73547>>>>>>>              ifnot (FDX_FieldIdenticalOverlapStructures(oFDX#,file#,field#,rel_file#,rel_field#)) send add_error TDERROR_REL_MISMATCH2 field# rel_file# rel_field# ""
73550>>>>>>>            end
73550>>>>>>>>
73550>>>>>>>          end
73550>>>>>>>>
73550>>>>>>>
73550>>>>>>>          // Check if index is RECNUM
73550>>>>>>>          ifnot rel_field# send add_error TDERROR_REL_RECNUM_BASED field# rel_file# "" ""
73553>>>>>>>          else begin
73554>>>>>>>            if (integer(FDX_AttrValue_FILE(oFDX#,DF_FILE_IS_SYSTEM_FILE,rel_file#))) eq DFTRUE send add_error TDERROR_REL_TO_SYSTEM_FILE field# rel_file# "" ""
73557>>>>>>>            else begin
73558>>>>>>>              // Check to see if related file is uniquely indexed on that related field:
73558>>>>>>>              get FDX_IndexFindUnique oFDX# rel_file# rel_field# 0 to rel_index#
73559>>>>>>>              if rel_index# begin
73561>>>>>>>                get FDX_AttrValue_FIELD oFDX# DF_FIELD_INDEX rel_file# rel_field# to rel_index#
73562>>>>>>>                if rel_index# begin
73564>>>>>>>
73564>>>>>>>                  // Retrieve fields in related index:
73564>>>>>>>                  get FDX_IndexAsFields oFDX# rel_file# rel_index# to rel_index_fields#
73565>>>>>>>                  get FDX_FieldsTranslateOverlaps oFDX# rel_file# rel_index_fields# to rel_index_fields#
73566>>>>>>>                  get FDX_FieldsRemoveDublettes rel_index_fields# to rel_index_fields#
73567>>>>>>>
73567>>>>>>>
73567>>>>>>>                  get FDX_FieldsTranslateOverlaps oFDX# rel_file# rel_field# to rel_fields#
73568>>>>>>>                  get FDX_FieldsRemoveDublettes rel_fields# to rel_fields#
73569>>>>>>>                  move (length(rel_fields#)/4) to max_pos#
73570>>>>>>>                  for pos# from 1 to max_pos#
73576>>>>>>>>
73576>>>>>>>                    move (mid(rel_fields#,4,pos#-1*4+1)) to index_field#
73577>>>>>>>                    move (replace(index_field#,rel_index_fields#,"")) to rel_index_fields#
73578>>>>>>>                  loop
73579>>>>>>>>
73579>>>>>>>                  if rel_index_fields# ne "" send add_error TDERROR_REL_FIELD_WRONG_MAIN_INDEX field# rel_file# rel_field# ""
73582>>>>>>>                end
73582>>>>>>>>
73582>>>>>>>                else send add_error TDERROR_REL_FIELD_NO_MAIN_INDEX field# rel_file# rel_field# ""
73584>>>>>>>              end
73584>>>>>>>>
73584>>>>>>>              else send add_error TDERROR_REL_FIELD_NOT_UNIQUELY_INDEXED field# rel_file# rel_field# ""
73586>>>>>>>            end
73586>>>>>>>>
73586>>>>>>>          end
73586>>>>>>>>
73586>>>>>>>        end
73586>>>>>>>>
73586>>>>>>>      end
73586>>>>>>>>
73586>>>>>>>    loop
73587>>>>>>>>
73587>>>>>>>  end_procedure
73588>>>>>>>
73588>>>>>>>  //> Reports errors/warnings if:
73588>>>>>>>  //>   Same field appears more than once in an index
73588>>>>>>>  //>   Recnum is part of an index while not being the last field
73588>>>>>>>  //>   Non-ASCII field marked as U/C in index
73588>>>>>>>  //>   Index file not found (DataFlex only)
73588>>>>>>>  //>   Superflous index (One index is a sub-ordering of another or is identical)
73588>>>>>>>  //>   Index on system file
73588>>>>>>>  procedure Check_Indices
73590>>>>>>>    integer oFDX#
73590>>>>>>>    integer file#
73590>>>>>>>    integer RealData#
73590>>>>>>>    integer index1#
73590>>>>>>>    integer index2#
73590>>>>>>>    integer field1#
73590>>>>>>>    integer field2#
73590>>>>>>>    integer DataFlex#
73590>>>>>>>    integer max_seg#
73590>>>>>>>    integer segment#
73590>>>>>>>    integer oCheckIndexSet#
73590>>>>>>>    integer fin#
73590>>>>>>>    integer case#
73590>>>>>>>    string  fn#
73590>>>>>>>    string  fields1#
73590>>>>>>>    string  fields2#
73590>>>>>>>    string  check_doubles#
73590>>>>>>>    string  field#
73590>>>>>>>
73590>>>>>>>    get piServer to oFDX#
73591>>>>>>>    get piFile to file#
73592>>>>>>>    get piRealData to RealData#
73593>>>>>>>    get piDataFlex to DataFlex#
73594>>>>>>>    move (oCheckIndexSet(self)) to oCheckIndexSet#
73595>>>>>>>    get psPhysicalName to fn#
73596>>>>>>>    for index1# from 1 to 16
73602>>>>>>>>
73602>>>>>>>      get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# index1# to max_seg#
73603>>>>>>>      if max_seg# begin // If there's an index at all
73605>>>>>>>        if (DataFlex# and RealData#) begin
73607>>>>>>>          // Check if we can find index file
73607>>>>>>>          if (iFileExists(self,fn#+".K"+string(index1#))) ne SEQIT_FILE send add_error TDERROR_IDX_MISSING_FILE (fn#+".K"+string(index1#)) index1# "" ""
73610>>>>>>>        end
73610>>>>>>>>
73610>>>>>>>
73610>>>>>>>        send delete_data to oCheckIndexSet#
73611>>>>>>>        get FDX_IndexAsFields oFDX# file# index1# to fields1#
73612>>>>>>>
73612>>>>>>>        move (length(fields1#)/4) to max_seg#
73613>>>>>>>        move "" to check_doubles#
73614>>>>>>>        for segment# from 1 to max_seg#
73620>>>>>>>>
73620>>>>>>>          move (mid(fields1#,4,segment#-1*4+1)) to field#
73621>>>>>>>
73621>>>>>>>          // Check for dublettes:
73621>>>>>>>          ifnot field# in check_doubles# move (check_doubles#+field#) to check_doubles#
73624>>>>>>>          else send add_error TDERROR_IDX_SAME_FIELD (trim(field#)) index1# "" ""
73626>>>>>>>
73626>>>>>>>          // Recnum not at end?
73626>>>>>>>          if (not(field#) and segment#<>max_seg#) send add_error TDERROR_IDX_RECNUM_NOT_AT_END index1# "" "" ""
73629>>>>>>>
73629>>>>>>>          // Uppercase on non ASCII field?
73629>>>>>>>
73629>>>>>>>          if (integer(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,file#,integer(trim(field#))))) ne DF_ASCII begin
73631>>>>>>>            get FDX_AttrValue_IDXSEG oFDX# DF_INDEX_SEGMENT_CASE file# index1# segment# to case#
73632>>>>>>>            if case# eq DF_CASE_IGNORED send add_error TDERROR_IDX_UPPERCASE_ERROR field# index1# "" ""
73635>>>>>>>          end
73635>>>>>>>>
73635>>>>>>>        loop
73636>>>>>>>>
73636>>>>>>>
73636>>>>>>>        for index2# from (index1#+1) to 16 // Compare to all other indices:
73642>>>>>>>>
73642>>>>>>>          if (integer(FDX_AttrValue_INDEX(oFDX#,DF_INDEX_NUMBER_SEGMENTS,file#,index2#))) begin
73644>>>>>>>            get FDX_IndexAsFields oFDX# file# index2# to fields2#
73645>>>>>>>            get FDX_FieldsTranslateOverlaps oFDX# file# fields2# to fields2#
73646>>>>>>>
73646>>>>>>>            move 0 to segment#
73647>>>>>>>            move 0 to fin#
73648>>>>>>>            repeat
73648>>>>>>>>
73648>>>>>>>              move (segment#>15) to fin#
73649>>>>>>>              ifnot fin# begin
73651>>>>>>>                move (mid(fields1#,4,segment#*4+1)) to field1#
73652>>>>>>>                move (mid(fields2#,4,segment#*4+1)) to field2#
73653>>>>>>>                if field1# eq field2# increment segment#
73656>>>>>>>                else begin
73657>>>>>>>                  if (field1#=0 or field2#=0) send add_error TDERROR_IDX_SUPERFLOUS (if(field1#<>0,index2#,index1#)) (if(field1#<>0,index1#,index2#)) "" ""
73660>>>>>>>                  move 1 to fin#
73661>>>>>>>                end
73661>>>>>>>>
73661>>>>>>>              end
73661>>>>>>>>
73661>>>>>>>            until fin#
73663>>>>>>>            if segment# eq 16 send add_error TDERROR_IDX_IDENTICAL index1# index2# "" ""
73666>>>>>>>          end
73666>>>>>>>>
73666>>>>>>>        loop
73667>>>>>>>>
73667>>>>>>>      end
73667>>>>>>>>
73667>>>>>>>    loop
73668>>>>>>>>
73668>>>>>>>  end_procedure
73669>>>>>>>
73669>>>>>>>  procedure Check_Table integer lhFDX integer liFile
73671>>>>>>>    integer lbDataFlex lbRealData
73671>>>>>>>    string lsRoot
73671>>>>>>>    move (DBMS_DriverNameToType(FDX_AttrValue_FILE(lhFDX,DF_FILE_DRIVER,liFile))=DBMS_DRIVER_DATAFLEX) to lbDataFlex
73672>>>>>>>    if lhFDX move (piDataOrigin(lhFDX)=FDX_REAL_WORLD) to lbRealData
73675>>>>>>>    else move 1 to lbRealData
73677>>>>>>>    set piFile to liFile
73678>>>>>>>    send AddItemIfNotAlready to (oFdxSetOfTables(self)) liFile 0
73679>>>>>>>    set psLogicalName  to (FDX_AttrValue_FILELIST(lhFDX,DF_FILE_LOGICAL_NAME,liFile))
73680>>>>>>>    move (FDX_AttrValue_FILELIST(lhFDX,DF_FILE_ROOT_NAME,liFile)) to lsRoot
73681>>>>>>>    set psPhysicalName to lsRoot
73682>>>>>>>    set piRealData to lbRealData
73683>>>>>>>    set piDataFlex to lbDataFlex
73684>>>>>>>    set piServer to lhFDX
73685>>>>>>>    if (liFile=207 and lsRoot<>"" and not(uppercase(lsRoot) contains "CODETYPE")) send add_error TDERROR_FILE_ENTRY_207 lsRoot "" "" ""
73688>>>>>>>    if (liFile=208 and lsRoot<>"" and not(uppercase(lsRoot) contains "CODEMAST")) send add_error TDERROR_FILE_ENTRY_208 lsRoot "" "" ""
73691>>>>>>>    send Check_FD_File
73692>>>>>>>    send Check_TAG_File
73693>>>>>>>    send Check_Missing_Files
73694>>>>>>>    send Check_Relations
73695>>>>>>>    send Check_Indices
73696>>>>>>>  end_procedure
73697>>>>>>>end_class // cFdxCheck
73698>>>>>>>
73698>>>>>>>desktop_section
73703>>>>>>>  object oFdxCheck is a cFdxCheck NO_IMAGE
73705>>>>>>>  end_object
73706>>>>>>>end_desktop_section
73711>>>>>>>
73711>>>>>>>//> Reset set the oFdxCheck object.
73711>>>>>>>procedure DoFdxCheckReset global
73713>>>>>>>  send reset to (oFdxCheck(self))
73714>>>>>>>end_procedure
73715>>>>>>>//> Send this message to have the oFdxCheck object check whatever conditions
73715>>>>>>>//> it checks for a given file.
73715>>>>>>>//> NOTE that oFDX# must be the same for all subsequent calls of this procedure.
73715>>>>>>>procedure DoFdxCheckTable global integer oFDX# integer file#
73717>>>>>>>  send Check_Table to (oFdxCheck(self)) oFDX# file#
73718>>>>>>>end_procedure
73719>>>>>>>//> Returns the object ID of the SetOfTables object inside global object
73719>>>>>>>//> oFdxCheck.
73719>>>>>>>function FdxCheck_SOT_Object global returns integer
73721>>>>>>>  function_return (oFdxSetOfTables(oFdxCheck(self)))
73722>>>>>>>end_function
73723>>>>>Use FdxSet.pkg   // cFdxSetOfFieldsList class
73723>>>>>
73723>>>>>Use RGB.utl      // Some color functions
73723>>>>>class cFdxCheckErrorList is a aps.Grid
73724>>>>>  procedure construct_object integer img#
73726>>>>>    forward send construct_object img#
73728>>>>>    property integer piServer public 0 // SOF = SetOfTables
73729>>>>>    property integer piDetailLevel public TDINFO_WARNING
73730>>>>>    set line_width to 4 0
73731>>>>>    send GridPrepare_AddColumn "#"          AFT_ASCII4
73732>>>>>    send GridPrepare_AddColumn "Root name"  AFT_ASCII32
73733>>>>>    send GridPrepare_AddColumn "Err#"       AFT_ASCII4
73734>>>>>    send GridPrepare_AddColumn "Error text" AFT_ASCII40
73735>>>>>    send GridPrepare_Apply self
73736>>>>>    //set current_item_color of obj# to clBlue
73736>>>>>    set select_mode to no_select
73737>>>>>    on_key KNEXT_ITEM send switch
73738>>>>>    on_key KPREVIOUS_ITEM send switch_back
73739>>>>>    on_key KENTER send NEXT
73740>>>>>    on_key KEY_CTRL+KEY_R send sort_data
73741>>>>>    on_key KEY_CTRL+KEY_C send Toggle_DetailLevel
73742>>>>>    on_key KEY_CTRL+KEY_W send DoWriteToFile
73743>>>>>  end_procedure
73744>>>>>
73744>>>>>  procedure DoWriteToFile
73746>>>>>    send Grid_DoWriteToFile self
73747>>>>>  end_procedure
73748>>>>>
73748>>>>>  procedure Toggle_DetailLevel
73750>>>>>    integer iDtlLvl
73750>>>>>    get piDetailLevel to iDtlLvl
73751>>>>>    if iDtlLvl eq TDINFO_INFO move TDINFO_WARNING to iDtlLvl
73754>>>>>    else if iDtlLvl eq TDINFO_WARNING move TDINFO_ERROR to iDtlLvl
73758>>>>>    else if iDtlLvl eq TDINFO_ERROR move TDINFO_INFO to iDtlLvl
73762>>>>>    set piDetailLevel to iDtlLvl
73763>>>>>    send fill_list.i (piServer(self))
73764>>>>>  end_procedure
73765>>>>>
73765>>>>>  function sErrorClassText.i integer cls# returns string
73767>>>>>    if cls# eq TDINFO_INFO    function_return "Info"
73770>>>>>    if cls# eq TDINFO_WARNING function_return "Warning"
73773>>>>>    if cls# eq TDINFO_ERROR   function_return "Error"
73776>>>>>  end_function
73777>>>>>
73777>>>>>  function Row_File integer row# returns integer
73779>>>>>    integer columns#
73779>>>>>    get Grid_Columns self to columns#
73780>>>>>    function_return (value(self,row#*columns#))
73781>>>>>  end_function
73782>>>>>  procedure OnChangeFile integer row#
73784>>>>>    if (item_count(self)) begin
73786>>>>>      //if (Row_Shadow_State(self,row#)) send DFMatrix_NewFileInSelector 0
73786>>>>>      send DFMatrix_NewFileInSelector (Row_File(self,row#))
73787>>>>>    end
73787>>>>>>
73787>>>>>  end_procedure
73788>>>>>  procedure OnErrorChange string full_error_text# integer error_class#
73790>>>>>  end_procedure
73791>>>>>  procedure row_change integer row_from# integer row_to#
73793>>>>>    integer row# srv# base#
73793>>>>>    send OnChangeFile row_to#
73794>>>>>    get Grid_RowBaseItem self row_to# to base#
73795>>>>>    get piServer to srv#
73796>>>>>    get aux_value item base# to row#
73797>>>>>    send OnErrorChange (sErrorText2.i(srv#,row#)) (iErrorClass.i(srv#,row#))
73798>>>>>  end_procedure
73799>>>>>  procedure item_change integer i1# integer i2# returns integer
73801>>>>>    integer rval# row_from# row_to# columns#
73801>>>>>    get Grid_Columns self to columns#
73802>>>>>    forward get msg_item_change i1# i2# to rval#
73804>>>>>    if (i1#/columns#) ne (i2#/columns#) send row_change (i1#/columns#) (i2#/columns#)
73807>>>>>    procedure_return rval#
73808>>>>>  end_procedure
73809>>>>>
73809>>>>>  function iSpecialSortValueOnColumn.i integer column# returns integer
73811>>>>>    if column# eq 0 function_Return 1
73814>>>>>    if column# eq 2 function_Return 2
73817>>>>>  end_function
73818>>>>>
73818>>>>>  function sSortValue.ii integer column# integer itm# returns string
73820>>>>>    if column# eq 0 function_return (IntToStrR(value(self,itm#),4))
73823>>>>>    if column# eq 2 function_return (IntToStrR(value(self,itm#),4))
73826>>>>>  end_function
73827>>>>>
73827>>>>>  procedure sort_data.i integer column#
73829>>>>>    send Grid_SortByColumn self column#
73830>>>>>  end_procedure
73831>>>>>
73831>>>>>  procedure sort_data
73833>>>>>    integer cc#
73833>>>>>    get Grid_CurrentColumn self to cc#
73834>>>>>    send sort_data.i cc#
73835>>>>>  end_procedure
73836>>>>>  procedure header_mouse_click integer itm#
73838>>>>>    send sort_data.i itm#
73839>>>>>    forward send header_mouse_click itm#
73841>>>>>  end_procedure
73842>>>>>  function iClassColor.i integer iCls returns integer
73844>>>>>    integer iClr
73844>>>>>    if iCls eq TDINFO_INFO    function_return (RGB_Brighten(clGreen,75))
73847>>>>>    if iCls eq TDINFO_WARNING function_return (RGB_Brighten(clYellow,75))
73850>>>>>    if iCls eq TDINFO_ERROR   function_return (RGB_Brighten(clRed,75))
73853>>>>>  end_function
73854>>>>>  function sDetail_Level_Text.i integer lvl# returns string
73856>>>>>    if lvl# eq TDINFO_INFO    function_return "All"
73859>>>>>    if lvl# eq TDINFO_WARNING function_return "Warnings and Errors"
73862>>>>>    if lvl# eq TDINFO_ERROR   function_return "Errors only"
73865>>>>>  end_function
73866>>>>>  procedure fill_list.i integer oFdxCheck#
73868>>>>>    integer error_count# warning_count# err# err_class# iBase srv#
73868>>>>>    integer color# file# row# max# iDtlLvl oFDX#
73868>>>>>    move 0 to error_count#
73869>>>>>    move 0 to warning_count#
73870>>>>>    send delete_data
73871>>>>>    if oFdxCheck# eq 0 procedure_return
73874>>>>>    set dynamic_update_state to DFFALSE
73875>>>>>    get piDetailLevel to iDtlLvl
73876>>>>>    get row_count of oFdxCheck# to max#
73877>>>>>    set piServer to oFdxCheck#
73878>>>>>    get piServer of oFdxCheck# to oFDX#
73879>>>>>    decrement max#
73880>>>>>    for row# from 0 to max#
73886>>>>>>
73886>>>>>      get iErrorClass.i of oFdxCheck# row# to err_class#
73887>>>>>      if err_class# ge iDtlLvl begin
73889>>>>>        get piFile.i      of oFdxCheck# row# to file#
73890>>>>>        get piError.i     of oFdxCheck# row# to err#
73891>>>>>        get item_count to iBase
73892>>>>>        send add_item msg_none (string(file#))
73893>>>>>        send add_item msg_none (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_ROOT_NAME,file#))
73894>>>>>        send add_item msg_none (string(err#))
73895>>>>>        send add_item msg_none (sErrorText1.i(oFdxCheck#,row#))
73896>>>>>        set aux_value item iBase to row#
73897>>>>>        get iClassColor.i err_class# to color#
73898>>>>>        set ItemColor item (iBase+3) to color#
73899>>>>>      end
73899>>>>>>
73899>>>>>      if err_class# eq TDINFO_ERROR   increment error_count#
73902>>>>>      if err_class# eq TDINFO_WARNING increment warning_count#
73905>>>>>    loop
73906>>>>>>
73906>>>>>    send Grid_SetEntryState self DFFALSE
73907>>>>>    send update_display_counter error_count# warning_count# (sDetail_Level_Text.i(self,iDtlLvl))
73908>>>>>    set dynamic_update_state to DFTRUE
73909>>>>>    if (item_count(self)) begin
73911>>>>>      get piServer to srv#
73912>>>>>      send OnErrorChange (sErrorText2.i(srv#,0)) (iErrorClass.i(srv#,0))
73913>>>>>    end
73913>>>>>>
73913>>>>>    else send OnErrorChange "" ""
73915>>>>>  end_procedure
73916>>>>>  procedure update_display_counter integer errors# integer warnings# string detail_level_text#
73918>>>>>  end_procedure
73919>>>>>end_class // cFdxCheckErrorList
73920>>>>>
73920>>>
73920>>>register_object oGrp
73920>>>register_object oFrm_ErrorText
73920>>>object oFdxCheck_Vw is a aps.View label "Check definitions"
73923>>>  property integer piDoRunOnActivate public 0
73925>>>  on_key KCANCEL send close_panel
73926>>>  object oLst is a cFdxCheckErrorList
73928>>>    procedure OnErrorChange string full_error_text# integer error_class#
73931>>>      set value of (oFrm_ErrorText(oGrp(self))) item 0 to full_error_text#
73932>>>      set label of (oFrm_ErrorText(oGrp(self))) to (sErrorClassText.i(self,error_class#)+":")
73933>>>    end_procedure
73934>>>    procedure update_display_counter integer errors# integer warnings# string detail_level_text#
73937>>>      string str#
73937>>>      move "# error(s) and # warning(s), displaying #" to str#
73938>>>      replace "#" in str# with errors#
73940>>>      replace "#" in str# with warnings#
73942>>>      replace "#" in str# with (lowercase(detail_level_text#))
73944>>>      send UpdateTotal str#
73945>>>    end_procedure
73946>>>  end_object
73947>>>  object oTotal is a aps.TextBox snap SL_DOWN
73950>>>    set fixed_size to 0 200
73951>>>    set auto_size_state to DFFALSE
73952>>>    set Justification_Mode to JMODE_LEFT
73953>>>  end_object
73954>>>  procedure UpdateTotal string str#
73957>>>    set label of (oTotal(self)) to str#
73958>>>  end_procedure
73959>>>  object oGrp is a aps.Group label "Current error info" snap SL_DOWN
73963>>>    object oFrm_ErrorText is a aps.Form abstract AFT_ASCII60 label "Error:"
73967>>>      set enabled_state to DFFALSE
73968>>>      Set Fontweight to 900
73969>>>    end_object
73970>>>  end_object
73971>>>  send aps_align_by_sizing (oGrp(self)) (oLst(self)) SL_ALIGN_RIGHT
73972>>>  procedure update_display
73975>>>    integer iObj
73975>>>    move (oFdxCheck(self)) to iObj
73976>>>    send fill_list.i to (oLst(self)) iObj
73977>>>  end_procedure
73978>>>
73978>>>  procedure Callback_Filelist_Entry integer file# integer selected# integer shaded#
73981>>>    send DoFdxCheckTable (fdx.object_id(0)) file#
73982>>>  end_procedure
73983>>>
73983>>>  procedure DoRun
73986>>>    integer select_count#
73986>>>    send cursor_wait to (cursor_control(self))
73987>>>    send DoFdxCheckReset
73988>>>    send DFMatrix_CallBack_Selected_Files msg_Callback_Filelist_Entry self -1 0 1 // Selected=Dont care, shaded=0, master tables only
73989>>>    send update_display
73990>>>    send cursor_ready to (cursor_control(self))
73991>>>  end_procedure
73992>>>
73992>>>  procedure OnChangeFDX_Broadcasted
73995>>>    set delegation_mode to DELEGATE_TO_PARENT
73996>>>    if (active_state(self)) send DoRun
73999>>>    else set piDoRunOnActivate to DFTRUE
74001>>>  end_procedure
74002>>>
74002>>>  procedure DoDisplayDefinitionFromCheckView
74005>>>    integer vw# sz#
74005>>>    move (oFdxDisplayFileAttributes(self)) to vw#
74006>>>    ifnot (active_state(vw#)) begin
74008>>>      send Activate_Table_Definition
74009>>>      set location to 5 5
74010>>>      get size to sz#
74011>>>      move (hi(sz#)) to sz#
74012>>>      send aps_onResize (230-sz#) 0
74013>>>      set location of vw# to 235 5
74014>>>    end
74014>>>>
74014>>>    else send Activate_Table_Definition
74016>>>  end_procedure
74017>>>  object oBtn1 is a aps.Multi_Button
74019>>>    on_item "Show &definition" send DoDisplayDefinitionFromCheckView
74020>>>  end_object
74021>>>  object oBtn2 is a aps.Multi_Button
74023>>>    on_item "Severity level" send Toggle_DetailLevel to (oLst(self))
74024>>>  end_object
74025>>>  object oBtn3 is a aps.Multi_Button
74027>>>    on_item "Close" send close_panel
74028>>>  end_object
74029>>>  send aps_locate_multi_buttons
74030>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
74031>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
74034>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
74035>>>    send aps_auto_locate_control (oTotal(self)) SL_DOWN
74036>>>    send aps_auto_locate_control (oGrp(self)) SL_DOWN
74037>>>    send aps_register_multi_button (oBtn1(self))
74038>>>    send aps_register_multi_button (oBtn2(self))
74039>>>    send aps_register_multi_button (oBtn3(self))
74040>>>    send aps_locate_multi_buttons
74041>>>    send aps_auto_size_container
74042>>>  end_procedure
74043>>>  procedure popup
74046>>>    forward send popup
74048>>>    if (piDoRunOnActivate(self)) send DoRun
74051>>>    set piDoRunOnActivate to DFFALSE
74052>>>  end_procedure
74053>>>end_object // oFdxCheck_Vw
74054>>>
74054>>>procedure Activate_FdxCheck_Vw
74057>>>  send popup to (oFdxCheck_Vw(self))
74058>>>end_procedure
74059>
74059>    Use FDXSet.vw    // Display contents of cSetOfFiles cSetOfFields
74059>    Use DfmFnc01.pkg // Create table definitions (Popup_CreateFromFdx)
Including file: dfmfnc01.pkg    (C:\Apps\VDFQuery\AppSrc\dfmfnc01.pkg)
74059>>>Use Files.utl    // Utilities for handling file related stuff
74059>>>Use StructEx.utl // Restructuring extensions
Including file: structex.utl    (C:\Apps\VDFQuery\AppSrc\structex.utl)
74059>>>>>// Use StructEx.utl // Restructuring extensions
74059>>>>>
74059>>>>>Use Fdx_Attr.utl // FDX compatible attribute functions
74059>>>>>Use Structur.utl // Object for restructuring table definitions
74059>>>>>
74059>>>>>function RSX_CreateTableFromFDX global integer lhFDX integer liFile string lsRoot returns integer
74061>>>>>  integer liField liMax liIndex liSegment liMaxSegment liTmp
74061>>>>>  integer liLockType liType liRelFile liRelField liMainIndex liDir
74061>>>>>  integer liValue
74061>>>>>  string lsRN
74061>>>>>  if lsRoot ne "" move lsRoot to lsRN
74064>>>>>  else move (FDX_AttrValue_FILELIST(lhFDX,DF_FILE_ROOT_NAME,liFile)) to lsRN
74066>>>>>
74066>>>>>//  get DBMS_StripPathAndDriver lsRN to lsRN
74066>>>>>//  get HowManyWords lsRN "/\:" to liTmp
74066>>>>>//  if (liTmp<>1) get ExtractWord lsRN "/\:" liTmp to lsRN // get rid of driver and path
74066>>>>>
74066>>>>>  if lsRN ne "" begin
74068>>>>>    if (RS_TableCreateName(lsRN)) begin
74070>>>>>      // Create fields:
74070>>>>>      move (FDX_AttrValue_FILE(lhFDX,DF_FILE_NUMBER_FIELDS,liFile)) to liMax
74071>>>>>      for liField from 1 to liMax
74077>>>>>>
74077>>>>>        move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_TYPE,liFile,liField)) to liType
74078>>>>>        send RS_AppendField (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_NAME,liFile,liField)) liType
74079>>>>>        if liType ne DF_DATE ;          send RS_SetFieldAttr DF_FIELD_LENGTH IMPLICIT_FIELD (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_LENGTH,liFile,liField))
74082>>>>>        if liType eq DF_BCD ;          send RS_SetFieldAttr DF_FIELD_PRECISION IMPLICIT_FIELD (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_PRECISION,liFile,liField))
74085>>>>>        move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_RELATED_FILE,liFile,liField))  to liRelFile
74086>>>>>        move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_RELATED_FIELD,liFile,liField)) to liRelField
74087>>>>>        move (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_INDEX,liFile,liField))         to liMainIndex
74088>>>>>        if liRelFile   send RS_SetFieldAttr DF_FIELD_RELATED_FILE  IMPLICIT_FIELD liRelFile
74091>>>>>        if liRelField  send RS_SetFieldAttr DF_FIELD_RELATED_FIELD IMPLICIT_FIELD liRelField
74094>>>>>        if liMainIndex send RS_SetFieldAttr DF_FIELD_INDEX         IMPLICIT_FIELD liMainIndex
74097>>>>>        if liType eq DF_OVERLAP ;          send RS_SetFieldAttr DF_FIELD_OFFSET IMPLICIT_FIELD (FDX_AttrValue_FIELD(lhFDX,DF_FIELD_OFFSET,liFile,liField))
74100>>>>>      loop
74101>>>>>>
74101>>>>>      for liIndex from 1 to 15
74107>>>>>>
74107>>>>>        move (integer(FDX_AttrValue_INDEX(lhFDX,DF_INDEX_NUMBER_SEGMENTS,liFile,liIndex))) to liMaxSegment
74108>>>>>        if liMaxSegment begin
74110>>>>>          send RS_SetIndexAttr DF_INDEX_NUMBER_SEGMENTS liIndex liMaxSegment
74111>>>>>          for liSegment from 1 to liMaxSegment
74117>>>>>>
74117>>>>>            send RS_SetIndexSegAttr DF_INDEX_SEGMENT_FIELD     liIndex liSegment (FDX_AttrValue_IDXSEG(lhFDX,DF_INDEX_SEGMENT_FIELD    ,liFile,liIndex,liSegment))
74118>>>>>            get FDX_AttrValue_IDXSEG lhFDX DF_INDEX_SEGMENT_DIRECTION liFile liIndex liSegment to liDir
74119>>>>>            send RS_SetIndexSegAttr DF_INDEX_SEGMENT_DIRECTION liIndex liSegment liDir // (FDX_AttrValue_IDXSEG(lhFDX,DF_INDEX_SEGMENT_DIRECTION,liFile,liIndex,liSegment))
74120>>>>>            send RS_SetIndexSegAttr DF_INDEX_SEGMENT_CASE      liIndex liSegment (FDX_AttrValue_IDXSEG(lhFDX,DF_INDEX_SEGMENT_CASE     ,liFile,liIndex,liSegment))
74121>>>>>          loop
74122>>>>>>
74122>>>>>          send RS_SetIndexAttr DF_INDEX_TYPE liIndex (FDX_AttrValue_INDEX(lhFDX,DF_INDEX_TYPE,liFile,liIndex))
74123>>>>>        end
74123>>>>>>
74123>>>>>      loop
74124>>>>>>
74124>>>>>
74124>>>>>      // File parameters:
74124>>>>>
74124>>>>>      move (FDX_AttrValue_FILE(lhFDX,DF_FILE_MAX_RECORDS    ,liFile)) to liValue
74125>>>>>      if (liValue>16711679) move 16711679 to liValue
74128>>>>>      send RS_SetFileAttr DF_FILE_MAX_RECORDS     liValue
74129>>>>>
74129>>>>>      send RS_SetFileAttr DF_FILE_MULTIUSER       (FDX_AttrValue_FILE(lhFDX,DF_FILE_MULTIUSER      ,liFile))
74130>>>>>      send RS_SetFileAttr DF_FILE_REUSE_DELETED   (FDX_AttrValue_FILE(lhFDX,DF_FILE_REUSE_DELETED  ,liFile))
74131>>>>>      send RS_SetFileAttr DF_FILE_COMPRESSION     (FDX_AttrValue_FILE(lhFDX,DF_FILE_COMPRESSION    ,liFile))
74132>>>>>      send RS_SetFileAttr DF_FILE_RECORD_LENGTH   (FDX_AttrValue_FILE(lhFDX,DF_FILE_RECORD_LENGTH  ,liFile))
74133>>>>>      send RS_SetFileAttr DF_FILE_INTEGRITY_CHECK (FDX_AttrValue_FILE(lhFDX,DF_FILE_INTEGRITY_CHECK,liFile))
74134>>>>>
74134>>>>>      move (FDX_AttrValue_FILE(lhFDX,DF_FILE_TRANSACTION    ,liFile)) to liValue
74135>>>>>      if (liValue=DF_FILE_TRANSACTION_SERVER_LOGGED) move DF_FILE_TRANSACTION_CLIENT_ATOMIC to liValue
74138>>>>>      send RS_SetFileAttr DF_FILE_TRANSACTION     liValue
74139>>>>>
74139>>>>>      // Mysteriously we have to 'fork' lock type in place. Apparently
74139>>>>>      // DF_FILE_LOCK_TYPE *may* return 255, which is not a legal value.
74139>>>>>      move (FDX_AttrValue_FILE(lhFDX,DF_FILE_LOCK_TYPE,liFile)) to liLockType
74140>>>>>      if (liLockType<>DF_LOCK_TYPE_NONE and liLockType<>DF_LOCK_TYPE_FILE and liLockType<>DF_LOCK_TYPE_RECORD) move DF_LOCK_TYPE_FILE to liLockType
74143>>>>>      if (liLockType=DF_LOCK_TYPE_RECORD) move DF_LOCK_TYPE_FILE to liLockType
74146>>>>>      send RS_SetFileAttr DF_FILE_LOCK_TYPE liLockType
74147>>>>>
74147>>>>>      send RS_Structure_End
74148>>>>>      function_Return 1
74149>>>>>    end
74149>>>>>>
74149>>>>>  end
74149>>>>>>
74149>>>>>  function_return 0
74150>>>>>end_function
74151>>>Use MsgBox.utl   // obs procedure
74151>>>Use FList.nui    // A lot of FLIST- procedures and functions
74151>>>
74151>>>object oDfmFnc01 is a fdxrpt.ModalClient label "Create selected tables (empty ones)"
74154>>>  object oFrm1 is a aps.SelectDirForm label "Target directory:" abstract AFT_ASCII50
74158>>>    on_key kenter send next
74159>>>    set p_extra_internal_width to -40
74160>>>  end_object
74161>>>  send aps_goto_max_row
74162>>>  send make_column_space 70
74163>>>  object oCb1 is a aps.CheckBox label "Update FILELIST.CFG"
74166>>>    set checked_state to true
74167>>>  end_object
74168>>>  object oCb2 is a aps.CheckBox label "Create FD files" snap SL_DOWN
74172>>>  end_object
74173>>>  object oCb3 is a aps.CheckBox label "Create DEF files" snap SL_DOWN
74177>>>  end_object
74178>>>  object oBtn1 is a aps.Multi_Button
74180>>>    on_item t.btn.ok send DoReport
74181>>>  end_object
74182>>>  object oBtn2 is a aps.Multi_Button
74184>>>    on_item t.btn.cancel send close_panel
74185>>>  end_object
74186>>>  send aps_locate_multi_buttons
74187>>>  function sDestination returns string
74190>>>    function_return (value(oFrm1(self),0))
74191>>>  end_function
74192>>>  function iUpdateFilelist returns integer
74195>>>    function_return (checked_state(oCb1(self)))
74196>>>  end_function
74197>>>  function iCreateFD returns integer
74200>>>    function_return (checked_state(oCb2(self)))
74201>>>  end_function
74202>>>  function iCreateDEF returns integer
74205>>>    function_return (checked_state(oCb3(self)))
74206>>>  end_function
74207>>>  set piDontRegister to dfTrue // Don't register with the main menu
74208>>>  procedure Callback_Filelist_Entry integer liFile integer lbSelected integer lbShaded
74211>>>    integer lhFDX liNeverMind lbCreateDEF lbCreateFD
74211>>>    string lsFolder lsLogical lsRoot lsLogicalPath lsRootPath
74211>>>    get sDestination to lsFolder
74212>>>    get piFDX_Server to lhFDX
74213>>>    get FDX_AttrValue_FILELIST lhFDX DF_FILE_ROOT_NAME liFile to lsRoot
74214>>>    get FDX_AttrValue_FILELIST lhFDX DF_FILE_LOGICAL_NAME liFile to lsLogical
74215>>>
74215>>>    get DBMS_StripPathAndDriver lsRoot to lsRoot
74216>>>    if (lsFolder<>"") begin
74218>>>      get Files_AppendPath lsFolder lsRoot to lsRootPath
74219>>>    end
74219>>>>
74219>>>    get RSX_CreateTableFromFDX lhFDX liFile lsRootPath to liNeverMind
74220>>>    if (iUpdateFilelist(self)) begin
74222>>>      set_attribute DF_FILE_ROOT_NAME    of liFile to lsRoot
74225>>>      set_attribute DF_FILE_LOGICAL_NAME of liFile to lsLogical
74228>>>      set_attribute DF_FILE_DISPLAY_NAME of liFile to (FDX_AttrValue_FILELIST(lhFDX,DF_FILE_DISPLAY_NAME,liFile))
74231>>>    end
74231>>>>
74231>>>    get Files_AppendPath lsFolder (lowercase(lsLogical)) to lsLogicalPath
74232>>>
74232>>>    get iCreateDEF to lbCreateDEF
74233>>>    get iCreateFD  to lbCreateFD
74234>>>
74234>>>
74234>>>    if (lbCreateDEF or lbCreateFD) begin
74236>>>      move (ToAnsi(lsLogicalPath)) to lsLogicalPath
74237>>>      if (DBMS_OpenFileAs(lsRootPath,liFile,DF_SHARE,0)) begin
74239>>>        if lbCreateDEF begin
74241>>>          Output_Aux_File DF_AUX_FILE_DEF For liFile Number liFile to (lsLogicalPath+".def")
74243>>>        end
74243>>>>
74243>>>        if lbCreateFD begin
74245>>>          Output_Aux_File DF_AUX_FILE_FD For liFile Number liFile to (lsLogicalPath+".fd")
74247>>>        end
74247>>>>
74247>>>        close liFile
74248>>>      end
74248>>>>
74248>>>    end
74248>>>>
74248>>>  end_procedure
74249>>>  procedure DoReport
74252>>>    integer update_filelist# select_count#
74252>>>    string dir# filelist#
74252>>>    get File_Select_Count of (DFMatrix_SelectorObject()) to select_count#
74253>>>    ifnot select_count# send obs "No tables selected!"
74256>>>    else begin
74257>>>      get iUpdateFilelist to update_filelist#
74258>>>      if update_filelist# begin
74260>>>        get sDestination to dir#
74261>>>        if dir# ne "" begin
74263>>>          if (SEQ_FileExists(dir#)=SEQIT_DIRECTORY) begin
74265>>>            move (SEQ_ComposeAbsoluteFileName(dir#,"filelist.cfg")) to filelist#
74266>>>            ifnot (SEQ_FileExists(filelist#)) begin
74268>>>              if (MB_Verify4("A 'Filelist.cfg' does not exist","in that area!","Create one?","",1)) begin
74270>>>                if (FLIST_CreateEmptyFileList(filelist#)) begin
74272>>>                  send FLIST_PushCurrentFilelist
74273>>>                  send FLIST_SetCurrentFilelist filelist#
74274>>>                  send RS_Progress RS_PG_LEAVE_ON
74275>>>                  send Callback_Filelist_Entries 1 0 // This does the actual work!
74276>>>                  send RS_Progress RS_PG_OFF
74277>>>                  send FLIST_PopCurrentFilelist
74278>>>                  send obs "Done"
74279>>>                end
74279>>>>
74279>>>                else send obs "A 'Filelist.cfg' could not be created." "Operation has been cancelled."
74281>>>              end
74281>>>>
74281>>>            end
74281>>>>
74281>>>            else begin
74282>>>              send FLIST_PushCurrentFilelist
74283>>>              send FLIST_SetCurrentFilelist filelist#
74284>>>              send RS_Progress RS_PG_LEAVE_ON
74285>>>              send Callback_Filelist_Entries 1 0 // This does the actual work!
74286>>>              send RS_Progress RS_PG_OFF
74287>>>              send FLIST_PopCurrentFilelist
74288>>>              send obs "Done"
74289>>>            end
74289>>>>
74289>>>          end
74289>>>>
74289>>>          else send obs "The specified directory does not exist" ("("+dir#+")")
74291>>>          procedure_return
74292>>>        end
74292>>>>
74292>>>      end
74292>>>>
74292>>>      send RS_Progress RS_PG_LEAVE_ON
74293>>>      send Callback_Filelist_Entries 1 0 // This does the actual work!
74294>>>      send RS_Progress RS_PG_OFF
74295>>>      send obs "Done"
74296>>>    end
74296>>>>
74296>>>  end_procedure
74297>>>end_object // oDfmFnc01
74298>>>
74298>>>procedure Popup_CreateFromFdx
74301>>>  send popup to (oDfmFnc01(self))
74302>>>end_function
74303>    Use DfmFnc03.pkg // Find stray index files (Popup_FindStrayIndexFiles)
Including file: dfmfnc03.pkg    (C:\Apps\VDFQuery\AppSrc\dfmfnc03.pkg)
74303>>>// Use DfmFnc03.pkg // Find stray index files (Popup_FindStrayIndexFiles)
74303>>>
74303>>>Use Files.utl    // Utilities for handling file related stuff
74303>>>Use Strings.nui  // String manipulation for VDF
74303>>>Use GridUtil.utl // Grid and List utilities
74303>>>
74303>>>Use wvaW32fh.pkg // Wil's windows routines
74303>>>
/DFMFNC03
Image 18, DFMFNC03
Clicking the 'Search files' button will detect index files
that are not located next to their respective data file.
Subsequently clicking the 'Move files' button will then move
the index files to the data file directory.
The latter operation requires exclusive access to the data
files meaning that no other users are allowed on the data
base while executing.
/* // ******************************************************
74303>>>
74303>>>object oFindStrayIndexFiles_Arr is a cArray no_image
74305>>>  item_property_list
74305>>>    item_property integer piType.i // 0=move 1=not found
74305>>>    item_property integer piFile.i
74305>>>    item_property string  psSourceFile.i
74305>>>    item_property string  psTargetFile.i
74305>>>    item_property integer piTargetFileAlreadyExists.i
74305>>>    item_property integer piOverWrite.i
74305>>>  end_item_property_list
#REM 74354 DEFINE FUNCTION PIOVERWRITE.I INTEGER LIROW RETURNS INTEGER
#REM 74359 DEFINE PROCEDURE SET PIOVERWRITE.I INTEGER LIROW INTEGER VALUE
#REM 74364 DEFINE FUNCTION PITARGETFILEALREADYEXISTS.I INTEGER LIROW RETURNS INTEGER
#REM 74369 DEFINE PROCEDURE SET PITARGETFILEALREADYEXISTS.I INTEGER LIROW INTEGER VALUE
#REM 74374 DEFINE FUNCTION PSTARGETFILE.I INTEGER LIROW RETURNS STRING
#REM 74379 DEFINE PROCEDURE SET PSTARGETFILE.I INTEGER LIROW STRING VALUE
#REM 74384 DEFINE FUNCTION PSSOURCEFILE.I INTEGER LIROW RETURNS STRING
#REM 74389 DEFINE PROCEDURE SET PSSOURCEFILE.I INTEGER LIROW STRING VALUE
#REM 74394 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 74399 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
#REM 74404 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 74409 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
74415>>>  procedure add_file_move integer file# string source# string target# integer type# integer exists#
74418>>>    integer row#
74418>>>    get row_count to row#
74419>>>    set piType.i       row# to type# // 0=move 1=not found
74420>>>    set piFile.i       row# to file#
74421>>>    set psSourceFile.i row# to source#
74422>>>    set psTargetFile.i row# to target#
74423>>>    set piTargetFileAlreadyExists.i row# to exists#
74424>>>  end_procedure
74425>>>  procedure check_index integer file# integer idx# string home# string root#
74428>>>    integer exists#
74428>>>    string fn# path# source# target#
74428>>>    move (root#+".K"+string(idx#)) to fn#
74429>>>    get SEQ_FindFileAlongDFPath fn# to path#
74430>>>    if path# ne "" begin // Meaning we found it!
74432>>>      if (right(path#,1)) eq (sysconf(SYSCONF_DIR_SEPARATOR)) move (StringLeftBut(path#,1)) to path#
74435>>>      if (lowercase(path#)) ne (lowercase(home#)) begin
74437>>>        move (SEQ_ComposeAbsoluteFileName(path#,fn#)) to source#
74438>>>        move (SEQ_ComposeAbsoluteFileName(home#,fn#)) to target#
74439>>>        move (SEQ_FileExists(target#)) to exists#
74440>>>        send add_file_move file# source# target# 0 exists#
74441>>>      end
74441>>>>
74441>>>    end
74441>>>>
74441>>>    else send add_file_move file# fn# "" 1 0 // Not found!
74443>>>  end_procedure
74444>>>  procedure Search_Files_Help integer file#
74447>>>    integer oFdx# idx# seg_max#
74447>>>    string root# home#
74447>>>    move (fdx.object_id(0)) to oFDX#
74448>>>    if oFDX# begin
74450>>>      move (sDatPath.i(oFDX#,file#)) to root#
74451>>>      if (right(lowercase(root#),4)) eq ".dat" begin
74453>>>        move (StringLeftBut(root#,4)) to root#
74454>>>        move (SEQ_ExtractPathFromFileName(root#)) to home#
74455>>>        move (SEQ_RemovePathFromFileName(root#)) to root#
74456>>>        for idx# from 1 to 15
74462>>>>
74462>>>          get FDX_AttrValue_INDEX oFDX# DF_INDEX_NUMBER_SEGMENTS file# idx# to seg_max#
74463>>>          if seg_max# send check_index file# idx# home# root#
74466>>>        loop
74467>>>>
74467>>>      end
74467>>>>
74467>>>    end
74467>>>>
74467>>>  end_procedure
74468>>>  procedure Search_Files
74471>>>    send delete_data
74472>>>    send Callback_General to (DFMatrix_SelectorObject()) msg_Search_Files_Help self 1 0 1
74473>>>  end_procedure
74474>>>  procedure Move_Files
74477>>>    integer max# row# exists# overwrite# grb#
74477>>>    string source# target#
74477>>>    get row_count to max#
74478>>>    for row# from 0 to (max#-1)
74484>>>>
74484>>>      if (piType.i(self,row#)) eq 0 begin
74486>>>        get piTargetFileAlreadyExists.i row# to exists#
74487>>>        get piOverWrite.i               row# to overwrite#
74488>>>        if (not(exists#) or overwrite#) begin
74490>>>          get psSourceFile.i row# to source#
74491>>>          get psTargetFile.i row# to target#
74492>>>          get wvaWin32_ShMoveFile source# target# to grb#
74493>>>        end
74493>>>>
74493>>>      end
74493>>>>
74493>>>    loop
74494>>>>
74494>>>  end_procedure
74495>>>end_object // oFindStrayIndexFiles_Arr
74496>>>
74496>>>class cFindStrayIndexFiles_Grid is a aps.Grid
74497>>>  procedure construct_object integer img#
74499>>>    forward send construct_object img#
74501>>>    set line_width to 3 0
74502>>>    set header_label item 0 to "Type"
74503>>>    set header_label item 1 to "Stray file"
74504>>>    set header_label item 2 to "!"
74505>>>    set form_margin item 0 to 3   //
74506>>>    set form_margin item 1 to 60  //
74507>>>    set form_margin item 2 to 2   //
74508>>>    set highlight_row_state to TRUE
74509>>>//   set highlight_row_color to (rgb(0,255,255))
74509>>>//   set current_item_color to (rgb(0,255,255))
74509>>>    set CurrentCellColor     to clHighlight
74510>>>    set CurrentCellTextColor to clHighlightText
74511>>>    set CurrentRowColor      to clHighlight
74512>>>    set CurrentRowTextColor  to clHighlightText
74513>>>    set select_mode to no_select
74514>>>    on_key knext_item send switch
74515>>>    on_key kprevious_item send switch_back
74516>>>    on_key kenter send next
74517>>>    on_key key_ctrl+key_r send sort_data
74518>>>  end_procedure
74519>>>  function sTypeText.i integer type# returns string
74521>>>    if type# eq 0 function_return "MOV"
74524>>>    if type# eq 1 function_return "ERR"
74527>>>    function_return "?"
74528>>>  end_function
74529>>>  procedure sort_data.i integer column#
74531>>>    send Grid_SortByColumn self column#
74532>>>  end_procedure
74533>>>  procedure sort_data
74535>>>    integer cc#
74535>>>    get Grid_CurrentColumn self to cc#
74536>>>    send sort_data.i cc#
74537>>>  end_procedure
74538>>>  procedure fill_list
74540>>>    integer max# row# obj# type# exists#
74540>>>    move (oFindStrayIndexFiles_Arr(self)) to obj#
74541>>>    send delete_data
74542>>>    get row_count of obj# to max#
74543>>>    for row# from 0 to (max#-1)
74549>>>>
74549>>>      get piType.i of obj# row# to type#
74550>>>      send add_item msg_none (sTypeText.i(self,type#))
74551>>>      send add_item msg_none (psSourceFile.i(obj#,row#))
74552>>>      get piTargetFileAlreadyExists.i of obj# row# to exists#
74553>>>      send add_item msg_none (if(exists#,"!",""))
74554>>>    loop
74555>>>>
74555>>>    send Grid_SetEntryState self DFFALSE
74556>>>    set dynamic_update_state to true
74557>>>  end_procedure
74558>>>end_class // cFindStrayIndexFiles_Grid
74559>>>
74559>>>object oFindStrayIndexFiles_Vw is a aps.ModalPanel label "Find stray index files"
74562>>>  set locate_mode to CENTER_ON_SCREEN
74563>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
74564>>>  set pMinimumSize to 50 130 // Resize to no less than this!
74565>>>  on_key kcancel send close_panel
74566>>>  object oLst is a cFindStrayIndexFiles_Grid
74568>>>    set size to 150 0
74569>>>  end_object
74570>>>  procedure Search_Files
74573>>>    send cursor_wait to (cursor_control(self))
74574>>>    send Search_Files to (oFindStrayIndexFiles_Arr(self))
74575>>>    send fill_list to (oLst(self))
74576>>>    send cursor_ready to (cursor_control(self))
74577>>>    ifnot (item_count(oLst(self))) send obs "No index files are astray"
74580>>>  end_procedure
74581>>>  procedure Move_Files
74584>>>    send cursor_wait to (cursor_control(self))
74585>>>    send Move_Files to (oFindStrayIndexFiles_Arr(self))
74586>>>    send Search_Files to (oFindStrayIndexFiles_Arr(self))
74587>>>    send fill_list to (oLst(self))
74588>>>    send cursor_ready to (cursor_control(self))
74589>>>  end_procedure
74590>>>  object oBtn1 is a aps.Multi_Button
74592>>>    on_item "Search files" send Search_Files
74593>>>  end_object
74594>>>  object oBtn2 is a aps.Multi_Button
74596>>>    on_item "Move files"   send Move_Files
74597>>>  end_object
74598>>>  object oBtn3 is a aps.Multi_Button
74600>>>    on_item "Close"        send close_panel
74601>>>  end_object
74602>>>  send aps_locate_multi_buttons
74603>>>
74603>>>  procedure popup
74606>>>    integer select_count#
74606>>>    get File_Select_Count of (DFMatrix_SelectorObject()) to select_count#
74607>>>    if select_count# begin
74609>>>      if (DFMatrix_RealDataPrimary()) forward send popup
74613>>>      else send obs "This function is not available when you are" "working with remote table definitions." "" "Select 'Open current definitions' from the 'File' pulldown"
74615>>>    end
74615>>>>
74615>>>    else send obs "No tables selected!"
74617>>>  end_procedure
74618>>>
74618>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
74621>>>    send aps_resize (oLst(self)) delta_rw# 0
74622>>>    send aps_register_multi_button (oBtn1(self))
74623>>>    send aps_register_multi_button (oBtn2(self))
74624>>>    send aps_register_multi_button (oBtn3(self))
74625>>>    send aps_locate_multi_buttons
74626>>>    send aps_auto_size_container
74627>>>  end_procedure
74628>>>end_object // oFindStrayIndexFiles_Vw
74629>>>
74629>>>procedure Popup_FindStrayIndexFiles
74632>>>  send popup to (oFindStrayIndexFiles_Vw(self))
74633>>>end_procedure
74634>    Use DfmFnc05.pkg // Import Export data
Including file: dfmfnc05.pkg    (C:\Apps\VDFQuery\AppSrc\dfmfnc05.pkg)
74634>>>// Use DfmFnc05.pkg // Import Export data
74634>>>
74634>>>object oDfmFnc05 is a fdxrpt.ModalClient label "Import/Export data"
74637>>>  set location to 5 12 absolute
74638>>>  set p_auto_column to 1
74639>>>  object oCb1 is a aps.CheckBox label "Export"
74642>>>    set checked_state to true
74643>>>    set p_extra_external_width to 40
74644>>>  end_object
74645>>>  object oCb2 is a aps.CheckBox label "Zerofile (erase)"
74648>>>    set checked_state to false
74649>>>  end_object
74650>>>  object oCb3 is a aps.CheckBox label "Import"
74653>>>    set checked_state to false
74654>>>  end_object
74655>>>  object oBtn1 is a aps.Multi_Button
74657>>>    on_item t.btn.ok send DoReport
74658>>>  end_object
74659>>>  object oBtn2 is a aps.Multi_Button
74661>>>    on_item t.btn.cancel send cancel
74662>>>  end_object
74663>>>  send aps_locate_multi_buttons
74664>>>  function iExport returns integer
74667>>>    function_return (select_state(oCb1(self),0))
74668>>>  end_function
74669>>>  function iZero returns integer
74672>>>    function_return (select_state(oCb2(self),0))
74673>>>  end_function
74674>>>  function iImport returns integer
74677>>>    function_return (select_state(oCb3(self),0))
74678>>>  end_function
74679>>>  set piDontRegister to DFTRUE // Don't register with the main menu
74680>>>  procedure Callback_Filelist_Entry integer file# integer selected# integer shaded#
74683>>>    integer oFDX# ch# found# seqeof#
74683>>>    string root#
74683>>>    if (selected# and not(shaded#)) begin
74685>>>      get piFDX_Server to oFDX#
74686>>>      move (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_ROOT_NAME,file#)) to root#
74687>>>      move (DBMS_StripPathAndDriver(root#)) to root#
74688>>>      if (DBMS_OpenFile(file#,DF_SHARE,0)) begin
74690>>>
74690>>>        if (iExport(self)) begin
74692>>>          move (SEQ_DirectOutput(root#+".ASC")) to ch#
74693>>>          if ch# ge 0 begin
74695>>>            clear file#
74696>>>            repeat
74696>>>>
74696>>>              vfind file# 0 gt // Find next
74698>>>              move (found) to found#
74699>>>              if found# send SEQ_WriteRecordBuffer_LD ch# file#
74702>>>            until (not(found#))
74704>>>            send SEQ_CloseOutput ch#
74705>>>          end
74705>>>>
74705>>>        end
74705>>>>
74705>>>
74705>>>        if (iZero(self)) zerofile file#
74708>>>
74708>>>        if (iImport(self)) begin
74710>>>          move (SEQ_DirectInput(root#+".ASC")) to ch#
74711>>>          if ch# ge 0 begin
74713>>>            lock
74714>>>>
74714>>>              repeat
74714>>>>
74714>>>                clear file#
74715>>>                send SEQ_ReadRecordBuffer_LD ch# file#
74716>>>                move (seqeof) to seqeof#
74717>>>                ifnot seqeof# saverecord file#
74720>>>              until seqeof#
74722>>>            unlock
74723>>>>
74723>>>            send SEQ_CloseInput ch#
74724>>>          end
74724>>>>
74724>>>        end
74724>>>>
74724>>>
74724>>>        close file#
74725>>>      end
74725>>>>
74725>>>      else send obs "Could not access table:" root#
74727>>>    end
74727>>>>
74727>>>  end_procedure
74728>>>  procedure DoReport
74731>>>    integer select_count# oFDX# liInteger1 liInteger2 liInteger3
74731>>>    string filelist#
74731>>>    get File_Select_Count of (DFMatrix_SelectorObject()) to select_count#
74732>>>    get piFDX_Server to oFDX#
74733>>>    if (piDataOrigin(oFDX#)) ne FDX_REAL_WORLD send obs "Only works with real data"
74736>>>    else begin
74737>>>      ifnot select_count# send obs "No tables selected!"
74740>>>      else begin
74741>>>        send cursor_wait to (cursor_control(self))
74742>>>        get_attribute DF_DATE_FORMAT to liInteger1
74745>>>        get_attribute DF_DATE_SEPARATOR to liInteger2
74748>>>        get_attribute DF_DECIMAL_SEPARATOR to liInteger3
74751>>>        set_attribute DF_DATE_FORMAT to DF_DATE_EUROPEAN
74754>>>        set_attribute DF_DATE_SEPARATOR to 45     // -
74757>>>        set_attribute DF_DECIMAL_SEPARATOR to 46  // .
74760>>>        send Callback_Filelist_Entries 1 0 // This does the actual work!
74761>>>        set_attribute DF_DATE_FORMAT to liInteger1
74764>>>        set_attribute DF_DATE_SEPARATOR to liInteger2
74767>>>        set_attribute DF_DECIMAL_SEPARATOR to liInteger3
74770>>>        send cursor_ready to (cursor_control(self))
74771>>>        send obs "Done"
74772>>>      end
74772>>>>
74772>>>    end
74772>>>>
74772>>>  end_procedure
74773>>>end_object // oDfmFnc05
74774>>>
74774>>>procedure Popup_ImportExport
74777>>>  //if (DFMatrix_RealData_Check())
74777>>>  string lsVal1 lsVal2 lsVal3
74777>>>  move 'The "Import/Export data" function is only available for compatibility with earlier versions of DFMatrix and with' to lsVal1
74778>>>  move 'the character mode version.' to lsVal2
74779>>>  move 'If you are not using this function for any of these reasons you should use the "Dump/Load data" function instead' to lsVal3
74780>>>  send obs lsVal1 lsVal2 lsVal3
74781>>>  send popup to (oDfmFnc05(self))
74782>>>end_function
74783>    Use DfmFnc07.pkg // Create DEF/FD files (Popup_CreateDEF_FD)
Including file: dfmfnc07.pkg    (C:\Apps\VDFQuery\AppSrc\dfmfnc07.pkg)
74783>>>object oDfmFnc07 is a fdxrpt.ModalClient label "Create selected DEF/FD files"
74786>>>  object oFrm1 is a aps.SelectDirForm label "Target directory:" abstract AFT_ASCII50
74790>>>    on_key kenter send next
74791>>>    set p_extra_internal_width to -40
74792>>>  end_object
74793>>>  send aps_goto_max_row
74794>>>  send make_column_space 70
74795>>>  object oCb1 is a aps.CheckBox label "Create FD files" snap SL_DOWN
74799>>>    set checked_state to true
74800>>>  end_object
74801>>>  object oCb2 is a aps.CheckBox label "Create DEF files" snap SL_DOWN
74805>>>    set checked_state to true
74806>>>  end_object
74807>>>  object oBtn1 is a aps.Multi_Button
74809>>>    on_item t.btn.ok send DoReport
74810>>>  end_object
74811>>>  object oBtn2 is a aps.Multi_Button
74813>>>    on_item t.btn.cancel send close_panel
74814>>>  end_object
74815>>>  send aps_locate_multi_buttons
74816>>>  function sDestination returns string
74819>>>    function_return (value(oFrm1(self),0))
74820>>>  end_function
74821>>>  function iCreateFD returns integer
74824>>>    integer liCS
74824>>>    get checked_state of (oCb1(self)) to liCS
74825>>>    function_return liCS
74826>>>  end_function
74827>>>  function iCreateDEF returns integer
74830>>>    integer liCS
74830>>>    get checked_state of (oCb2(self)) to liCS
74831>>>    function_return liCS
74832>>>  end_function
74833>>>  set piDontRegister to dfTrue // Don't register with the main menu
74834>>>  procedure Callback_Filelist_Entry integer file# integer selected# integer shaded#
74837>>>    integer oFDX# grb#
74837>>>    string root# dir# dfname#
74837>>>    get sDestination to dir#
74838>>>    get piFDX_Server to oFDX#
74839>>>    move (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_ROOT_NAME,file#)) to root#
74840>>>    move (FDX_AttrValue_FILELIST(oFDX#,DF_FILE_LOGICAL_NAME,file#)) to dfname#
74841>>>    if dir# ne "" move (SEQ_ComposeAbsoluteFileName(dir#,root#)) to root#
74844>>>    if (DBMS_OpenFileAs(root#,file#,DF_SHARE,0)) begin
74846>>>      if (iCreateDEF(self)) Output_Aux_File DF_AUX_FILE_DEF For file# Number file# to (dfname#+".DEF")
74850>>>      if (iCreateFD(self)) Output_Aux_File DF_AUX_FILE_FD For file# Number file# to (dfname#+".FD")
74854>>>      close file#
74855>>>    end
74855>>>>
74855>>>  end_procedure
74856>>>  procedure DoReport
74859>>>    integer update_filelist# select_count#
74859>>>    string dir# filelist#
74859>>>    get File_Select_Count of (DFMatrix_SelectorObject()) to select_count#
74860>>>    ifnot select_count# send obs "No tables selected!"
74863>>>    else begin
74864>>>      send Callback_Filelist_Entries 1 0 // This does the actual work!
74865>>>      send obs "Done"
74866>>>    end
74866>>>>
74866>>>  end_procedure
74867>>>end_object // oDfmFnc07
74868>>>
74868>>>procedure Popup_CreateDEF_FD
74871>>>  send popup to (oDfmFnc07(self))
74872>>>end_function
74873>    Use StrucPgm.vw  // View for creating and executing RS programs
Including file: strucpgm.vw    (C:\Apps\VDFQuery\AppSrc\strucpgm.vw)
74873>>>// Use StrucPgm.vw  // View for creating and executing RS programs
74873>>>Use StrucPgm.utl // Class for storing a sequence of restructure instructions
Including file: strucpgm.utl    (C:\Apps\VDFQuery\AppSrc\strucpgm.utl)
74873>>>>>use StrucPgm.nui
Including file: strucpgm.nui    (C:\Apps\VDFQuery\AppSrc\strucpgm.nui)
74873>>>>>>>// Use StrucPgm.nui // Class for storing a sequence of restructure instructions
74873>>>>>>>
74873>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
74873>>>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
74873>>>>>>>Use Structur.utl // Object for restructuring table definitions
74873>>>>>>>Use DBMS.nui     // Basic DBMS functions
74873>>>>>>>Use API_Attr.nui // Functions for querying API attributes
74873>>>>>>>Use Files.nui    // Utilities for handling file related stuff
74873>>>>>>>Use FDX.nui      // cFDX class
74873>>>>>>>
74873>>>>>>>enumeration_list // Program types
74873>>>>>>>  define PGM_TYPE_NONE
74873>>>>>>>  define PGM_TYPE_EMPTY
74873>>>>>>>  define PGM_TYPE_EDIT
74873>>>>>>>  define PGM_TYPE_CREATE
74873>>>>>>>  define PGM_TYPE_DROP
74873>>>>>>>  define PGM_TYPE_FILELIST
74873>>>>>>>end_enumeration_list
74873>>>>>>>
74873>>>>>>>function StructPgm_ProgramType_Text global integer type# returns string
74875>>>>>>>  if type# eq PGM_TYPE_NONE     function_return "Unknown"
74878>>>>>>>  if type# eq PGM_TYPE_EMPTY    function_return "Unchanged"
74881>>>>>>>  if type# eq PGM_TYPE_EDIT     function_return "Changed"
74884>>>>>>>  if type# eq PGM_TYPE_CREATE   function_return "Create"
74887>>>>>>>  if type# eq PGM_TYPE_DROP     function_return "Drop"
74890>>>>>>>  if type# eq PGM_TYPE_FILELIST function_return "Filelist"
74893>>>>>>>end_function
74894>>>>>>>
74894>>>>>>>enumeration_list // Instruction types
74894>>>>>>>  define INSTR_TYPE_EDIT
74894>>>>>>>  define INSTR_TYPE_CREATE
74894>>>>>>>  define INSTR_TYPE_DELETE
74894>>>>>>>  define INSTR_TYPE_APPEND
74894>>>>>>>end_enumeration_list
74894>>>>>>>
74894>>>>>>>function StructPgm_FieldInstructionType_Text global integer type# returns string
74896>>>>>>>  if type# eq INSTR_TYPE_EDIT   function_return "Edit"
74899>>>>>>>  if type# eq INSTR_TYPE_CREATE function_return "Insert"
74902>>>>>>>  if type# eq INSTR_TYPE_DELETE function_return "Delete"
74905>>>>>>>  if type# eq INSTR_TYPE_APPEND function_return "Append"
74908>>>>>>>end_function
74909>>>>>>>
74909>>>>>>>// This package defines a class called cFdxRestructureProgram meant to
74909>>>>>>>// be used for storing the instructions making up a restructure program.
74909>>>>>>>// Due to the different nature of changing FILE, FIELD, INDEX and INDEX
74909>>>>>>>// SEGMENT attributes the instructions for these are stored in four
74909>>>>>>>// separate embedded arrays that are all based on the cStrucPgmHelpClass
74909>>>>>>>// class.
74909>>>>>>>//
74909>>>>>>>// The cStrucPgmHelpClass class itself supports storing a text version
74909>>>>>>>// in an embedded array (object oReportText).
74909>>>>>>>
74909>>>>>>>class cStrucPgmHelpClass is a cArray
74910>>>>>>>  procedure construct_object integer iImg
74912>>>>>>>    forward send construct_object iImg
74914>>>>>>>    object oReportText is a cArray NO_IMAGE
74916>>>>>>>    end_object
74917>>>>>>>  end_procedure
74918>>>>>>>  procedure reset
74920>>>>>>>    send delete_data to (oReportText(self))
74921>>>>>>>    send delete_data
74922>>>>>>>  end_procedure
74923>>>>>>>end_class // cStrucPgmHelpClass
74924>>>>>>>
74924>>>>>>>class cStrucPgmHelp1 is a cStrucPgmHelpClass // FILELIST/FILE instructions
74925>>>>>>>  item_property_list
74925>>>>>>>    item_property integer piAttr.i
74925>>>>>>>    item_property string  psValue.i
74925>>>>>>>    item_property string  psPrevValue.i
74925>>>>>>>  end_item_property_list cStrucPgmHelp1
#REM 74960 DEFINE FUNCTION PSPREVVALUE.I INTEGER LIROW RETURNS STRING
#REM 74964 DEFINE PROCEDURE SET PSPREVVALUE.I INTEGER LIROW STRING VALUE
#REM 74968 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 74972 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 74976 DEFINE FUNCTION PIATTR.I INTEGER LIROW RETURNS INTEGER
#REM 74980 DEFINE PROCEDURE SET PIATTR.I INTEGER LIROW INTEGER VALUE
74985>>>>>>>  procedure add_instruction integer attr# string value#
74987>>>>>>>    integer row#
74987>>>>>>>    get row_count to row#
74988>>>>>>>    set piAttr.i  row# to attr#
74989>>>>>>>    set psValue.i row# to value#
74990>>>>>>>  end_procedure
74991>>>>>>>  function sInstructionText.i integer row# returns string
74993>>>>>>>    integer attr#
74993>>>>>>>    string val# prev_val# rval#
74993>>>>>>>    get piAttr.i      row# to attr#
74994>>>>>>>    get psValue.i     row# to val#
74995>>>>>>>    get psPrevValue.i row# to prev_val#
74996>>>>>>>    move ("Set "+API_Attr_Name(attr#)+" To "+API_Attr_ValueName(attr#,val#)) to rval#
74997>>>>>>>    if prev_val# ne "" move (rval#+" (Prev: "+API_Attr_ValueName(attr#,prev_val#)+")") to rval#
75000>>>>>>>    function_return rval#
75001>>>>>>>  end_function
75002>>>>>>>  procedure seq_report_on_changes integer liChannel
75004>>>>>>>    integer liMax liRow liAttr
75004>>>>>>>    string lsFrom lsTo lsValue
75004>>>>>>>    get row_count to liMax
75005>>>>>>>    decrement liMax
75006>>>>>>>    for liRow from 0 to liMax
75012>>>>>>>>
75012>>>>>>>      get piAttr.i      liRow to liAttr
75013>>>>>>>      get psValue.i     liRow to lsTo
75014>>>>>>>      get psPrevValue.i liRow to lsFrom
75015>>>>>>>      get API_Attr_ValueName liAttr lsTo to lsTo
75016>>>>>>>      get API_Attr_ValueName liAttr lsFrom to lsFrom
75017>>>>>>>
75017>>>>>>>      move "Set # to # (previously: #)" to lsValue
75018>>>>>>>      move (replace("#",lsValue,API_Attr_Name(liAttr))) to lsValue
75019>>>>>>>      move (replace("#",lsValue,lsTo)) to lsValue
75020>>>>>>>      move (replace("#",lsValue,lsFrom)) to lsValue
75021>>>>>>>
75021>>>>>>>      writeln channel liChannel "  " lsValue
75025>>>>>>>    loop
75026>>>>>>>>
75026>>>>>>>  end_procedure
75027>>>>>>>end_class // cStrucPgmHelp1
75028>>>>>>>
75028>>>>>>>class cStrucPgmHelp2 is a cStrucPgmHelpClass // FIELD instructions
75029>>>>>>>  item_property_list
75029>>>>>>>    item_property integer piInstrType.i // Instruction type
75029>>>>>>>    item_property integer piAttr.i      // Set_Attribute Attr#
75029>>>>>>>    item_property integer piField.i     //        Field Field#
75029>>>>>>>    item_property string  psFieldName.i //        (with name#)
75029>>>>>>>    item_property string  psValue.i     //           To Value#
75029>>>>>>>    item_property string  psPrevValue.i // (value was previously: prev)
75029>>>>>>>  end_item_property_list cStrucPgmHelp2
#REM 75073 DEFINE FUNCTION PSPREVVALUE.I INTEGER LIROW RETURNS STRING
#REM 75077 DEFINE PROCEDURE SET PSPREVVALUE.I INTEGER LIROW STRING VALUE
#REM 75081 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 75085 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 75089 DEFINE FUNCTION PSFIELDNAME.I INTEGER LIROW RETURNS STRING
#REM 75093 DEFINE PROCEDURE SET PSFIELDNAME.I INTEGER LIROW STRING VALUE
#REM 75097 DEFINE FUNCTION PIFIELD.I INTEGER LIROW RETURNS INTEGER
#REM 75101 DEFINE PROCEDURE SET PIFIELD.I INTEGER LIROW INTEGER VALUE
#REM 75105 DEFINE FUNCTION PIATTR.I INTEGER LIROW RETURNS INTEGER
#REM 75109 DEFINE PROCEDURE SET PIATTR.I INTEGER LIROW INTEGER VALUE
#REM 75113 DEFINE FUNCTION PIINSTRTYPE.I INTEGER LIROW RETURNS INTEGER
#REM 75117 DEFINE PROCEDURE SET PIINSTRTYPE.I INTEGER LIROW INTEGER VALUE
75122>>>>>>>
75122>>>>>>>  function sInstructionText.i integer row# returns string
75124>>>>>>>    integer type# field# attr#
75124>>>>>>>    string name# val# prev_val# rval#
75124>>>>>>>    get piInstrType.i row# to type#
75125>>>>>>>    get piAttr.i      row# to attr#
75126>>>>>>>    get piField.i     row# to field#
75127>>>>>>>    get psFieldName.i row# to name#
75128>>>>>>>    get psValue.i     row# to val#
75129>>>>>>>    get psPrevValue.i row# to prev_val#
75130>>>>>>>    if type# eq INSTR_TYPE_DELETE function_return ("Delete field "+string(field#)+" ("+name#+")")
75133>>>>>>>    if type# eq INSTR_TYPE_CREATE function_return ("Insert field "+val#+" before field "+string(field#)+", "+name#)
75136>>>>>>>    if type# eq INSTR_TYPE_APPEND function_return ("Append field "+val#)
75139>>>>>>>    move ("Set "+API_Attr_Name(attr#)+" field "+string(field#)+" ("+name#+")"+" To "+API_Attr_ValueName(attr#,val#)) to rval#
75140>>>>>>>    if prev_val# ne "" move (rval#+" (Prev: "+API_Attr_ValueName(attr#,prev_val#)+")") to rval#
75143>>>>>>>    function_return rval#
75144>>>>>>>  end_function
75145>>>>>>>
75145>>>>>>>  procedure seq_report_on_changes integer liChannel
75147>>>>>>>    integer liMax liRow liAttr liType liIgnoreField
75147>>>>>>>    string lsFrom lsTo lsValue
75147>>>>>>>    get row_count to liMax
75148>>>>>>>    decrement liMax
75149>>>>>>>    move -1 to liIgnoreField
75150>>>>>>>    for liRow from 0 to liMax
75156>>>>>>>>
75156>>>>>>>      get piInstrType.i liRow to liType
75157>>>>>>>      get piAttr.i liRow      to liAttr
75158>>>>>>>      if (liType=INSTR_TYPE_DELETE or liType=INSTR_TYPE_CREATE or liType=INSTR_TYPE_APPEND) begin
75160>>>>>>>        get sInstructionText.i liRow to lsValue
75161>>>>>>>        writeln channel liChannel "  " lsValue
75165>>>>>>>        get piField.i liRow to liIgnoreField
75166>>>>>>>      //if liType eq INSTR_TYPE_DELETE begin
75166>>>>>>>      //end
75166>>>>>>>      //if liType eq INSTR_TYPE_CREATE begin
75166>>>>>>>      //  get liField.i liRow to liIgnoreField
75166>>>>>>>      //end
75166>>>>>>>      //if liType eq INSTR_TYPE_APPEND begin
75166>>>>>>>      //  get liField.i liRow to liIgnoreField
75166>>>>>>>      //end
75166>>>>>>>      end
75166>>>>>>>>
75166>>>>>>>      else begin
75167>>>>>>>        if (piField.i(self,liRow)) ne liIgnoreField begin
75169>>>>>>>          get sInstructionText.i liRow to lsValue
75170>>>>>>>          writeln channel liChannel "  " lsValue
75174>>>>>>>        end
75174>>>>>>>>
75174>>>>>>>      end
75174>>>>>>>>
75174>>>>>>>    loop
75175>>>>>>>>
75175>>>>>>>  end_procedure
75176>>>>>>>
75176>>>>>>>  procedure add_instruction integer type# integer attr# integer field# string name# string value#
75178>>>>>>>    integer row#
75178>>>>>>>    get row_count to row#
75179>>>>>>>    set piInstrType.i row# to type#
75180>>>>>>>    set piAttr.i      row# to attr#
75181>>>>>>>    set piField.i     row# to field#
75182>>>>>>>    set psFieldName.i row# to name#
75183>>>>>>>    set psValue.i     row# to value#
75184>>>>>>>  end_procedure
75185>>>>>>>
75185>>>>>>>  // This function derives the attributes of a field stored in a sequence of
75185>>>>>>>  // rows in this object starting at liStartRow.
75185>>>>>>>  function sFillReportTextArrayHelp integer liStartRow returns string
75187>>>>>>>    integer liMax liRow liBreak liField
75187>>>>>>>    integer liPrevField liType liLength liPrecision liRelFile liRelField
75187>>>>>>>    string lsRval lsLength
75187>>>>>>>    move "#1 #2 (->#3,#4)" to lsRval
75188>>>>>>>    get piField.i liStartRow to liPrevField
75189>>>>>>>    get row_count to liMax
75190>>>>>>>    move 0 to liBreak
75191>>>>>>>    move liStartRow to liField
75192>>>>>>>    while (not(liBreak) and liField<=liMax and liPrevField=liField)
75196>>>>>>>    end
75197>>>>>>>>
75197>>>>>>>    move (replace("#1",lsRval,"?")) to lsRval
75198>>>>>>>    move (replace("#2",lsRval,"?")) to lsRval
75199>>>>>>>    move (replace("#3",lsRval,"?")) to lsRval
75200>>>>>>>    move (replace("#4",lsRval,"?")) to lsRval
75201>>>>>>>    function_return lsRval
75202>>>>>>>  end_function
75203>>>>>>>
75203>>>>>>>  procedure FillReportTextArray
75205>>>>>>>    integer liReportText liMax liRow liType liAttr liField liDontListField
75205>>>>>>>    string  lsStr lsName lsVal lsPrevVal
75205>>>>>>>    move (oReportText(self)) to liReportText
75206>>>>>>>    get row_count to liMax
75207>>>>>>>    move -1 to liDontListField
75208>>>>>>>    decrement liMax
75209>>>>>>>    for liRow from 0 to liMax
75215>>>>>>>>
75215>>>>>>>      get piInstrType.i liRow to liType
75216>>>>>>>      get piAttr.i      liRow to liAttr
75217>>>>>>>      get piField.i     liRow to liField
75218>>>>>>>      get psFieldName.i liRow to lsName
75219>>>>>>>      get psValue.i     liRow to lsVal
75220>>>>>>>      get psPrevValue.i liRow to lsPrevVal
75221>>>>>>>
75221>>>>>>>      if liType eq INSTR_TYPE_DELETE begin
75223>>>>>>>        move ("Delete field "+string(liField)+" ("+lsName+")") to lsStr
75224>>>>>>>        set value of liReportText item (item_count(liReportText)) to lsStr
75225>>>>>>>        move -1 to liDontListField
75226>>>>>>>      end
75226>>>>>>>>
75226>>>>>>>      else if liType eq INSTR_TYPE_CREATE begin
75229>>>>>>>        move ("Insert field "+lsVal+" before field "+string(liField)+", "+lsName) to lsStr
75230>>>>>>>        set value of liReportText item (item_count(liReportText)) to lsStr
75231>>>>>>>        move liField to liDontListField
75232>>>>>>>      end
75232>>>>>>>>
75232>>>>>>>      else if liType eq INSTR_TYPE_APPEND begin
75235>>>>>>>        move ("Append field "+lsVal) to lsStr
75236>>>>>>>        set value of liReportText item (item_count(liReportText)) to lsStr
75237>>>>>>>        move 0 to liDontListField
75238>>>>>>>      end
75238>>>>>>>>
75238>>>>>>>      else begin
75239>>>>>>>        if liField ne liDontListField move -2 to liDontListField
75242>>>>>>>      end
75242>>>>>>>>
75242>>>>>>>      if liDontListField ge 0 set value of liReportText item (item_count(liReportText)) to lsStr
75245>>>>>>>    loop
75246>>>>>>>>
75246>>>>>>>  end_procedure
75247>>>>>>>end_class // cStrucPgmHelp2
75248>>>>>>>
75248>>>>>>>class cStrucPgmHelp3 is a cStrucPgmHelpClass // INDEX instructions
75249>>>>>>>  item_property_list
75249>>>>>>>    item_property integer piInstrType.i // Instruction type
75249>>>>>>>    item_property integer piAttr.i      // Set_Attribute Attr#
75249>>>>>>>    item_property integer piIndex.i     //        Index index#
75249>>>>>>>    item_property string  psValue.i     //           To Value#
75249>>>>>>>  end_item_property_list cStrucPgmHelp3
#REM 75287 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 75291 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 75295 DEFINE FUNCTION PIINDEX.I INTEGER LIROW RETURNS INTEGER
#REM 75299 DEFINE PROCEDURE SET PIINDEX.I INTEGER LIROW INTEGER VALUE
#REM 75303 DEFINE FUNCTION PIATTR.I INTEGER LIROW RETURNS INTEGER
#REM 75307 DEFINE PROCEDURE SET PIATTR.I INTEGER LIROW INTEGER VALUE
#REM 75311 DEFINE FUNCTION PIINSTRTYPE.I INTEGER LIROW RETURNS INTEGER
#REM 75315 DEFINE PROCEDURE SET PIINSTRTYPE.I INTEGER LIROW INTEGER VALUE
75320>>>>>>>  procedure add_instruction integer type# integer attr# integer index# string value#
75322>>>>>>>    integer row#
75322>>>>>>>    get row_count to row#
75323>>>>>>>    set piInstrType.i row# to type#
75324>>>>>>>    set piAttr.i      row# to attr#
75325>>>>>>>    set piIndex.i     row# to index#
75326>>>>>>>    set psValue.i     row# to value#
75327>>>>>>>  end_procedure
75328>>>>>>>  function sInstructionText.i integer row# returns string
75330>>>>>>>    integer type# index# attr#
75330>>>>>>>    string val# rval#
75330>>>>>>>    get piInstrType.i row# to type#
75331>>>>>>>    get piAttr.i      row# to attr#
75332>>>>>>>    get piIndex.i     row# to index#
75333>>>>>>>    get psValue.i row# to val#
75334>>>>>>>    move ("Set "+API_Attr_Name(attr#)+" index "+string(index#)+" To "+API_Attr_ValueName(attr#,val#)) to rval#
75335>>>>>>>    function_return rval#
75336>>>>>>>  end_function
75337>>>>>>>  procedure seq_report_on_changes integer liChannel
75339>>>>>>>  end_procedure
75340>>>>>>>end_class // cStrucPgmHelp3
75341>>>>>>>
75341>>>>>>>class cStrucPgmHelp4 is a cStrucPgmHelpClass // INDEX SEGMENT instructions
75342>>>>>>>  item_property_list
75342>>>>>>>    item_property integer piInstrType.i // Instruction type
75342>>>>>>>    item_property integer piAttr.i      // Set_Attribute Attr#
75342>>>>>>>    item_property integer piIndex.i     //        Index index#
75342>>>>>>>    item_property integer piSegment.i   //    segment segment#
75342>>>>>>>    item_property string  psValue.i     //           To Value#
75342>>>>>>>  end_item_property_list cStrucPgmHelp4
#REM 75383 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 75387 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 75391 DEFINE FUNCTION PISEGMENT.I INTEGER LIROW RETURNS INTEGER
#REM 75395 DEFINE PROCEDURE SET PISEGMENT.I INTEGER LIROW INTEGER VALUE
#REM 75399 DEFINE FUNCTION PIINDEX.I INTEGER LIROW RETURNS INTEGER
#REM 75403 DEFINE PROCEDURE SET PIINDEX.I INTEGER LIROW INTEGER VALUE
#REM 75407 DEFINE FUNCTION PIATTR.I INTEGER LIROW RETURNS INTEGER
#REM 75411 DEFINE PROCEDURE SET PIATTR.I INTEGER LIROW INTEGER VALUE
#REM 75415 DEFINE FUNCTION PIINSTRTYPE.I INTEGER LIROW RETURNS INTEGER
#REM 75419 DEFINE PROCEDURE SET PIINSTRTYPE.I INTEGER LIROW INTEGER VALUE
75424>>>>>>>  procedure add_instruction integer type# integer attr# integer index# integer segment# string value#
75426>>>>>>>    integer row#
75426>>>>>>>    get row_count to row#
75427>>>>>>>    set piInstrType.i row# to type#
75428>>>>>>>    set piAttr.i      row# to attr#
75429>>>>>>>    set piIndex.i     row# to index#
75430>>>>>>>    set piSegment.i   row# to segment#
75431>>>>>>>    set psValue.i     row# to value#
75432>>>>>>>  end_procedure
75433>>>>>>>  function sInstructionText.i integer row# returns string
75435>>>>>>>    integer type# index# attr# segment#
75435>>>>>>>    string val# rval#
75435>>>>>>>    get piInstrType.i row# to type#
75436>>>>>>>    get piAttr.i      row# to attr#
75437>>>>>>>    get piIndex.i     row# to index#
75438>>>>>>>    get piSegment.i   row# to segment#
75439>>>>>>>    get psValue.i row# to val#
75440>>>>>>>    move ("Set "+API_Attr_Name(attr#)+" index "+string(index#)+" segment "+string(segment#)+" To "+API_Attr_ValueName(attr#,val#)) to rval#
75441>>>>>>>    function_return rval#
75442>>>>>>>  end_function
75443>>>>>>>  procedure seq_report_on_changes integer liChannel
75445>>>>>>>  end_procedure
75446>>>>>>>end_class // cStrucPgmHelp4
75447>>>>>>>
75447>>>>>>>class cFdxRestructureProgram is a cArray
75448>>>>>>>  procedure construct_object integer img#
75450>>>>>>>    forward send construct_object img#
75452>>>>>>>
75452>>>>>>>    property integer piFile               public 0
75453>>>>>>>    property string  psRootName           public ""
75454>>>>>>>    property integer piProgramType        public PGM_TYPE_NONE // PGM_TYPE_NONE PGM_TYPE_EMPTY PGM_TYPE_EDIT PGM_TYPE_CREATE PGM_TYPE_DROP
75455>>>>>>>    property integer piExecuted           public 0
75456>>>>>>>    property integer piSortOnEndStructure  public DFFALSE
75457>>>>>>>    property integer pbDeleteDroppedTables public DFFALSE
75458>>>>>>>    property integer pbRestructureError   public DFFALSE
75459>>>>>>>
75459>>>>>>>    object oFileListPgm is a cStrucPgmHelp1 NO_IMAGE
75461>>>>>>>    end_object
75462>>>>>>>    object oFilePgm     is a cStrucPgmHelp1 NO_IMAGE
75464>>>>>>>    end_object
75465>>>>>>>    object oFieldPgm    is a cStrucPgmHelp2 NO_IMAGE
75467>>>>>>>    end_object
75468>>>>>>>    object oIndexPgm    is a cStrucPgmHelp3 NO_IMAGE
75470>>>>>>>    end_object
75471>>>>>>>    object oIndexSegPgm is a cStrucPgmHelp4 NO_IMAGE
75473>>>>>>>    end_object
75474>>>>>>>    object oInitialStateFDX is a cFdxFileDef NO_IMAGE
75476>>>>>>>    end_object
75477>>>>>>>  end_procedure
75478>>>>>>>
75478>>>>>>>  procedure callback_deleted_fields integer lhMsg integer lhObj
75480>>>>>>>    integer liRow liMax liFile lhFieldPgm liField
75480>>>>>>>    integer liInstrMax liInstr liInstrType
75480>>>>>>>    string  lsRoot lsName
75480>>>>>>>    if (not(piExecuted(self)) and piProgramType(self)=PGM_TYPE_EDIT) begin
75482>>>>>>>      get piFile     to liFile
75483>>>>>>>      get psRootName to lsRoot
75484>>>>>>>      move (oFieldPgm(self)) to lhFieldPgm
75485>>>>>>>
75485>>>>>>>      get row_count of lhFieldPgm to liInstrMax
75486>>>>>>>      decrement liInstrMax
75487>>>>>>>      for liInstr from 0 to liInstrMax
75493>>>>>>>>
75493>>>>>>>        if (piInstrType.i(lhFieldPgm,liInstr)=INSTR_TYPE_DELETE) begin
75495>>>>>>>
75495>>>>>>>          get piField.i of lhFieldPgm liInstr to liField
75496>>>>>>>          get psFieldName.i of lhFieldPgm liInstr to lsName
75497>>>>>>>          send lhMsg to lhObj liFile liField lsName lsRoot
75498>>>>>>>        end
75498>>>>>>>>
75498>>>>>>>      loop
75499>>>>>>>>
75499>>>>>>>    end
75499>>>>>>>>
75499>>>>>>>  end_procedure
75500>>>>>>>
75500>>>>>>>  function sTitle returns string
75502>>>>>>>    integer lbExecuted lbError
75502>>>>>>>    string lsRval
75502>>>>>>>    get piExecuted to lbExecuted
75503>>>>>>>    get pbRestructureError to lbError
75504>>>>>>>
75504>>>>>>>    get psRootName to lsRval
75505>>>>>>>    move (lsRval+" ("+string(piFile(self))+"): "+StructPgm_ProgramType_Text(piProgramType(self))) to lsRval
75506>>>>>>>
75506>>>>>>>    if lbExecuted begin
75508>>>>>>>      if lbError move (lsRval+" (EXEC-ERROR)") to lsRval
75511>>>>>>>      else move (lsRval+" (Executed)") to lsRval
75513>>>>>>>    end
75513>>>>>>>>
75513>>>>>>>    else if lbError move (lsRval+" (INIT-ERROR)") to lsRval
75517>>>>>>>    function_return lsRval
75518>>>>>>>  end_function
75519>>>>>>>  procedure reset
75521>>>>>>>    send reset to (oFileListPgm(self))
75522>>>>>>>    send reset to (oFilePgm(self))
75523>>>>>>>    send reset to (oFieldPgm(self))
75524>>>>>>>    send reset to (oIndexPgm(self))
75525>>>>>>>    send reset to (oInitialStateFDX(self))
75526>>>>>>>    set piExecuted to DFFALSE
75527>>>>>>>  end_procedure
75528>>>>>>>  procedure add_filelist_instruction integer attr# string value#
75530>>>>>>>    send add_instruction to (oFileListPgm(self)) attr# value#
75531>>>>>>>  end_procedure
75532>>>>>>>  procedure add_file_instruction integer attr# string value#
75534>>>>>>>    send add_instruction to (oFilePgm(self)) attr# value#
75535>>>>>>>  end_procedure
75536>>>>>>>  procedure add_field_instruction integer type# integer attr# integer field# string name# string value#
75538>>>>>>>    send add_instruction to (oFieldPgm(self)) type# attr# field# name# value#
75539>>>>>>>  end_procedure
75540>>>>>>>  procedure add_index_instruction integer type# integer attr# integer index# string value#
75542>>>>>>>    send add_instruction to (oIndexPgm(self)) type# attr# index# value#
75543>>>>>>>  end_procedure
75544>>>>>>>  procedure add_indexseg_instruction integer type# integer attr# integer index# integer segment# string value#
75546>>>>>>>    send add_instruction to (oIndexSegPgm(self)) type# attr# index# segment# value#
75547>>>>>>>  end_procedure
75548>>>>>>>  procedure apply_filelist_changes
75550>>>>>>>    integer obj# row# max# attr# file#
75550>>>>>>>    string str#
75550>>>>>>>    move (oFileListPgm(self)) to obj#
75551>>>>>>>    get row_count of obj# to max#
75552>>>>>>>    get piFile to file#
75553>>>>>>>    for row# from 0 to (max#-1)
75559>>>>>>>>
75559>>>>>>>      get piAttr.i  of obj# row# to attr#
75560>>>>>>>      get psValue.i of obj# row# to str#
75561>>>>>>>      send RS_SetFileListAttr attr# file# str#
75562>>>>>>>    loop
75563>>>>>>>>
75563>>>>>>>  end_procedure
75564>>>>>>>  procedure apply_file_changes
75566>>>>>>>    integer obj# row# max# attr#
75566>>>>>>>    string str#
75566>>>>>>>    move (oFilePgm(self)) to obj#
75567>>>>>>>    get row_count of obj# to max#
75568>>>>>>>    for row# from 0 to (max#-1)
75574>>>>>>>>
75574>>>>>>>      get piAttr.i  of obj# row# to attr#
75575>>>>>>>      get psValue.i of obj# row# to str#
75576>>>>>>>      send RS_SetFileAttr attr# str#
75577>>>>>>>    loop
75578>>>>>>>>
75578>>>>>>>  end_procedure
75579>>>>>>>  procedure apply_field_changes
75581>>>>>>>    integer obj# row# max# attr# field# type#
75581>>>>>>>    string str# name#
75581>>>>>>>    move (oFieldPgm(self)) to obj#
75582>>>>>>>    get row_count of obj# to max#
75583>>>>>>>    for row# from 0 to (max#-1)
75589>>>>>>>>
75589>>>>>>>      get piInstrType.i of obj# row# to type#
75590>>>>>>>      get piAttr.i      of obj# row# to attr#
75591>>>>>>>      get piField.i     of obj# row# to field#
75592>>>>>>>      get psFieldName.i of obj# row# to name#
75593>>>>>>>      get psValue.i     of obj# row# to str#
75594>>>>>>>      if type# eq INSTR_TYPE_EDIT begin
75596>>>>>>>        if field# eq 0 begin // Field has just been created
75598>>>>>>>          send RS_SetFieldAttr attr# IMPLICIT_FIELD str#
75599>>>>>>>        end
75599>>>>>>>>
75599>>>>>>>        else begin
75600>>>>>>>          send RS_SetFieldAttr_ByName attr# name# str#
75601>>>>>>>        end
75601>>>>>>>>
75601>>>>>>>      end
75601>>>>>>>>
75601>>>>>>>      if type# eq INSTR_TYPE_CREATE send RS_CreateField field# str# DF_ASCII // DF_ASCII is just temporary
75604>>>>>>>      if type# eq INSTR_TYPE_DELETE send RS_DeleteField_OldNumber field#
75607>>>>>>>      if type# eq INSTR_TYPE_APPEND send RS_AppendField str# DF_ASCII // DF_ASCII is just temporary
75610>>>>>>>    loop
75611>>>>>>>>
75611>>>>>>>  end_procedure
75612>>>>>>>  procedure initialize.i integer oFDX# integer file#
75614>>>>>>>  end_procedure
75615>>>>>>>  procedure apply_index_changes
75617>>>>>>>    integer obj# row# max# attr# index# segment#
75617>>>>>>>    string str#
75617>>>>>>>    move (oIndexPgm(self)) to obj#
75618>>>>>>>    get row_count of obj# to max#
75619>>>>>>>    for row# from 0 to (max#-1)
75625>>>>>>>>
75625>>>>>>>      get piAttr.i  of obj# row# to attr#
75626>>>>>>>      get piIndex.i of obj# row# to index#
75627>>>>>>>      get psValue.i of obj# row# to str#
75628>>>>>>>      send RS_SetIndexAttr attr# index# str#
75629>>>>>>>    loop
75630>>>>>>>>
75630>>>>>>>    move (oIndexSegPgm(self)) to obj#
75631>>>>>>>    get row_count of obj# to max#
75632>>>>>>>    for row# from 0 to (max#-1)
75638>>>>>>>>
75638>>>>>>>      get piAttr.i    of obj# row# to attr#
75639>>>>>>>      get piIndex.i   of obj# row# to index#
75640>>>>>>>      get piSegment.i of obj# row# to segment#
75641>>>>>>>      get psValue.i   of obj# row# to str#
75642>>>>>>>      send RS_SetIndexSegAttr attr# index# segment# str#
75643>>>>>>>    loop
75644>>>>>>>>
75644>>>>>>>  end_procedure
75645>>>>>>>  enumeration_list
75645>>>>>>>    define PCE_NO_ERROR
75645>>>>>>>    define PCE_NOT_A_VALID_ENTRY
75645>>>>>>>    define PCE_ROOTNAME_MISMATCH
75645>>>>>>>    define PCE_INCOMPATIBLE_TABLE_DEFINITION
75645>>>>>>>    define PCE_NOT_FLEXERRS
75645>>>>>>>  end_enumeration_list
75645>>>>>>>  function iPreconditionsError returns integer
75647>>>>>>>    integer file# rval#
75647>>>>>>>    string rn# current_rn#
75647>>>>>>>    move PCE_NO_ERROR to rval#
75648>>>>>>>    get piFile to file# // This is the file we're supposed to restructure
75649>>>>>>>    // Do we have such a file?
75649>>>>>>>    move (API_AttrValue_FILELIST(DF_FILE_ROOT_NAME,file#)) to current_rn#
75650>>>>>>>//  if current_rn# ne "" begin
75650>>>>>>>      get psRootName to rn#
75651>>>>>>>      if (uppercase(DBMS_StripPathAndDriver(rn#))=uppercase(DBMS_StripPathAndDriver(current_rn#)) or current_rn#="") begin
75653>>>>>>>        if (uppercase(rn#)<>"FLEXERRS") begin
75655>>>>>>>          // In the future one could check the initial definition of the
75655>>>>>>>          // table here!
75655>>>>>>>        end
75655>>>>>>>>
75655>>>>>>>        else move PCE_NOT_FLEXERRS to rval#
75657>>>>>>>      end
75657>>>>>>>>
75657>>>>>>>      else begin
75658>>>>>>>        //send obs (uppercase(DBMS_StripPathAndDriver(rn#))) (uppercase(DBMS_StripPathAndDriver(current_rn#)))
75658>>>>>>>        move PCE_ROOTNAME_MISMATCH to rval#
75659>>>>>>>      end
75659>>>>>>>>
75659>>>>>>>//  end
75659>>>>>>>//  else move PCE_NOT_A_VALID_ENTRY to rval#
75659>>>>>>>    function_return rval#
75660>>>>>>>  end_function
75661>>>>>>>  procedure Execute
75663>>>>>>>    integer type# file# ok# err#
75663>>>>>>>    string rn#
75663>>>>>>>    ifnot (piExecuted(self)) begin
75665>>>>>>>      get piFile     to file#
75666>>>>>>>      get psRootName to rn#
75667>>>>>>>      get iPreconditionsError to err#
75668>>>>>>>      if err# eq PCE_NO_ERROR begin
75670>>>>>>>        get piProgramType to type#
75671>>>>>>>        if (type#<>PGM_TYPE_NONE and type#<>PGM_TYPE_EMPTY) begin // If it's there and it's not empty
75673>>>>>>>          if type# eq PGM_TYPE_CREATE   get RS_TableCreateName rn# to ok#
75676>>>>>>>          else begin
75677>>>>>>>            if (RS_TableExistsName(rn#)) begin
75679>>>>>>>              if type# eq PGM_TYPE_DROP begin
75681>>>>>>>                if (pbDeleteDroppedTables(self)) get RS_TableDropName rn# to ok#
75684>>>>>>>                else move 1 to ok# // No delete
75686>>>>>>>              end
75686>>>>>>>>
75686>>>>>>>              if type# eq PGM_TYPE_EDIT begin
75688>>>>>>>                get RS_TableOpenName file# rn# to ok#
75689>>>>>>>                ifnot ok# error 321 ("Could not open: "+trim(rn#))
75692>>>>>>>              end
75692>>>>>>>>
75692>>>>>>>              if type# eq PGM_TYPE_FILELIST begin
75694>>>>>>>                move 1 to ok#
75695>>>>>>>              end
75695>>>>>>>>
75695>>>>>>>            end
75695>>>>>>>>
75695>>>>>>>            else error 322 ("Table not found: "+trim(rn#))
75697>>>>>>>          end
75697>>>>>>>>
75697>>>>>>>
75697>>>>>>>          if ok# begin
75699>>>>>>>            set pbRestructureError to  DFFALSE
75700>>>>>>>            send apply_filelist_changes
75701>>>>>>>            if (type#<>PGM_TYPE_DROP and type#<>PGM_TYPE_FILELIST) begin
75703>>>>>>>              send apply_file_changes
75704>>>>>>>              send apply_field_changes
75705>>>>>>>              send apply_index_changes
75706>>>>>>>              send RS_Structure_End (piSortOnEndStructure(self))
75707>>>>>>>              set pbRestructureError to (pbError(oStructure_LogFile(self)))
75708>>>>>>>            end
75708>>>>>>>>
75708>>>>>>>            set piExecuted to DFTRUE
75709>>>>>>>          end
75709>>>>>>>>
75709>>>>>>>          else set pbRestructureError to DFTRUE
75711>>>>>>>        end
75711>>>>>>>>
75711>>>>>>>      end
75711>>>>>>>>
75711>>>>>>>      else begin
75712>>>>>>>        if err# eq PCE_NOT_A_VALID_ENTRY send error 323 (string(file#)+" is not a valid entry")
75715>>>>>>>        if err# eq PCE_NOT_FLEXERRS      send error 324 ("I refuse to restructure FLEXERRS.DAT. Sorry! (File number: "+string(file#)+")")
75718>>>>>>>        if err# eq PCE_ROOTNAME_MISMATCH send error 325 "Incorrect root name"
75721>>>>>>>      end
75721>>>>>>>>
75721>>>>>>>    end
75721>>>>>>>>
75721>>>>>>>  end_procedure
75722>>>>>>>  // Procedure seq_write writes the contents of the object so that seq_read
75722>>>>>>>  // will read it back in again
75722>>>>>>>  procedure seq_write integer liChannel
75724>>>>>>>    writeln channel liChannel (piFile(self))
75727>>>>>>>    writeln (psRootName(self))
75729>>>>>>>    writeln (piProgramType(self))
75731>>>>>>>    writeln (piExecuted(self))
75733>>>>>>>    send SEQ_WriteArrayItems liChannel (oFileListPgm(self))
75734>>>>>>>    send SEQ_WriteArrayItems liChannel (oFilePgm(self))
75735>>>>>>>    send SEQ_WriteArrayItems liChannel (oFieldPgm(self))
75736>>>>>>>    send SEQ_WriteArrayItems liChannel (oIndexPgm(self))
75737>>>>>>>    send SEQ_WriteArrayItems liChannel (oIndexSegPgm(self))
75738>>>>>>>    send Seq_Write to (oInitialStateFDX(self)) liChannel
75739>>>>>>>  end_procedure
75740>>>>>>>  // Procedure seq_read reads what seq_write has written
75740>>>>>>>  procedure seq_read integer liChannel
75742>>>>>>>    set piFile        to (SEQ_ReadLn(liChannel))
75743>>>>>>>    set psRootName    to (SEQ_ReadLn(liChannel))
75744>>>>>>>    set piProgramType to (SEQ_ReadLn(liChannel))
75745>>>>>>>    set piExecuted    to (SEQ_ReadLn(liChannel))
75746>>>>>>>    send SEQ_ReadArrayItems liChannel (oFileListPgm(self))
75747>>>>>>>    send SEQ_ReadArrayItems liChannel (oFilePgm(self))
75748>>>>>>>    send SEQ_ReadArrayItems liChannel (oFieldPgm(self))
75749>>>>>>>    send SEQ_ReadArrayItems liChannel (oIndexPgm(self))
75750>>>>>>>    send SEQ_ReadArrayItems liChannel (oIndexSegPgm(self))
75751>>>>>>>    send Seq_Read to (oInitialStateFDX(self)) liChannel
75752>>>>>>>  end_procedure
75753>>>>>>>//
75753>>>>>>>//  /StrucPgm.ProgList.Header
75753>>>>>>>//
75753>>>>>>>//  /*
75753>>>>>>>//
75753>>>>>>>//    // Procedure seq_report outputs changes in report format
75753>>>>>>>//           Fields Att Idx
75753>>>>>>>//  Root     Ins Del Alt Alt Alt Location
75753>>>>>>>//  ________ __. __. __. __. __. _______________________________________________
75753>>>>>>>//
75753>>>>>>>
75753>>>>>>>  procedure seq_report_on_changes integer liChannel
75755>>>>>>>    integer liObj liProgType
75755>>>>>>>    string lsRootName lsString
75755>>>>>>>    get piProgramType to liProgType
75756>>>>>>>    get psRootName    to lsRootName
75757>>>>>>>    if (liProgType=PGM_TYPE_CREATE or liProgType=PGM_TYPE_DROP or liProgType=PGM_TYPE_EDIT) begin
75759>>>>>>>      writeln channel liChannel ""
75762>>>>>>>      if liProgType eq PGM_TYPE_CREATE writeln channel liChannel ("Create "+lsRootName)
75767>>>>>>>      if liProgType eq PGM_TYPE_DROP   writeln channel liChannel ("Drop "+lsRootName)
75772>>>>>>>      if liProgType eq PGM_TYPE_EDIT   begin
75774>>>>>>>        writeln channel liChannel ("Edit "+lsRootName)
75777>>>>>>>        send seq_report_on_changes to (oFileListPgm(self)) liChannel
75778>>>>>>>        send seq_report_on_changes to (oFilePgm(self)) liChannel
75779>>>>>>>        send seq_report_on_changes to (oFieldPgm(self)) liChannel
75780>>>>>>>        send seq_report_on_changes to (oIndexPgm(self)) liChannel
75781>>>>>>>      end
75781>>>>>>>>
75781>>>>>>>    end
75781>>>>>>>>
75781>>>>>>>  end_procedure
75782>>>>>>>            procedure callback_program_listing_help integer lhPgmFragment integer liMsg integer lhObj
75784>>>>>>>              integer liRow liMax
75784>>>>>>>              get row_count of lhPgmFragment to liMax
75785>>>>>>>              for liRow from 0 to (liMax-1)
75791>>>>>>>>
75791>>>>>>>                send liMsg to lhObj (sInstructionText.i(lhPgmFragment,liRow))
75792>>>>>>>              loop
75793>>>>>>>>
75793>>>>>>>            end_procedure
75794>>>>>>>  procedure callback_program_listing integer liMsg integer lhObj
75796>>>>>>>    send liMsg to lhObj "******* Filelist parameters *******"
75797>>>>>>>    send callback_program_listing_help (oFileListPgm(self)) liMsg lhObj
75798>>>>>>>    send liMsg to lhObj "******* File parameters *******"
75799>>>>>>>    send callback_program_listing_help (oFilePgm(self)) liMsg lhObj
75800>>>>>>>    send liMsg to lhObj "******* Field parameters *******"
75801>>>>>>>    send callback_program_listing_help (oFieldPgm(self)) liMsg lhObj
75802>>>>>>>    send liMsg to lhObj "******* Index parameters *******"
75803>>>>>>>    send callback_program_listing_help (oIndexPgm(self)) liMsg lhObj
75804>>>>>>>    send callback_program_listing_help (oIndexSegPgm(self)) liMsg lhObj
75805>>>>>>>  end_procedure
75806>>>>>>>end_class // cFdxRestructureProgram
75807>>>>>>>
75807>>>>>>>function iCreateFdxRestructureProgram global returns integer
75809>>>>>>>  integer lhRval lhSelf
75809>>>>>>>  move self to lhSelf
75810>>>>>>>  move desktop to self
75811>>>>>>>  object oFdxRestructureProgram is a cFdxRestructureProgram NO_IMAGE
75813>>>>>>>    move self to lhRval
75814>>>>>>>  end_object
75815>>>>>>>  move lhSelf to self
75816>>>>>>>  function_return lhRval
75817>>>>>>>end_function
75818>>>>>>>
75818>>>>>>>class cFdxRestructureProgramArray is a cArray
75819>>>>>>>  procedure construct_object integer liImg
75821>>>>>>>    forward send construct_object liImg
75823>>>>>>>    property integer piSortOnEndStructure   public DFFALSE
75824>>>>>>>    property integer pbDeleteDroppedTables public DFFALSE
75825>>>>>>>    property integer piErrorDuringStructure public DFFALSE
75826>>>>>>>  end_procedure
75827>>>>>>>  item_property_list
75827>>>>>>>    item_property integer piFile.i
75827>>>>>>>    item_property string  psRootName.i
75827>>>>>>>    item_property integer piObject.i
75827>>>>>>>  end_item_property_list cFdxRestructureProgramArray
#REM 75862 DEFINE FUNCTION PIOBJECT.I INTEGER LIROW RETURNS INTEGER
#REM 75866 DEFINE PROCEDURE SET PIOBJECT.I INTEGER LIROW INTEGER VALUE
#REM 75870 DEFINE FUNCTION PSROOTNAME.I INTEGER LIROW RETURNS STRING
#REM 75874 DEFINE PROCEDURE SET PSROOTNAME.I INTEGER LIROW STRING VALUE
#REM 75878 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 75882 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
75887>>>>>>>  procedure Reset
75889>>>>>>>    integer row# max# obj#
75889>>>>>>>    get row_count to max#
75890>>>>>>>    for row# from 0 to (max#-1)
75896>>>>>>>>
75896>>>>>>>      get piObject.i row# to obj#
75897>>>>>>>      if obj# send request_destroy_object to obj#
75900>>>>>>>    loop
75901>>>>>>>>
75901>>>>>>>    send delete_data
75902>>>>>>>  end_procedure
75903>>>>>>>  procedure Reset.i integer liRow
75905>>>>>>>    integer lhObj
75905>>>>>>>    get piObject.i liRow to lhObj
75906>>>>>>>    if lhObj send request_destroy_object to lhObj
75909>>>>>>>    set piObject.i liRow to 0
75910>>>>>>>    send delete_row liRow
75911>>>>>>>  end_procedure
75912>>>>>>>  function iAddPgmRow.is integer liFile string lsRoot returns integer
75914>>>>>>>    integer liRow
75914>>>>>>>    get row_count to liRow
75915>>>>>>>    set piFile.i     liRow to liFile
75916>>>>>>>    set psRootName.i liRow to lsRoot
75917>>>>>>>    function_return liRow
75918>>>>>>>  end_function
75919>>>>>>>  function iFindPgmRow.is integer liFile string lsRoot returns integer
75921>>>>>>>    integer liMax liRow
75921>>>>>>>    get row_count to liMax
75922>>>>>>>    for liRow from 0 to (liMax-1)
75928>>>>>>>>
75928>>>>>>>      if (uppercase(lsRoot)=uppercase(psRootName.i(self,liRow))) function_return liRow
75931>>>>>>>    loop
75932>>>>>>>>
75932>>>>>>>    function_return -1
75933>>>>>>>  end_function
75934>>>>>>>  function iFindRowFromFile.i integer liFile returns integer
75936>>>>>>>    integer liMax liRow
75936>>>>>>>    get row_count to liMax
75937>>>>>>>    for liRow from 0 to (liMax-1)
75943>>>>>>>>
75943>>>>>>>      if (liFile=piFile.i(self,liRow)) function_return liRow
75946>>>>>>>    loop
75947>>>>>>>>
75947>>>>>>>    function_return -1
75948>>>>>>>  end_function
75949>>>>>>>  function iFindRowFromPgm.i integer pgm# returns integer
75951>>>>>>>    integer liMax liRow
75951>>>>>>>    get row_count to liMax
75952>>>>>>>    for liRow from 0 to (liMax-1)
75958>>>>>>>>
75958>>>>>>>      if (pgm#=piObject.i(self,liRow)) function_return liRow
75961>>>>>>>    loop
75962>>>>>>>>
75962>>>>>>>    function_return -1
75963>>>>>>>  end_function
75964>>>>>>>  //  procedure HandleDeletedField integer liFile integer liField string lsName
75964>>>>>>>  procedure callback_deleted_fields integer lhMsg integer lhObj
75966>>>>>>>    integer liRow liMax lhPgm liFile lhFieldPgm liField
75966>>>>>>>    integer liInstrMax liInstr liInstrType
75966>>>>>>>    string  lsRoot lsName
75966>>>>>>>    get row_count to liMax
75967>>>>>>>    decrement liMax
75968>>>>>>>    for liRow from 0 to liMax
75974>>>>>>>>
75974>>>>>>>      get piObject.i liRow to lhPgm
75975>>>>>>>      if lhPgm send callback_deleted_fields to lhPgm lhMsg lhObj
75978>>>>>>>    loop
75979>>>>>>>>
75979>>>>>>>  end_procedure
75980>>>>>>>  // procedure HandleDeletedTable integer liFile string lsRoot
75980>>>>>>>  procedure callback_deleted_tables integer lhMsg integer lhObj
75982>>>>>>>    integer liRow liMax lhPgm liFile
75982>>>>>>>    string  lsRoot
75982>>>>>>>    get row_count to liMax
75983>>>>>>>    decrement liMax
75984>>>>>>>    for liRow from 0 to liMax
75990>>>>>>>>
75990>>>>>>>      get piObject.i liRow to lhPgm
75991>>>>>>>      if lhPgm begin
75993>>>>>>>        if (not(piExecuted(lhPgm)) and piProgramType(lhPgm)=PGM_TYPE_DROP) begin
75995>>>>>>>          get piFile.i     liRow to liFile
75996>>>>>>>          get psRootName.i liRow to lsRoot
75997>>>>>>>          send lhMsg to lhObj liFile lsRoot (piProgramType(lhPgm)) (piExecuted(lhPgm)) (sTitle(lhPgm))
75998>>>>>>>        end
75998>>>>>>>>
75998>>>>>>>      end
75998>>>>>>>>
75998>>>>>>>    loop
75999>>>>>>>>
75999>>>>>>>  end_procedure
76000>>>>>>>  procedure callback_all integer lhMsg integer lhObj
76002>>>>>>>    integer liRow liMax lhPgm liFile
76002>>>>>>>    string  lsRoot
76002>>>>>>>    get row_count to liMax
76003>>>>>>>    decrement liMax
76004>>>>>>>    for liRow from 0 to liMax
76010>>>>>>>>
76010>>>>>>>      get piObject.i liRow to lhPgm
76011>>>>>>>      if lhPgm begin
76013>>>>>>>        get piFile.i     liRow to liFile
76014>>>>>>>        get psRootName.i liRow to lsRoot
76015>>>>>>>        send lhMsg to lhObj liFile lsRoot (piProgramType(lhPgm)) (piExecuted(lhPgm)) (sTitle(lhPgm))
76016>>>>>>>      end
76016>>>>>>>>
76016>>>>>>>    loop
76017>>>>>>>>
76017>>>>>>>  end_procedure
76018>>>>>>>  procedure callback_program_listing integer liFile integer liMsg integer lhObj
76020>>>>>>>    integer liRow lhPgm
76020>>>>>>>    get iFindRowFromFile.i liFile to liRow
76021>>>>>>>    if (liRow<>-1) begin
76023>>>>>>>      get piObject.i liRow to lhPgm
76024>>>>>>>      send callback_program_listing to lhPgm liMsg lhObj
76025>>>>>>>    end
76025>>>>>>>>
76025>>>>>>>  end_procedure
76026>>>>>>>  procedure Execute
76028>>>>>>>    integer max# row# liState liObj
76028>>>>>>>    set piErrorDuringStructure to DFFALSE
76029>>>>>>>    send RS_Progress RS_PG_LEAVE_ON
76030>>>>>>>    get row_count to max#
76031>>>>>>>    for row# from 0 to (max#-1)
76037>>>>>>>>
76037>>>>>>>      get piObject.i row# to liObj
76038>>>>>>>      get piSortOnEndStructure  of liObj to liState
76039>>>>>>>      set piSortOnEndStructure  of liObj to (piSortOnEndStructure(self))
76040>>>>>>>      set pbDeleteDroppedTables of liObj to (pbDeleteDroppedTables(self))
76041>>>>>>>      send Execute to liObj
76042>>>>>>>      if (pbRestructureError(liObj)) set piErrorDuringStructure to DFTRUE
76045>>>>>>>      set piSortOnEndStructure of liObj to liState
76046>>>>>>>    loop
76047>>>>>>>>
76047>>>>>>>    send RS_Progress RS_PG_OFF
76048>>>>>>>  end_procedure
76049>>>>>>>end_class // cFdxRestructureProgramArray
76050>>>>>>>
76050>>>>>>>desktop_section
76055>>>>>>>  object oFdxRestructureProgramArray is a cFdxRestructureProgramArray NO_IMAGE
76057>>>>>>>  end_object // oFdxRestructureProgramArray
76058>>>>>>>end_desktop_section
76063>>>Use FdxCompa.nui // Class for comparing table definitions
Including file: fdxcompa.nui    (C:\Apps\VDFQuery\AppSrc\fdxcompa.nui)
76063>>>>>// Use FdxCompa.nui // Class for comparing table definitions
76063>>>>>
76063>>>>>Use Compare.nui  // Abstract class for comparing item based information
Including file: compare.nui    (C:\Apps\VDFQuery\AppSrc\compare.nui)
76063>>>>>>>// Use Compare.nui  // Abstract class for comparing item based information
76063>>>>>>>// From the VDFQuery download by Sture ApS
76063>>>>>>>
76063>>>>>>>//> pkgdoc.begin
76063>>>>>>>//> Class for comparing item based information. This class may be used when you have random access to
76063>>>>>>>//> the data that you want to compare (ie. when the data resides in arrays).
76063>>>>>>>//> pkgdoc.end
76063>>>>>>>
76063>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
76063>>>>>>>
76063>>>>>>>// ===========================================================================
76063>>>>>>>//    cItemBasedCompare class
76063>>>>>>>// ===========================================================================
76063>>>>>>>
76063>>>>>>>define COMPARE_ORDERED   for 0 // Formerly: COMPARE_SYNCHRONIZED
76063>>>>>>>define COMPARE_UNORDERED for 1 // Formerly: COMPARE_SINGLE_SEQUENTIAL
76063>>>>>>>
76063>>>>>>>
76063>>>>>>>class cItemBasedCompare is an cArray
76064>>>>>>>  procedure construct_object integer img#
76066>>>>>>>    forward send construct_object img#
76068>>>>>>>
76068>>>>>>>    //> Setting piStrategy to COMPARE_UNORDERED will perform the comparison
76068>>>>>>>    //> assuming no particular ordering sequence of the items to be compared. Could be
76068>>>>>>>    //> used for creating any kind of map for matching for example field names in a
76068>>>>>>>    //> table with column names in a CSV file.
76068>>>>>>>    //>
76068>>>>>>>    //> On the other hand, setting piStrategy to COMPARE_ORDERED will assume that the
76068>>>>>>>    //> items are to occur in identical order on the two sides. Using this strategy you will
76068>>>>>>>    //> not be able to detect if entries have been switched. It could be used for comparing
76068>>>>>>>    //> two text files (if loaded into arrays).
76068>>>>>>>    property integer piStrategy  public COMPARE_ORDERED
76069>>>>>>>
76069>>>>>>>    //> This property defines how how far the object will search
76069>>>>>>>    //> in order to re-syncronize.
76069>>>>>>>    //> Setting it to 0 (its default value) means there is no limit.
76069>>>>>>>    property integer piSyncLimit public 0 // 0 means no limit
76070>>>>>>>
76070>>>>>>>    property integer pItemStart1 public 0 //> Lowest index on the primary side.
76071>>>>>>>    property integer pItemStop1  public 0 //> Highest index on the primary side.
76072>>>>>>>    property integer pItemStart2 public 0 //> Lowest index on the secondary side.
76073>>>>>>>    property integer pItemStop2  public 0 //> Highest index on the secondary side.
76074>>>>>>>  end_procedure
76075>>>>>>>  //> Return TRUE if the items match. Must be augmented.
76075>>>>>>>  function iCompareItems.ii integer itm1# integer itm2# returns integer
76077>>>>>>>  end_function
76078>>>>>>>  //> This is sent when items are found to be identical. Should be augmented.
76078>>>>>>>  procedure items_matched integer itm1# integer itm2#
76080>>>>>>>  end_procedure
76081>>>>>>>  //> This is sent when an item cannot be matched.
76081>>>>>>>  //> Means itm# on the left side couldn't be matched. The info parameter
76081>>>>>>>  //> gives a little extra information.
76081>>>>>>>  //>    -2: The item is missing in the end of the sequence
76081>>>>>>>  //>    -1: Sync limit exceeded. Missing somewhere in the middle of things.
76081>>>>>>>  //>   >=0: Missing from the right side at position info#
76081>>>>>>>  //> Should be augmented.
76081>>>>>>>  procedure item_not_matched1 integer itm# integer info#
76083>>>>>>>  end_procedure
76084>>>>>>>  //> This is sent when an item cannot be matched
76084>>>>>>>  //> Means itm# on the right side couldn't be matched. The info parameter
76084>>>>>>>  //> gives a little extra information.
76084>>>>>>>  //>    -2: The item is missing in the end of the sequence
76084>>>>>>>  //>    -1: Sync limit exceeded. Missing somewhere in the middle of things.
76084>>>>>>>  //>   >=0: Missing from the left side at position info#
76084>>>>>>>  //> Should be augmented.
76084>>>>>>>  procedure item_not_matched2 integer itm# integer info#
76086>>>>>>>  end_procedure
76087>>>>>>>  // This algorithm will not be able to detect if entries have been switched. It could be used
76087>>>>>>>  // for comparing two text files.
76087>>>>>>>  procedure run_synchronized
76089>>>>>>>    integer current1# current2#
76089>>>>>>>    integer stop1# stop2#
76089>>>>>>>    integer tmp_offset# fin# SyncLimit# itm#
76089>>>>>>>    get pItemStart1 to current1#  // Give us where to start and where to
76090>>>>>>>    get pItemStart2 to current2#  // stop on left and right side.
76091>>>>>>>    get pItemStop1 to stop1#      //
76092>>>>>>>    get pItemStop2 to stop2#      //
76093>>>>>>>    get piSyncLimit to SyncLimit# // Is there a limit
76094>>>>>>>    repeat
76094>>>>>>>>
76094>>>>>>>      ifnot (current1#>stop1# or current2#>stop2#) begin // There are still items to compare
76096>>>>>>>        if (iCompareItems.ii(self,current1#,current2#)) begin // And the next ones in line do match
76098>>>>>>>          send items_matched current1# current2#
76099>>>>>>>          increment current1#
76100>>>>>>>          increment current2#
76101>>>>>>>        end
76101>>>>>>>>
76101>>>>>>>        else begin // Didn't match
76102>>>>>>>          move 1 to tmp_offset#
76103>>>>>>>          move 0 to fin#
76104>>>>>>>          repeat
76104>>>>>>>>
76104>>>>>>>            if ((current2#+tmp_offset#<=stop2#) and iCompareItems.ii(self,current1#,current2#+tmp_offset#)) begin
76106>>>>>>>              for itm# from current2# to (current2#+tmp_offset#-1)
76112>>>>>>>>
76112>>>>>>>                send item_not_matched2 itm# current1#
76113>>>>>>>              loop
76114>>>>>>>>
76114>>>>>>>              send items_matched current1# (current2#+tmp_offset#)
76115>>>>>>>              increment current1#
76116>>>>>>>              move (current2#+tmp_offset#+1) to current2#
76117>>>>>>>              move 1 to fin#
76118>>>>>>>            end
76118>>>>>>>>
76118>>>>>>>            else begin
76119>>>>>>>              if ((current1#+tmp_offset#<=stop1#) and iCompareItems.ii(self,current1#+tmp_offset#,current2#)) begin
76121>>>>>>>                for itm# from current1# to (current1#+tmp_offset#-1)
76127>>>>>>>>
76127>>>>>>>                  send item_not_matched1 itm# current2#
76128>>>>>>>                loop
76129>>>>>>>>
76129>>>>>>>                send items_matched (current1#+tmp_offset#) current2#
76130>>>>>>>                move (current1#+tmp_offset#+1) to current1#
76131>>>>>>>                increment current2#
76132>>>>>>>                move 1 to fin#
76133>>>>>>>              end
76133>>>>>>>>
76133>>>>>>>            end
76133>>>>>>>>
76133>>>>>>>            ifnot fin# begin
76135>>>>>>>              increment tmp_offset#
76136>>>>>>>              if ((SyncLimit# and (tmp_offset#>SyncLimit#)) or (((current1#+tmp_offset#)>stop1#) and ((current2#+tmp_offset#)>stop2#))) begin
76138>>>>>>>                // Either sync-limit has been broken, or incrementing the
76138>>>>>>>                // tmp_offset# variable means that we are about to break the
76138>>>>>>>                // the stop item limit on one of the sides.
76138>>>>>>>                // NOTE! It is very important that the two next messages are sent
76138>>>>>>>                // in this order (first 2 then 1):
76138>>>>>>>                send item_not_matched2 current2# -1 // means: missing in the middle
76139>>>>>>>                send item_not_matched1 current1# -1 // means: missing in the middle
76140>>>>>>>                increment current1#
76141>>>>>>>                increment current2#
76142>>>>>>>                move 1 to fin#
76143>>>>>>>              end
76143>>>>>>>>
76143>>>>>>>            end
76143>>>>>>>>
76143>>>>>>>          until fin#
76145>>>>>>>        end
76145>>>>>>>>
76145>>>>>>>      end
76145>>>>>>>>
76145>>>>>>>    until (current1#>stop1# or current2#>stop2#)
76147>>>>>>>    for itm# from current1# to stop1#
76153>>>>>>>>
76153>>>>>>>      send item_not_matched1 itm# -2 // means: missing in the end
76154>>>>>>>    loop
76155>>>>>>>>
76155>>>>>>>    for itm# from current2# to stop2#
76161>>>>>>>>
76161>>>>>>>      send item_not_matched2 itm# -2 // means: missing in the end
76162>>>>>>>    loop
76163>>>>>>>>
76163>>>>>>>  end_procedure
76164>>>>>>>
76164>>>>>>>            procedure private.register_matched integer itm#
76166>>>>>>>              set value item itm# to 1
76167>>>>>>>            end_procedure
76168>>>>>>>            function private.is_matched integer itm# returns integer
76170>>>>>>>              function_return (value(self,itm#))
76171>>>>>>>            end_function
76172>>>>>>>
76172>>>>>>>  // This one assumes no particular sequence of items in either of the objects
76172>>>>>>>  // to be compared. Could be used for creating any kind of map for matching
76172>>>>>>>  // for example field names in a table with column names in a CSV file.
76172>>>>>>>  procedure run_single_sequential
76174>>>>>>>    integer current1# current2#
76174>>>>>>>    integer start1# start2#
76174>>>>>>>    integer stop1# stop2#
76174>>>>>>>    integer matched#
76174>>>>>>>    get pItemStart1 to start1#
76175>>>>>>>    get pItemStart2 to start2#
76176>>>>>>>    get pItemStop1 to stop1#
76177>>>>>>>    get pItemStop2 to stop2#
76178>>>>>>>    send delete_data
76179>>>>>>>    for current1# from start1# to stop1#
76185>>>>>>>>
76185>>>>>>>      move start2# to current2#
76186>>>>>>>      move 0 to matched#
76187>>>>>>>      repeat
76187>>>>>>>>
76187>>>>>>>        if (not(private.is_matched(self,current2#)) and iCompareItems.ii(self,current1#,current2#)) begin
76189>>>>>>>          send private.register_matched current2#
76190>>>>>>>          send items_matched current1# current2#
76191>>>>>>>          move 1 to matched#
76192>>>>>>>        end
76192>>>>>>>>
76192>>>>>>>        else increment current2#
76194>>>>>>>      until (matched# or current2#>stop2#)
76196>>>>>>>      ifnot matched# send item_not_matched1 current1#
76199>>>>>>>    loop
76200>>>>>>>>
76200>>>>>>>    for current2# from start2# to stop2#
76206>>>>>>>>
76206>>>>>>>      ifnot (private.is_matched(self,current2#)) send item_not_matched2 current2#
76209>>>>>>>    loop
76210>>>>>>>>
76210>>>>>>>  end_procedure
76211>>>>>>>  procedure run
76213>>>>>>>    integer liStrategy
76213>>>>>>>    get piStrategy to liStrategy
76214>>>>>>>    if liStrategy eq COMPARE_ORDERED      send run_synchronized
76217>>>>>>>    if liStrategy eq COMPARE_UNORDERED send run_single_sequential
76220>>>>>>>  end_procedure
76221>>>>>>>end_class // cItemBasedCompare
76222>>>>>>>
76222>>>>>>>//> Class for comparing sorted data that are not item based. Values are not
76222>>>>>>>//> retrieved by item numbers but rather by specifying how to get this next value
76222>>>>>>>//> ("find ge" on one side and "readln" on the other for example)
76222>>>>>>>//>
76222>>>>>>>//> Using this class you indicate the ordering of values (like: this value is
76222>>>>>>>//> >=, = or <= than this other value) rather than indicating if they match or
76222>>>>>>>//> not (like in the cItemBasedCompare class)
76222>>>>>>>//>
76222>>>>>>>//> This strategy would be good if comparing records sorted by uniform indices in
76222>>>>>>>//> two different tables.
76222>>>>>>>//>
76222>>>>>>>//> It is also good when you know your in-data are sorted (could be sorted arrays) and you
76222>>>>>>>//> need the output from the compare to be sorted as well (like when comparing the list of
76222>>>>>>>//> filenames in two directories)
76222>>>>>>>//>
76222>>>>>>>//> The terminology of the methods and their parameters reflects that the
76222>>>>>>>//> values that are compared are not retrieved from an array (are not item
76222>>>>>>>//> based) but rather these values are retrieved by running sequentially
76222>>>>>>>//> through the records of a table by some index.
76222>>>>>>>//>
76222>>>>>>>//> The name cDoubleOrderedCompare indicates that both the left side and
76222>>>>>>>//> the right side are presumed to be ordered.
76222>>>>>>>class cDoubleOrderedCompare is an cArray
76223>>>>>>>
76223>>>>>>>  //> Augment this function in order to seed the left buffer (1). Return TRUE
76223>>>>>>>  //> if the seeding was succesful. For example:
76223>>>>>>>  //> 
76223>>>>>>>  //> function iSeed1 returns integer
76223>>>>>>>  //>   clear Customer
76223>>>>>>>  //>   function_Return TRUE
76223>>>>>>>  //> end_function
76223>>>>>>>  //> 
76223>>>>>>>  function iSeed1 returns integer
76225>>>>>>>  end_function
76226>>>>>>>  //> Augment this function in order to seed the right buffer (2). Return TRUE
76226>>>>>>>  //> if the seeding was succesful.
76226>>>>>>>  function iSeed2 returns integer
76228>>>>>>>  end_function
76229>>>>>>>  //> The function should be augmented to return the value for the left buffer (1) to be used for comparing. For example:
76229>>>>>>>  //> 
76229>>>>>>>  //> function sValue1 returns string
76229>>>>>>>  //>   function_return Customer.Name
76229>>>>>>>  //> end_function
76229>>>>>>>  //> 
76229>>>>>>>  function sValue1 returns string
76231>>>>>>>  end_procedure
76232>>>>>>>  //> The function should be augmented to return the value for the right buffer (2) to be used for comparing.
76232>>>>>>>  //> 
76232>>>>>>>  //> function sValue2 returns string
76232>>>>>>>  //>   function_return Vendor.Vendor_Name
76232>>>>>>>  //> end_function
76232>>>>>>>  //> 
76232>>>>>>>  function sValue2 returns string
76234>>>>>>>  end_procedure
76235>>>>>>>  //> Augment to "advance" the left buffer. Return TRUE if advancing was succesful. Could be:
76235>>>>>>>  //> 
76235>>>>>>>  //> function iAdvance1 returns integer
76235>>>>>>>  //>   find gt Customer by index.2 // Name is most significant in index.2
76235>>>>>>>  //>   function_return (found)
76235>>>>>>>  //> end_function
76235>>>>>>>  //> 
76235>>>>>>>  function iAdvance1 returns integer
76237>>>>>>>  end_function
76238>>>>>>>  //> Augment to "advance" the right buffer. Return TRUE if advancing was succesful.
76238>>>>>>>  //> 
76238>>>>>>>  //> function iAdvance2 returns integer
76238>>>>>>>  //>   find gt Vendor by index.2
76238>>>>>>>  //>   function_return (found)
76238>>>>>>>  //> end_function
76238>>>>>>>  //> 
76238>>>>>>>  function iAdvance2 returns integer
76240>>>>>>>  end_function
76241>>>>>>>  //> This is sent when items are found to be identical.
76241>>>>>>>  //> 
76241>>>>>>>  //>   procedure Match string lsVal1 string lsVal2
76241>>>>>>>  //>     showln "Both in Customer and Vendor tables: " lsVal1
76241>>>>>>>  //>   end_procedure
76241>>>>>>>  //> 
76241>>>>>>>  procedure Match string lsVal1 string lsVal2
76243>>>>>>>  end_procedure
76244>>>>>>>  //> This is sent when a left side (1) item cannot be matched.
76244>>>>>>>  //> 
76244>>>>>>>  //> procedure NotMatched1 string lsVal
76244>>>>>>>  //>   showln "Only found in Customer table: " lsVal
76244>>>>>>>  //> end_procedure
76244>>>>>>>  //> 
76244>>>>>>>  procedure NotMatched1 string lsVal
76246>>>>>>>  end_procedure
76247>>>>>>>  //> This is sent when a right side (2) item cannot be matched.
76247>>>>>>>  //> 
76247>>>>>>>  //> procedure NotMatched2 string lsVal
76247>>>>>>>  //>   showln "Only found in Vendor table: " lsVal
76247>>>>>>>  //> end_procedure
76247>>>>>>>  //> 
76247>>>>>>>  procedure NotMatched2 string lsVal
76249>>>>>>>  end_procedure
76250>>>>>>>  function iCompare.ss string lsVal1 string lsVal2 returns integer
76252>>>>>>>    if (lsVal1=lsVal2) function_return 0  // Match
76255>>>>>>>    if (lsVal1>>>>>>    function_return 1                       // Right value is smaller
76259>>>>>>>  end_function
76260>>>>>>>  procedure run
76262>>>>>>>    integer lbOk1 lbOk2 liCompRes
76262>>>>>>>    string lsVal1 lsVal2
76262>>>>>>>    get iSeed1 to lbOk1
76263>>>>>>>    get iSeed2 to lbOk2
76264>>>>>>>    while (lbOk1 or lbOk2)
76268>>>>>>>      if lbOk1 get sValue1 to lsVal1
76271>>>>>>>      if lbOk2 get sValue2 to lsVal2
76274>>>>>>>      if (lbOk1 and lbOk2) begin //
76276>>>>>>>        get iCompare.ss lsVal1 lsVal2 to liCompRes
76277>>>>>>>        if liCompRes eq 0 begin
76279>>>>>>>          send match lsVal1 lsVal2
76280>>>>>>>          get iAdvance1 to lbOk1
76281>>>>>>>          get iAdvance2 to lbOk2
76282>>>>>>>        end
76282>>>>>>>>
76282>>>>>>>        if liCompRes eq -1 begin // Value 1 is lesser
76284>>>>>>>          send NotMatched1 lsVal1
76285>>>>>>>          get iAdvance1 to lbOk1
76286>>>>>>>        end
76286>>>>>>>>
76286>>>>>>>        if liCompRes eq 1 begin // Value 2 is lesser
76288>>>>>>>          send NotMatched2 lsVal2
76289>>>>>>>          get iAdvance2 to lbOk2
76290>>>>>>>        end
76290>>>>>>>>
76290>>>>>>>      end
76290>>>>>>>>
76290>>>>>>>      else begin
76291>>>>>>>        if lbOk1 begin
76293>>>>>>>          send NotMatched1 lsVal1
76294>>>>>>>          get iAdvance1 to lbOk1
76295>>>>>>>        end
76295>>>>>>>>
76295>>>>>>>        else begin
76296>>>>>>>          send NotMatched2 lsVal2
76297>>>>>>>          get iAdvance2 to lbOk2
76298>>>>>>>        end
76298>>>>>>>>
76298>>>>>>>      end
76298>>>>>>>>
76298>>>>>>>    end
76299>>>>>>>>
76299>>>>>>>  end_procedure
76300>>>>>>>end_class // cDoubleOrderedCompare
76301>>>>>>>
76301>>>>>>>// class cForwardOnlySynchronizedCompare is a cArray
76301>>>>>>>//   procedure construct_object integer img#
76301>>>>>>>//     forward send construct_object img#
76301>>>>>>>//     property integer piSyncLimit public 0 // 0 means no limit
76301>>>>>>>//     object oStackedValues1 is a cArray no_image
76301>>>>>>>//     end_object
76301>>>>>>>//     object oStackedValues2 is a cArray no_image
76301>>>>>>>//     end_object
76301>>>>>>>//   end_procedure
76301>>>>>>>//   function iSeed1 returns integer
76301>>>>>>>//   end_function
76301>>>>>>>//   function iSeed2 returns integer
76301>>>>>>>//   end_function
76301>>>>>>>//   function sValue1 returns string
76301>>>>>>>//   end_procedure
76301>>>>>>>//   function sValue2 returns string
76301>>>>>>>//   end_procedure
76301>>>>>>>//   function iAdvance1 returns integer
76301>>>>>>>//   end_function
76301>>>>>>>//   function iAdvance2 returns integer
76301>>>>>>>//   end_function
76301>>>>>>>//   //> This is sent when items are found to be identical
76301>>>>>>>//   procedure Match string value1# string value2#
76301>>>>>>>//   end_procedure
76301>>>>>>>//   //> This is sent when a left side (1) item cannot be matched
76301>>>>>>>//   procedure NotMatched1 string value#
76301>>>>>>>//   end_procedure
76301>>>>>>>//   //> This is sent when a right side (2) item cannot be matched
76301>>>>>>>//   procedure NotMatched2 string value#
76301>>>>>>>//   end_procedure
76301>>>>>>>//   function iCompare.ss string value1# string value2# returns integer
76301>>>>>>>//     if value1# eq value2# function_return 1
76301>>>>>>>//     //function_return 0
76301>>>>>>>//   end_function
76301>>>>>>>//   procedure run
76301>>>>>>>//     integer ok1# ok2# comp_res# oStackedValues1# oStackedValues2#
76301>>>>>>>//     string value1# value2#
76301>>>>>>>//     move (oStackedValues1(self)) to oStackedValues1#
76301>>>>>>>//     move (oStackedValues2(self)) to oStackedValues2#
76301>>>>>>>//     send delete_data to oStackedValues1#
76301>>>>>>>//     send delete_data to oStackedValues2#
76301>>>>>>>//     get iSeed1 to ok1#
76301>>>>>>>//     get iSeed2 to ok2#
76301>>>>>>>//     while (ok1# or ok2#)
76301>>>>>>>//       if ok1# get sValue1 to value1#
76301>>>>>>>//       if ok2# get sValue2 to value2#
76301>>>>>>>//       if (ok1# and ok2#) begin //
76301>>>>>>>//         get iCompare.ss value1# value2# to comp_res#
76301>>>>>>>//         if comp_res# begin // Match
76301>>>>>>>//           send match value1# value2#
76301>>>>>>>//           get iAdvance1 to ok1#
76301>>>>>>>//           get iAdvance2 to ok2#
76301>>>>>>>//         end
76301>>>>>>>//         else begin // No match
76301>>>>>>>//         end
76301>>>>>>>//       end
76301>>>>>>>//       else begin
76301>>>>>>>//         if ok1# begin
76301>>>>>>>//           send NotMatched1 value1#
76301>>>>>>>//           get iAdvance1 to ok1#
76301>>>>>>>//         end
76301>>>>>>>//         else begin
76301>>>>>>>//           send NotMatched2 value2#
76301>>>>>>>//           get iAdvance2 to ok2#
76301>>>>>>>//         end
76301>>>>>>>//       end
76301>>>>>>>//     end
76301>>>>>>>//   end_procedure
76301>>>>>>>// end_class // cDoubleOrderedCompare
76301>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
76301>>>>>Use StrucPgm.nui // Class for storing a sequence of restructure instructions
76301>>>>>
76301>>>>>enumeration_list // Field compare results
76301>>>>>  define FIELDSTHESAME_YES
76301>>>>>  define FIELDSTHESAME_NO
76301>>>>>  define FIELDSTHESAME_MAYBE
76301>>>>>end_enumeration_list
76301>>>>>
76301>>>>>register_function piFDX1  returns integer
76301>>>>>register_function piFile1 returns integer
76301>>>>>register_function piFDX2  returns integer
76301>>>>>register_function piFile2 returns integer
76301>>>>>
76301>>>>>// FIELD COMPARING
76301>>>>>
76301>>>>>//> An object of this class is used to dictate which fields are identical
76301>>>>>//> prior to a compare operation. It should be understood as: This field
76301>>>>>//> in file1 is the same as this field in file2.
76301>>>>>//>
76301>>>>>//> There is however not currently an interface for doing so.
76301>>>>>class cFdxTheseFieldsAreTheSame is a cArray // Private class
76302>>>>>  item_property_list
76302>>>>>    item_property integer piField1.i
76302>>>>>    item_property integer piField2.i
76302>>>>>  end_item_property_list cFdxTheseFieldsAreTheSame
#REM 76334 DEFINE FUNCTION PIFIELD2.I INTEGER LIROW RETURNS INTEGER
#REM 76338 DEFINE PROCEDURE SET PIFIELD2.I INTEGER LIROW INTEGER VALUE
#REM 76342 DEFINE FUNCTION PIFIELD1.I INTEGER LIROW RETURNS INTEGER
#REM 76346 DEFINE PROCEDURE SET PIFIELD1.I INTEGER LIROW INTEGER VALUE
76351>>>>>  function iSameField.ii integer Field1# integer Field2# returns integer
76353>>>>>    integer row# max#
76353>>>>>    get row_count to max#
76354>>>>>    for row# from 0 to (max#-1)
76360>>>>>>
76360>>>>>      if (piField1.i(self,row#)=Field1# and piField2.i(self,row#)=Field2#) ;                 function_return FIELDSTHESAME_YES
76363>>>>>      else if (piField1.i(self,row#)=Field1# or piField2.i(self,row#)=Field2#) ;                 function_return FIELDSTHESAME_NO
76367>>>>>    loop
76368>>>>>>
76368>>>>>    function_return FIELDSTHESAME_MAYBE
76369>>>>>  end_function
76370>>>>>  procedure add_field_match integer field1# integer field2#
76372>>>>>    integer row#
76372>>>>>    get row_count to row#
76373>>>>>    set piField1.i row# to field1#
76374>>>>>    set piField2.i row# to field2#
76375>>>>>  end_procedure
76376>>>>>end_class // cFdxTheseFieldsAreTheSame
76377>>>>>
76377>>>>>// And here's one like the above, except this one is used to
76377>>>>>// dictate that two fields are NOT the same
76377>>>>>
76377>>>>>class cFdxTheseFieldsAreNotTheSame is a cArray // Private class
76378>>>>>  item_property_list
76378>>>>>    item_property integer piField1.i
76378>>>>>    item_property integer piField2.i
76378>>>>>  end_item_property_list cFdxTheseFieldsAreNotTheSame
#REM 76410 DEFINE FUNCTION PIFIELD2.I INTEGER LIROW RETURNS INTEGER
#REM 76414 DEFINE PROCEDURE SET PIFIELD2.I INTEGER LIROW INTEGER VALUE
#REM 76418 DEFINE FUNCTION PIFIELD1.I INTEGER LIROW RETURNS INTEGER
#REM 76422 DEFINE PROCEDURE SET PIFIELD1.I INTEGER LIROW INTEGER VALUE
76427>>>>>  function iSameField.ii integer Field1# integer Field2# returns integer
76429>>>>>    integer row# max#
76429>>>>>    get row_count to max#
76430>>>>>    for row# from 0 to (max#-1)
76436>>>>>>
76436>>>>>      if (piField1.i(self,row#)=Field1# and piField2.i(self,row#)=Field2#) ;                 function_return FIELDSTHESAME_NO
76439>>>>>    loop
76440>>>>>>
76440>>>>>    function_return FIELDSTHESAME_MAYBE
76441>>>>>  end_function
76442>>>>>  procedure add_field_not_match integer field1# integer field2#
76444>>>>>    integer row#
76444>>>>>    get row_count to row#
76445>>>>>    set piField1.i row# to field1#
76446>>>>>    set piField2.i row# to field2#
76447>>>>>  end_procedure
76448>>>>>end_class // cFdxTheseFieldsAreNotTheSame
76449>>>>>
76449>>>>>//> An object of class cFdxTheseNamesAreTheSame is used to inform
76449>>>>>//> the compare operation that these field names are in fact identical.
76449>>>>>//> For example you may have named a product number field PRODUCT in
76449>>>>>//> some tables and PRODUCT_CODE in others.
76449>>>>>class cFdxTheseNamesAreTheSame is a cArray // Private class
76450>>>>>  item_property_list
76450>>>>>    item_property string psName1.i
76450>>>>>    item_property string psName2.i
76450>>>>>  end_item_property_list cFdxTheseNamesAreTheSame
#REM 76482 DEFINE FUNCTION PSNAME2.I INTEGER LIROW RETURNS STRING
#REM 76486 DEFINE PROCEDURE SET PSNAME2.I INTEGER LIROW STRING VALUE
#REM 76490 DEFINE FUNCTION PSNAME1.I INTEGER LIROW RETURNS STRING
#REM 76494 DEFINE PROCEDURE SET PSNAME1.I INTEGER LIROW STRING VALUE
76499>>>>>  function iSameName.ss string Name1# string Name2# returns integer
76501>>>>>    integer row# max#
76501>>>>>    get row_count to max#
76502>>>>>    for row# from 0 to (max#-1)
76508>>>>>>
76508>>>>>      if (psName1.i(self,row#)=Name1# and psName2.i(self,row#)=Name2#) function_return FIELDSTHESAME_YES
76511>>>>>    loop
76512>>>>>>
76512>>>>>    function_return FIELDSTHESAME_MAYBE
76513>>>>>  end_function
76514>>>>>  procedure add_name_match string Name1# string Name2#
76516>>>>>    integer row#
76516>>>>>    get row_count to row#
76517>>>>>    set psName1.i row# to Name1#
76518>>>>>    set psName2.i row# to Name1#
76519>>>>>  end_procedure
76520>>>>>  procedure DoReadFDNFile string lsFileName
76522>>>>>    integer liRow liChannel lbEof
76522>>>>>    string lsName1 lsName2
76522>>>>>    send delete_data
76523>>>>>    get SEQ_DirectInput lsFileName to liChannel
76524>>>>>    if (liChannel>=0) begin
76526>>>>>      repeat
76526>>>>>>
76526>>>>>        readln channel liChannel lsName1
76528>>>>>        readln lsName2
76529>>>>>        move (seqeof) to lbEof
76530>>>>>        ifnot lbEof begin
76532>>>>>          get row_count to liRow
76533>>>>>          set psName1.i liRow to lsName1
76534>>>>>          set psName2.i liRow to lsName2
76535>>>>>        end
76535>>>>>>
76535>>>>>      until lbEof
76537>>>>>      send SEQ_CloseInput liChannel
76538>>>>>    end
76538>>>>>>
76538>>>>>  end_procedure
76539>>>>>end_class // cFdxTheseNamesAreTheSame
76540>>>>>
76540>>>>>class cFdxFieldMap is a cArray
76541>>>>>  item_property_list
76541>>>>>    item_property integer piField1.i
76541>>>>>    item_property integer piField2.i
76541>>>>>  end_item_property_list cFdxFieldMap
#REM 76573 DEFINE FUNCTION PIFIELD2.I INTEGER LIROW RETURNS INTEGER
#REM 76577 DEFINE PROCEDURE SET PIFIELD2.I INTEGER LIROW INTEGER VALUE
#REM 76581 DEFINE FUNCTION PIFIELD1.I INTEGER LIROW RETURNS INTEGER
#REM 76585 DEFINE PROCEDURE SET PIFIELD1.I INTEGER LIROW INTEGER VALUE
76590>>>>>  procedure reset
76592>>>>>    send delete_data
76593>>>>>  end_procedure
76594>>>>>  procedure add_field_map integer field1# integer field2#
76596>>>>>    integer row#
76596>>>>>    get row_count to row#
76597>>>>>    set piField1.i row# to field1#
76598>>>>>    set piField2.i row# to field2#
76599>>>>>  end_procedure
76600>>>>>end_class // cFdxFieldMap
76601>>>>>
76601>>>>>class cFdxFieldAttrCompare is a cItemBasedCompare
76602>>>>>  procedure construct_object integer img#
76604>>>>>    forward send construct_object img#
76606>>>>>    set piSyncLimit to 0 // 0 means no limit
76607>>>>>    set piStrategy  to COMPARE_ORDERED
76608>>>>>    object oFdxTheseFieldsAreTheSame is a cFdxTheseFieldsAreTheSame NO_IMAGE
76610>>>>>    end_object
76611>>>>>    object oFdxTheseFieldsAreNotTheSame is a cFdxTheseFieldsAreNotTheSame NO_IMAGE
76613>>>>>    end_object
76614>>>>>    object oFdxTheseNamesAreTheSame is a cFdxTheseNamesAreTheSame NO_IMAGE
76616>>>>>    end_object
76617>>>>>    object oFdxFieldMap is a cFdxFieldMap NO_IMAGE
76619>>>>>      // After a comparison (procedure run) this object will contain
76619>>>>>      // information about which fields were matched. A zero value
76619>>>>>      // means that the field wasn't matched (which in turn means
76619>>>>>      // that it should be inserted or deleted depending on which
76619>>>>>      // side the zero occurs).
76619>>>>>    end_object
76620>>>>>  end_procedure
76621>>>>>
76621>>>>>  procedure add_instruction integer type# integer attr# integer field# string name# string value#
76623>>>>>    integer row#
76623>>>>>    set piInstrType.i row# to type#
76624>>>>>    set piAttr.i      row# to attr#
76625>>>>>    set piField.i     row# to field#
76626>>>>>    set psFieldName.i row# to name#
76627>>>>>    set psValue.i     row# to value#
76628>>>>>  end_procedure
76629>>>>>
76629>>>>>  function iCompareItems.ii integer field1# integer field2# returns integer
76631>>>>>    integer rval#
76631>>>>>    string name1# name2#
76631>>>>>    // First ask the explicit field pairing object:
76631>>>>>    get iSameField.ii of (oFdxTheseFieldsAreTheSame(self)) field1# field2# to rval#
76632>>>>>    if rval# eq FIELDSTHESAME_MAYBE begin
76634>>>>>      // Then ask the explicit field dispairing object:
76634>>>>>      get iSameField.ii of (oFdxTheseFieldsAreNotTheSame(self)) field1# field2# to rval#
76635>>>>>      if rval# eq FIELDSTHESAME_MAYBE begin
76637>>>>>        // If no definate answers, we have to try and figure it out:
76637>>>>>        get FDX_AttrValue_FIELD (piFDX1(self)) DF_FIELD_NAME (piFile1(self)) field1# to name1#
76638>>>>>        get FDX_AttrValue_FIELD (piFDX2(self)) DF_FIELD_NAME (piFile2(self)) field2# to name2#
76639>>>>>        // Then ask the implicit field pairing object:
76639>>>>>        get iSameName.ss of (oFdxTheseNamesAreTheSame(self)) name1# name2# to rval#
76640>>>>>        if rval# eq FIELDSTHESAME_MAYBE begin
76642>>>>>          // As a last resort we ask if the field names are identical
76642>>>>>          if name1# eq name2# move FIELDSTHESAME_YES to rval#
76645>>>>>        end
76645>>>>>>
76645>>>>>      end
76645>>>>>>
76645>>>>>    end
76645>>>>>>
76645>>>>>    function_return (rval#=FIELDSTHESAME_YES)
76646>>>>>  end_function
76647>>>>>
76647>>>>>  function iIsChangedField.iii integer attr# integer field1# integer field2# returns integer
76649>>>>>    function_return (FDX_AttrValue_FIELD(piFDX1(self),attr#,piFile1(self),field1#)<>FDX_AttrValue_FIELD(piFDX2(self),attr#,piFile2(self),field2#))
76650>>>>>  end_function
76651>>>>>
76651>>>>>  // This is sent when items are found to be identical
76651>>>>>  procedure items_matched integer field1# integer field2#
76653>>>>>    integer type# file1#
76653>>>>>    string name#
76653>>>>>    move (FDX_AttrValue_FIELD(piFDX1(self),DF_FIELD_NAME,piFile1(self),field1#)) to name#
76654>>>>>    move (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_TYPE,piFile2(self),field2#)) to type#
76655>>>>>    if (iIsChangedField.iii(self,DF_FIELD_TYPE         ,field1#,field2#)) begin
76657>>>>>      send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_TYPE          field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_TYPE         ,piFile2(self),field2#))
76658>>>>>      send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_LENGTH        field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_LENGTH       ,piFile2(self),field2#))
76659>>>>>    end
76659>>>>>>
76659>>>>>    if type# ne DF_DATE begin // Only interfere with field length if not a DATE field
76661>>>>>      if (iIsChangedField.iii(self,DF_FIELD_LENGTH       ,field1#,field2#)) begin
76663>>>>>        send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_LENGTH        field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_LENGTH       ,piFile2(self),field2#))
76664>>>>>      end
76664>>>>>>
76664>>>>>      if (iIsChangedField.iii(self,DF_FIELD_PRECISION    ,field1#,field2#)) begin
76666>>>>>        send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_PRECISION     field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_PRECISION    ,piFile2(self),field2#))
76667>>>>>      end
76667>>>>>>
76667>>>>>    end
76667>>>>>>
76667>>>>>    if (iIsChangedField.iii(self,DF_FIELD_RELATED_FILE ,field1#,field2#)) begin
76669>>>>>      send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_RELATED_FILE  field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_RELATED_FILE ,piFile2(self),field2#))
76670>>>>>    end
76670>>>>>>
76670>>>>>    if (iIsChangedField.iii(self,DF_FIELD_RELATED_FIELD,field1#,field2#)) begin
76672>>>>>      send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_RELATED_FIELD field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_RELATED_FIELD,piFile2(self),field2#))
76673>>>>>    end
76673>>>>>>
76673>>>>>    if (iIsChangedField.iii(self,DF_FIELD_INDEX        ,field1#,field2#)) begin
76675>>>>>      send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_INDEX         field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_INDEX        ,piFile2(self),field2#))
76676>>>>>    end
76676>>>>>>
76676>>>>>    if (iIsChangedField.iii(self,DF_FIELD_OFFSET       ,field1#,field2#)) begin
76678>>>>>      if type# eq DF_OVERLAP ;        send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_OFFSET      field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_OFFSET       ,piFile2(self),field2#))
76681>>>>>    end
76681>>>>>>
76681>>>>>    if (iIsChangedField.iii(self,DF_FIELD_NAME         ,field1#,field2#)) begin
76683>>>>>      send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_NAME          field1# name# (FDX_AttrValue_FIELD(piFDX2(self),DF_FIELD_NAME         ,piFile2(self),field2#))
76684>>>>>    end
76684>>>>>>
76684>>>>>    send add_field_map to (oFdxFieldMap(self)) field1# field2#
76685>>>>>  end_procedure
76686>>>>>
76686>>>>>  procedure item_not_matched1 integer field# integer info#
76688>>>>>    integer identity_field#
76688>>>>>    get FDX_AttrValue_FILE (piFDX1(self)) DF_FILE_RECORD_IDENTITY (piFile1(self)) to identity_field#
76689>>>>>    if field# ne identity_field# begin
76691>>>>>      // Field on left side not matched => We must delete it:
76691>>>>>      send add_field_instruction INSTR_TYPE_DELETE 0 field# (FDX_AttrValue_FIELD(piFDX1(self),DF_FIELD_NAME,piFile1(self),field#)) ""
76692>>>>>      send NoteFieldDeleted field#
76693>>>>>      send add_field_map to (oFdxFieldMap(self)) field# 0
76694>>>>>    end
76694>>>>>>
76694>>>>>  end_procedure
76695>>>>>
76695>>>>>    // Means itm# on the right side couldn't be matched. The info parameter
76695>>>>>    // gives a little extra information.
76695>>>>>    //    -2: The item is missing in the end of the sequence
76695>>>>>    //    -1: Sync limit exceeded. Missing somewhere in the middle of things.
76695>>>>>    //   >=0: Missing from the left side at position info#
76695>>>>>  procedure item_not_matched2 integer field# integer info#
76697>>>>>    // Field on right side not matched => We must create it:
76697>>>>>    integer oFDX# file#
76697>>>>>    integer type# length# precision# offset# index# rfile# rfield#
76697>>>>>    string name#
76697>>>>>    integer identity_field#
76697>>>>>    get piFDX2 to oFDX#
76698>>>>>    get piFile2 to file#
76699>>>>>    get FDX_AttrValue_FILE oFDX# DF_FILE_RECORD_IDENTITY file# to identity_field#
76700>>>>>    if field# ne identity_field# begin
76702>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_NAME,file#,field#)) to name#
76703>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE         ,file#,field#)) to type#
76704>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_LENGTH       ,file#,field#)) to length#
76705>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_PRECISION    ,file#,field#)) to precision#
76706>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FILE ,file#,field#)) to rfile#
76707>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_RELATED_FIELD,file#,field#)) to rfield#
76708>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_INDEX        ,file#,field#)) to index#
76709>>>>>      move (FDX_AttrValue_FIELD(oFDX#,DF_FIELD_OFFSET       ,file#,field#)) to offset#
76710>>>>>  //  if info# ne -1 begin
76710>>>>>        if info# eq -2 begin
76712>>>>>          send add_field_instruction INSTR_TYPE_APPEND DF_FIELD_NAME 0 "" name#
76713>>>>>          move 0 to field#
76714>>>>>        end
76714>>>>>>
76714>>>>>        else send add_field_instruction INSTR_TYPE_CREATE DF_FIELD_NAME field# "" name#
76716>>>>>        send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_TYPE          field# name# type#
76717>>>>>        if type# ne DF_DATE begin
76719>>>>>          send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_LENGTH        field# name# length#
76720>>>>>          send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_PRECISION     field# name# precision#
76721>>>>>        end
76721>>>>>>
76721>>>>>        send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_RELATED_FILE  field# name# rfile#
76722>>>>>        send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_RELATED_FIELD field# name# rfield#
76723>>>>>        send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_INDEX         field# name# index#
76724>>>>>        if type# eq DF_OVERLAP send add_field_instruction INSTR_TYPE_EDIT DF_FIELD_OFFSET field# name# offset#
76727>>>>>        send add_field_map to (oFdxFieldMap(self)) 0 field#
76728>>>>>  //  end
76728>>>>>  //  else send obs "Info er sgu' -1" name#
76728>>>>>    end
76728>>>>>>
76728>>>>>  end_procedure
76729>>>>>
76729>>>>>  procedure add_same_field integer field1# integer field2#
76731>>>>>    send add_field_match to (oFdxTheseFieldsAreTheSame(self)) field1# field2#
76732>>>>>  end_procedure
76733>>>>>  procedure add_not_same_field integer field1# integer field2#
76735>>>>>    send add_field_not_match to (oFdxTheseFieldsAreNotTheSame(self)) field1# field2#
76736>>>>>  end_procedure
76737>>>>>  procedure add_same_name string name1# string name2#
76739>>>>>    send add_name_match to (oFdxTheseNamesAreTheSame(self)) name1# name2#
76740>>>>>  end_procedure
76741>>>>>
76741>>>>>  procedure run
76743>>>>>    integer lhFdx liOrigin lhObj
76743>>>>>    string lsFileName lsPath
76743>>>>>    set pItemStart1 to 1
76744>>>>>    set pItemStart2 to 1
76745>>>>>//    if (iCanOpen.i(piFDX1(self),piFile1(self))) set pItemStop1 to (FDX_AttrValue_FILE(piFDX1(self),DF_FILE_NUMBER_FIELDS,piFile1(self)))
76745>>>>>    if (piFile1(self)) begin
76747>>>>>      set pItemStop1 to (FDX_AttrValue_FILE(piFDX1(self),DF_FILE_NUMBER_FIELDS,piFile1(self)))
76748>>>>>
76748>>>>>      get FDX_AttrValue_FILELIST (piFDX1(self)) DF_FILE_ROOT_NAME (piFile1(self)) to lsFileName
76749>>>>>      move (lsFileName+".fdn") to lsFileName
76750>>>>>
76750>>>>>      get piFDX2 to lhFdx
76751>>>>>      get piDataOrigin of lhFdx to liOrigin
76752>>>>>      if (liOrigin=FDX_REAL_WORLD) begin
76754>>>>>
76754>>>>>        if (iFdxIsEncapsulated(lhFdx)) begin
76756>>>>>          get piFileDefObject.i of lhFdx (piFile1(self)) to lhObj
76757>>>>>          get psDatPath of lhObj to lsPath
76758>>>>>          get SEQ_ExtractPathFromFileName lsPath to lsPath
76759>>>>>          get SEQ_ComposeAbsoluteFileName lsPath lsFileName to lsFileName
76760>>>>>        end
76760>>>>>>
76760>>>>>        else move "" to lsFileName
76762>>>>>//        send obs "Real world" lsFileName
76762>>>>>      end
76762>>>>>>
76762>>>>>      if (liOrigin=FDX_READ_FROM_FILE) begin
76764>>>>>        get psFileName of lhFdx to lsPath
76765>>>>>        get SEQ_ExtractPathFromFileName lsPath to lsPath
76766>>>>>        get SEQ_ComposeAbsoluteFileName lsPath lsFileName to lsFileName
76767>>>>>//        send obs "Read from file" lsFileName
76767>>>>>      end
76767>>>>>>
76767>>>>>
76767>>>>>      if (lsFileName<>"") send DoReadFDNFile to (oFdxTheseNamesAreTheSame(self)) lsFileName
76770>>>>>      else send delete_data to (oFdxTheseNamesAreTheSame(self))
76772>>>>>    end
76772>>>>>>
76772>>>>>    else set pItemStop1 to 0 // We are creating!
76774>>>>>
76774>>>>>
76774>>>>>    set pItemStop2 to (FDX_AttrValue_FILE(piFDX2(self),DF_FILE_NUMBER_FIELDS,piFile2(self)))
76775>>>>>
76775>>>>>    forward send run
76777>>>>>  end_procedure
76778>>>>>  procedure reset
76780>>>>>    send delete_data
76781>>>>>    send delete_data to (oFdxTheseFieldsAreTheSame(self))
76782>>>>>    send delete_data to (oFdxTheseFieldsAreNotTheSame(self))
76783>>>>>    send delete_data to (oFdxTheseNamesAreTheSame(self))
76784>>>>>    send delete_data to (oFdxFieldMap(self))
76785>>>>>  end_procedure
76786>>>>>end_class // cFdxFieldAttrCompare
76787>>>>>
76787>>>>>// INDEX COMPARING
76787>>>>>
76787>>>>>class cFdxIndexAttrCompare is a cArray
76788>>>>>  item_property_list
76788>>>>>    item_property integer piIndexDirty.i
76788>>>>>  end_item_property_list cFdxIndexAttrCompare
#REM 76817 DEFINE FUNCTION PIINDEXDIRTY.I INTEGER LIROW RETURNS INTEGER
#REM 76821 DEFINE PROCEDURE SET PIINDEXDIRTY.I INTEGER LIROW INTEGER VALUE
76826>>>>>  procedure reset
76828>>>>>    send delete_data
76829>>>>>  end_procedure
76830>>>>>  procedure AnalyzeDeletedFields integer fieldarr#
76832>>>>>    integer max# field# fdx# file# index# segment# seg_max#
76832>>>>>    get piFile1 to file#
76833>>>>>    get piFDX1 to fdx#
76834>>>>>    get item_count of fieldarr# to max#
76835>>>>>    for field# from 1 to (max#-1)
76841>>>>>>
76841>>>>>      if (integer(value(fieldarr#,field#))) begin // Field has been deleted
76843>>>>>        for index# from 1 to 16
76849>>>>>>
76849>>>>>          get FDX_AttrValue_INDEX fdx# DF_INDEX_NUMBER_SEGMENTS file# index# to seg_max#
76850>>>>>          for segment# from 1 to seg_max#
76856>>>>>>
76856>>>>>            if (FDX_AttrValue_IDXSEG(fdx#,DF_INDEX_SEGMENT_FIELD,file#,index#,segment#)) eq field# set piIndexDirty.i index# to 1
76859>>>>>          loop
76860>>>>>>
76860>>>>>        loop
76861>>>>>>
76861>>>>>      end
76861>>>>>>
76861>>>>>    loop
76862>>>>>>
76862>>>>>  end_procedure
76863>>>>>  function sIndex_Fields.iii integer oFDX# integer file# integer index# returns string
76865>>>>>    integer max_segment# segment# field#
76865>>>>>    string rval#
76865>>>>>    move "" to rval#
76866>>>>>    if file# begin
76868>>>>>      move (FDX_AttrValue_INDEX(oFDX#,DF_INDEX_NUMBER_SEGMENTS,file#,index#)) to max_segment#
76869>>>>>      for segment# from 1 to max_segment#
76875>>>>>>
76875>>>>>        move (FDX_AttrValue_IDXSEG(oFDX#,DF_INDEX_SEGMENT_FIELD,file#,index#,segment#)) to field#
76876>>>>>        move (rval#+string(field#)) to rval#
76877>>>>>        if segment# ne max_segment# move (rval#+" ") to rval#
76880>>>>>      loop
76881>>>>>>
76881>>>>>    end
76881>>>>>>
76881>>>>>    function_return rval# // This value is only used for comparing
76882>>>>>  end_function
76883>>>>>  function sIndex_Direction.iii integer oFDX# integer file# integer index# returns string
76885>>>>>    integer max_segment# segment# dir#
76885>>>>>    string rval#
76885>>>>>    move "" to rval#
76886>>>>>    if file# begin
76888>>>>>      move (FDX_AttrValue_INDEX(oFDX#,DF_INDEX_NUMBER_SEGMENTS,file#,index#)) to max_segment#
76889>>>>>      for segment# from 1 to max_segment#
76895>>>>>>
76895>>>>>        move (FDX_AttrValue_IDXSEG(oFDX#,DF_INDEX_SEGMENT_DIRECTION,file#,index#,segment#)) to dir#
76896>>>>>        if dir# eq DF_ASCENDING  move (rval#+"+") to rval#
76899>>>>>        if dir# eq DF_DESCENDING move (rval#+"-") to rval#
76902>>>>>      loop
76903>>>>>>
76903>>>>>    end
76903>>>>>>
76903>>>>>    function_return rval# // This value is only used for comparing
76904>>>>>  end_function
76905>>>>>  function sIndex_CaseUsed.iii integer oFDX# integer file# integer index# returns string
76907>>>>>    integer max_segment# segment# case#
76907>>>>>    string rval#
76907>>>>>    move "" to rval#
76908>>>>>    if file# begin
76910>>>>>      move (FDX_AttrValue_INDEX(oFDX#,DF_INDEX_NUMBER_SEGMENTS,file#,index#)) to max_segment#
76911>>>>>      for segment# from 1 to max_segment#
76917>>>>>>
76917>>>>>        move (FDX_AttrValue_IDXSEG(oFDX#,DF_INDEX_SEGMENT_CASE,file#,index#,segment#)) to case#
76918>>>>>        if case# eq DF_CASE_USED    move (rval#+"x") to rval#
76921>>>>>        if case# eq DF_CASE_IGNORED move (rval#+"X") to rval#
76924>>>>>      loop
76925>>>>>>
76925>>>>>    end
76925>>>>>>
76925>>>>>    function_return rval# // This value is only used for comparing
76926>>>>>  end_function
76927>>>>>  procedure Make_Directions integer index# string dir1# string dir2#
76929>>>>>    integer pos# len# value#
76929>>>>>    string char1# char2#
76929>>>>>    move (length(dir2#)) to len#
76930>>>>>    for pos# from 1 to len#
76936>>>>>>
76936>>>>>      move (mid(dir1#,1,pos#)) to char1#
76937>>>>>      move (mid(dir2#,1,pos#)) to char2#
76938>>>>>      if char1# ne char2# begin
76940>>>>>        if char2# eq "-" move DF_DESCENDING to value#
76943>>>>>        else move DF_ASCENDING to value#
76945>>>>>        send add_indexseg_instruction INSTR_TYPE_EDIT DF_INDEX_SEGMENT_DIRECTION index# pos# value#
76946>>>>>      end
76946>>>>>>
76946>>>>>    loop
76947>>>>>>
76947>>>>>  end_procedure
76948>>>>>  procedure Make_CaseUsed integer index# string case1# string case2#
76950>>>>>    integer pos# len# value#
76950>>>>>    string char1# char2#
76950>>>>>    move (length(case2#)) to len#
76951>>>>>    for pos# from 1 to len#
76957>>>>>>
76957>>>>>      move (mid(case1#,1,pos#)) to char1#
76958>>>>>      move (mid(case2#,1,pos#)) to char2#
76959>>>>>      if char1# ne char2# begin
76961>>>>>        if char2# eq "X" move DF_CASE_IGNORED to value#
76964>>>>>        else move DF_CASE_USED to value#
76966>>>>>        send add_indexseg_instruction INSTR_TYPE_EDIT DF_INDEX_SEGMENT_CASE index# pos# value#
76967>>>>>      end
76967>>>>>>
76967>>>>>    loop
76968>>>>>>
76968>>>>>  end_procedure
76969>>>>>
76969>>>>>  procedure Make_Index integer index#
76971>>>>>    integer max_segment# segment# field# oFDX# file#
76971>>>>>    move (piFDX2(self)) to oFDX#
76972>>>>>    move (piFile2(self)) to file#
76973>>>>>    move (FDX_AttrValue_INDEX(oFDX#,DF_INDEX_NUMBER_SEGMENTS,file#,index#)) to max_segment#
76974>>>>>    if max_segment# eq 0 begin // Delete index
76976>>>>>      send add_index_instruction INSTR_TYPE_DELETE DF_INDEX_NUMBER_SEGMENTS index# 0
76977>>>>>    end
76977>>>>>>
76977>>>>>    else begin // Edit or create index
76978>>>>>      send add_index_instruction INSTR_TYPE_CREATE DF_INDEX_NUMBER_SEGMENTS index# max_segment#
76979>>>>>      for segment# from 1 to max_segment#
76985>>>>>>
76985>>>>>        move (FDX_AttrValue_IDXSEG(oFDX#,DF_INDEX_SEGMENT_FIELD,file#,index#,segment#)) to field#
76986>>>>>        send add_indexseg_instruction INSTR_TYPE_EDIT DF_INDEX_SEGMENT_FIELD     index# segment# field#
76987>>>>>        send add_indexseg_instruction INSTR_TYPE_EDIT DF_INDEX_SEGMENT_CASE      index# segment# (FDX_AttrValue_IDXSEG(oFDX#,DF_INDEX_SEGMENT_CASE,file#,index#,segment#))
76988>>>>>        send add_indexseg_instruction INSTR_TYPE_EDIT DF_INDEX_SEGMENT_DIRECTION index# segment# (FDX_AttrValue_IDXSEG(oFDX#,DF_INDEX_SEGMENT_DIRECTION,file#,index#,segment#))
76989>>>>>      loop
76990>>>>>>
76990>>>>>      send add_index_instruction INSTR_TYPE_CREATE DF_INDEX_TYPE index# (FDX_AttrValue_INDEX(oFDX#,DF_INDEX_TYPE,file#,index#))
76991>>>>>    end
76991>>>>>>
76991>>>>>  end_procedure
76992>>>>>
76992>>>>>  procedure compare_index integer index#
76994>>>>>    integer type1# type2#
76994>>>>>    string fields1# fields2#
76994>>>>>    string comp_val1# comp_val2#
76994>>>>>    // Compare fields:
76994>>>>>    get sIndex_Fields.iii (piFDX1(self)) (piFile1(self)) index# to fields1#
76995>>>>>    get sIndex_Fields.iii (piFDX2(self)) (piFile2(self)) index# to fields2#
76996>>>>>    if (fields1#=fields2#) begin // At least the fields are identical
76998>>>>>      ifnot (piIndexDirty.i(self,index#)) begin // No segments have been deleted as a consequence of field deletions
77000>>>>>        // Compare directions:
77000>>>>>        get sIndex_Direction.iii (piFDX1(self)) (piFile1(self)) index# to comp_val1#
77001>>>>>        get sIndex_Direction.iii (piFDX2(self)) (piFile2(self)) index# to comp_val2#
77002>>>>>        send Make_Directions index# comp_val1# comp_val2#
77003>>>>>        // Compare cases:
77003>>>>>        get sIndex_CaseUsed.iii (piFDX1(self)) (piFile1(self)) index# to comp_val1#
77004>>>>>        get sIndex_CaseUsed.iii (piFDX2(self)) (piFile2(self)) index# to comp_val2#
77005>>>>>        send Make_CaseUsed index# comp_val1# comp_val2#
77006>>>>>        if fields2# ne "" begin
77008>>>>>          move (FDX_AttrValue_INDEX(piFDX1(self),DF_INDEX_TYPE,piFile1(self),index#)) to type1#
77009>>>>>          move (FDX_AttrValue_INDEX(piFDX2(self),DF_INDEX_TYPE,piFile2(self),index#)) to type2#
77010>>>>>          if type1# ne type2# send add_index_instruction INSTR_TYPE_EDIT DF_INDEX_TYPE index# type2#
77013>>>>>        end
77013>>>>>>
77013>>>>>      end
77013>>>>>>
77013>>>>>      else send Make_Index index#
77015>>>>>    end
77015>>>>>>
77015>>>>>    else send Make_Index index#
77017>>>>>  end_procedure
77018>>>>>  procedure run
77020>>>>>    integer index#
77020>>>>>    for index# from 1 to 16
77026>>>>>>
77026>>>>>      send compare_index index#
77027>>>>>    loop
77028>>>>>>
77028>>>>>  end_procedure
77029>>>>>end_class // cFdxIndexAttrCompare
77030>>>>>
77030>>>>>class cDummyCompareResultReciever is a cArray
77031>>>>>  procedure construct_object integer liImg
77033>>>>>    forward send construct_object liImg
77035>>>>>    property integer piFile                  public 0
77036>>>>>    property string  psRootName              public ""
77037>>>>>    property integer piFileList_Change       public 0  // True if changes in filelist parameters
77038>>>>>    property integer piFile_Change           public 0  // True if changes in file parameters
77039>>>>>    property integer piField_Change          public 0  // True if changes in field parameters
77040>>>>>    property integer piField_Sequence_Change public 0  // True only if fields have been added or removed
77041>>>>>    property integer piIndex_Change          public 0  // True if changes in index parameters
77042>>>>>    property integer piProgramType           public 0
77043>>>>>  end_procedure
77044>>>>>  procedure add_filelist_instruction integer liAttr string lsValue
77046>>>>>    set piFileList_Change to true
77047>>>>>  end_procedure
77048>>>>>  procedure add_file_instruction integer liAttr string lsValue
77050>>>>>    set piFile_Change to true
77051>>>>>  end_procedure
77052>>>>>  procedure add_field_instruction integer liType integer liAttr integer liField string lsName string lsValue
77054>>>>>    set piField_Change to true
77055>>>>>    if (liType=INSTR_TYPE_DELETE or liType=INSTR_TYPE_APPEND or liType=INSTR_TYPE_CREATE) set piField_Sequence_Change to true
77058>>>>>  end_procedure
77059>>>>>  procedure add_index_instruction integer liType integer liAttr integer liIndex string lsValue
77061>>>>>    set piIndex_Change to true
77062>>>>>  end_procedure
77063>>>>>  procedure add_indexseg_instruction integer liType integer liAttr integer liIndex integer liSegment string lsValue
77065>>>>>    set piIndex_Change to true
77066>>>>>  end_procedure
77067>>>>>  procedure reset
77069>>>>>    set piFile            to 0
77070>>>>>    set psRootName        to ""
77071>>>>>    set piFileList_Change to 0
77072>>>>>    set piFile_Change     to 0
77073>>>>>    set piField_Change    to 0
77074>>>>>    set piIndex_Change    to 0
77075>>>>>    set piField_Sequence_Change to 0
77076>>>>>  end_procedure
77077>>>>>  function iGenericChange returns integer
77079>>>>>    function_return (piFile_Change(self) or piField_Change(self))
77080>>>>>  end_function
77081>>>>>end_class // cDummyCompareResultReciever
77082>>>>>
77082>>>>>// PUTTING IT ALL TOGETHER:
77082>>>>>
77082>>>>>enumeration_list
77082>>>>>  define FDXCOMP_MODE_ALL       // Compare both table definintion and filelist values
77082>>>>>  define FDXCOMP_MODE_FILE      // Compare table definitions only
77082>>>>>  define FDXCOMP_MODE_FILELIST  // Compare filelist values only
77082>>>>>end_enumeration_list
77082>>>>>
77082>>>>>class cFdxTableCompare is an cArray
77083>>>>>  procedure construct_object integer img#
77085>>>>>    forward send construct_object img#
77087>>>>>    property integer piFile1                     public 0 // Compare file1
77088>>>>>    property integer piFDX1                      public 0 // of FDX1
77089>>>>>    property integer piFile2                     public 0 // with file2
77090>>>>>    property integer piFDX2                      public 0 // of FDX2
77091>>>>>    property integer piPgmObject                 public 0 // and put the result in this object
77092>>>>>
77092>>>>>    // These are set during the comparison operation:
77092>>>>>    property integer piFileList_Change           public 0
77093>>>>>    property integer piFile_Change               public 0
77094>>>>>    property integer piField_Change              public 0
77095>>>>>    property integer piIndex_Change              public 0
77096>>>>>
77096>>>>>    // Setup parameters:
77096>>>>>    property integer piSetup_RootName_CaseSens   public 1
77097>>>>>    property integer piSetup_DFName_CaseSens     public 0
77098>>>>>    property integer piSetup_UserName_CaseSens   public 1
77099>>>>>
77099>>>>>    property integer piIgnore_DisplayName        public 0 // Filelist, DF_FILE_DISPLAY_NAME
77100>>>>>    property integer piIgnore_MaxRecords         public 1 // File, DF_FILE_MAX_RECORDS
77101>>>>>    property integer piIgnore_Compression        public 0 // File, DF_FILE_COMPRESSION
77102>>>>>    property integer piIgnore_IntegrityCheck     public 0 // File, DF_FILE_INTEGRITY_CHECK
77103>>>>>    property integer piIgnore_LockType           public 0 // File, DF_FILE_LOCK_TYPE
77104>>>>>    property integer piIgnore_MultiUser          public 0 // File, DF_FILE_MULTIUSER
77105>>>>>    property integer piIgnore_ReuseDeleted       public 0 // File, DF_FILE_REUSE_DELETED
77106>>>>>    property integer piIgnore_TransactionSetting public 0 // File, DF_FILE_TRANSACTION
77107>>>>>    property integer piIgnore_Rootname           public 0 // File, DF_FILE_ROOT_NAME
77108>>>>>    property integer piIgnore_RecordLength       public 0 // File, DF_FILE_RECORD_LENGTH
77109>>>>>    property integer piIgnore_RecordIdentity     public 0 // File, DF_FILE_RECORD_IDENTITY
77110>>>>>
77110>>>>>    object oFdxFieldAttrCompare is a cFdxFieldAttrCompare NO_IMAGE
77112>>>>>    end_object
77113>>>>>    object oFdxIndexAttrCompare is a cFdxIndexAttrCompare NO_IMAGE
77115>>>>>    end_object
77116>>>>>    object oDeletedFields is a cArray NO_IMAGE
77118>>>>>    end_object
77119>>>>>  end_procedure
77120>>>>>
77120>>>>>  procedure reset
77122>>>>>    send reset to (oFdxFieldAttrCompare(self))
77123>>>>>    send reset to (oFdxIndexAttrCompare(self))
77124>>>>>    send delete_data to (oDeletedFields(self))
77125>>>>>    set piFileList_Change to False
77126>>>>>    set piFile_Change     to False
77127>>>>>    set piField_Change    to False
77128>>>>>    set piIndex_Change    to False
77129>>>>>  end_procedure
77130>>>>>
77130>>>>>  procedure NoteFieldDeleted integer field#
77132>>>>>    set value of (oDeletedFields(self)) item field# to 1
77133>>>>>  end_procedure
77134>>>>>
77134>>>>>  function iAnyChange returns integer
77136>>>>>    function_return (piFileList_Change(self)+piFile_Change(self)+piField_Change(self)+piIndex_Change(self))
77137>>>>>  end_function
77138>>>>>
77138>>>>>  procedure add_filelist_instruction integer attr# string value#
77140>>>>>    integer obj#
77140>>>>>    get piPgmObject to obj#
77141>>>>>    if obj# send add_filelist_instruction to obj# attr# value#
77144>>>>>    set piFileList_Change to true
77145>>>>>  end_procedure
77146>>>>>  procedure add_file_instruction integer attr# string value#
77148>>>>>    integer obj#
77148>>>>>    get piPgmObject to obj#
77149>>>>>    if obj# send add_file_instruction to obj# attr# value#
77152>>>>>    set piFile_Change to true
77153>>>>>  end_procedure
77154>>>>>  procedure add_field_instruction integer type# integer attr# integer field# string name# string value#
77156>>>>>    integer obj#
77156>>>>>    get piPgmObject to obj#
77157>>>>>    if obj# send add_field_instruction to obj# type# attr# field# name# value#
77160>>>>>    set piField_Change to true
77161>>>>>  end_procedure
77162>>>>>  procedure add_index_instruction integer type# integer attr# integer index# string value#
77164>>>>>    integer obj#
77164>>>>>    get piPgmObject to obj#
77165>>>>>    if obj# send add_index_instruction to obj# type# attr# index# value#
77168>>>>>    set piIndex_Change to true
77169>>>>>  end_procedure
77170>>>>>  procedure add_indexseg_instruction integer type# integer attr# integer index# integer segment# string value#
77172>>>>>    integer obj#
77172>>>>>    get piPgmObject to obj#
77173>>>>>    if obj# send add_indexseg_instruction to obj# type# attr# index# segment# value#
77176>>>>>    set piIndex_Change to true
77177>>>>>  end_procedure
77178>>>>>
77178>>>>>  function iIsChangedFileList.ii integer attr# integer CaseSens# returns integer
77180>>>>>    string value1# value2#
77180>>>>>    move (FDX_AttrValue_FILELIST(piFDX1(self),attr#,piFile1(self))) to value1#
77181>>>>>    move (FDX_AttrValue_FILELIST(piFDX2(self),attr#,piFile2(self))) to value2#
77182>>>>>    if (attr#=DF_FILE_DISPLAY_NAME and piIgnore_DisplayName(self) and trim(value2#)<>"") function_return 0
77185>>>>>    if (attr#=DF_FILE_ROOT_NAME and piIgnore_RootName(self) and trim(value2#)<>"") function_return 0
77188>>>>>    if (not(CaseSens#)) begin
77190>>>>>      move (uppercase(value1#)) to value1#
77191>>>>>      move (uppercase(value2#)) to value2#
77192>>>>>    end
77192>>>>>>
77192>>>>>    function_return (value1#<>value2#)
77193>>>>>  end_function
77194>>>>>  function iIsChangedFile.i integer attr# returns integer
77196>>>>>    if (attr#=DF_FILE_MAX_RECORDS     and piIgnore_MaxRecords(self)) function_return 0
77199>>>>>    if (attr#=DF_FILE_COMPRESSION     and piIgnore_Compression(self)) function_return 0
77202>>>>>    if (attr#=DF_FILE_INTEGRITY_CHECK and piIgnore_IntegrityCheck(self)) function_return 0
77205>>>>>    if (attr#=DF_FILE_LOCK_TYPE       and piIgnore_LockType(self)) function_return 0
77208>>>>>    if (attr#=DF_FILE_MULTIUSER       and piIgnore_MultiUser(self)) function_return 0
77211>>>>>    if (attr#=DF_FILE_REUSE_DELETED   and piIgnore_ReuseDeleted(self)) function_return 0
77214>>>>>    if (attr#=DF_FILE_TRANSACTION     and piIgnore_TransactionSetting(self)) function_return 0
77217>>>>>    if (attr#=DF_FILE_RECORD_LENGTH   and piIgnore_RecordLength(self)) function_return 0
77220>>>>>    if (attr#=DF_FILE_RECORD_IDENTITY and piIgnore_RecordIdentity(self)) function_return 0
77223>>>>>    function_return (FDX_AttrValue_FILE(piFDX1(self),attr#,piFile1(self))<>FDX_AttrValue_FILE(piFDX2(self),attr#,piFile2(self)))
77224>>>>>  end_function
77225>>>>>
77225>>>>>  procedure run.ii integer restruct_program_object# integer liCompareMode
77227>>>>>    integer file1# file2# pgm_type# lhFDX2 lbFilelistSlotEmpty
77227>>>>>    set piPgmObject to restruct_program_object#
77228>>>>>    send reset to restruct_program_object# // 03-09-2000
77229>>>>>    send reset
77230>>>>>    get piFile1 to file1#
77231>>>>>    get piFile2 to file2#
77232>>>>>    if (file1#+file2#) begin
77234>>>>>      if file2# ne 0 begin
77236>>>>>        get piFDX2 to lhFDX2
77237>>>>>        if (liCompareMode=FDXCOMP_MODE_FILELIST or liCompareMode=FDXCOMP_MODE_ALL) begin
77239>>>>>          // Check filelist parameters:
77239>>>>>          get AttrValue_IsEmpty of lhFDX2 file2# to lbFilelistSlotEmpty
77240>>>>>
77240>>>>>          if (not(file1#) or iIsChangedFileList.ii(self,DF_FILE_ROOT_NAME,piSetup_RootName_CaseSens(self))) begin
77242>>>>>            if lbFilelistSlotEmpty send add_filelist_instruction DF_FILE_ROOT_NAME ""
77245>>>>>            else send add_filelist_instruction DF_FILE_ROOT_NAME    (FDX_AttrValue_FILELIST(lhFDX2,DF_FILE_ROOT_NAME,piFile2(self)))
77247>>>>>          end
77247>>>>>>
77247>>>>>          if (not(file1#) or iIsChangedFileList.ii(self,DF_FILE_LOGICAL_NAME,piSetup_DFName_CaseSens(self))) begin
77249>>>>>            if lbFilelistSlotEmpty send add_filelist_instruction DF_FILE_LOGICAL_NAME ""
77252>>>>>            else send add_filelist_instruction DF_FILE_LOGICAL_NAME (FDX_AttrValue_FILELIST(lhFDX2,DF_FILE_LOGICAL_NAME,piFile2(self)))
77254>>>>>          end
77254>>>>>>
77254>>>>>          if (not(file1#) or iIsChangedFileList.ii(self,DF_FILE_DISPLAY_NAME,piSetup_UserName_CaseSens(self))) begin
77256>>>>>            if lbFilelistSlotEmpty send add_filelist_instruction DF_FILE_DISPLAY_NAME ""
77259>>>>>            else send add_filelist_instruction DF_FILE_DISPLAY_NAME (FDX_AttrValue_FILELIST(lhFDX2,DF_FILE_DISPLAY_NAME,piFile2(self)))
77261>>>>>          end
77261>>>>>>
77261>>>>>        end
77261>>>>>>
77261>>>>>
77261>>>>>        if (liCompareMode=FDXCOMP_MODE_FILE or liCompareMode=FDXCOMP_MODE_ALL) begin
77263>>>>>          // Check file parameters:
77263>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_MAX_RECORDS    ))  send add_file_instruction DF_FILE_MAX_RECORDS      (FDX_AttrValue_FILE(lhFDX2,DF_FILE_MAX_RECORDS    ,file2#))
77266>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_MULTIUSER      ))  send add_file_instruction DF_FILE_MULTIUSER        (FDX_AttrValue_FILE(lhFDX2,DF_FILE_MULTIUSER      ,file2#))
77269>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_REUSE_DELETED  ))  send add_file_instruction DF_FILE_REUSE_DELETED    (FDX_AttrValue_FILE(lhFDX2,DF_FILE_REUSE_DELETED  ,file2#))
77272>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_COMPRESSION    ))  send add_file_instruction DF_FILE_COMPRESSION      (FDX_AttrValue_FILE(lhFDX2,DF_FILE_COMPRESSION    ,file2#))
77275>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_TRANSACTION    ))  send add_file_instruction DF_FILE_TRANSACTION      (FDX_AttrValue_FILE(lhFDX2,DF_FILE_TRANSACTION    ,file2#))
77278>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_RECORD_LENGTH  ))  send add_file_instruction DF_FILE_RECORD_LENGTH    (FDX_AttrValue_FILE(lhFDX2,DF_FILE_RECORD_LENGTH  ,file2#))
77281>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_INTEGRITY_CHECK))  send add_file_instruction DF_FILE_INTEGRITY_CHECK  (FDX_AttrValue_FILE(lhFDX2,DF_FILE_INTEGRITY_CHECK,file2#))
77284>>>>>          if (not(file1#) or iIsChangedFile.i(self,DF_FILE_RECORD_IDENTITY))  send add_file_instruction DF_FILE_RECORD_IDENTITY  (FDX_AttrValue_FILE(lhFDX2,DF_FILE_RECORD_IDENTITY,file2#))
77287>>>>>
77287>>>>>          send run to (oFdxFieldAttrCompare(self))
77288>>>>>          send AnalyzeDeletedFields to (oFdxIndexAttrCompare(self)) (oDeletedFields(self))
77289>>>>>          send run to (oFdxIndexAttrCompare(self))
77290>>>>>        end
77290>>>>>>
77290>>>>>
77290>>>>>        if (file1#*file2#) begin // EDIT or NOCHANGE
77292>>>>>          if (iAnyChange(self)) move PGM_TYPE_EDIT to pgm_type#
77295>>>>>          else move PGM_TYPE_EMPTY to pgm_type#
77297>>>>>        end
77297>>>>>>
77297>>>>>        else begin
77298>>>>>          if file1# eq 0 begin
77300>>>>>            if (liCompareMode=FDXCOMP_MODE_FILELIST) move PGM_TYPE_FILELIST to pgm_type#
77303>>>>>            else move PGM_TYPE_CREATE to pgm_type#
77305>>>>>          end
77305>>>>>>
77305>>>>>        end
77305>>>>>>
77305>>>>>      end
77305>>>>>>
77305>>>>>      else begin // File2 is 0 => Drop table:
77306>>>>>        send add_filelist_instruction DF_FILE_ROOT_NAME    ""
77307>>>>>        send add_filelist_instruction DF_FILE_LOGICAL_NAME ""
77308>>>>>        send add_filelist_instruction DF_FILE_DISPLAY_NAME ""
77309>>>>>        move PGM_TYPE_DROP to pgm_type# // Makes the program drop the file.
77310>>>>>      end
77310>>>>>>
77310>>>>>      set piProgramType of restruct_program_object# to pgm_type#
77311>>>>>    end
77311>>>>>>
77311>>>>>  end_procedure
77312>>>>>end_class // cFdxTableCompare
77313>>>>>
77313>>>>>desktop_section
77318>>>>>  object oFdxTableCompare is a cFdxTableCompare NO_IMAGE
77320>>>>>  end_object
77321>>>>>end_desktop_section
77326>>>>>
77326>>>>>//> Function iFdxCompareTables.iiiiii compares two table definitions and
77326>>>>>//> returns the object ID of a cFdxRestructureProgram object that
77326>>>>>//> holds the instructions to restructure the data definition
77326>>>>>function iFdxCompareTables.iiiiii global integer lhPgmObj integer lhFdx1 integer liFile1 integer lhFdx2 integer liFile2 integer liCompareMode returns integer
77328>>>>>  integer lhTableCompare
77328>>>>>  ifnot lhPgmObj get iCreateFdxRestructureProgram to lhPgmObj
77331>>>>>  send reset to lhPgmObj
77332>>>>>  set piFile of lhPgmObj to liFile1
77333>>>>>  ifnot (iCanOpen.i(lhFdx1,liFile1)) begin
77335>>>>>    set psRootName of lhPgmObj to (FDX_AttrValue_FILELIST(lhFdx2,DF_FILE_ROOT_NAME,liFile2))
77336>>>>>    move 0 to liFile1 // This signals a creation
77337>>>>>  end
77337>>>>>>
77337>>>>>  else set psRootName of lhPgmObj to (FDX_AttrValue_FILELIST(lhFdx1,DF_FILE_ROOT_NAME,liFile1))
77339>>>>>  move (oFdxTableCompare(self)) to lhTableCompare
77340>>>>>  set piFDX1  of lhTableCompare to lhFdx1
77341>>>>>  set piFile1 of lhTableCompare to liFile1
77342>>>>>  set piFDX2  of lhTableCompare to lhFdx2
77343>>>>>  set piFile2 of lhTableCompare to liFile2
77344>>>>>  send run.ii to lhTableCompare lhPgmObj liCompareMode
77345>>>>>//  send DoEditFieldMatch lhTableCompare
77345>>>>>  function_return lhPgmObj
77346>>>>>end_function
77347>>>>>
77347>>>>>// Returns 0 if no changes and file was not written (or rather deleted if present)
77347>>>>>// Returns 1 if changes and file was written
77347>>>>>// Returns 2 if different number of fields
77347>>>>>function Fdx_GenerateFieldNameChanges global integer lhFDX1 integer liFile1 integer lhFDX2 integer liFile2 string lsDir returns integer
77349>>>>>  integer liChannel liField liMax lbChanges liGarbage
77349>>>>>  string lsOutFileName lsName1 lsName2
77349>>>>>  ifnot (liFile1*liFile2) function_return 0
77352>>>>>  if (FDX_AttrValue_FILE(lhFdx1,DF_FILE_NUMBER_FIELDS,liFile1)=FDX_AttrValue_FILE(lhFdx2,DF_FILE_NUMBER_FIELDS,liFile2)) begin
77354>>>>>
77354>>>>>    move (FDX_AttrValue_FILE(lhFdx1,DF_FILE_NUMBER_FIELDS,liFile1)) to liMax
77355>>>>>
77355>>>>>    get FDX_AttrValue_FILELIST lhFDX1 DF_FILE_ROOT_NAME liFile1 to lsOutFileName
77356>>>>>
77356>>>>>    move (lsOutFileName+".fdn") to lsOutFileName
77357>>>>>    get SEQ_ComposeAbsoluteFileName lsDir lsOutFileName to lsOutFileName
77358>>>>>
77358>>>>>    get SEQ_DirectOutput lsOutFileName to liChannel
77359>>>>>    if (liChannel>=0) begin
77361>>>>>      move DFFALSE to lbChanges
77362>>>>>      for liField from 1 to liMax
77368>>>>>>
77368>>>>>        get FDX_AttrValue_FIELD lhFDX1 DF_FIELD_NAME liFile1 liField to lsName1
77369>>>>>        get FDX_AttrValue_FIELD lhFDX2 DF_FIELD_NAME liFile2 liField to lsName2
77370>>>>>        if (lsName1<>lsName2) begin
77372>>>>>          move DFTRUE to lbChanges
77373>>>>>          writeln channel liChannel lsName1
77376>>>>>          writeln lsName2
77378>>>>>        end
77378>>>>>>
77378>>>>>      loop
77379>>>>>>
77379>>>>>      send SEQ_CloseOutput liChannel
77380>>>>>      ifnot lbChanges begin
77382>>>>>        get SEQ_EraseFile lsOutFileName to liGarbage
77383>>>>>        //delete the file
77383>>>>>      end
77383>>>>>>
77383>>>>>      function_return 1
77384>>>>>    end
77384>>>>>>
77384>>>>>  end
77384>>>>>>
77384>>>>>  else begin
77385>>>>>//    send obs "Incompatible number of fields in file:" lsOutFileName
77385>>>>>    function_return 2
77386>>>>>  end
77386>>>>>>
77386>>>>>end_function
77387>>>>>
77387>>>>>
77387>>>>>//enumeration_list
77387>>>>>//  define ARCERR_NO_ERROR
77387>>>>>//  define ARCERR_INCOMPATIBLE_FILE_FOUND // "Target data file exists, but can't be opened
77387>>>>>//  define ARCERR_SOURCE_FILE_NOT_FOUND
77387>>>>>//  define ARCERR_RESTRUCTURE_NEEDED
77387>>>>>//  define ARCERR_CREATE_FAILED
77387>>>>>//end_enumeration_list
77387>>>>>//
77387>>>>>//// Denne funktion undersger hvorvidt, der allerede findes en data file
77387>>>>>//// i target biblioteket. Hvis alt er i orden returneres 0
77387>>>>>//function iValidateDataFile integer file# returns integer
77387>>>>>//  integer oFDX1# oFDX2# rval# obj#
77387>>>>>//  string target_dir# root# target_root#
77387>>>>>//  move 0 to rval#
77387>>>>>//  close file#
77387>>>>>//  if (DBMS_OpenFile(file#,DF_SHARE,0)) begin
77387>>>>>//    // Read current file definition
77387>>>>>//    object oFdx1 is a cFdxFileDef no_image
77387>>>>>//      send Read_File_Definition.i file#
77387>>>>>//      move self to oFDX1#
77387>>>>>//    end_object
77387>>>>>//
77387>>>>>//    // Check if there's one in the target directory
77387>>>>>//    get ArchiveSetupValue ARC_DIRECTORY to target_dir#
77387>>>>>//    move (API_AttrValue_FILELIST(DF_FILE_ROOT_NAME,file#)) to root#
77387>>>>>//    move (SEQ_ComposeAbsoluteFileName(target_dir#,root#)) to target_root#
77387>>>>>//    if (SEQ_FileExists(target_root#+".dat")) begin // compare
77387>>>>>//      close file#
77387>>>>>//      if (DBMS_OpenFileAs(target_root#,file#,DF_SHARE,0)) begin
77387>>>>>//        object oFdx2 is a cFdxFileDef no_image
77387>>>>>//          send Read_File_Definition.i file#
77387>>>>>//          move self to oFDX2#
77387>>>>>//        end_object
77387>>>>>//        get iFdxCompareTables.iiiiii (oArcCompareResult(self)) oFDX1# file# oFDX2# file# FDXCOMP_MODE_ALL to obj#
77387>>>>>//        if (iGenericChange(obj#)) move ARCERR_RESTRUCTURE_NEEDED to rval#
77387>>>>>//        send request_destroy_object to oFDX2#
77387>>>>>//        // Her
77387>>>>>//      end
77387>>>>>//      else move ARCERR_INCOMPATIBLE_FILE_FOUND to rval#
77387>>>>>//    end
77387>>>>>//    else begin
77387>>>>>//      //send obs "P dette sted kunne programmet oprette filnr" (string(file#)) target_root#
77387>>>>>//      move (RSX_CreateTableFromFDX(oFDX1#,file#,target_root#)) to rval#
77387>>>>>//      if rval# move 0 to rval#
77387>>>>>//      else move ARCERR_CREATE_FAILED to rval#
77387>>>>>//    end
77387>>>>>//    send request_destroy_object to oFDX1#
77387>>>>>//  end
77387>>>>>//  else move ARCERR_SOURCE_FILE_NOT_FOUND to rval#
77387>>>>>//  close file#
77387>>>>>//  function_return rval#
77387>>>>>//end_function
77387>>>>>
77387>>>Use StrucPgm.pkg // Display restructure program (procedure StructPgm_Display)
Including file: strucpgm.pkg    (C:\Apps\VDFQuery\AppSrc\strucpgm.pkg)
77387>>>>>// Use StrucPgm.pkg // Display restructure program (procedure StructPgm_Display)
77387>>>>>Use StrucPgm.nui // Class for storing a sequence of restructure instructions
77387>>>>>Use GridUtil.utl // Grid and List utilities
77387>>>>>
77387>>>>>Use Aps.pkg
77387>>>>>class StrucPgmDisplayList is a aps.Grid
77388>>>>>  procedure construct_object integer img#
77390>>>>>    forward send construct_object img#
77392>>>>>    set highlight_row_state to dfTrue
77393>>>>>    property integer piPgm_Object public 0
77394>>>>>    set line_width to 1 0
77395>>>>>    send GridPrepare_AddColumn "" AFT_ASCII60
77396>>>>>    send GridPrepare_Apply self
77397>>>>>    set header_visible_state to false
77398>>>>>    set gridline_mode to GRID_VISIBLE_NONE
77399>>>>>    set form_margin item 0 to  60   //
77400>>>>>    set select_mode to no_select
77401>>>>>    on_key key_ctrl+key_w send DoWriteToFile
77402>>>>>  end_procedure
77403>>>>>
77403>>>>>  procedure DoWriteToFile
77405>>>>>    send Grid_DoWriteToFile self
77406>>>>>  end_procedure
77407>>>>>
77407>>>>>  procedure prv.fill_list integer obj#
77409>>>>>    integer row# max#
77409>>>>>    string val# prev_val# str#
77409>>>>>    get row_count of obj# to max#
77410>>>>>    for row# from 0 to (max#-1)
77416>>>>>>
77416>>>>>      send add_item msg_none (sInstructionText.i(obj#,row#))
77417>>>>>    loop
77418>>>>>>
77418>>>>>  end_procedure
77419>>>>>
77419>>>>>  procedure fill_list_filelist
77421>>>>>    send prv.fill_list (oFileListPgm(piPgm_Object(self)))
77422>>>>>  end_procedure
77423>>>>>  procedure fill_list_file
77425>>>>>    send prv.fill_list (oFilePgm(piPgm_Object(self)))
77426>>>>>  end_procedure
77427>>>>>  procedure fill_list_fields
77429>>>>>    send prv.fill_list (oFieldPgm(piPgm_Object(self)))
77430>>>>>  end_procedure
77431>>>>>  procedure fill_list_indices
77433>>>>>    send prv.fill_list (oIndexPgm(piPgm_Object(self)))
77434>>>>>    send prv.fill_list (oIndexSegPgm(piPgm_Object(self)))
77435>>>>>  end_procedure
77436>>>>>  procedure fill_list.i integer pgm#
77438>>>>>    integer max# itm#
77438>>>>>    set piPgm_Object to pgm#
77439>>>>>    send delete_data
77440>>>>>    send add_item msg_none "******* Filelist parameters *******"
77441>>>>>    send fill_list_filelist
77442>>>>>    send add_item msg_none "******* File parameters *******"
77443>>>>>    send fill_list_file
77444>>>>>    send add_item msg_none "******* Field parameters *******"
77445>>>>>    send fill_list_fields
77446>>>>>    send add_item msg_none "******* Index parameters *******"
77447>>>>>    send fill_list_indices
77448>>>>>    send Grid_SetEntryState self 0
77449>>>>>    set dynamic_update_state to true
77450>>>>>  end_procedure
77451>>>>>end_class // StrucPgmDisplayList
77452>>>>>
77452>>>>>object oDisplayStrucPgm is a aps.ModalPanel
77454>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
77455>>>>>  on_key kcancel send close_panel
77456>>>>>  set locate_mode to CENTER_ON_SCREEN
77457>>>>>  set pMinimumSize to 100 100
77458>>>>>  object oLst is a StrucPgmDisplayList
77460>>>>>    set size to 200 0
77461>>>>>  end_object
77462>>>>>  object oBtn is a aps.Multi_Button
77464>>>>>    on_item "Close" send close_panel
77465>>>>>  end_object
77466>>>>>  send aps_locate_multi_buttons
77467>>>>>  procedure popup.i integer pgm#
77470>>>>>    integer rval#
77470>>>>>    set label to (sTitle(pgm#))
77471>>>>>    send fill_list.i to (oLst(self)) pgm#
77472>>>>>    send popup
77473>>>>>  end_procedure
77474>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
77477>>>>>    send aps_resize (oLst(self)) delta_rw# delta_cl#
77478>>>>>    send aps_register_multi_button (oBtn(self))
77479>>>>>    send aps_locate_multi_buttons
77480>>>>>    send aps_auto_size_container
77481>>>>>  end_procedure
77482>>>>>end_object // oDisplayStrucPgm
77483>>>>>
77483>>>>>procedure StructPgm_Display global integer pgm#
77485>>>>>  send popup.i to (oDisplayStrucPgm(self)) pgm#
77486>>>>>end_procedure
77487>>>Use StrucTrc.utl // Object for tracing a restructure operation
77487>>>Use LogFile.pkg  // Object for specifying log file properties
Including file: logfile.pkg    (C:\Apps\VDFQuery\AppSrc\logfile.pkg)
77487>>>>>// Use LogFile.pkg  // Object for specifying log file properties
77487>>>>>//
77487>>>>>// by Sture Andersen
77487>>>>>//
77487>>>>>Use LogFile.nui  // Class for handling a log file (No User Interface)
77487>>>>>Use Files.utl    // Utilities for handling file related stuff
77487>>>>>Use Output.utl   // Basic sequential output service
77487>>>>>Use Dates.nui    // Date routines (No User Interface)
77487>>>>>
77487>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
77487>>>>>Use Buttons.utl  // Button texts
77487>>>>>register_object oFrm1
77487>>>>>register_object oFrm2
77487>>>>>register_object oFrm3
77487>>>>>object oLogFilePropertiesPanel is a aps.ModalPanel label "Log fil"
77490>>>>>  set locate_mode to CENTER_ON_SCREEN
77491>>>>>  property integer phLogFile public 0
77493>>>>>  on_key kcancel send close_panel
77494>>>>>  object oFrm1 is a aps.Form abstract AFT_ASCII60 label "Current log file is:"
77498>>>>>    set label_justification_mode to JMODE_TOP
77499>>>>>    set object_shadow_state to DFTRUE
77500>>>>>  end_object
77501>>>>>  send aps_new_field_row
77502>>>>>  send aps_make_row_space 5
77503>>>>>  object oFrm2 is a aps.Form abstract AFT_ASCII15 label "Size:"
77507>>>>>    set object_shadow_state to DFTRUE
77508>>>>>  end_object
77509>>>>>  procedure DoUpdateFile
77512>>>>>    integer lhLogFile
77512>>>>>    string lsFile
77512>>>>>    get phLogFile to lhLogFile
77513>>>>>    get psFileName of lhLogFile to lsFile
77514>>>>>    set value of (oFrm1(self)) item 0 to lsFile
77515>>>>>    if (SEQ_FileExists(lsFile)=SEQIT_FILE) begin
77517>>>>>      set value of (oFrm2(self)) item 0 to (SEQ_FileSizeToString(SEQ_FileSize(lsFile)))
77518>>>>>      set value of (oFrm3(self)) item 0 to (TS_ConvertToString(SEQ_FileModTime(lsFile)))
77519>>>>>    end
77519>>>>>>
77519>>>>>    else begin
77520>>>>>      set value of (oFrm2(self)) item 0 to "-"
77521>>>>>      set value of (oFrm3(self)) item 0 to "-"
77522>>>>>    end
77522>>>>>>
77522>>>>>  end_procedure
77523>>>>>
77523>>>>>  procedure DoView
77526>>>>>    runprogram BACKGROUND ("notepad "+psFileName(phLogFile(self)))
77527>>>>>  end_procedure
77528>>>>>  procedure DoReset
77531>>>>>    send DeleteFile to (phLogFile(self))
77532>>>>>    send DoUpdateFile
77533>>>>>  end_procedure
77534>>>>>  object oFrm3 is a aps.Form abstract AFT_ASCII25 label "Tidsstempling:" snap SL_RIGHT_SPACE
77539>>>>>    set object_shadow_state to DFTRUE
77540>>>>>  end_object
77541>>>>>  object oBtn1 is a aps.Multi_Button
77543>>>>>    on_item "View file"   send DoView
77544>>>>>  end_object
77545>>>>>  object oBtn1 is a aps.Multi_Button
77547>>>>>    on_item "Reset file"  send DoReset
77548>>>>>  end_object
77549>>>>>  object oBtn1 is a aps.Multi_Button
77551>>>>>    on_item t.btn.close send close_panel
77552>>>>>  end_object
77553>>>>>  send aps_locate_multi_buttons
77554>>>>>  procedure popup.i integer lhLogFile
77557>>>>>     integer rval#
77557>>>>>   set phLogFile to lhLogFile
77558>>>>>    send DoUpdateFile
77559>>>>>    send popup
77560>>>>>  end_procedure
77561>>>>>end_object // oLogFilePropertiesPanel
77562>>>>>
77562>>>>>procedure Popup_LogFileProperties global integer lhLogFile
77564>>>>>  send popup.i to (oLogFilePropertiesPanel(self)) lhLogFile
77565>>>>>end_procedure
77566>>>Use Spec0007.utl // Display modal text (DoDisplayText)
77566>>>Use WildCard.nui // WildCardMatch function
77566>>>Use Files.utl    // Utilities for handling file related stuff
77566>>>
77566>>>desktop_section
77571>>>  object oFdxRestructureProgramArray_StrucPgm is a cFdxRestructureProgramArray NO_IMAGE
77573>>>    procedure save_browse
77576>>>      integer liChannel row# max# obj#
77576>>>      string fn#
77576>>>      get row_count to max#
77577>>>      if max# begin
77579>>>        move (SEQ_SelectOutFile("Restructure Program File destination (*.rpf)","Restructure program file|*.rpf")) to fn#
77580>>>        if fn# ne "" begin
77582>>>          move (SEQ_DirectOutput(fn#)) to liChannel
77583>>>          if liChannel ge 0 begin
77585>>>            for row# from 0 to (max#-1)
77591>>>>
77591>>>              writeln channel liChannel (piFile.i(self,row#))
77594>>>              writeln (psRootName.i(self,row#))
77596>>>              get piObject.i row# to obj#
77597>>>              send Seq_Write to obj# liChannel
77598>>>            loop
77599>>>>
77599>>>            send SEQ_CloseOutput liChannel
77600>>>          end
77600>>>>
77600>>>        end
77600>>>>
77600>>>      end
77600>>>>
77600>>>    end_procedure
77601>>>    procedure open_browse
77604>>>      integer fin# obj# file# row# liChannel
77604>>>      string fn#
77604>>>      move (SEQ_SelectFile("Select Restructure Program File (*.rpf)","Restructure program file|*.rpf")) to fn#
77605>>>      if fn# ne "" begin
77607>>>        move (SEQ_DirectInput(fn#)) to liChannel
77608>>>        if liChannel ge 0 begin
77610>>>          send reset
77611>>>          repeat
77611>>>>
77611>>>            move (SEQ_ReadLn(liChannel)) to file#
77612>>>            move (seqeof) to fin#
77613>>>            ifnot fin# begin
77615>>>              get row_count to row#
77616>>>              set piFile.i row# to file#
77617>>>              set psRootName.i row# to (SEQ_ReadLn(liChannel))
77618>>>              get iCreateFdxRestructureProgram to obj#
77619>>>              set piObject.i row# to obj#
77620>>>              send Seq_Read to obj# liChannel
77621>>>            end
77621>>>>
77621>>>          until fin#
77623>>>          send SEQ_CloseInput liChannel
77624>>>        end
77624>>>>
77624>>>      end
77624>>>>
77624>>>    end_procedure
77625>>>  end_object // oFdxRestructureProgramArray_StrucPgm
77626>>>end_desktop_section
77631>>>
77631>>>// NEWTHING
77631>>>class cNewMaxRecordsList is a aps.Grid
77632>>>  procedure construct_object integer liImage
77634>>>    forward send construct_object liImage
77636>>>    send GridPrepare_AddColumn ""             AFT_ASCII3
77637>>>    send GridPrepare_AddColumn "#"            AFT_ASCII4
77638>>>    send GridPrepare_AddColumn "Root name"    AFT_ASCII15
77639>>>    send GridPrepare_AddColumn "Display name" AFT_ASCII25
77640>>>    send GridPrepare_AddColumn "Max recs"     AFT_NUMERIC8.0
77641>>>    send GridPrepare_AddColumn "Cur recs"     AFT_NUMERIC8.0
77642>>>    send GridPrepare_AddColumn "Pct full"     AFT_NUMERIC4.0
77643>>>    send GridPrepare_AddColumn "New max"      AFT_NUMERIC8.0
77644>>>    send GridPrepare_Apply self
77645>>>    set select_mode to MULTI_SELECT
77646>>>    on_key kenter send next
77647>>>    on_key key_ctrl+key_r send sort_data
77648>>>    on_key knext_item send increment_item
77649>>>    on_key kprevious_item send decrement_item
77650>>>    on_key kswitch send switch
77651>>>    on_key kswitch_back send switch_back
77652>>>  end_procedure
77653>>>  procedure decrement_item
77655>>>    integer liCurrentItem
77655>>>    get current_item to liCurrentItem
77656>>>    decrement liCurrentItem
77657>>>    if liCurrentItem ge 0 set current_item to liCurrentItem
77660>>>    else send switch_back
77662>>>  end_procedure
77663>>>  procedure increment_item
77665>>>    integer liCurrentItem
77665>>>    get current_item to liCurrentItem
77666>>>    increment liCurrentItem
77667>>>    if liCurrentItem le (item_count(self)-1) set current_item to liCurrentItem
77670>>>    else send switch
77672>>>  end_procedure
77673>>>  function iSpecialSortValueOnColumn.i integer liColumn returns integer
77675>>>    if liColumn eq 2 function_return 0
77678>>>    if liColumn eq 3 function_return 0
77681>>>    function_return 1
77682>>>  end_function
77683>>>  function sSortValue.ii integer liColumn integer liItm returns string
77685>>>    if liColumn eq 0 function_return (not(select_state(self,liItm)))
77688>>>    if liColumn eq 6 function_return (IntToStrR(1000-integer(value(self,liItm)),10))
77691>>>    function_return (IntToStrR(value(self,liItm),10))
77692>>>  end_function
77693>>>  procedure sort_data.i integer liColumn
77695>>>    send Grid_SortByColumn self liColumn
77696>>>  end_procedure
77697>>>  procedure sort_data
77699>>>    integer liCurrentColumn
77699>>>    get Grid_CurrentColumn self to liCurrentColumn
77700>>>    send sort_data.i liCurrentColumn
77701>>>  end_procedure
77702>>>  procedure header_mouse_click integer liItm
77704>>>    send sort_data.i liItm
77705>>>    forward send header_mouse_click liItm
77707>>>  end_procedure
77708>>>  procedure select_toggling integer liItm integer liValue
77710>>>    integer liBase lbState liNewMaxRec NewMaxliItm
77710>>>    move (Grid_BaseItem(self)) to liBase
77711>>>    move (liBase+7) to NewMaxliItm
77712>>>    forward send select_toggling liBase liValue // Redirect to first column
77714>>>    get select_state item liBase to lbState
77715>>>    set entry_state item NewMaxliItm to lbState
77716>>>    if lbState begin
77718>>>      set current_item to NewMaxliItm
77719>>>      get aux_value item NewMaxliItm to liNewMaxRec
77720>>>      ifnot liNewMaxRec begin
77722>>>        get value item (liBase+5) to liNewMaxRec
77723>>>        move (integer(value(self,liBase+4)) max liNewMaxRec) to liNewMaxRec
77724>>>      end
77724>>>>
77724>>>      set value item NewMaxliItm to liNewMaxRec
77725>>>    end
77725>>>>
77725>>>    else begin
77726>>>      set aux_value item NewMaxliItm to (value(self,NewMaxliItm))
77727>>>      set value item NewMaxliItm to ""
77728>>>    end
77728>>>>
77728>>>  end_procedure
77729>>>  procedure fill_list.i integer lhFdx
77731>>>    integer liRow liFile liBase liMaxRecs liUsedRecs liPct
77731>>>    send delete_data
77732>>>    move 0 to liFile
77733>>>    repeat
77733>>>>
77733>>>      move (FDX_AttrValue_FLSTNAV(lhFdx,DF_FILE_NEXT_USED,liFile)) to liFile
77734>>>      if liFile begin
77736>>>        // Only if DataFlex file and only if it has indices defined:
77736>>>        if (FDX_AttrValue_FILE(lhFdx,DF_FILE_DRIVER,liFile)="DATAFLEX" and integer(FDX_AttrValue_FILE(lhFdx,DF_FILE_LAST_INDEX_NUMBER,liFile))<>0 and not(integer(FDX_AttrValue_FILE(lhFdx,DF_FILE_IS_SYSTEM_FILE,liFile)))) begin
77738>>>          get item_count to liBase
77739>>>          send add_item msg_none ""
77740>>>          set checkbox_item_state item liBase to DFTRUE
77741>>>          send add_item msg_none liFile
77742>>>          send add_item msg_none (FDX_AttrValue_FILELIST(lhFdx,DF_FILE_ROOT_NAME,liFile))
77743>>>          send add_item msg_none (FDX_AttrValue_FILELIST(lhFdx,DF_FILE_DISPLAY_NAME,liFile))
77744>>>          move (FDX_AttrValue_FILE(lhFdx,DF_FILE_MAX_RECORDS,liFile))  to liMaxRecs
77745>>>          move (FDX_AttrValue_FILE(lhFdx,DF_FILE_RECORDS_USED,liFile)) to liUsedRecs
77746>>>          send add_item msg_none liMaxRecs
77747>>>          send add_item msg_none liUsedRecs
77748>>>          move (liUsedRecs*100.0/liMaxRecs) to liPct
77749>>>          if liPct gt 999 move 999 to liPct
77752>>>          send add_item msg_none liPct
77753>>>          send add_item msg_none ""
77754>>>        end
77754>>>>
77754>>>      end
77754>>>>
77754>>>    until liFile eq 0
77756>>>    send Grid_SetEntryState self DFFALSE
77757>>>    send sort_data.i 6
77758>>>    set current_item to 0
77759>>>    set dynamic_update_state to DFTRUE
77760>>>  end_procedure
77761>>>  procedure Callback_ModifiedEntries integer msg# integer obj#
77763>>>    integer liRow liMax liNewMax liBase liFile
77763>>>    string root#
77763>>>    get Grid_RowCount self to liMax
77764>>>    for liRow from 0 to (liMax-1)
77770>>>>
77770>>>      get Grid_RowBaseItem self liRow to liBase
77771>>>      if (select_state(self,liBase)) begin
77773>>>        get value item (liBase+1) to liFile
77774>>>        get value item (liBase+2) to root#
77775>>>        get value item (liBase+7) to liNewMax
77776>>>        send msg# to obj# liFile root# liNewMax
77777>>>      end
77777>>>>
77777>>>    loop
77778>>>>
77778>>>  end_procedure
77779>>>  procedure AutoSetParameters integer liMinPctFree integer liNewPctFree
77781>>>    integer liRow liMax liNewMax liBase liPctFull liCurRecs
77781>>>    if (liNewPctFree>liMinPctFree and liNewPctFree<=90) begin // Only if there's a point
77783>>>      get Grid_RowCount self to liMax
77784>>>      for liRow from 0 to (liMax-1)
77790>>>>
77790>>>        get Grid_RowBaseItem self liRow to liBase
77791>>>        ifnot (select_state(self,liBase)) begin // Only the ones that are not already modified
77793>>>          get value item (liBase+6) to liPctFull
77794>>>          if ((100-liPctFull)>>            set select_state item liBase to true
77797>>>            get value item (liBase+5) to liCurRecs
77798>>>            move (liCurRecs*100.0/(100-liNewPctFree)) to liNewMax
77799>>>            if (liNewMax>16711679) move 16711679 to liNewMax // dffile of 3.2 says this is maximum
77802>>>            set value item (liBase+7) to liNewMax
77803>>>          end
77803>>>>
77803>>>        end
77803>>>>
77803>>>      loop
77804>>>>
77804>>>    end
77804>>>>
77804>>>  end_procedure
77805>>>end_class // cNewMaxRecordsList
77806>>>
77806>>>Use APS          // Auto Positioning and Sizing classes for VDF
77806>>>Use Buttons.utl  // Button texts
77806>>>object oNewMaxRecords is a aps.ModalPanel label "Set new maximum number of records (indexed DataFlex tables only)"
77809>>>  set locate_mode to CENTER_ON_SCREEN
77810>>>  on_key ksave_record send close_panel_ok
77811>>>  on_key kcancel send close_panel
77812>>>  set pMinimumSize to 200 0
77813>>>  property integer piResult public 0
77815>>>  object oLst is a cNewMaxRecordsList
77817>>>    set size to 200 0
77818>>>  end_object
77819>>>  object oBtn1 is a aps.Multi_Button
77821>>>    on_item t.btn.ok send close_panel_ok
77822>>>  end_object
77823>>>  object oBtn2 is a aps.Multi_Button
77825>>>    on_item t.btn.cancel send close_panel
77826>>>  end_object
77827>>>  send aps_locate_multi_buttons
77828>>>  procedure close_panel_ok
77831>>>    set piResult to 1
77832>>>    send close_panel
77833>>>  end_procedure
77834>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
77835>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
77838>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
77839>>>    send aps_register_multi_button (oBtn1(self))
77840>>>    send aps_register_multi_button (oBtn2(self))
77841>>>    send aps_locate_multi_buttons
77842>>>    send aps_auto_size_container
77843>>>  end_procedure
77844>>>  function iPopup returns integer
77847>>>    set piResult to 0
77848>>>    send fill_list.i to (oLst(self)) (fdx.object_id(0))
77849>>>    send popup
77850>>>    function_return (piResult(self))
77851>>>  end_procedure
77852>>>  procedure AutoSetParameters integer liMinPct integer liNewPct
77855>>>    send AutoSetParameters to (oLst(self)) liMinPct liNewPct
77856>>>  end_procedure
77857>>>  procedure precond_setup
77860>>>    send fill_list.i to (oLst(self)) (fdx.object_id(0))
77861>>>  end_procedure
77862>>>end_object // oNewMaxRecords
77863>>>
77863>>>Use APS          // Auto Positioning and Sizing classes for VDF
77863>>>Use Buttons.utl  // Button texts
77863>>>object oRestructFilterPn is a aps.ModalPanel label "Filter parameters"
77866>>>  set locate_mode to CENTER_ON_SCREEN
77867>>>  on_key ksave_record send close_panel_ok
77868>>>  on_key kcancel send close_panel
77869>>>  send tab_column_define 1 30 25 jmode_left
77870>>>  set p_auto_column to 1
77871>>>  on_key key_ctrl+key_a send select_all
77872>>>  property integer piResult public 0
77874>>>  object oCb1 is a aps.CheckBox label "Ignore Display Name"
77877>>>  end_object
77878>>>  object oCb2 is a aps.CheckBox label "Ignore Max Records"
77881>>>  end_object
77882>>>  object oCb3 is a aps.CheckBox label "Ignore Compression"
77885>>>  end_object
77886>>>  object oCb4 is a aps.CheckBox label "Ignore Integrity Check"
77889>>>  end_object
77890>>>  object oCb5 is a aps.CheckBox label "Ignore Lock Type"
77893>>>  end_object
77894>>>  object oCb6 is a aps.CheckBox label "Ignore Multi User"
77897>>>  end_object
77898>>>  object oCb7 is a aps.CheckBox label "Ignore Reuse Deleted"
77901>>>  end_object
77902>>>  object oCb8 is a aps.CheckBox label "Ignore Transaction setting"
77905>>>  end_object
77906>>>  object oCb9 is a aps.CheckBox label "Ignore Root name"
77909>>>  end_object
77910>>>  object oCb10 is a aps.CheckBox label "Ignore Record Length"
77913>>>  end_object
77914>>>  object oCb11 is a aps.CheckBox label "Ignore Record Identity"
77917>>>  end_object
77918>>>  procedure select_all
77921>>>    integer lbState
77921>>>    get checked_state of (oCb1(self)) to lbState
77922>>>    move (not(lbState)) to lbState
77923>>>    set checked_state of (oCb1(self)) to lbState
77924>>>    set checked_state of (oCb2(self)) to lbState
77925>>>    set checked_state of (oCb3(self)) to lbState
77926>>>    set checked_state of (oCb4(self)) to lbState
77927>>>    set checked_state of (oCb5(self)) to lbState
77928>>>    set checked_state of (oCb6(self)) to lbState
77929>>>    set checked_state of (oCb7(self)) to lbState
77930>>>    set checked_state of (oCb8(self)) to lbState
77931>>>    set checked_state of (oCb9(self)) to lbState
77932>>>    set checked_state of (oCb10(self)) to lbState
77933>>>    set checked_state of (oCb11(self)) to lbState
77934>>>  end_procedure
77935>>>  object oBtn1 is a aps.Multi_Button
77937>>>    on_item t.btn.ok send close_panel_ok
77938>>>  end_object
77939>>>  object oBtn2 is a aps.Multi_Button
77941>>>    on_item t.btn.cancel send close_panel
77942>>>  end_object
77943>>>  send aps_locate_multi_buttons
77944>>>  procedure close_panel_ok
77947>>>    set piResult to 1
77948>>>    send close_panel
77949>>>  end_procedure
77950>>>  procedure popup
77953>>>    integer lhObj
77953>>>    move (oFdxTableCompare(self)) to lhObj
77954>>>    set piResult to 0
77955>>>    set checked_state of (oCb1(self)) to (piIgnore_DisplayName(lhObj))
77956>>>    set checked_state of (oCb2(self)) to (piIgnore_MaxRecords(lhObj))
77957>>>    set checked_state of (oCb3(self)) to (piIgnore_Compression(lhObj))
77958>>>    set checked_state of (oCb4(self)) to (piIgnore_IntegrityCheck(lhObj))
77959>>>    set checked_state of (oCb5(self)) to (piIgnore_LockType(lhObj))
77960>>>    set checked_state of (oCb6(self)) to (piIgnore_MultiUser(lhObj))
77961>>>    set checked_state of (oCb7(self)) to (piIgnore_ReuseDeleted(lhObj))
77962>>>    set checked_state of (oCb8(self)) to (piIgnore_TransactionSetting(lhObj))
77963>>>    set checked_state of (oCb9(self)) to (piIgnore_RootName(lhObj))
77964>>>    set checked_state of (oCb10(self)) to (piIgnore_RecordLength(lhObj))
77965>>>    set checked_state of (oCb11(self)) to (piIgnore_RecordIdentity(lhObj))
77966>>>    forward send popup
77968>>>    if (piResult(self)) begin
77970>>>      set piIgnore_DisplayName        of lhObj to (checked_state(oCb1(self)))
77971>>>      set piIgnore_MaxRecords         of lhObj to (checked_state(oCb2(self)))
77972>>>      set piIgnore_Compression        of lhObj to (checked_state(oCb3(self)))
77973>>>      set piIgnore_IntegrityCheck     of lhObj to (checked_state(oCb4(self)))
77974>>>      set piIgnore_LockType           of lhObj to (checked_state(oCb5(self)))
77975>>>      set piIgnore_MultiUser          of lhObj to (checked_state(oCb6(self)))
77976>>>      set piIgnore_ReuseDeleted       of lhObj to (checked_state(oCb7(self)))
77977>>>      set piIgnore_TransactionSetting of lhObj to (checked_state(oCb8(self)))
77978>>>      set piIgnore_Rootname           of lhObj to (checked_state(oCb9(self)))
77979>>>      set piIgnore_RecordLength       of lhObj to (checked_state(oCb10(self)))
77980>>>      set piIgnore_RecordIdentity     of lhObj to (checked_state(oCb11(self)))
77981>>>    end
77981>>>>
77981>>>  end_procedure
77982>>>end_object // oRestructFilterPn
77983>>>
77983>>>class StrucPgmFdxList is a aps.Grid
77984>>>  procedure construct_object integer liImage
77986>>>    forward send construct_object liImage
77988>>>    property integer piFDX_Server public 0
77989>>>    property integer prv.GenerateChangeEvent public 1
77990>>>    set highlight_row_state to DFTRUE
77991>>>    on_key key_ctrl+key_d send display_file_things
77992>>>    set line_width to 2 0
77993>>>    set header_visible_state to false
77994>>>    set gridline_mode to GRID_VISIBLE_NONE
77995>>>    set form_margin item 0 to  4   //
77996>>>    set form_margin item 1 to  40  //
77997>>>    set highlight_row_state to true
77998>>>    set highlight_row_color to (rgb(0,255,255))
77999>>>    set current_item_color to (rgb(0,255,255))
78000>>>    set select_mode to no_select
78001>>>    on_key knext_item send switch
78002>>>    on_key kprevious_item send switch_back
78003>>>  end_procedure
78004>>>  function iCurrentFile returns integer
78006>>>    integer liBase
78006>>>    move ((current_item(self)/2)*2) to liBase
78007>>>    if (item_count(self)) function_return (value(self,liBase))
78010>>>    function_return 0
78011>>>  end_function
78012>>>  procedure display_file_things
78014>>>    send FDX_ModalDisplayFileAttributes (piFDX_Server(self)) (iCurrentFile(self))
78015>>>  end_procedure
78016>>>  procedure fill_list.i integer lhFdx
78018>>>    integer liFile liMax liItm
78018>>>    set piFDX_Server to lhFdx
78019>>>    send delete_data
78020>>>    move 0 to liFile
78021>>>    repeat
78021>>>>
78021>>>      move (FDX_AttrValue_FLSTNAV(lhFdx,DF_FILE_NEXT_USED,liFile)) to liFile
78022>>>      if liFile begin
78024>>>        send add_item msg_none liFile
78025>>>        send add_item msg_none (FDX_AttrValue_FILELIST(lhFdx,DF_FILE_DISPLAY_NAME,liFile))
78026>>>      end
78026>>>>
78026>>>    until liFile eq 0
78028>>>    set dynamic_update_state to true
78029>>>    get item_count to liMax
78030>>>    for liItm from 0 to (liMax-1)
78036>>>>
78036>>>      set entry_state item liItm to false
78037>>>    loop
78038>>>>
78038>>>  end_procedure
78039>>>  procedure DoGotoFile integer liFile
78041>>>    integer liItm liMax
78041>>>    get item_count to liMax
78042>>>    move 0 to liItm
78043>>>    while (liItm>>      if liFile eq (integer(value(self,liItm))) set current_item to liItm
78050>>>      move (liItm+2) to liItm
78051>>>    end
78052>>>>
78052>>>  end_procedure
78053>>>  procedure DoGotoFilelistEntry string lsRootName string lsLogicalName
78055>>>    integer liFile lhFdx
78055>>>    get piFDX_Server to lhFdx
78056>>>    if lhFdx begin
78058>>>      get iFindLogicalName.si of lhFdx lsLogicalName 0 to liFile
78059>>>      ifnot liFile get iFindRootName.sii of lhFdx lsRootName 0 0 to liFile
78062>>>      ifnot liFile get iFindRootName.sii of lhFdx lsRootName 0 1 to liFile
78065>>>      if liFile send DoGotoFile liFile
78068>>>    end
78068>>>>
78068>>>  end_procedure
78069>>>  procedure OnFilelistEntry string lsRootName string lsLogicalName
78071>>>  end_procedure
78072>>>  procedure item_change integer liFrom integer liTo returns integer
78074>>>    integer liRval liFile
78074>>>    forward get msg_item_change liFrom liTo to liRval
78076>>>    if (item_count(self) and prv.GenerateChangeEvent(self)) begin
78078>>>      set prv.GenerateChangeEvent to 0
78079>>>      move (value(self,(liRval/2)*2)) to liFile
78080>>>      send OnFilelistEntry (AttrValue_FILELIST(piFDX_Server(self),DF_FILE_ROOT_NAME,liFile)) (AttrValue_FILELIST(piFDX_Server(self),DF_FILE_LOGICAL_NAME,liFile))
78081>>>      set prv.GenerateChangeEvent to 1
78082>>>    end
78082>>>>
78082>>>    procedure_return liRval
78083>>>  end_procedure
78084>>>end_class // StrucPgmFdxList
78085>>>
78085>>>register_object oLst1
78085>>>register_object oLst2
78085>>>class cFdxCompareDefinitions_Pn is a aps.ModalPanel
78086>>>  procedure construct_object integer liImage
78088>>>    forward send construct_object liImage
78090>>>    object oArray is a cArray NO_IMAGE
78092>>>    end_object
78093>>>  end_procedure
78094>>>  procedure DoLoadCurrent
78096>>>    send DFMatrix_SecondaryOpenCurrentFilelist
78097>>>    send DisplayHeaders
78098>>>    send fill_list.i to (oLst2(self)) (fdx.object_id(1))
78099>>>    send activate to (oLst2(self))
78100>>>  end_procedure
78101>>>  procedure DoLoadFile
78103>>>    if (DFMatrix_SecondaryOpenFdxFile()) begin
78105>>>      send DisplayHeaders
78106>>>      send fill_list.i to (oLst2(self)) (fdx.object_id(1))
78107>>>      send activate to (oLst2(self))
78108>>>    end
78108>>>>
78108>>>  end_procedure
78109>>>  procedure compare_definitions integer liFile1 integer liFile2 integer liCompareMode
78111>>>    integer lhFDX1 lhFDX2 lhProgArray liPgmRow lhPgm lbCreate
78111>>>    string lsRoot
78111>>>
78111>>>    move (oFDXRestructureProgramArray_StrucPgm(self)) to lhProgArray
78112>>>
78112>>>    move (fdx.object_id(0)) to lhFDX1
78113>>>    move (fdx.object_id(1)) to lhFDX2
78114>>>
78114>>>    move (not(iCanOpen.i(lhFDX1,liFile1))) to lbCreate
78115>>>
78115>>>    if lbCreate move (AttrValue_FILELIST(lhFDX2,DF_FILE_ROOT_NAME,liFile2)) to lsRoot
78118>>>    else        move (AttrValue_FILELIST(lhFDX1,DF_FILE_ROOT_NAME,liFile1)) to lsRoot
78120>>>
78120>>>    // Do the comparison (thereby creating a pgm object):
78120>>>    move (iFdxCompareTables.iiiiii(0,lhFDX1,liFile1,lhFDX2,liFile2,liCompareMode)) to lhPgm
78121>>>
78121>>>    if (piProgramType(lhPgm)<>PGM_TYPE_EMPTY) begin
78123>>>
78123>>>      // Is there such a program already?
78123>>>      uppercase lsRoot
78124>>>>
78124>>>      move (iFindPgmRow.is(lhProgArray,liFile1,lsRoot)) to liPgmRow
78125>>>      if liPgmRow ne -1 send reset.i to lhProgArray liPgmRow // If so, reset it
78128>>>      else get iAddPgmRow.is of lhProgArray liFile1 lsRoot to liPgmRow // If not, create it
78130>>>
78130>>>      set piObject.i of lhProgArray liPgmRow to lhPgm
78131>>>    end
78131>>>>
78131>>>    else send request_destroy_object to lhPgm
78133>>>  end_procedure
78134>>>  procedure DoFilter
78136>>>    send popup to (oRestructFilterPn(self))
78137>>>  end_procedure
78138>>>  procedure DoOne
78140>>>    integer file1# file2# oFDX1# oFDX2#
78140>>>    move (fdx.object_id(0)) to oFDX1#
78141>>>    move (fdx.object_id(1)) to oFDX2#
78142>>>    if (piDataOrigin(oFDX1#)<>FDX_EMPTY and piDataOrigin(oFDX2#)<>FDX_EMPTY) begin
78144>>>      get iCurrentFile of (oLst1(self)) to file1#
78145>>>      get iCurrentFile of (oLst2(self)) to file2#
78146>>>      if (file1# or file2#) begin
78148>>>        if file1# eq 0 move file2# to file1# // Create!
78151>>>        send compare_definitions file1# file2# FDXCOMP_MODE_ALL
78152>>>        send obs "Comparison done"
78153>>>      end
78153>>>>
78153>>>    end
78153>>>>
78153>>>    else send obs "Can not compare with empty source or destination!"
78155>>>  end_procedure
78156>>>  procedure CheckFdnFile string lsFile string lsPath
78158>>>    integer lhArray
78158>>>    if (WildCardMatch(lsFile)) begin
78160>>>      move (oArray(self)) to lhArray
78161>>>      set value of lhArray item (item_count(self)) to lsFile
78162>>>    end
78162>>>>
78162>>>  end_procedure
78163>>>  procedure DeleteFdnFile string lsFile string lsPath
78165>>>    integer liGrb
78165>>>    if (WildCardMatch(lsFile)) begin
78167>>>      get SEQ_ComposeAbsoluteFileName lsPath lsFile to lsFile
78168>>>      get SEQ_EraseFile lsFile to liGrb
78169>>>    end
78169>>>>
78169>>>  end_procedure
78170>>>  procedure DoAll_CompareFieldNames
78172>>>    integer max# liRow olst1# olst2# file1# file2# oFDX1# oFDX2# synch_state# liRval
78172>>>    integer lbContinue
78172>>>    string rn1# ln1# lsDir
78172>>>    get synch_state to synch_state#
78173>>>    set synch_state to 1
78174>>>    move (oLst1(self)) to olst1#
78175>>>    move (oLst2(self)) to olst2#
78176>>>    move (fdx.object_id(0)) to oFDX1#
78177>>>    move (fdx.object_id(1)) to oFDX2#
78178>>>    if (piDataOrigin(oFDX1#)<>FDX_EMPTY and piDataOrigin(oFDX2#)<>FDX_EMPTY) begin
78180>>>      // Do changes and drops:
78180>>>      get SEQ_SelectDirectory "Directory in which to place the fdn files" to lsDir
78181>>>      if (lsDir<>"") begin
78183>>>
78183>>>        send SEQ_Load_ItemsInDir lsDir
78184>>>        send delete_data to (oArray(self))
78185>>>        send WildCardMatchPrepare "*.FDN"
78186>>>        send SEQ_CallBack_ItemsInDir SEQCB_FILES_ONLY MSG_CheckFdnFile self
78187>>>        if (item_count(oArray(self))) get MB_Verify4 "FDN files are already present in that directory." "" "Should we delete them before we continue?" "" DFFALSE to lbContinue
78190>>>        else move DFTRUE to lbContinue
78192>>>
78192>>>        if lbContinue begin
78194>>>          move (item_count(oLst1#)/2) to max#
78195>>>          for liRow from 0 to (max#-1)
78201>>>>
78201>>>            set current_item of olst1# to (liRow*2)
78202>>>            get iCurrentFile of oLst1# to file1#
78203>>>            if file1# ne 50 begin
78205>>>              if (iCanOpen.i(oFDX1#,file1#) or file1#=0) begin
78207>>>                move (AttrValue_FILELIST(oFDX1#,DF_FILE_ROOT_NAME,file1#)) to rn1#
78208>>>                move (AttrValue_FILELIST(oFDX1#,DF_FILE_LOGICAL_NAME,file1#)) to ln1#
78209>>>                get iFindLogicalName.si of oFDX2# ln1# 0 to file2#
78210>>>                ifnot file2# get iFindRootName.sii of oFDX2# rn1# 0 0 to file2#
78213>>>                ifnot file2# get iFindRootName.sii of oFDX2# rn1# 0 1 to file2#
78216>>>                if (file2#<>0 and iCanOpen.i(oFDX2#,file2#)) begin
78218>>>                  get Fdx_GenerateFieldNameChanges oFDX1# File1# oFDX2# File2# lsDir to liRval
78219>>>
78219>>>                end
78219>>>>
78219>>>              end
78219>>>>
78219>>>            end
78219>>>>
78219>>>          loop
78220>>>>
78220>>>          procedure_return msg_ok
78221>>>        end
78221>>>>
78221>>>      end
78221>>>>
78221>>>    end
78221>>>>
78221>>>    else send obs "Can not compare with empty source or destination!"
78223>>>  end_procedure
78224>>>  procedure DoAll
78226>>>    integer liMax liRow lhLst1 lhLst2 liFile1 liFile2 lhFDX1 lhFDX2 lbSynch
78226>>>    integer lbOldStrategy liTestFile lbFirstTime lbDrop lbCanOpen2
78226>>>    string lsRoot1 lsLogic1 lsRoot2
78226>>>    get synch_state to lbSynch
78227>>>    set synch_state to 1
78228>>>    move (oLst1(self)) to lhLst1
78229>>>    move (oLst2(self)) to lhLst2
78230>>>    move (fdx.object_id(0)) to lhFDX1
78231>>>    move (fdx.object_id(1)) to lhFDX2
78232>>>    if (piDataOrigin(lhFDX1)<>FDX_EMPTY and piDataOrigin(lhFDX2)<>FDX_EMPTY) begin // Neither list can be empty!
78234>>>      // Do changes and drops:
78234>>>      move (item_count(lhLst1)/2) to liMax
78235>>>      for liRow from 0 to (liMax-1) // Go through all the files in the <- list
78241>>>>
78241>>>        set current_item of lhLst1 to (liRow*2)
78242>>>        get iCurrentFile of lhLst1 to liFile1
78243>>>        if liFile1 ne 50 begin
78245>>>          if (iCanOpen.i(lhFDX1,liFile1) or liFile1=0) begin
78247>>>            move (AttrValue_FILELIST(lhFDX1,DF_FILE_ROOT_NAME,liFile1)) to lsRoot1
78248>>>            move (AttrValue_FILELIST(lhFDX1,DF_FILE_LOGICAL_NAME,liFile1)) to lsLogic1
78249>>>
78249>>>            // At this point we have the table number, root name and logical name of the table
78249>>>            // we want to update.
78249>>>
78249>>>            if 0 begin // Old strategy
78251>>>              get iFindLogicalName.si of lhFDX2 lsLogic1 0 to liFile2
78252>>>              ifnot liFile2 get iFindRootName.sii of lhFDX2 lsRoot1 0 0 to liFile2 // Start at entry 0, consider path and driver
78255>>>              ifnot liFile2 get iFindRootName.sii of lhFDX2 lsRoot1 0 1 to liFile2 // Start at entry 0, do not consider path and driver
78258>>>              if (iCanOpen.i(lhFDX2,liFile2) or liFile2=0) send compare_definitions liFile1 liFile2 FDXCOMP_MODE_ALL
78261>>>            end
78261>>>>
78261>>>            else begin // New Strategy
78262>>>              // First we figure out if we have already dealt with this table (as it could be an alias file)
78262>>>              get iFindRootName.sii of lhFDX1 lsRoot1 0 1 to liTestFile // Start at entry 0, do not consider path and driver
78263>>>              get iFindRootName.sii of lhFDX2 lsRoot1 0 1 to liFile2    // Start at entry 0, do not consider path and driver
78264>>>
78264>>>              move (liTestFile=liFile1) to lbFirstTime
78265>>>              move (not(liFile2))       to lbDrop
78266>>>
78266>>>              if lbDrop begin
78268>>>                send compare_definitions liFile1 0 FDXCOMP_MODE_ALL
78269>>>              end
78269>>>>
78269>>>              else begin
78270>>>                // Edited 19/10-2004 by Sture
78270>>>                if lbFirstTime begin
78272>>>                  get iCanOpen.i of lhFDX2 liFile2 to lbCanOpen2
78273>>>                  if lbCanOpen2 send compare_definitions liFile1 liFile2 FDXCOMP_MODE_FILE // Compare table attributes only
78276>>>                  send compare_definitions liFile1 liFile1 FDXCOMP_MODE_FILELIST // Compare filelist values only
78277>>>                  //                            Compare the same entry at both sides
78277>>>                end
78277>>>>
78277>>>                else begin
78278>>>                  send compare_definitions liFile1 liFile1 FDXCOMP_MODE_FILELIST
78279>>>                end
78279>>>>
78279>>>              end
78279>>>>
78279>>>
78279>>>
78279>>>            //if lbFirstTime begin
78279>>>            //
78279>>>            //end
78279>>>            //else move 0 to lbDrop
78279>>>            //
78279>>>            //if (liTestFile>>            //  send compare_definitions liFile1 liFile1 FDXCOMP_MODE_FILELIST
78279>>>            //end
78279>>>            //else begin // Physical definition must be dealt with
78279>>>            //  get iFindRootName.sii of lhFDX2 lsRoot1 0 1 to liFile2 // Start at entry 0, do not consider path and driver
78279>>>            //  if (iCanOpen.i(lhFDX2,liFile2) or liFile2=0) send compare_definitions liFile1 liFile2 FDXCOMP_MODE_ALL
78279>>>            //
78279>>>            //end
78279>>>
78279>>>            end
78279>>>>
78279>>>          end
78279>>>>
78279>>>        end
78279>>>>
78279>>>      loop
78280>>>>
78280>>>
78280>>>      // Do creates:
78280>>>      set synch_state to 0
78281>>>      move (item_count(lhLst2)/2) to liMax
78282>>>      for liRow from 0 to (liMax-1)
78288>>>>
78288>>>        set current_item of lhLst2 to (liRow*2)
78289>>>        get iCurrentFile of lhLst2 to liFile2
78290>>>
78290>>>        if (iCanOpen.i(lhFDX2,liFile2) or liFile2=0) begin
78292>>>          ifnot (iCanOpen.i(lhFDX1,liFile2)) begin
78294>>>            if liFile2 ne 50 begin
78296>>>              // Here we need to see if a table with that root name is already present
78296>>>              // in the <- database. If this is the case we do not need to create the
78296>>>              // table, only set the values in filelist.cfg
78296>>>              move (AttrValue_FILELIST(lhFDX2,DF_FILE_ROOT_NAME,liFile2)) to lsRoot2 // Get the root name from reference
78297>>>              get iFindRootName.sii of lhFDX1 lsRoot2 0 1 to liTestFile // See if you can find it in current database. (Start at entry 0, do not consider path and driver)
78298>>>              if liTestFile begin // We alreeady have that file
78300>>>                send compare_definitions liFile2 liFile2 FDXCOMP_MODE_FILELIST
78301>>>              end
78301>>>>
78301>>>              else begin // Create it
78302>>>                send compare_definitions liFile2 liFile2 FDXCOMP_MODE_ALL
78303>>>              end
78303>>>>
78303>>>            end
78303>>>>
78303>>>          end
78303>>>>
78303>>>        end
78303>>>>
78303>>>
78303>>>      loop
78304>>>>
78304>>>      set synch_state to lbSynch
78305>>>      procedure_return msg_ok
78306>>>    end
78306>>>>
78306>>>    else send obs "Can not compare with empty source or destination!"
78308>>>    set synch_state to lbSynch
78309>>>  end_procedure
78310>>>end_class // cFdxCompareDefinitions_Pn
78311>>>
78311>>>object oFdxCompareDefinitions_Pn is a cFdxCompareDefinitions_Pn label "Compare data definitions"
78314>>>  set locate_mode to CENTER_ON_SCREEN
78315>>>  on_key key_alt+key_1 send activate_list1
78316>>>  on_key key_alt+key_2 send activate_list2
78317>>>  on_key key_alt+key_3 send activate_buttons
78318>>>  on_key kcancel send close_panel
78319>>>  object oHdr1 is a aps.TextBox
78321>>>    set value item 0 to "Table definitions"
78322>>>  end_object
78323>>>  object oHdr2 is a aps.TextBox
78325>>>    set value item 0 to "Reference definitions"
78326>>>  end_object
78327>>>  send aps_goto_max_row
78328>>>  object oContents1 is a aps.TextBox
78330>>>    set border_style to BORDER_STATICEDGE
78331>>>    set justification_mode to (JMODE_CENTER+JMODE_VCENTER)
78332>>>  end_object
78333>>>  object oContents2 is a aps.TextBox
78335>>>    set border_style to BORDER_STATICEDGE
78336>>>    set justification_mode to (JMODE_CENTER+JMODE_VCENTER)
78337>>>  end_object
78338>>>  send aps_goto_max_row
78339>>>  send aps_make_row_space 5
78340>>>
78340>>>  procedure DisplayHeaders
78343>>>    set value of (oContents1(self)) item 0 to (sFdxTitle.i(fdx.object_id(0)))
78344>>>    set value of (oContents2(self)) item 0 to (sFdxTitle.i(fdx.object_id(1)))
78345>>>  end_procedure
78346>>>
78346>>>  register_object oLst2
78346>>>  register_object oBtn2
78346>>>  object oLst1 is a StrucPgmFdxList
78348>>>    set location to 3 0 relative
78349>>>    procedure OnFilelistEntry string rn# string ln#
78352>>>      if (select_state(oBtn2(self),0)) send DoGotoFilelistEntry to (oLst2(self)) rn# ln#
78355>>>    end_procedure
78356>>>  end_object
78357>>>  object oLst2 is a StrucPgmFdxList
78359>>>    set location to 3 39 relative
78360>>>    procedure OnFilelistEntry string rn# string ln#
78363>>>      if (select_state(oBtn2(self),0)) send DoGotoFilelistEntry to (oLst1(self)) rn# ln#
78366>>>    end_procedure
78367>>>  end_object
78368>>>
78368>>>  send aps_align_by_moving (oHdr1(self)) (oLst1(self)) SL_ALIGN_LEFT
78369>>>  send aps_align_by_sizing (oHdr1(self)) (oLst1(self)) SL_ALIGN_RIGHT
78370>>>  send aps_align_by_moving (oHdr2(self)) (oLst2(self)) SL_ALIGN_LEFT
78371>>>  send aps_align_by_sizing (oHdr2(self)) (oLst2(self)) SL_ALIGN_RIGHT
78372>>>  send aps_align_by_moving (oContents1(self)) (oLst1(self)) SL_ALIGN_LEFT
78373>>>  send aps_align_by_sizing (oContents1(self)) (oLst1(self)) SL_ALIGN_RIGHT
78374>>>  send aps_align_by_moving (oContents2(self)) (oLst2(self)) SL_ALIGN_LEFT
78375>>>  send aps_align_by_sizing (oContents2(self)) (oLst2(self)) SL_ALIGN_RIGHT
78376>>>  send aps_goto_max_row
78377>>>
78377>>>  object oBtn1_1 is a aps.Multi_Button
78379>>>    on_item "Open current" send DoLoadCurrent
78380>>>  end_object
78381>>>  object oBtn1_2 is a aps.Multi_Button
78383>>>    on_item "Open FDX file" send DoLoadFile
78384>>>  end_object
78385>>>  send aps_locate_multi_buttons
78386>>>  send aps_goto_max_row
78387>>>  object oBtn2 is a aps.CheckBox label "Synchronized lists"
78390>>>    set checked_state to true
78391>>>  end_object
78392>>>  function synch_state returns integer
78395>>>    function_return (checked_state(oBtn2(self)))
78396>>>  end_function
78397>>>  procedure set synch_state integer value#
78400>>>    set checked_state of (oBtn2(self)) to value#
78401>>>  end_procedure
78402>>>  object oBtn3_1 is a aps.Multi_Button
78404>>>    on_item "Filter" send DoFilter
78405>>>  end_object
78406>>>  object oBtn3_2 is a aps.Multi_Button
78408>>>    on_item "Compare" send DoOne
78409>>>  end_object
78410>>>  object oBtn3_3 is a aps.Multi_Button
78412>>>    on_item "Compare all" send DoAll
78413>>>  end_object
78414>>>  object oBtn3_4 is a aps.Multi_Button
78416>>>    on_item "Close"        send close_panel
78417>>>  end_object
78418>>>  on_key key_ctrl+key_f send DoFilter
78419>>>  on_key key_ctrl+key_c send DoOne
78420>>>  on_key key_ctrl+key_a send DoAll
78421>>>  on_key key_ctrl+key_t send DoAll_CompareFieldNames
78422>>>  send aps_locate_multi_buttons
78423>>>  procedure activate_list1
78426>>>    send activate to (oLst1(self))
78427>>>  end_procedure
78428>>>  procedure activate_list2
78431>>>    send activate to (oLst2(self))
78432>>>  end_procedure
78433>>>  procedure activate_buttons
78436>>>    send activate to (oBtn3(self))
78437>>>  end_procedure
78438>>>  procedure popup
78441>>>    integer grb#
78441>>>    send DisplayHeaders
78442>>>    send fill_list.i to (oLst1(self)) (fdx.object_id(0))
78443>>>    send fill_list.i to (oLst2(self)) (fdx.object_id(1))
78444>>>    ui_accept self to grb#
78445>>>  end_procedure
78446>>>  procedure aps_beautify
78449>>>    send aps_align_inside_container_by_moving (oBtn2(self)) SL_ALIGN_CENTER
78450>>>  end_procedure
78451>>>end_object // oFdxCompareDefinitions_Pn
78452>>>
78452>>>register_object oFrm1
78452>>>register_object oFrm2
78452>>>register_object oFrm3
78452>>>register_object oFrm4
78452>>>register_object oFrm5
78452>>>register_object oFrm6
78452>>>object oStrucPgmOther_Pn is a aps.ModalPanel label "Change parameters for selected tables"
78455>>>  set locate_mode to CENTER_ON_SCREEN
78456>>>  on_key ksave_record send close_panel_ok
78457>>>  on_key kcancel send close_panel
78458>>>  property integer piResult public 0
78460>>>  set p_auto_column to 1
78461>>>  send tab_column_define 1  20 15 JMODE_LEFT // Default column setting
78462>>>  send tab_column_define 2 100 15 JMODE_LEFT // Default column setting
78463>>>  object oCb1 is a aps.CheckBox label "Compression"
78466>>>    procedure OnChange
78469>>>      set object_shadow_state of (oFrm1(self)) to (not(checked_state(self)))
78470>>>    end_procedure
78471>>>  end_object
78472>>>  object oFrm1 is a Api_Attr.ComboFormAux abstract AFT_ASCII20 snap 2
78476>>>    send prepare_attr_values DF_FILE_COMPRESSION
78477>>>    set object_shadow_state to true
78478>>>  end_object
78479>>>  object oCb2 is a aps.CheckBox label "Integrity check"
78482>>>    procedure OnChange
78485>>>      set object_shadow_state of (oFrm2(self)) to (not(checked_state(self)))
78486>>>    end_procedure
78487>>>  end_object
78488>>>  object oFrm2 is a Api_Attr.ComboFormAux abstract AFT_ASCII20 snap 2
78492>>>    send prepare_attr_values DF_FILE_INTEGRITY_CHECK
78493>>>    set object_shadow_state to true
78494>>>  end_object
78495>>>  object oCb3 is a aps.CheckBox label "Multiuser"
78498>>>    procedure OnChange
78501>>>      set object_shadow_state of (oFrm3(self)) to (not(checked_state(self)))
78502>>>    end_procedure
78503>>>  end_object
78504>>>  object oFrm3 is a Api_Attr.ComboFormAux abstract AFT_ASCII20 snap 2
78508>>>    send prepare_attr_values DF_FILE_MULTIUSER
78509>>>    set object_shadow_state to true
78510>>>  end_object
78511>>>  object oCb4 is a aps.CheckBox label "Reuse deleted"
78514>>>    procedure OnChange
78517>>>      set object_shadow_state of (oFrm4(self)) to (not(checked_state(self)))
78518>>>    end_procedure
78519>>>  end_object
78520>>>  object oFrm4 is a Api_Attr.ComboFormAux abstract AFT_ASCII20 snap 2
78524>>>    send prepare_attr_values DF_FILE_REUSE_DELETED
78525>>>    set object_shadow_state to true
78526>>>  end_object
78527>>>
78527>>>  object oCb5 is a aps.CheckBox label "Transaction type"
78530>>>    procedure OnChange
78533>>>      set object_shadow_state of (oFrm5(self)) to (not(checked_state(self)))
78534>>>    end_procedure
78535>>>  end_object
78536>>>  object oFrm5 is a Api_Attr.ComboFormAux abstract AFT_ASCII20 snap 2
78540>>>    send prepare_attr_values DF_FILE_TRANSACTION
78541>>>    set object_shadow_state to true
78542>>>  end_object
78543>>>  object oCb6 is a aps.CheckBox label "Lock type"
78546>>>    procedure OnChange
78549>>>      set object_shadow_state of (oFrm6(self)) to (not(checked_state(self)))
78550>>>    end_procedure
78551>>>  end_object
78552>>>  object oFrm6 is a Api_Attr.ComboFormAux abstract AFT_ASCII20 snap 2
78556>>>    send prepare_attr_values DF_FILE_LOCK_TYPE
78557>>>    set object_shadow_state to true
78558>>>  end_object
78559>>>
78559>>>  object oCb9 is a aps.CheckBox label "Trim record length"
78562>>>  end_object
78563>>>  object oBtn1 is a aps.Multi_Button
78565>>>    on_item t.btn.ok send close_panel_ok
78566>>>  end_object
78567>>>  object oBtn2 is a aps.Multi_Button
78569>>>    on_item t.btn.cancel send close_panel
78570>>>  end_object
78571>>>  send aps_locate_multi_buttons
78572>>>  procedure close_panel_ok
78575>>>    set piResult to 1
78576>>>    send close_panel
78577>>>  end_procedure
78578>>>  procedure popup
78581>>>    set piResult to 0
78582>>>    forward send popup
78584>>>    if (piResult(self)) begin
78586>>>    end
78586>>>>
78586>>>  end_procedure
78587>>>  function iPopup returns integer
78590>>>    send popup
78591>>>    function_return (piResult(self))
78592>>>  end_function
78593>>>  function iSetAttribute.i integer attr# returns integer
78596>>>    if attr# eq DF_FILE_COMPRESSION     function_return (checked_state(oCb1(self)))
78599>>>    if attr# eq DF_FILE_INTEGRITY_CHECK function_return (checked_state(oCb2(self)))
78602>>>    if attr# eq DF_FILE_MULTIUSER       function_return (checked_state(oCb3(self)))
78605>>>    if attr# eq DF_FILE_REUSE_DELETED   function_return (checked_state(oCb4(self)))
78608>>>    if attr# eq DF_FILE_TRANSACTION     function_return (checked_state(oCb5(self)))
78611>>>    if attr# eq DF_FILE_LOCK_TYPE       function_return (checked_state(oCb6(self)))
78614>>>    if attr# eq DF_FILE_RECORD_LENGTH   function_return (checked_state(oCb9(self)))
78617>>>    //function_return 0
78617>>>  end_function
78618>>>  function sAttributeValue.i integer attr# returns string
78621>>>    if attr# eq DF_FILE_COMPRESSION     function_return (Combo_Current_Aux_Value(oFrm1(self)))
78624>>>    if attr# eq DF_FILE_INTEGRITY_CHECK function_return (Combo_Current_Aux_Value(oFrm2(self)))
78627>>>    if attr# eq DF_FILE_MULTIUSER       function_return (Combo_Current_Aux_Value(oFrm3(self)))
78630>>>    if attr# eq DF_FILE_REUSE_DELETED   function_return (Combo_Current_Aux_Value(oFrm4(self)))
78633>>>    if attr# eq DF_FILE_TRANSACTION     function_return (Combo_Current_Aux_Value(oFrm5(self)))
78636>>>    if attr# eq DF_FILE_LOCK_TYPE       function_return (Combo_Current_Aux_Value(oFrm6(self)))
78639>>>    function_return ""
78640>>>  end_function
78641>>>end_object // oStrucPgmOther_Pn
78642>>>
78642>>>
78642>>>object oListOfTablesAndFieldsThatItIsOkToDropAndDelete is a cArray NO_IMAGE
78644>>>
78644>>>            function iFindItem.s string lsItem returns integer
78647>>>              integer liMax liItm
78647>>>              move (lowercase(lsItem)) to lsItem
78648>>>              get item_count to liMax
78649>>>              decrement liMax
78650>>>              for liItm from 0 to liMax
78656>>>>
78656>>>                if (lsItem=value(self,liItm)) function_return liItm
78659>>>              loop
78660>>>>
78660>>>              function_return -1
78661>>>            end_function
78662>>>
78662>>>                                  procedure add_thing string lsValue
78665>>>                                    integer liItm
78665>>>                                    get item_count to liItm
78666>>>                                    set value item liItm to (lowercase(lsValue))
78667>>>                                  end_procedure
78668>>>            procedure DeleteFieldBuildList integer liFile integer liField string lsName string lsRoot
78671>>>              send add_thing (lsRoot+"."+lsName)
78672>>>            end_procedure
78673>>>            procedure DeleteTableBuildList integer liFile string lsName
78676>>>              send add_thing lsName
78677>>>            end_procedure
78678>>>
78678>>>  define DFM_DROP_FILE_ID for "File ID: DFMatrix allowed drops"
78678>>>  //> Write contents to file
78678>>>  procedure SEQ_Write integer liChannel
78681>>>    integer liMax liItm
78681>>>    writeln channel liChannel DFM_DROP_FILE_ID
78684>>>    get item_count to liMax
78685>>>    decrement liMax
78686>>>    for liItm from 0 to liMax
78692>>>>
78692>>>      writeln channel liChannel (value(self,liItm))
78695>>>    loop
78696>>>>
78696>>>  end_procedure
78697>>>
78697>>>  //> Read contents from file
78697>>>  procedure SEQ_Read integer liChannel
78700>>>    integer lbSeqEof
78700>>>    string lsLine
78700>>>    send delete_data
78701>>>    readln channel liChannel lsLine
78703>>>    if (lsLine=DFM_DROP_FILE_ID) begin
78705>>>      repeat
78705>>>>
78705>>>        readln channel liChannel lsLine
78707>>>        move (seqeof) to lbSeqEof
78708>>>        ifnot lbSeqEof begin
78710>>>          send add_thing lsLine
78711>>>        end
78711>>>>
78711>>>      until lbSeqEof
78713>>>    end
78713>>>>
78713>>>    else error 751 "Incompatible drop file"
78715>>>  end_procedure
78716>>>
78716>>>            property integer pbOkToRestructure public 0
78718>>>            procedure DeleteFieldCheck integer liFile integer liField string lsName string lsRoot
78721>>>              integer liItem
78721>>>              move (lsRoot+"."+lsName) to lsName
78722>>>              get iFindItem.s lsName to liItem
78723>>>              if (liItem=-1) begin // If not found, then we can't proceed
78725>>>                set pbOkToRestructure to false
78726>>>                send DoWriteTimeEntry to (oStructure_LogFile(self)) ("Error: Not OK to delete field "+lsName)
78727>>>              end
78727>>>>
78727>>>            end_procedure
78728>>>            procedure DeleteTableCheck integer liFile string lsName
78731>>>              integer liItem
78731>>>              get iFindItem.s lsName to liItem
78732>>>              if (liItem=-1) begin // If not found, then we can't proceed
78734>>>                set pbOkToRestructure to false
78735>>>                send DoWriteTimeEntry to (oStructure_LogFile(self)) ("Error: Not OK to drop table "+lsName)
78736>>>              end
78736>>>>
78736>>>            end_procedure
78737>>>
78737>>>  //> Can we approve of the array of programs
78737>>>  function bOkToRestructure integer lhPgmArr returns integer
78740>>>    set pbOkToRestructure to true
78741>>>    send AppendOutput to (oStructure_LogFile(self))
78742>>>    send callback_deleted_fields to lhPgmArr MSG_DeleteFieldCheck self
78743>>>    send callback_deleted_tables to lhPgmArr MSG_DeleteTableCheck self
78744>>>    ifnot (pbOkToRestructure(self)) send DoWriteTimeEntry to (oStructure_LogFile(self)) "(Restructure will be cancelled)"
78747>>>    send CloseOutput to (oStructure_LogFile(self))
78748>>>    function_return (pbOkToRestructure(self))
78749>>>  end_function
78750>>>
78750>>>  //
78750>>>  procedure ConfirmAndWriteFile
78753>>>  end_procedure
78754>>>
78754>>>  //> Write contents to log file
78754>>>  procedure SEQ_WriteReportToLog integer liChannel
78757>>>  end_procedure
78758>>>end_object // oListOfTablesAndFieldsThatItIsOkToDropAndDelete
78759>>>
78759>>>class cStrucPgmList is a aps.Grid
78760>>>  procedure construct_object integer img#
78762>>>    forward send construct_object img#
78764>>>    set highlight_row_state to dfTrue
78765>>>    on_key kenter send display_program
78766>>>    on_key key_ctrl+key_e send execute_one
78767>>>    on_key kdelete_record send request_delete
78768>>>    set line_width to 1 0
78769>>>    set header_visible_state to false
78770>>>    set gridline_mode to GRID_VISIBLE_NONE
78771>>>    set form_margin item 0 to 70  //
78772>>>    set highlight_row_state to true
78773>>>    set highlight_row_color to (rgb(0,255,255))
78774>>>    set current_item_color to (rgb(0,255,255))
78775>>>    set select_mode to no_select
78776>>>    on_key knext_item send switch
78777>>>    on_key kprevious_item send switch_back
78778>>>    property integer priv.pbDeletesOrDrops public DFFALSE
78779>>>  end_procedure
78780>>>  procedure request_delete
78782>>>    integer liRow lhServer lhPgm itm#
78782>>>    if (item_count(self)) begin
78784>>>      get piStructPgm_Server to lhServer // Gets from encapsulating object
78785>>>      get current_item to itm#
78786>>>      get aux_value item itm# to lhPgm
78787>>>      get iFindRowFromPgm.i of lhServer lhPgm to liRow
78788>>>      if liRow ne -1 begin
78790>>>        send Reset.i to lhServer liRow
78791>>>        get current_item to liRow
78792>>>        send fill_list
78793>>>        if liRow gt (item_count(self)-1) decrement liRow
78796>>>        set current_item to liRow
78797>>>      end
78797>>>>
78797>>>    end
78797>>>>
78797>>>  end_procedure
78798>>>  procedure display_program
78800>>>    if (item_count(self)) send StructPgm_Display (aux_value(self,current_item(self)))
78803>>>  end_procedure
78804>>>  procedure mouse_click integer liItem integer liGrb
78806>>>    if ((liItem-1)>>  end_procedure
78810>>>  procedure fill_list
78812>>>    integer max# liRow lhServer lhPgm itm# type#
78812>>>    send delete_data
78813>>>    get piStructPgm_Server to lhServer
78814>>>    get row_count of lhServer to max#
78815>>>    for liRow from 0 to (max#-1)
78821>>>>
78821>>>      get piObject.i of lhServer liRow to lhPgm
78822>>>      get piProgramType of lhPgm to type#
78823>>>      send add_item msg_none (sTitle(lhPgm))
78824>>>      set aux_value item (item_count(self)-1) to lhPgm
78825>>>    loop
78826>>>>
78826>>>    set dynamic_update_state to DFTRUE
78827>>>    get item_count to max#
78828>>>    for itm# from 0 to (max#-1)
78834>>>>
78834>>>      set entry_state item itm# to DFFALSE
78835>>>    loop
78836>>>>
78836>>>  end_procedure
78837>>>
78837>>>  procedure DeleteFieldWarning integer liFile integer liField string lsName string lsRoot
78839>>>    string lsValue
78839>>>    set priv.pbDeletesOrDrops to DFTRUE
78840>>>    move "Field [ will be deleted (in table [)." to lsValue
78841>>>    move (replace("[",lsValue,lsName)) to lsValue
78842>>>    move (replace("[",lsValue,lsRoot)) to lsValue
78843>>>    send DoDisplayTextConfirm_AddLine lsValue
78844>>>  end_procedure
78845>>>
78845>>>  procedure DeleteTableWarning integer liFile string lsName
78847>>>    string lsValue
78847>>>    set priv.pbDeletesOrDrops to DFTRUE
78848>>>    move "Table # will be dropped." to lsValue
78849>>>    move (replace("#",lsValue,lsName)) to lsValue
78850>>>    send DoDisplayTextConfirm_AddLine lsValue
78851>>>  end_procedure
78852>>>
78852>>>  procedure generate_list_of_tables_and_fields_that_it_is_ok_to_drop_and_delete
78854>>>    integer oPgmArr# lbForceReindex lbContinue lhListOfTablesAndFieldsThatItIsOkToDropAndDelete
78854>>>    if (DFMatrix_RealDataPrimary()) begin
78856>>>      move (oListOfTablesAndFieldsThatItIsOkToDropAndDelete(Self)) to lhListOfTablesAndFieldsThatItIsOkToDropAndDelete
78857>>>
78857>>>      get piStructPgm_Server to oPgmArr#  // Gets from encapsulating object
78858>>>
78858>>>      set priv.pbDeletesOrDrops to DFFALSE
78859>>>      send delete_data to lhListOfTablesAndFieldsThatItIsOkToDropAndDelete
78860>>>      send callback_deleted_fields to oPgmArr# MSG_DeleteFieldBuildList lhListOfTablesAndFieldsThatItIsOkToDropAndDelete
78861>>>      send callback_deleted_tables to oPgmArr# MSG_DeleteTableBuildList lhListOfTablesAndFieldsThatItIsOkToDropAndDelete
78862>>>
78862>>>      move DFTRUE to lbContinue
78863>>>//      if (priv.pbDeletesOrDrops(self)) get DoDisplayTextConfirm "Restructure warning!" "" to lbContinue
78863>>>    end
78863>>>>
78863>>>  end_procedure
78864>>>
78864>>>  procedure execute_one
78866>>>    integer lhPgm file# ci# lbForceReindex lbContinue lbDeleteDroppedTables
78866>>>    if (item_count(self)) begin
78868>>>      if (DFMatrix_RealDataPrimary()) begin
78870>>>        move (aux_value(self,current_item(self))) to lhPgm
78871>>>
78871>>>        set priv.pbDeletesOrDrops to DFFALSE // NEWTHING
78872>>>        send DoDisplayTextConfirm_Reset // NEWTHING
78873>>>        send callback_deleted_fields to lhPgm MSG_DeleteFieldWarning self // NEWTHING
78874>>>
78874>>>        move DFTRUE to lbContinue // NEWTHING
78875>>>        if (priv.pbDeletesOrDrops(self)) get DoDisplayTextConfirm "Restructure warning!" "" to lbContinue // NEWTHING
78878>>>
78878>>>        if lbContinue begin // NEWTHING
78880>>>          get piFile of lhPgm to file#
78881>>>          get bForceReindex to lbForceReindex
78882>>>          set piSortOnEndStructure of lhPgm to lbForceReindex
78883>>>
78883>>>          get bDeleteDroppedTables to lbDeleteDroppedTables
78884>>>          set pbDeleteDroppedTables of lhPgm to lbDeleteDroppedTables
78885>>>
78885>>>          send Execute to lhPgm
78886>>>          get current_item to ci#
78887>>>          send fill_list
78888>>>          set current_item to ci#
78889>>>          // Now reread the definition(s) that was just restructured:
78889>>>          send Read_File_RootName_Again to (fdx.object_id(0)) (API_AttrValue_FILELIST(DF_FILE_ROOT_NAME,file#))
78890>>>        end
78890>>>>
78890>>>      end
78890>>>>
78890>>>      else send obs "To execute a program, real data must be loaded (Read current)"
78892>>>    end
78892>>>>
78892>>>  end_procedure
78893>>>  procedure execute_all
78895>>>    integer oPgmArr# lbForceReindex lbContinue lbBatchMode lbReindexAll lbDeleteDroppedTables
78895>>>    integer liGrb
78895>>>    if (DFMatrix_RealDataPrimary()) begin
78897>>>      //move (oFdxRestructureProgramArray_StrucPgm(self)) to oPgmArr#
78897>>>      get piStructPgm_Server to oPgmArr#
78898>>>
78898>>>      get DfmBatchMode to lbBatchMode
78899>>>
78899>>>      if lbBatchMode begin
78901>>>        get bOkToRestructure of (oListOfTablesAndFieldsThatItIsOkToDropAndDelete(self)) oPgmArr# to lbContinue
78902>>>      end
78902>>>>
78902>>>      else begin
78903>>>        set priv.pbDeletesOrDrops to DFFALSE // NEWTHING
78904>>>        send DoDisplayTextConfirm_Reset // NEWTHING
78905>>>        send callback_deleted_fields to oPgmArr# MSG_DeleteFieldWarning self // NEWTHING
78906>>>        send callback_deleted_tables to oPgmArr# MSG_DeleteTableWarning self // NEWTHING
78907>>>        move DFTRUE to lbContinue // NEWTHING
78908>>>        if (priv.pbDeletesOrDrops(self)) get DoDisplayTextConfirm "Restructure warning!" "" to lbContinue // NEWTHING
78911>>>      end
78911>>>>
78911>>>
78911>>>      if lbContinue begin // NEWTHING
78913>>>        get bForceReindex to lbForceReindex
78914>>>        set piSortOnEndStructure of oPgmArr# to lbForceReindex
78915>>>        get bDeleteDroppedTables to lbDeleteDroppedTables
78916>>>        set pbDeleteDroppedTables of oPgmArr# to lbDeleteDroppedTables
78917>>>        send Execute to oPgmArr#
78918>>>
78918>>>        if lbBatchMode begin // If we're in batch mode we will check if we should reindex all on completion:
78920>>>          get bReindexAll to lbReindexAll
78921>>>          if lbReindexAll begin
78923>>>            runprogram wait "cls"
78924>>>            runprogram wait "dfsort -a"
78925>>>            send refresh_screen
78926>>>            get SEQ_AppendFiles (DfmBatchMode_LogfileName()) "dfsort.log" to liGrb
78927>>>          end
78927>>>>
78927>>>        end
78927>>>>
78927>>>
78927>>>        send fill_list
78928>>>        send DFMatrix_PrimaryReread
78929>>>        if (piErrorDuringStructure(oPgmArr#)) begin
78931>>>          if lbBatchMode begin
78933>>>            error 750 "Errors occurred during restructure"
78934>>>>
78934>>>          end
78934>>>>
78934>>>          else send obs "Errors occurred during restructure" "Check 'dfmatrix.log' for details"
78936>>>        end
78936>>>>
78936>>>      end
78936>>>>
78936>>>    end
78936>>>>
78936>>>    else send obs "To execute a program, real data must be loaded (Read current)"
78938>>>  end_procedure
78939>>>  procedure request_open
78941>>>    integer lhServer
78941>>>    get piStructPgm_Server to lhServer
78942>>>    send open_browse to lhServer
78943>>>    send fill_list
78944>>>  end_procedure
78945>>>  procedure request_save
78947>>>    integer lhServer
78947>>>    get piStructPgm_Server to lhServer
78948>>>    send save_browse to lhServer
78949>>>  end_procedure
78950>>>
78950>>>  function iProgramObject.is integer file# string rn# returns integer
78952>>>    integer oOther# pgm_obj# oPgmArr# pgm_liRow
78952>>>    move (oFdxRestructureProgramArray_StrucPgm(self)) to oPgmArr#
78953>>>    // Is there such a program already?
78953>>>    move (iFindPgmRow.is(oPgmArr#,file#,rn#)) to pgm_liRow
78954>>>    if pgm_liRow ne -1 begin
78956>>>      //send reset.i to oPgmArr# pgm_liRow // If so, reset it
78956>>>      get piObject.i of oPgmArr# pgm_liRow to pgm_obj#
78957>>>    end
78957>>>>
78957>>>    else begin
78958>>>      get iAddPgmRow.is of oPgmArr# file# rn# to pgm_liRow // If not, create it
78959>>>      get iCreateFdxRestructureProgram to pgm_obj#
78960>>>      send reset to pgm_obj#
78961>>>      set piFile     of pgm_obj# to file#
78962>>>      set psRootName of pgm_obj# to rn#
78963>>>      set piProgramType of pgm_obj# to PGM_TYPE_EDIT
78964>>>      set piObject.i of oPgmArr# pgm_liRow to pgm_obj#
78965>>>    end
78965>>>>
78965>>>    function_return pgm_obj#
78966>>>  end_function
78967>>>
78967>>>  procedure DoOthers_Help integer file# string dn# string ln# string rn#
78969>>>    integer oOther# pgm_obj# oFDX# reclength#
78969>>>    integer DoCompression# DoIntegrity_check# DoMultiuser# DoReuse_deleted# DoRecord_length#
78969>>>    integer DoTransaction# DoLocktype#
78969>>>    move (oStrucPgmOther_Pn(self)) to oOther#
78970>>>    get iSetAttribute.i of oOther# DF_FILE_COMPRESSION     to DoCompression#
78971>>>    get iSetAttribute.i of oOther# DF_FILE_INTEGRITY_CHECK to DoIntegrity_check#
78972>>>    get iSetAttribute.i of oOther# DF_FILE_MULTIUSER       to DoMultiuser#
78973>>>    get iSetAttribute.i of oOther# DF_FILE_REUSE_DELETED   to DoReuse_deleted#
78974>>>    get iSetAttribute.i of oOther# DF_FILE_RECORD_LENGTH   to DoRecord_length#
78975>>>    get iSetAttribute.i of oOther# DF_FILE_TRANSACTION     to DoTransaction#
78976>>>    get iSetAttribute.i of oOther# DF_FILE_LOCK_TYPE       to DoLocktype#
78977>>>    if (DoCompression#+DoIntegrity_check#+DoMultiuser#+DoReuse_deleted#+DoRecord_length#+DoTransaction#+DoLocktype#) begin
78979>>>      get iProgramObject.is file# rn# to pgm_obj#
78980>>>      if DoCompression#     send add_file_instruction to pgm_obj# DF_FILE_COMPRESSION     (sAttributeValue.i(oOther#,DF_FILE_COMPRESSION))
78983>>>      if DoIntegrity_check# send add_file_instruction to pgm_obj# DF_FILE_INTEGRITY_CHECK (sAttributeValue.i(oOther#,DF_FILE_INTEGRITY_CHECK))
78986>>>      if DoMultiuser#       send add_file_instruction to pgm_obj# DF_FILE_MULTIUSER       (sAttributeValue.i(oOther#,DF_FILE_MULTIUSER))
78989>>>      if DoReuse_deleted#   send add_file_instruction to pgm_obj# DF_FILE_REUSE_DELETED   (sAttributeValue.i(oOther#,DF_FILE_REUSE_DELETED))
78992>>>      if DoTransaction#     send add_file_instruction to pgm_obj# DF_FILE_TRANSACTION     (sAttributeValue.i(oOther#,DF_FILE_TRANSACTION))
78995>>>      if DoLocktype#        send add_file_instruction to pgm_obj# DF_FILE_LOCK_TYPE       (sAttributeValue.i(oOther#,DF_FILE_LOCK_TYPE))
78998>>>      if DoRecord_length#   begin
79000>>>        move (fdx.object_id(0)) to oFDX#
79001>>>        get AttrValue_FILE of oFDX# DF_FILE_RECORD_LENGTH_USED file# to reclength#
79002>>>        send add_file_instruction to pgm_obj# DF_FILE_RECORD_LENGTH reclength#
79003>>>      end
79003>>>>
79003>>>    end
79003>>>>
79003>>>  end_procedure
79004>>>
79004>>>  procedure DoOthers
79006>>>    integer oOther# pgm_obj# oPgmArr# select_count#
79006>>>    move (oStrucPgmOther_Pn(self)) to oOther#
79007>>>    if (iPopup(oOther#)) begin
79009>>>      get File_Select_Count of (DFMatrix_SelectorObject()) to select_count#
79010>>>      ifnot select_count# send obs "No files selected!"
79013>>>      else begin
79014>>>        send Callback_Selected_Files to (DFMatrix_SelectorObject()) msg_DoOthers_Help self
79015>>>        send fill_list
79016>>>      end
79016>>>>
79016>>>    end
79016>>>>
79016>>>  end_procedure
79017>>>
79017>>>  procedure DoMaxRecs_Help integer file# string root# integer new_max#
79019>>>    integer pgm_obj#
79019>>>    get iProgramObject.is file# root# to pgm_obj#
79020>>>    send add_file_instruction to pgm_obj# DF_FILE_MAX_RECORDS new_max#
79021>>>    set piProgramType of pgm_obj# to PGM_TYPE_EDIT
79022>>>  end_procedure
79023>>>
79023>>>  procedure DoMaxRecs
79025>>>    integer oNewMaxRecords#
79025>>>    move (oNewMaxRecords(self)) to oNewMaxRecords#
79026>>>    if (iPopup(oNewMaxRecords#)) send post_maxrecords
79029>>>  end_procedure
79030>>>
79030>>>  procedure post_maxrecords
79032>>>    integer oNewMaxRecords# lhSelf
79032>>>    move self to lhSelf
79033>>>    move (oNewMaxRecords(self)) to oNewMaxRecords#
79034>>>    send Callback_ModifiedEntries to (oLst(oNewMaxRecords#)) msg_DoMaxRecs_Help lhSelf
79035>>>    send fill_list
79036>>>  end_procedure
79037>>>end_class // cStrucPgmList
79038>>>
79038>>>activate_view Activate_RestructPrograms for oStructPgmArray_Vw
79043>>>object oStructPgmArray_Vw is a aps.View label "Restructure programs"
79046>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
79047>>>  set pMinimumSize to 200 0
79048>>>  property integer piStructPgm_Server public (oFdxRestructureProgramArray_StrucPgm(self))
79050>>>  on_key kcancel send close_panel
79051>>>  object oCont is a aps.Container3d
79053>>>    set p_auto_column to 0
79054>>>    register_object oBtn1
79054>>>    register_object oBtn11
79054>>>    object oLst is a cStrucPgmList
79056>>>      set size to 200 0
79057>>>      on_key kswitch send activate to (oBtn1(self))
79058>>>    end_object
79059>>>    object oBtn1 is a aps.Multi_Button
79061>>>      on_key kswitch send activate to (oBtn11(self))
79062>>>      on_item "List program" send display_program to (oLst(self))
79063>>>    end_object
79064>>>    object oBtn2 is a aps.Multi_Button
79066>>>      on_key kswitch send activate to (oBtn11(self))
79067>>>      on_item "Execute"  send request_execute_one
79068>>>    end_object
79069>>>    object oBtn3 is a aps.Multi_Button
79071>>>      on_key kswitch send activate to (oBtn11(self))
79072>>>      on_item "Execute all"  send request_execute_all
79073>>>    end_object
79074>>>    object oBtn4 is a aps.Multi_Button
79076>>>      on_key kswitch send activate to (oBtn11(self))
79077>>>      on_item "Remove"       send Request_delete to (oLst(self))
79078>>>    end_object
79079>>>    object oBtn5 is a aps.Multi_Button
79081>>>      on_key kswitch send activate to (oBtn11(self))
79082>>>      on_item "Remove all"   send reset_list
79083>>>    end_object
79084>>>    send aps_locate_multi_buttons sl_vertical
79085>>>    object oCb1 is a aps.CheckBox label "Trace on" snap SL_DOWN
79089>>>      on_key kswitch send activate to (oBtn11(self))
79090>>>    end_object
79091>>>    object oCb2 is a aps.CheckBox label "Delete dropped" snap SL_DOWN
79095>>>      on_key kswitch send activate to (oBtn11(self))
79096>>>    end_object
79097>>>    object oCb3 is a aps.CheckBox label "Force reindex" snap SL_DOWN
79101>>>      on_key kswitch send activate to (oBtn11(self))
79102>>>    end_object
79103>>>    object oBtn6 is a aps.Button snap SL_DOWN
79106>>>      on_key kswitch send activate to (oBtn11(self))
79107>>>      on_item "Trace view" send Activate_RestructureTracer
79108>>>    end_object
79109>>>    procedure DoLogFileProperties
79112>>>      send Popup_LogFileProperties (oStructure_LogFile(self))
79113>>>    end_procedure
79114>>>    object oBtn7 is a aps.Button snap SL_DOWN
79117>>>      on_key kswitch send activate to (oBtn11(self))
79118>>>      on_item "Log file" send DoLogFileProperties
79119>>>    end_object
79120>>>    function bDeleteDroppedTables returns integer
79123>>>      integer rval#
79123>>>      get checked_state of (oCB2(self)) to rval#
79124>>>      function_return rval#
79125>>>    end_function
79126>>>    procedure request_execute_one
79129>>>      integer trace# lhPgm lhLst
79129>>>      string fn#
79129>>>      move (oLst(self)) to lhLst
79130>>>      if (item_count(lhLst)) begin
79132>>>        // At this point we need to check that then program has not already been
79132>>>        // executed.
79132>>>        move (aux_value(lhLst,current_item(lhLst))) to lhPgm
79133>>>        if (piExecuted(lhPgm)) send obs "This program has already been executed"
79136>>>        else begin
79137>>>          get checked_state of (oCB1(self)) to trace#
79138>>>          if trace# send RS_TraceOn
79141>>>          send execute_one to lhLst
79142>>>          if trace# begin
79144>>>            send RS_TraceOff
79145>>>            get sRootInclPath of oRestructurer# to fn#
79146>>>            move (fn#+".rst") to fn#
79147>>>            send obs "The restructure trace was saved in file" fn# "" "Press OK to view the file..."
79148>>>            send Activate_RestructureTracer_With_File fn#
79149>>>          end
79149>>>>
79149>>>        end
79149>>>>
79149>>>      end
79149>>>>
79149>>>    end_procedure
79150>>>    procedure request_execute_all
79153>>>      integer trace#
79153>>>      get checked_state of (oCB1(self)) to trace#
79154>>>      if trace# send obs "Tracing a restructure can only be done" "when executing one program a time." "" "Trace setting will be ignored."
79157>>>      //if trace# send RS_TraceOn
79157>>>      send execute_all to (oLst(self))
79158>>>      //if trace# send RS_TraceOff
79158>>>    end_procedure
79159>>>  end_object // oCont
79160>>>
79160>>>  function bForceReindex returns integer
79163>>>    integer lbRval
79163>>>    get checked_state of (oCB3(oCont(self))) to lbRval
79164>>>    function_return lbRval
79165>>>  end_function
79166>>>
79166>>>  property integer pbReindexAll public 0 // Secret, for use with batch mode only (and only in character mode)
79168>>>  function bReindexAll returns integer
79171>>>    function_return (pbReindexAll(self))
79172>>>  end_function
79173>>>
79173>>>  procedure compare_tables
79176>>>    send popup to (oFdxCompareDefinitions_Pn(self))
79177>>>    send fill_list to (oLst(oCont(self)))
79178>>>    send activate to (oLst(oCont(self)))
79179>>>  end_procedure
79180>>>  procedure reset_list
79183>>>    send Reset to (piStructPgm_Server(self))
79184>>>    send fill_list to (oLst(oCont(self)))
79185>>>  end_procedure
79186>>>  object oBtn11 is a aps.Multi_Button
79188>>>    on_key kswitch send activate to (oLst(oCont(self)))
79189>>>    on_item "Compare" send compare_tables
79190>>>  end_object
79191>>>  object oBtn12 is a aps.Multi_Button
79193>>>    on_key kswitch send activate to (oLst(oCont(self)))
79194>>>    on_item "Max records" send DoMaxRecs to (oLst(oCont(self)))
79195>>>  end_object
79196>>>  object oBtn13 is a aps.Multi_Button
79198>>>    on_key kswitch send activate to (oLst(oCont(self)))
79199>>>    on_item "Other"   send DoOthers to (oLst(oCont(self)))
79200>>>  end_object
79201>>>  send aps_register_multi_button (oBtn13(self))
79202>>>//object oBtn14 is a aps.Multi_Button
79202>>>//  on_key kswitch send activate to (oLst(oCont(self)))
79202>>>//  on_item "Open"    send request_open to (oLst(oCont(self)))
79202>>>//end_object
79202>>>//object oBtn15 is a aps.Multi_Button
79202>>>//  on_key kswitch send activate to (oLst(oCont(self)))
79202>>>//  on_item "Save"    send request_save to (oLst(oCont(self)))
79202>>>//end_object
79202>>>  object oBtn16 is a aps.Multi_Button
79204>>>    on_key kswitch send activate to (oLst(oCont(self)))
79205>>>    on_item "Close"   send close_panel
79206>>>  end_object
79207>>>  send aps_locate_multi_buttons
79208>>>
79208>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
79211>>>    send aps_resize (oCont(self)) delta_rw# 0
79212>>>    send aps_resize (oLst(oCont(self))) delta_rw# 0
79213>>>    send aps_register_multi_button (oBtn11(self))
79214>>>    send aps_register_multi_button (oBtn12(self))
79215>>>    send aps_register_multi_button (oBtn13(self))
79216>>>    send aps_register_multi_button (oBtn13(self)) // Twice is alright
79217>>>//  send aps_register_multi_button (oBtn14(self))
79217>>>//  send aps_register_multi_button (oBtn15(self))
79217>>>    send aps_register_multi_button (oBtn16(self))
79218>>>    send aps_locate_multi_buttons
79219>>>    send aps_auto_size_container
79220>>>  end_procedure
79221>>>end_object // oStructPgmArray_Vw
79222>    Use DataSamp.vw  // Field statistics
Including file: datasamp.vw    (C:\Apps\VDFQuery\AppSrc\datasamp.vw)
79222>>>Use DataSamp.utl // Class for sampling data file values (Field statistics)
Including file: datasamp.utl    (C:\Apps\VDFQuery\AppSrc\datasamp.utl)
79222>>>>>// Use DataSamp.utl // Class for sampling data file values (Field statistics)
79222>>>>>
79222>>>>>// This purpose of this package is to relieve me of having to remember which
79222>>>>>// package exactly holds a particular command or class.
79222>>>>>
79222>>>>>Use Array.nui    // Item_Property command
79222>>>>>Use Macros.utl   // Various macros (FOR_EX...)
79222>>>>>Use Set.utl      // cArray, cSet and cStack classes
79222>>>>>Use Dates.utl    // Date manipulation for VDF
79222>>>>>Use SetOfFld.utl // cSetOfFields class
79222>>>>>Use API_Attr.utl // Functions for querying API attributes
79222>>>>>Use Strings.nui  // String manipulation for VDF
79222>>>>>
79222>>>>>class cDataSamplerSet is a cSet
79223>>>>>  procedure construct_object integer img#
79225>>>>>    forward send construct_object img#
79227>>>>>    property integer piDataType public DF_ASCII
79228>>>>>  end_procedure
79229>>>>>  item_property_list
79229>>>>>    item_property integer piCount.i
79229>>>>>    item_property string  psValue.i
79229>>>>>  end_item_property_list cDataSamplerSet
#REM 79261 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 79265 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 79269 DEFINE FUNCTION PICOUNT.I INTEGER LIROW RETURNS INTEGER
#REM 79273 DEFINE PROCEDURE SET PICOUNT.I INTEGER LIROW INTEGER VALUE
79278>>>>>  function iFind.s string value# returns integer
79280>>>>>    integer row# max#
79280>>>>>    get row_count to max#
79281>>>>>    decrement max#
79282>>>>>    for row# from 0 to max#
79288>>>>>>
79288>>>>>      if (psValue.i(self,row#)) eq value# function_return row#
79291>>>>>    loop
79292>>>>>>
79292>>>>>    function_return -1
79293>>>>>  end_function
79294>>>>>  procedure seq_write integer ch#
79296>>>>>    integer row# max#
79296>>>>>    get row_count to max#
79297>>>>>    for row# from 0 to (max#-1)
79303>>>>>>
79303>>>>>      writeln channel ch# (IntToStrR(piCount.i(self,row#),8)) " " (psValue.i(self,row#))
79308>>>>>    loop
79309>>>>>>
79309>>>>>  end_procedure
79310>>>>>  procedure element_add string value#
79312>>>>>    integer row#
79312>>>>>    get iFind.s value# to row#
79313>>>>>    if row# eq -1 begin
79315>>>>>      get row_count to row#
79316>>>>>      set piCount.i row# to 1
79317>>>>>      set psValue.i row# to value#
79318>>>>>    end
79318>>>>>>
79318>>>>>    else set piCount.i row# to (piCount.i(self,row#)+1)
79320>>>>>  end_procedure
79321>>>>>end_class // cDataSamplerSet
79322>>>>>
79322>>>>>class cDataSampler is a cArray
79323>>>>>  procedure construct_object integer img#
79325>>>>>    forward send construct_object img#
79327>>>>>    object oBatchCompanion is a cBatchCompanion
79329>>>>>    end_object
79330>>>>>  end_procedure
79331>>>>>  item_property_list
79331>>>>>    item_property integer piType.i      // Type of variable
79331>>>>>    item_property string  psName.i      // Name of variable
79331>>>>>    item_property integer piCount.i     // Number of samples
79331>>>>>    item_property integer piNullCount.i // Number of null values
79331>>>>>    item_property number  pnMin.i       // Lowest value (DF_BCD and DF_DATE)
79331>>>>>    item_property number  pnMax.i       // Highest value (DF_BCD and DF_DATE)
79331>>>>>    item_property integer piDiscrete.i  // Collect descrete values?
79331>>>>>    item_property integer piSet.i       // Set of values (piDiscrete.i only)
79331>>>>>    item_property integer piFile.i      // Data origin
79331>>>>>    item_property integer piField.i     // Data origin
79331>>>>>  end_item_property_list cDataSampler
#REM 79387 DEFINE FUNCTION PIFIELD.I INTEGER LIROW RETURNS INTEGER
#REM 79391 DEFINE PROCEDURE SET PIFIELD.I INTEGER LIROW INTEGER VALUE
#REM 79395 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 79399 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
#REM 79403 DEFINE FUNCTION PISET.I INTEGER LIROW RETURNS INTEGER
#REM 79407 DEFINE PROCEDURE SET PISET.I INTEGER LIROW INTEGER VALUE
#REM 79411 DEFINE FUNCTION PIDISCRETE.I INTEGER LIROW RETURNS INTEGER
#REM 79415 DEFINE PROCEDURE SET PIDISCRETE.I INTEGER LIROW INTEGER VALUE
#REM 79419 DEFINE FUNCTION PNMAX.I INTEGER LIROW RETURNS NUMBER
#REM 79423 DEFINE PROCEDURE SET PNMAX.I INTEGER LIROW NUMBER VALUE
#REM 79427 DEFINE FUNCTION PNMIN.I INTEGER LIROW RETURNS NUMBER
#REM 79431 DEFINE PROCEDURE SET PNMIN.I INTEGER LIROW NUMBER VALUE
#REM 79435 DEFINE FUNCTION PINULLCOUNT.I INTEGER LIROW RETURNS INTEGER
#REM 79439 DEFINE PROCEDURE SET PINULLCOUNT.I INTEGER LIROW INTEGER VALUE
#REM 79443 DEFINE FUNCTION PICOUNT.I INTEGER LIROW RETURNS INTEGER
#REM 79447 DEFINE PROCEDURE SET PICOUNT.I INTEGER LIROW INTEGER VALUE
#REM 79451 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 79455 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
#REM 79459 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 79463 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
79468>>>>>  procedure seq_write_discrete_set integer row# integer ch#
79470>>>>>    integer obj#
79470>>>>>    get piSet.i row# to obj#
79471>>>>>    if obj# send seq_write to obj# ch#
79474>>>>>  end_procedure
79475>>>>>  function sMinMax.is integer row# string value# returns string
79477>>>>>    integer type#
79477>>>>>    get piType.i row# to type#
79478>>>>>    if type# eq DF_DATE move (date(integer(value#))) to value#
79481>>>>>    if type# eq DF_BCD  move (trim(value#)) to value#
79484>>>>>    function_return value#
79485>>>>>  end_function
79486>>>>>  function sMin.i integer row# returns string
79488>>>>>    function_return (sMinMax.is(self,row#,pnMin.i(self,row#)))
79489>>>>>  end_function
79490>>>>>  function sMax.i integer row# returns string
79492>>>>>    function_return (sMinMax.is(self,row#,pnMax.i(self,row#)))
79493>>>>>  end_function
79494>>>>>  procedure add_variable string name# integer type# integer Discrete# integer file# integer field#
79496>>>>>    integer row#
79496>>>>>    get row_count to row#
79497>>>>>    set psName.i     row# to name#
79498>>>>>    set piType.i     row# to type#
79499>>>>>    set piDiscrete.i row# to Discrete#
79500>>>>>    set piFile.i     row# to file#
79501>>>>>    set piField.i    row# to field#
79502>>>>>  end_procedure
79503>>>>>  procedure reset
79505>>>>>    integer row# max# set#
79505>>>>>    get row_count to max#
79506>>>>>    for row# from 0 to (max#-1)
79512>>>>>>
79512>>>>>      get piSet.i row# to set#
79513>>>>>      if set# send request_destroy_object to set#
79516>>>>>    loop
79517>>>>>>
79517>>>>>    send delete_data
79518>>>>>  end_procedure
79519>>>>>  function iSetID.i integer row# returns integer
79521>>>>>    integer set#
79521>>>>>    get piSet.i row# to set#
79522>>>>>    ifnot set# begin
79524>>>>>      object oSet is a cDataSamplerSet no_image
79526>>>>>        move self to set#
79527>>>>>      end_object
79528>>>>>      set piSet.i row# to set#
79529>>>>>      set piDataType of set# to (piType.i(self,row#))
79530>>>>>    end
79530>>>>>>
79530>>>>>    function_return set#
79531>>>>>  end_function
79532>>>>>  procedure init
79534>>>>>    integer row# max# type#
79534>>>>>    get row_count to max#
79535>>>>>    for row# from 0 to (max#-1)
79541>>>>>>
79541>>>>>      set piCount.i row# to 0
79542>>>>>      set piNullCount.i row# to 0
79543>>>>>      get piType.i row# to type#
79544>>>>>      if type# eq DF_BCD  begin
79546>>>>>        set pnMin.i row# to 99999999999999.99999999
79547>>>>>        set pnMax.i row# to -9999999999999.99999999
79548>>>>>      end
79548>>>>>>
79548>>>>>      if type# eq DF_DATE begin
79550>>>>>        set pnMin.i row# to LargestPossibleDate
79551>>>>>        set pnMax.i row# to 0
79552>>>>>      end
79552>>>>>>
79552>>>>>      if type# eq DF_ASCII begin
79554>>>>>      end
79554>>>>>>
79554>>>>>      if (piDiscrete.i(self,row#)) set piSet.i row# to (iSetID.i(self,row#))
79557>>>>>    loop
79558>>>>>>
79558>>>>>  end_procedure
79559>>>>>  procedure add_value integer row# string value#
79561>>>>>    integer type# ival#
79561>>>>>    number nval#
79561>>>>>    set piCount.i row# to (piCount.i(self,row#)+1)
79562>>>>>    get piType.i row# to type#
79563>>>>>    if (piDiscrete.i(self,row#)) send element_add to (piSet.i(self,row#)) value#
79566>>>>>    if type# eq DF_BCD begin
79568>>>>>      move value# to nval#
79569>>>>>      if nval# eq 0 set piNullCount.i row# to (piNullCount.i(self,row#)+1)
79572>>>>>      if nval# lt (pnMin.i(self,row#)) set pnMin.i row# to nval#
79575>>>>>      if nval# gt (pnMax.i(self,row#)) set pnMax.i row# to nval#
79578>>>>>    end
79578>>>>>>
79578>>>>>    if type# eq DF_DATE begin
79580>>>>>      move value# to ival#
79581>>>>>      if ival# eq 0 set piNullCount.i row# to (piNullCount.i(self,row#)+1)
79584>>>>>      if ival# lt (pnMin.i(self,row#)) set pnMin.i row# to ival#
79587>>>>>      if ival# gt (pnMax.i(self,row#)) set pnMax.i row# to ival#
79590>>>>>    end
79590>>>>>>
79590>>>>>    if type# eq DF_ASCII begin
79592>>>>>      if value# eq "" set piNullCount.i row# to (piNullCount.i(self,row#)+1)
79595>>>>>    end
79595>>>>>>
79595>>>>>  end_procedure
79596>>>>>end_class // cDataSampler
79597>>>>>
79597>>>>>class cdbDataSampler is a cDataSampler
79598>>>>>  procedure add_field.ii integer file# integer field#
79600>>>>>    integer type# len# discrete#
79600>>>>>    move (API_AttrValue_FIELD(DF_FIELD_TYPE,file#,field#)) to type#
79601>>>>>    if (type#<>DF_OVERLAP and type#<>DF_BINARY and type#<>DF_TEXT) begin
79603>>>>>      move 0 to discrete#
79604>>>>>      move (API_AttrValue_FIELD(DF_FIELD_LENGTH,file#,field#)) to len#
79605>>>>>      if (type#=DF_ASCII and len#<=10) move 1 to discrete#
79608>>>>>      send add_variable (API_AttrValue_FIELD(DF_FIELD_NAME,file#,field#)) type# discrete# file# field#
79609>>>>>    end
79609>>>>>>
79609>>>>>  end_procedure
79610>>>>>  procedure auto_add_all_fields integer file#
79612>>>>>    integer max# field#
79612>>>>>    move (API_AttrValue_FILE(DF_FILE_NUMBER_FIELDS,file#)) to max#
79613>>>>>    for field# from 1 to max#
79619>>>>>>
79619>>>>>      send add_field.ii file# field#
79620>>>>>    loop
79621>>>>>>
79621>>>>>    send init
79622>>>>>  end_procedure
79623>>>>>  function sValue.i integer row# returns string
79625>>>>>    function_return ""
79626>>>>>  end_function
79627>>>>>  procedure auto_add_values
79629>>>>>    integer row# max# file#
79629>>>>>    string value#
79629>>>>>    get row_count to max#
79630>>>>>    for row# from 0 to (max#-1)
79636>>>>>>
79636>>>>>      get piFile.i row# to file#
79637>>>>>      if file# begin
79639>>>>>        get_field_value file# (piField.i(self,row#)) to value#
79642>>>>>      end
79642>>>>>>
79642>>>>>      else get sValue.i row# to value#
79644>>>>>      send add_value row# value#
79645>>>>>    loop
79646>>>>>>
79646>>>>>  end_procedure
79647>>>>>  function iDoRelate.i integer file# returns integer
79649>>>>>    integer row# max#
79649>>>>>    get row_count to max#
79650>>>>>    for row# from 0 to (max#-1)
79656>>>>>>
79656>>>>>      if (piFile.i(self,row#) and piFile.i(self,row#)<>file#) function_return 1
79659>>>>>    loop
79660>>>>>>
79660>>>>>    // function_return 0
79660>>>>>  end_function
79661>>>>>  procedure run.iii integer file# integer idx# integer display_wait#
79663>>>>>    integer relate# found# oBatchCompanion# rec#
79663>>>>>    if display_wait# begin
79665>>>>>      move (oBatchCompanion(self)) to oBatchCompanion#
79666>>>>>      send batch_on to oBatchCompanion# "Sampling data"
79667>>>>>      send batch_update to oBatchCompanion# ("Scanning "+API_AttrValue_FILE(DF_FILE_RECORDS_USED,file#))
79668>>>>>      send batch_update2 to oBatchCompanion# "0 records scanned"
79669>>>>>    end
79669>>>>>>
79669>>>>>    send init
79670>>>>>    get iDoRelate.i file# to relate#
79671>>>>>    clear file#
79672>>>>>    move 0 to rec#
79673>>>>>    repeat
79673>>>>>>
79673>>>>>      vfind file# idx# gt // Find next
79675>>>>>      move (found) to found#
79676>>>>>      if found# begin
79678>>>>>        if relate# relate file#
79681>>>>>        send auto_add_values
79682>>>>>        increment rec#
79683>>>>>        if ((rec#/25)*25) eq rec# begin
79685>>>>>          if display_wait# begin
79687>>>>>            send batch_update2 to oBatchCompanion# (string(rec#)+" records scanned")
79688>>>>>            if (batch_interrupt(oBatchCompanion#)) move 0 to found#
79691>>>>>          end
79691>>>>>>
79691>>>>>        end
79691>>>>>>
79691>>>>>      end
79691>>>>>>
79691>>>>>    until (not(found#))
79693>>>>>    if display_wait# send batch_off to oBatchCompanion#
79696>>>>>  end_procedure
79697>>>>>end_class // cdbDataSampler
79698>>>>>
79698>>>>>//**********************************************************************
79698>>>>>// use DataSamp.utl // Data sampling objects
79698>>>>>//
79698>>>>>// By Sture Andersen
79698>>>>>//
79698>>>>>// Create: Tue  07-04-1997
79698>>>>>// Update:
79698>>>>>//
79698>>>>>//**********************************************************************
79698>>>>>//
79698>>>>>//    Strategies for calculating X offsets:
79698>>>>>//
79698>>>>>//    Symbol        Description             Remarks
79698>>>>>//    
79698>>>>>//    DT_AUTO_X     Data items are stored   Memory consuming
79698>>>>>//                  sequentially as added.
79698>>>>>//
79698>>>>>//    DT_IDX_X      Data items are stored
79698>>>>>//                  and added according to
79698>>>>>//                  specified X. A minimum
79698>>>>>//                  and a maximum index is
79698>>>>>//                  given beforehand.
79698>>>>>//
79698>>>>>//    DT_ALPHA_X    The X value is given    Slow
79698>>>>>//                  by a string.
79698>>>>>//
79698>>>>>//    DT_XY         X and Y is given        Double memory consumption
79698>>>>>//                  explicitly with every
79698>>>>>//                  data item.
79698>>>>>//
79698>>>>>//  enumeration_list // data types
79698>>>>>//    //> Y values are specified with an indexed X
79698>>>>>//    define DT_AUTOX_Y
79698>>>>>//
79698>>>>>//    //> Un-ordered values with no X values
79698>>>>>//    define DT_NOX_Y
79698>>>>>//    define DT_X_Y      // X and Y are given explicitly with every data item
79698>>>>>//    define DT_SAMPLE   // Data are quantisized
79698>>>>>//    define DT_IDX_X
79698>>>>>//  end_enumeration_list
79698>>>>>//
79698>>>>>// class cBasicDataSeries is an array
79698>>>>>//   procedure construct_object integer img#
79698>>>>>//     forward send construct_object img#
79698>>>>>//     property integer private.pDataType public DT_IDX_X
79698>>>>>//     set delegation_mode to delegate_to_parent
79698>>>>>//   end_procedure
79698>>>>>//   function pDataType returns integer
79698>>>>>//     function_return (private.pDataType(self))
79698>>>>>//   end_function
79698>>>>>//   procedure set pDataType integer value#
79698>>>>>//     ifnot (item_count(self)) set private.pDataType to value#
79698>>>>>//     else error 666 "Can't change type while containing data"
79698>>>>>//   end_procedure
79698>>>>>//   procedure reset_data
79698>>>>>//     send delete_data
79698>>>>>//   end_procedure
79698>>>>>//   procedure add_tick integer index#
79698>>>>>//     set value item index# to (value(self,index#)+1)
79698>>>>>//   end_procedure
79698>>>>>//   procedure add_auto_x_data number y#
79698>>>>>//     set value item (item_count(self)) to y#
79698>>>>>//   end_procedure
79698>>>>>//   procedure add_indexed_data integer index# number value#
79698>>>>>//     set value item index# to (value(self,index#)+value#)
79698>>>>>//   end_procedure
79698>>>>>//   procedure add_xy_data number x# number y#
79698>>>>>//     integer base#
79698>>>>>//     get item_count to base#
79698>>>>>//     set value item base# to x#
79698>>>>>//     set value item (base#+1) to y#
79698>>>>>//   end_procedure
79698>>>>>// end_class
79698>>>>>//
79698>>>>>//
79698>>>>>// // The cDataSampler class is used for collecting data
79698>>>>>//
79698>>>>>// Use Array.nui    // Item_Property command
79698>>>>>//
79698>>>>>// class cDataSampler is an array
79698>>>>>//   procedure construct_object integer img#
79698>>>>>//     forward send construct_object img#
79698>>>>>//     set delegation_mode to delegate_to_parent
79698>>>>>//     property number  pMinValue          public 0 // Lower limit of first interval
79698>>>>>//     property integer pNumberOfIntervals public 0
79698>>>>>//     // The pQuantifier_State property determines whether an alpha numeric
79698>>>>>//     // value determines each interval (which in that case is not intervals).
79698>>>>>//     // Used for counting incedents on ...
79698>>>>>//     property integer pQuantifier_State  public 0
79698>>>>>//   end_procedure
79698>>>>>//   procedure reset
79698>>>>>//     send delete_data
79698>>>>>//   end_procedure
79698>>>>>// end_class
79698>>>Use FdxSelct.utl // Functions iFdxSelectOneFile and iFdxSelectOneField
79698>>>Use SetOfFld.utl // cSetOfFields class
79698>>>Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles)
79698>>>Use DBMS.utl     // Basic DBMS functions
79698>>>Use Strings.utl  // String manipulation for VDF and 3.1
79698>>>Use Files.utl    // Utilities for handling file related stuff
79698>>>
79698>>>class cDisplayDataSamplerSet is a aps.Grid
79699>>>  procedure construct_object integer img#
79701>>>    forward send construct_object img#
79703>>>    property integer piDataType public 0
79704>>>    property integer piSet      public 0
79705>>>    send GridPrepare_AddColumn "Value"     AFT_ASCII40
79706>>>    send GridPrepare_AddColumn "Frequency" AFT_ASCII7
79707>>>    send GridPrepare_Apply self
79708>>>    set select_mode to no_select
79709>>>    on_key kenter send next
79710>>>    on_key kenter send next
79711>>>    on_key key_ctrl+key_r send sort_data
79712>>>  end_procedure
79713>>>  function iSpecialSortValueOnColumn.i integer itm# returns integer
79715>>>    function_return 1
79716>>>  end_function
79717>>>  function sSortValue.ii integer column# integer itm# returns string
79719>>>    integer type# int#
79719>>>    string rval#
79719>>>//    showln "sSortValue.ii " (string(column#)) " " (string(itm#))
79719>>>    get value item itm# to rval#
79720>>>    if column# eq 0 begin
79722>>>      get piDataType to type#
79723>>>      if type# eq DF_BCD move (NumToStrR(rval#,8,23)) to rval#
79726>>>      if type# eq DF_DATE begin
79728>>>        move (date(rval#)) to int#
79729>>>        move (IntToStrR(int#,10)) to rval#
79730>>>      end
79730>>>>
79730>>>      function_return rval#
79731>>>    end
79731>>>>
79731>>>    if column# eq 1 function_return (IntToStrR(rval#,10))
79734>>>  end_function
79735>>>  procedure sort_data.i integer column#
79737>>>    send Grid_SortByColumn self column#
79738>>>  end_procedure
79739>>>  procedure sort_data
79741>>>    integer cc#
79741>>>    get Grid_CurrentColumn self to cc#
79742>>>    send sort_data.i cc#
79743>>>  end_procedure
79744>>>  procedure header_mouse_click integer itm#
79746>>>    send sort_data.i itm#
79747>>>    forward send header_mouse_click itm#
79749>>>  end_procedure
79750>>>  procedure fill_list.i integer set#
79752>>>    integer row# max#
79752>>>    send delete_data
79753>>>    set piSet to set#
79754>>>    set piDataType to (piDataType(set#))
79755>>>    get row_count of set# to max#
79756>>>    for row# from 0 to (max#-1)
79762>>>>
79762>>>      send add_item msg_none (psValue.i(set#,row#))
79763>>>      send add_item msg_none (piCount.i(set#,row#))
79764>>>    loop
79765>>>>
79765>>>    send Grid_SetEntryState self dfFalse
79766>>>    send sort_data.i 0 // Sort by value
79767>>>    send beginning_of_data
79768>>>  end_procedure
79769>>>  procedure save_file
79771>>>    integer ch#
79771>>>    string fn#
79771>>>    move (SEQ_SelectOutFile("Save to text file","All (*.*)|*.*")) to fn#
79772>>>    if fn# ne "" begin
79774>>>      move (SEQ_DirectOutput(fn#)) to ch#
79775>>>      if ch# begin
79777>>>        send seq_write to (piSet(self)) ch#
79778>>>        send SEQ_CloseOutput ch#
79779>>>      end
79779>>>>
79779>>>    end
79779>>>>
79779>>>  end_procedure
79780>>>end_class // cDisplayDataSamplerSet
79781>>>
79781>>>Use APS          // Auto Positioning and Sizing classes for VDF
79781>>>Use Buttons.utl  // Button texts
79781>>>object oDisplayDataSamplerSet is a aps.ModalPanel
79783>>>  set locate_mode to CENTER_ON_SCREEN
79784>>>  on_key kcancel send close_panel
79785>>>  object oLst is a cDisplayDataSamplerSet
79787>>>    set size to 200 0
79788>>>  end_object
79789>>>  object oBtn1 is a aps.Multi_Button
79791>>>    on_item t.btn.save  send save_file to (oLst(self))
79792>>>  end_object
79793>>>  object oBtn2 is a aps.Multi_Button
79795>>>    on_item t.btn.close send close_panel
79796>>>  end_object
79797>>>  send aps_locate_multi_buttons
79798>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
79799>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
79802>>>    send aps_resize (oLst(self)) delta_rw# 0
79803>>>    send aps_register_multi_button (oBtn1(self))
79804>>>    send aps_register_multi_button (oBtn2(self))
79805>>>    send aps_locate_multi_buttons
79806>>>    send aps_auto_size_container
79807>>>  end_procedure
79808>>>  procedure popup.is integer set# string name#
79811>>>    set label to ("Discrete values for field: "+name#)
79812>>>    send fill_list.i to (oLst(self)) set#
79813>>>    send popup
79814>>>  end_procedure
79815>>>end_object // oDisplayDataSamplerSet
79816>>>
79816>>>
79816>>>class cDataSamplerResultList is a aps.Grid
79817>>>  procedure construct_object integer img#
79819>>>    forward send construct_object img#
79821>>>    property integer piDataSampler public 0
79822>>>    send GridPrepare_AddColumn "Name"     AFT_ASCII20
79823>>>    send GridPrepare_AddColumn "Type"     AFT_ASCII6
79824>>>    send GridPrepare_AddColumn "Count"    AFT_ASCII10
79825>>>    send GridPrepare_AddColumn "0 count"  AFT_ASCII10
79826>>>    send GridPrepare_AddColumn "Minimum"  AFT_ASCII14
79827>>>    send GridPrepare_AddColumn "Maximum"  AFT_ASCII14
79828>>>    send GridPrepare_AddColumn "Discrete" AFT_ASCII3
79829>>>    send GridPrepare_Apply self
79830>>>    on_key kEnter send display_discrete_values
79831>>>    set select_mode to MULTI_SELECT
79832>>>    on_key kenter send next
79833>>>  end_procedure
79834>>>  procedure select_toggling integer itm# integer i#
79836>>>    integer ci# hasrun#
79836>>>    get piHasRun to hasrun#
79837>>>    if hasrun# send display_discrete_values
79840>>>    else begin
79841>>>      get current_item to ci#
79842>>>      move ((ci#/7)*7+6) to ci# // Redirect to last column
79843>>>      forward send select_toggling ci# i#
79845>>>    end
79845>>>>
79845>>>  end_procedure
79846>>>  procedure display_discrete_values
79848>>>    integer base#
79848>>>    if (item_count(self)) begin
79850>>>      get Grid_BaseItem self to base#
79851>>>      if (select_state(self,base#+6)) begin
79853>>>        send popup.is to (oDisplayDataSamplerSet(self)) (piSet.i(piDataSampler(self),aux_value(self,base#))) (value(self,base#))
79854>>>      end
79854>>>>
79854>>>    end
79854>>>>
79854>>>  end_procedure
79855>>>  procedure Update_DataSampler
79857>>>    integer DataSampler# max# row# itm# st# columns# sampler_row# base#
79857>>>    get piDataSampler to DataSampler#
79858>>>    get Grid_RowCount self to max#
79859>>>    get Grid_Columns self to columns#
79860>>>    for row# from 0 to (max#-1)
79866>>>>
79866>>>      move (row#*columns#) to base#
79867>>>      get aux_value base# to sampler_row#
79868>>>      move (base#+columns#-1) to itm#
79869>>>      get select_state item itm# to st#
79870>>>      set piDiscrete.i of DataSampler# sampler_row# to st#
79871>>>    loop
79872>>>>
79872>>>  end_procedure
79873>>>  procedure fill_list
79875>>>    integer DataSampler# max# row# itm#
79875>>>    get piDataSampler to DataSampler#
79876>>>    send delete_data
79877>>>    set dynamic_update_state to false
79878>>>    if DataSampler# begin
79880>>>      get row_count of DataSampler# to max#
79881>>>      for row# from 0 to (max#-1)
79887>>>>
79887>>>        get item_count to itm#
79888>>>        send add_item msg_none (psName.i(DataSampler#,row#))
79889>>>        set aux_value item itm# to row#
79890>>>        send add_item msg_none (StringFieldType(piType.i(DataSampler#,row#)))
79891>>>        send add_item msg_none (piCount.i(DataSampler#,row#))
79892>>>        send add_item msg_none (piNullCount.i(DataSampler#,row#))
79893>>>        send add_item msg_none (sMin.i(DataSampler#,row#))
79894>>>        send add_item msg_none (sMax.i(DataSampler#,row#))
79895>>>        get item_count to itm#
79896>>>        send add_item msg_none ""
79897>>>        set checkbox_item_state item itm# to true
79898>>>        set select_state item itm# to (piDiscrete.i(DataSampler#,row#))
79899>>>      loop
79900>>>>
79900>>>    end
79900>>>>
79900>>>    send Grid_SetEntryState self dfFalse
79901>>>    set dynamic_update_state to true
79902>>>  end_procedure
79903>>>end_class // cDataSamplerResultList
79904>>>
79904>>>object oDataSampler_Vw is a aps.View label "Field statistics"
79907>>>  property integer piCurrentTable public 0
79909>>>  property integer piHasRun       public 0
79911>>>  on_key KCANCEL send close_panel
79912>>>
79912>>>  object oSetOfFields is a cSetOfFields
79914>>>  end_object
79915>>>  object oDataSampler is a cdbDataSampler
79917>>>    procedure rebuild_from_set
79920>>>      integer set# max# row#
79920>>>      move (oSetOfFields(self)) to set#
79921>>>      send reset
79922>>>      get row_count of set# to max#
79923>>>      for row# from 0 to (max#-1)
79929>>>>
79929>>>        send add_field.ii (piFile.i(set#,row#)) (piField.i(set#,row#))
79930>>>      loop
79931>>>>
79931>>>    end_procedure
79932>>>  end_object
79933>>>  object oLst is a cDataSamplerResultList
79935>>>    set piDataSampler to (oDataSampler(self))
79936>>>    set size to 200 0
79937>>>    procedure display_discrete_values
79940>>>      if (piHasRun(self)) forward send display_discrete_values
79944>>>    end_procedure
79945>>>  end_object
79946>>>  procedure select_table
79949>>>    integer file#
79949>>>    get piCurrentTable to file#
79950>>>    get iFdxSelectOneFile 0 file# to file#
79951>>>    if file# begin
79953>>>      set piCurrentTable to file#
79954>>>      send delete_data to (oSetOfFields(self))
79955>>>      send rebuild_from_set to (oDataSampler(self))
79956>>>      send fill_list to (oLst(self))
79957>>>      set piHasRun to false
79958>>>      send select_fields
79959>>>    end
79959>>>>
79959>>>  end_procedure
79960>>>  procedure select_related_fields
79963>>>  end_procedure
79964>>>  procedure select_fields
79967>>>    integer set#
79967>>>    if (piCurrentTable(self)) begin
79969>>>      move (oSetOfFields(self)) to set#
79970>>>      if (iFdxSelectFields(0,piCurrentTable(self),set#)) begin
79972>>>        send OpenStat_RegisterFiles
79973>>>        if (DBMS_OpenFile(piCurrentTable(self),DF_SHARE,0)) begin
79975>>>          send rebuild_from_set to (oDataSampler(self))
79976>>>          send fill_list to (oLst(self))
79977>>>        end
79977>>>>
79977>>>        set piHasRun to false
79978>>>        send OpenStat_RestoreFiles
79979>>>      end
79979>>>>
79979>>>    end
79979>>>>
79979>>>    else send obs "Before you can select which fields to sample" "you have to select a table!"
79981>>>  end_procedure
79982>>>  procedure DoRun
79985>>>    send OpenStat_RegisterFiles
79986>>>    if (piCurrentTable(self)) begin
79988>>>      if (DBMS_OpenFile(piCurrentTable(self),DF_SHARE,0)) begin // recnum Do display wait'er
79990>>>        send Update_DataSampler to (oLst(self))
79991>>>        send run.iii to (oDataSampler(self)) (piCurrentTable(self)) 0 1
79992>>>        send fill_list to (oLst(self))
79993>>>        send OpenStat_RestoreFiles
79994>>>        set piHasRun to true
79995>>>      end
79995>>>>
79995>>>    end
79995>>>>
79995>>>  end_procedure
79996>>>  object oBtn1 is a aps.Multi_Button
79998>>>    on_item "Select table" send select_table
79999>>>  end_object
80000>>>  object oBtn2 is a aps.Multi_Button
80002>>>    on_item "Select fields" send select_fields
80003>>>  end_object
80004>>>//object oBtn3 is a aps.Multi_Button
80004>>>//  on_item "Related fields" send select_related_fields
80004>>>//end_object
80004>>>  object oBtn4 is a aps.Multi_Button
80006>>>    on_item "Run" send DoRun
80007>>>  end_object
80008>>>  object oBtn5 is a aps.Multi_Button
80010>>>    on_item "Display discrete" send display_discrete_values to (oLst(self))
80011>>>  end_object
80012>>>  object oBtn6 is a aps.Multi_Button
80014>>>    on_item t.btn.close send close_panel
80015>>>  end_object
80016>>>  send aps_locate_multi_buttons
80017>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
80018>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
80021>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
80022>>>    send aps_register_multi_button (oBtn1(self))
80023>>>    send aps_register_multi_button (oBtn2(self))
80024>>>  //send aps_register_multi_button (oBtn3(self))
80024>>>    send aps_register_multi_button (oBtn4(self))
80025>>>    send aps_register_multi_button (oBtn5(self))
80026>>>    send aps_register_multi_button (oBtn6(self))
80027>>>    send aps_locate_multi_buttons
80028>>>    send aps_auto_size_container
80029>>>  end_procedure
80030>>>end_object
80031>>>procedure Activate_DataSampler_Vw
80034>>>  if (DFMatrix_RealData_Check()) send popup to (oDataSampler_Vw(self))
80037>>>end_procedure
80038>    Use Conv2000.vw  // Activate_Conv2000_Vw (for use in the DFMatrix environment)
Including file: conv2000.vw    (C:\Apps\VDFQuery\AppSrc\conv2000.vw)
80038>>>// Use Conv2000.vw  // Activate_Conv2000_Vw (for use in the DFMatrix environment)
80038>>>
80038>>>Use Conv2000.pkg // UI bricks for reindexing a set of tables
Including file: conv2000.pkg    (C:\Apps\VDFQuery\AppSrc\conv2000.pkg)
80038>>>>>// Use Conv2000.pkg // UI bricks for reindexing a set of tables
80038>>>>>
80038>>>>>Use Conv2000.utl // Make date fields y2000
Including file: conv2000.utl    (C:\Apps\VDFQuery\AppSrc\conv2000.utl)
80038>>>>>>>// Use Conv2000.utl // Make date fields y2000
80038>>>>>>>
80038>>>>>>>//Use DfAllent
80038>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
80038>>>>>>>Use DBMS.utl     // Basic DBMS functions
80038>>>>>>>Use Spec0008.utl // Small arrays with integer Codes (Dictionaries)
Including file: spec0008.utl    (C:\Apps\VDFQuery\AppSrc\spec0008.utl)
80038>>>>>>>>>// Use Spec0008.utl // Small arrays with integer Codes (Dictionaries)
80038>>>>>>>>>
80038>>>>>>>>>// Template:
80038>>>>>>>>>//
80038>>>>>>>>>//   object oSomething is a cIntegerCodeToText
80038>>>>>>>>>//     IntegerCodeList
80038>>>>>>>>>//       Define_IntegerCode XXX_SOMETHINGGOOD "Good"
80038>>>>>>>>>//       Define_IntegerCode XXX_SOMETHINGFAIR "Fair"
80038>>>>>>>>>//       Define_IntegerCode XXX_SOMETHINGNICE "Nice"
80038>>>>>>>>>//     End_IntegerCodeList
80038>>>>>>>>>//   end_object
80038>>>>>>>>>
80038>>>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
80038>>>>>>>>>
80038>>>>>>>>>class cIntegerCodeToText is a cArray
80039>>>>>>>>>  item_property_list
80039>>>>>>>>>    item_property integer piCode.i
80039>>>>>>>>>    item_property string  psText.i
80039>>>>>>>>>  end_item_property_list cIntegerCodeToText
#REM 80071 DEFINE FUNCTION PSTEXT.I INTEGER LIROW RETURNS STRING
#REM 80075 DEFINE PROCEDURE SET PSTEXT.I INTEGER LIROW STRING VALUE
#REM 80079 DEFINE FUNCTION PICODE.I INTEGER LIROW RETURNS INTEGER
#REM 80083 DEFINE PROCEDURE SET PICODE.I INTEGER LIROW INTEGER VALUE
80088>>>>>>>>>  procedure add_code.is integer iCode string sText
80090>>>>>>>>>    integer iRow
80090>>>>>>>>>    get row_count to iRow
80091>>>>>>>>>    set piCode.i iRow to iCode
80092>>>>>>>>>    set psText.i iRow to sText
80093>>>>>>>>>  end_procedure
80094>>>>>>>>>  function sText.i integer iCode returns string
80096>>>>>>>>>    integer iMax iRow
80096>>>>>>>>>    get row_count to iMax
80097>>>>>>>>>    for iRow from 0 to (iMax-1)
80103>>>>>>>>>>
80103>>>>>>>>>      if iCode eq (piCode.i(self,iRow)) function_return (psText.i(self,iRow))
80106>>>>>>>>>    loop
80107>>>>>>>>>>
80107>>>>>>>>>    function_return ""
80108>>>>>>>>>  end_function
80109>>>>>>>>>  function iFindCode.s string lsValue returns integer
80111>>>>>>>>>    integer liMax liRow
80111>>>>>>>>>    get row_count to liMax
80112>>>>>>>>>    for liRow from 0 to (liMax-1)
80118>>>>>>>>>>
80118>>>>>>>>>      if (uppercase(lsValue)=uppercase(psText.i(self,liRow))) function_return (piCode.i(self,liRow))
80121>>>>>>>>>    loop
80122>>>>>>>>>>
80122>>>>>>>>>    function_return -1
80123>>>>>>>>>  end_function
80124>>>>>>>>>  register_procedure Add_Table_Value String sData String sDescr Integer iRec
80124>>>>>>>>>  procedure Fill_DescriptionValidationTable integer iObj
80126>>>>>>>>>    integer iMax iRow
80126>>>>>>>>>    get row_count to iMax
80127>>>>>>>>>    decrement iMax
80128>>>>>>>>>    for iRow from 0 to iMax
80134>>>>>>>>>>
80134>>>>>>>>>      send Add_Table_Value to iObj (piCode.i(self,iRow)) (psText.i(self,iRow))
80135>>>>>>>>>    loop
80136>>>>>>>>>>
80136>>>>>>>>>  end_procedure
80137>>>>>>>>>  function iFindIndexFromCode.i integer liCode returns integer
80139>>>>>>>>>    integer liMax liRow
80139>>>>>>>>>    get row_count to liMax
80140>>>>>>>>>    decrement liMax
80141>>>>>>>>>    for liRow from 0 to liMax
80147>>>>>>>>>>
80147>>>>>>>>>      if liCode eq (piCode.i(self,liRow)) function_return liRow
80150>>>>>>>>>    loop
80151>>>>>>>>>>
80151>>>>>>>>>    function_return -1
80152>>>>>>>>>  end_function
80153>>>>>>>>>end_class
80154>>>>>>>>>
80154>>>>>>>Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles)
80154>>>>>>>Use SetTable.utl // cSetOfTables class
Including file: settable.utl    (C:\Apps\VDFQuery\AppSrc\settable.utl)
80154>>>>>>>>>// Use SetTable.utl // cSetOfTables class
80154>>>>>>>>>
80154>>>>>>>>>Use Base.utl     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
80154>>>>>>>>>Use API_Attr.utl // Functions for querying API attributes
80154>>>>>>>>>Use SetFiles.utl // SetOfFiles class (for disk files)
80154>>>>>>>>>Use Files.utl    // Utilities for handling file related stuff
80154>>>>>>>>>Use WorkSpc.utl  // cWorkSpace class (that features function sMakePath)
80154>>>>>>>>>desktop_section
80159>>>>>>>>>  object oSortSetFiles1 is a cSetOfFiles no_image
80161>>>>>>>>>  end_object
80162>>>>>>>>>  object oSortSetFiles2 is a cSetOfFiles no_image
80164>>>>>>>>>  end_object
80165>>>>>>>>>end_desktop_section
80170>>>>>>>>>
80170>>>>>>>>>class cSetOfTables is a cArray
80171>>>>>>>>>  item_property_list
80171>>>>>>>>>    item_property string  psRootName.i
80171>>>>>>>>>    item_property integer piStatus.i // These are for optional use by sub-classes
80171>>>>>>>>>    item_property integer piAux1.i   //
80171>>>>>>>>>    item_property integer piAux2.i   //
80171>>>>>>>>>  end_item_property_list cSetOfTables
#REM 80209 DEFINE FUNCTION PIAUX2.I INTEGER LIROW RETURNS INTEGER
#REM 80213 DEFINE PROCEDURE SET PIAUX2.I INTEGER LIROW INTEGER VALUE
#REM 80217 DEFINE FUNCTION PIAUX1.I INTEGER LIROW RETURNS INTEGER
#REM 80221 DEFINE PROCEDURE SET PIAUX1.I INTEGER LIROW INTEGER VALUE
#REM 80225 DEFINE FUNCTION PISTATUS.I INTEGER LIROW RETURNS INTEGER
#REM 80229 DEFINE PROCEDURE SET PISTATUS.I INTEGER LIROW INTEGER VALUE
#REM 80233 DEFINE FUNCTION PSROOTNAME.I INTEGER LIROW RETURNS STRING
#REM 80237 DEFINE PROCEDURE SET PSROOTNAME.I INTEGER LIROW STRING VALUE
80242>>>>>>>>>  procedure reset
80244>>>>>>>>>    send delete_data
80245>>>>>>>>>  end_procedure
80246>>>>>>>>>  function sFindRoot.s string sRoot returns integer
80248>>>>>>>>>    integer iMax iRow
80248>>>>>>>>>    move (uppercase(sRoot)) to sRoot
80249>>>>>>>>>    get row_count to iMax
80250>>>>>>>>>    decrement iMax
80251>>>>>>>>>    for iRow from 0 to iMax
80257>>>>>>>>>>
80257>>>>>>>>>      if sRoot eq (uppercase(psRootName.i(self,iRow))) function_return iRow
80260>>>>>>>>>    loop
80261>>>>>>>>>>
80261>>>>>>>>>    function_return -1
80262>>>>>>>>>  end_function
80263>>>>>>>>>
80263>>>>>>>>>  procedure DoSetAllStatus integer iVal
80265>>>>>>>>>    integer iMax iRow
80265>>>>>>>>>    get row_count to iMax
80266>>>>>>>>>    decrement iMax
80267>>>>>>>>>    for iRow from 0 to iMax
80273>>>>>>>>>>
80273>>>>>>>>>      set piStatus.i iRow to iVal
80274>>>>>>>>>    loop
80275>>>>>>>>>>
80275>>>>>>>>>  end_procedure
80276>>>>>>>>>  procedure DoSetAllAux1 integer iVal
80278>>>>>>>>>    integer iMax iRow
80278>>>>>>>>>    get row_count to iMax
80279>>>>>>>>>    decrement iMax
80280>>>>>>>>>    for iRow from 0 to iMax
80286>>>>>>>>>>
80286>>>>>>>>>      set piAux1.i iRow to iVal
80287>>>>>>>>>    loop
80288>>>>>>>>>>
80288>>>>>>>>>  end_procedure
80289>>>>>>>>>  procedure DoSetAllAux2 integer iVal
80291>>>>>>>>>    integer iMax iRow
80291>>>>>>>>>    get row_count to iMax
80292>>>>>>>>>    decrement iMax
80293>>>>>>>>>    for iRow from 0 to iMax
80299>>>>>>>>>>
80299>>>>>>>>>      set piAux2.i iRow to iVal
80300>>>>>>>>>    loop
80301>>>>>>>>>>
80301>>>>>>>>>  end_procedure
80302>>>>>>>>>
80302>>>>>>>>>  procedure Add_Rootname string sRoot
80304>>>>>>>>>    integer iRow
80304>>>>>>>>>    get SEQ_FindDataFileFromRootName sRoot to sRoot
80305>>>>>>>>>    if sRoot ne "" begin
80307>>>>>>>>>      if (sFindRoot.s(self,sRoot)) eq -1 begin
80309>>>>>>>>>        get row_count to iRow
80310>>>>>>>>>        set psRootName.i iRow to sRoot
80311>>>>>>>>>      end
80311>>>>>>>>>>
80311>>>>>>>>>    end
80311>>>>>>>>>>
80311>>>>>>>>>  end_procedure
80312>>>>>>>>>
80312>>>>>>>>>  procedure Add_FileListEntry integer iFile
80314>>>>>>>>>    string sRoot
80314>>>>>>>>>    get API_AttrValue_FILELIST DF_FILE_ROOT_NAME iFile to sRoot
80315>>>>>>>>>    send Add_Rootname sRoot
80316>>>>>>>>>  end_procedure
80317>>>>>>>>>
80317>>>>>>>>>  procedure Add_AllFileListEntries
80319>>>>>>>>>    integer iFile
80319>>>>>>>>>    move 0 to iFile
80320>>>>>>>>>    repeat
80320>>>>>>>>>>
80320>>>>>>>>>      move (API_AttrValue_FLSTNAV(DF_FILE_NEXT_USED,iFile)) to iFile
80321>>>>>>>>>      if iFile send Add_FileListEntry iFile
80324>>>>>>>>>    until iFile eq 0
80326>>>>>>>>>  end_procedure
80327>>>>>>>>>
80327>>>>>>>>>  procedure Add_RootNamesInDir_Help string sDir integer iIncSubDir
80329>>>>>>>>>    integer iFileObj1 iFileObj2 iRow iMax
80329>>>>>>>>>    string sFile
80329>>>>>>>>>    move (oSortSetFiles1(self)) to iFileObj1
80330>>>>>>>>>    move (oSortSetFiles2(self)) to iFileObj2
80331>>>>>>>>>    send reset to iFileObj1
80332>>>>>>>>>    send reset to iFileObj2
80333>>>>>>>>>
80333>>>>>>>>>    if iIncSubDir send AddSubDirectories to iFileObj1 sDir
80336>>>>>>>>>    else send AddDir to iFileObj1 sDir
80338>>>>>>>>>
80338>>>>>>>>>    send SnapShot_Build to iFileObj1
80339>>>>>>>>>    send CopyFilesFromObject to iFileObj2 "*.dat" iFileObj1
80340>>>>>>>>>
80340>>>>>>>>>    get row_count of iFileObj2 to iMax
80341>>>>>>>>>    decrement iMax
80342>>>>>>>>>    for iRow from 0 to iMax
80348>>>>>>>>>>
80348>>>>>>>>>      get sFileNameIncPath.i of iFileObj2 iRow to sFile
80349>>>>>>>>>      send Add_Rootname sFile
80350>>>>>>>>>    loop
80351>>>>>>>>>>
80351>>>>>>>>>
80351>>>>>>>>>    send reset to iFileObj1
80352>>>>>>>>>    send reset to iFileObj2
80353>>>>>>>>>  end_procedure
80354>>>>>>>>>  // Add all tables in directory
80354>>>>>>>>>  procedure Add_RootNamesInDirectory string sDir
80356>>>>>>>>>    send Add_RootNamesInDir_Help sDir 0
80357>>>>>>>>>  end_procedure
80358>>>>>>>>>  // Add all tables in directory and subdirectories
80358>>>>>>>>>  procedure Add_RootNamesInDirectories string sDir
80360>>>>>>>>>    send Add_RootNamesInDir_Help sDir 1
80361>>>>>>>>>  end_procedure
80362>>>>>>>>>  // Add all table found in any directory in path
80362>>>>>>>>>  procedure Add_RootNamesInPath string sPath
80364>>>>>>>>>    send SEQ_CallBack_DirsInPath sPath msg_Add_RootNamesInDirectory self
80365>>>>>>>>>  end_procedure
80366>>>>>>>>>
80366>>>>>>>>>  procedure Add_DataFilesInWS string sKeyName
80368>>>>>>>>>  end_procedure
80369>>>>>>>>>  procedure Add_DataFilesInAllWS
80371>>>>>>>>>    // Note: This procedure does not add all tables in a VDF 7 installation.
80371>>>>>>>>>    //       Some tables are used for copying to new projects. They are not
80371>>>>>>>>>    //       themselves member of a workspace. In addition there are some
80371>>>>>>>>>    //       tables in directories /global and under /demo that must be
80371>>>>>>>>>    //       included by other means. Look in SortUtil.vw in procedure
80371>>>>>>>>>    //       DoGetTablesAllWS to see how to include everything.
80371>>>>>>>>>    //       However, tables in directories pointed to by the registry
80371>>>>>>>>>    //       key /WorkSpaces/SystemMakePath are included (these are
80371>>>>>>>>>    //       common to all WorkSpaces should any tables reside there).
80371>>>>>>>>>    integer iAllWorkspaces iRow iMax
80371>>>>>>>>>    move (oAllWorkspaces(self)) to iAllWorkspaces
80372>>>>>>>>>    send ReadAllWorkspaces to iAllWorkspaces
80373>>>>>>>>>    get row_count of iAllWorkspaces to iMax
80374>>>>>>>>>    decrement iMax
80375>>>>>>>>>    for iRow from 0 to iMax
80381>>>>>>>>>>
80381>>>>>>>>>      send Add_RootNamesInPath (psMakePathNoSysPath.i(iAllWorkspaces,iRow))
80382>>>>>>>>>//      send Add_RootNamesInPath (psDataPath.i(iAllWorkspaces,iRow))
80382>>>>>>>>>    loop
80383>>>>>>>>>>
80383>>>>>>>>>    send Add_RootNamesInPath (psCurrentMakePath(iAllWorkspaces))
80384>>>>>>>>>  end_procedure
80385>>>>>>>>>end_class // cSetOfTables
80386>>>>>>>>>
80386>>>>>>>Use Files.utl    // Utilities for handling file related stuff
80386>>>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
80386>>>>>>>
80386>>>>>>>desktop_section
80391>>>>>>>  object oConv2000StatusCodes is a cIntegerCodeToText
80393>>>>>>>    IntegerCodeList
80393>>>>>>>      Define_IntegerCode Y2K_UNINITIALISED        "Not checked"
80394>>>>>>>      Define_IntegerCode Y2K_COULD_NOT_OPEN       "Could not open"
80395>>>>>>>      Define_IntegerCode Y2K_CONVERTED            "Converted"
80396>>>>>>>      Define_IntegerCode Y2K_NO_DATE_FIELDS       "No date fields"
80397>>>>>>>    End_IntegerCodeList
80397>>>>>>>  end_object
80398>>>>>>>end_desktop_section
80403>>>>>>>
80403>>>>>>>function Y2K_TableStatusText global integer iStatus returns string
80405>>>>>>>  function_return (sText.i(oConv2000StatusCodes(self),iStatus))
80406>>>>>>>end_function
80407>>>>>>>
80407>>>>>>>class cConv2000 is a cSetOfTables
80408>>>>>>>  procedure construct_object
80410>>>>>>>    forward send construct_object
80412>>>>>>>    // 0: One transaction
80412>>>>>>>    //-1: exclusive
80412>>>>>>>    //-2: means reread when necessary
80412>>>>>>>    property integer piUnlockRecordCount public -2
80413>>>>>>>    property integer piCallbackObj       public self
80414>>>>>>>    object oDateFields is a cArray no_image
80416>>>>>>>    end_object
80417>>>>>>>    object oDateFieldValues is a cArray no_image
80419>>>>>>>    end_object
80420>>>>>>>  end_procedure
80421>>>>>>>
80421>>>>>>>  // Find all fields of type DF_DATE and store them in the oDateFields array.
80421>>>>>>>  procedure priv.DoFindDateFields
80423>>>>>>>    integer hoDateFields iField iMax iType
80423>>>>>>>    move (oDateFields(self)) to hoDateFields
80424>>>>>>>    send delete_data to hoDateFields
80425>>>>>>>    move (FDX_AttrValue_FILE(0,DF_FILE_NUMBER_FIELDS,20)) to iMax
80426>>>>>>>    for iField from 1 to iMax
80432>>>>>>>>
80432>>>>>>>      move (FDX_AttrValue_FIELD(0,DF_FIELD_TYPE,20,iField)) to iType
80433>>>>>>>      if iType eq DF_DATE set value of hoDateFields item (item_count(hoDateFields)) to iField
80436>>>>>>>    loop
80437>>>>>>>>
80437>>>>>>>  end_procedure
80438>>>>>>>
80438>>>>>>>  function iCancel returns integer
80440>>>>>>>  end_function
80441>>>>>>>
80441>>>>>>>  procedure UpdateWait1 string sStr
80443>>>>>>>  end_procedure
80444>>>>>>>  procedure UpdateWait2 string sStr
80446>>>>>>>  end_procedure
80447>>>>>>>
80447>>>>>>>  procedure priv.DoConvRow integer iRow
80449>>>>>>>    integer iOpen iFile iUnlockCount iNeedsConverting
80449>>>>>>>    integer hoDateFields iField iMax iItm iFound hoDateFieldValues
80449>>>>>>>    integer iDate iDateConvCount iRecordUpdateCount iRecordCount
80449>>>>>>>    integer iRecCount iMaxRec iLockReccount
80449>>>>>>>    integer iCallbackObj iMaxRecord lbDate4State
80449>>>>>>>    string sRootName
80449>>>>>>>
80449>>>>>>>    GET_DATE_ATTRIBUTE Date4_State to lbDate4State
80450>>>>>>>    SET_DATE_ATTRIBUTE Date4_State to DFFALSE
80451>>>>>>>
80451>>>>>>>    move (oDateFields(self)) to hoDateFields
80452>>>>>>>    move (oDateFieldValues(self)) to hoDateFieldValues
80453>>>>>>>    get psRootName.i iRow to sRootName
80454>>>>>>>    get piCallbackObj to iCallbackObj
80455>>>>>>>    move 20 to iFile
80456>>>>>>>
80456>>>>>>>    move 0 to iRecordCount
80457>>>>>>>    move 0 to iDateConvCount
80458>>>>>>>    move 0 to iRecordUpdateCount
80459>>>>>>>
80459>>>>>>>    get piUnlockRecordCount to iUnlockCount
80460>>>>>>>
80460>>>>>>>    if iUnlockCount eq -1 move (DBMS_OpenFileAs(sRootName,iFile,DF_EXCLUSIVE,0)) to iOpen
80463>>>>>>>    else move (DBMS_OpenFileAs(sRootName,iFile,DF_SHARE,0)) to iOpen
80465>>>>>>>
80465>>>>>>>    if iOpen ne DBMS_DRIVER_ERROR begin
80467>>>>>>>      get FDX_AttrValue_FILE 0 DF_FILE_RECORDS_USED iFile to iMaxRec
80468>>>>>>>
80468>>>>>>>      send priv.DoFindDateFields
80469>>>>>>>      get item_count of hoDateFields to iMax
80470>>>>>>>      if iMax begin // If there's any date fields at all
80472>>>>>>>        send UpdateWait1 to iCallbackObj sRootName
80473>>>>>>>        decrement iMax
80474>>>>>>>        if iUnlockCount le 0 begin
80476>>>>>>>          clear 20
80477>>>>>>>          if (iUnlockCount=0 or iUnlockCount=-1) lock // 'One transaction' or 'exclusive'
80480>>>>>>>
80480>>>>>>>          repeat
80480>>>>>>>>
80480>>>>>>>            vfind 20 0 gt
80482>>>>>>>            move (found) to iFound
80483>>>>>>>            if iFound move (not(iCancel(self))) to iFound
80486>>>>>>>            if iFound begin
80488>>>>>>>              // Sample values
80488>>>>>>>              move 0 to iNeedsConverting
80489>>>>>>>              for iItm from 0 to iMax
80495>>>>>>>>
80495>>>>>>>                get value of hoDateFields item iItm to iField
80496>>>>>>>                get_field_value iFile iField to iDate
80499>>>>>>>                if (iDate and iDate>>>>>>                  move 1 to iNeedsConverting
80502>>>>>>>                  set value of hoDateFieldValues item iItm to (Date2to4(iDate))
80503>>>>>>>                  increment iDateConvCount
80504>>>>>>>                end
80504>>>>>>>>
80504>>>>>>>                else set value of hoDateFieldValues item iItm to (date(iDate))
80506>>>>>>>              loop
80507>>>>>>>>
80507>>>>>>>              if iNeedsConverting begin
80509>>>>>>>                if iUnlockCount eq -2 reread iFile
80515>>>>>>>                for iItm from 0 to iMax
80521>>>>>>>>
80521>>>>>>>                  get value of hoDateFields item iItm to iField
80522>>>>>>>                  set_field_value iFile iField to (value(hoDateFieldValues,iItm))
80525>>>>>>>                loop
80526>>>>>>>>
80526>>>>>>>                saverecord iFile
80527>>>>>>>                increment iRecordUpdateCount
80528>>>>>>>                if iUnlockCount eq -2 unlock
80531>>>>>>>              end
80531>>>>>>>>
80531>>>>>>>              increment iRecordCount
80532>>>>>>>              if (iRecordCount/50*50) eq iRecordCount send UpdateWait2 to iCallbackObj (string(iRecordCount)+"/"+string(iMaxRec))
80535>>>>>>>            end
80535>>>>>>>>
80535>>>>>>>          until (not(iFound))
80537>>>>>>>          if (iUnlockCount=0 or iUnlockCount=-1) unlock
80540>>>>>>>          send UpdateWait2 to iCallbackObj (string(iRecordCount)+"/"+string(iMaxRec))
80541>>>>>>>        end
80541>>>>>>>>
80541>>>>>>>        set piStatus.i iRow to Y2K_CONVERTED
80542>>>>>>>      end
80542>>>>>>>>
80542>>>>>>>      else set piStatus.i iRow to Y2K_NO_DATE_FIELDS
80544>>>>>>>      close iFile
80545>>>>>>>    end
80545>>>>>>>>
80545>>>>>>>    else set piStatus.i iRow to Y2K_COULD_NOT_OPEN
80547>>>>>>>    set piAux1.i iRow to iMaxRec
80548>>>>>>>    set piAux2.i iRow to iDateConvCount
80549>>>>>>>    SET_DATE_ATTRIBUTE Date4_State to lbDate4State
80550>>>>>>>  end_procedure
80551>>>>>>>
80551>>>>>>>  procedure DoConv
80553>>>>>>>    integer iMax iRow
80553>>>>>>>    send OpenStat_RegisterFiles
80554>>>>>>>    send OpenStat_CloseAllFiles
80555>>>>>>>    send DoSetAllAux1 0 // Clear Aux1 column
80556>>>>>>>    send DoSetAllAux2 0 // Clear Aux2 column
80557>>>>>>>    get row_count to iMax
80558>>>>>>>    decrement iMax
80559>>>>>>>    for iRow from 0 to iMax
80565>>>>>>>>
80565>>>>>>>      send priv.DoConvRow iRow
80566>>>>>>>    loop
80567>>>>>>>>
80567>>>>>>>    send OpenStat_RestoreFiles
80568>>>>>>>  end_procedure
80569>>>>>>>end_class // cConv2000
80570>>>>>>>
80570>>>>>>>// From here we just declare a default global thing and some
80570>>>>>>>// methods to operate it.
80570>>>>>>>
80570>>>>>>>integer gloConv2000# // Global integer pointing to the default Reindexer object
80570>>>>>>>desktop_section
80575>>>>>>>  object oConv2000 is a cConv2000 no_image
80577>>>>>>>    move self to gloConv2000#
80578>>>>>>>  end_object
80579>>>>>>>end_desktop_section
80584>>>>>>>
80584>>>>>>>procedure Y2K_ResetTableList global
80586>>>>>>>  send Reset to gloConv2000#
80587>>>>>>>end_procedure
80588>>>>>>>procedure Y2K_DoConv global
80590>>>>>>>  send DoConv to gloConv2000#
80591>>>>>>>end_procedure
80592>>>>>>>procedure Y2K_Add_RootNamesInDirectory global string sDir
80594>>>>>>>  send Add_RootNamesInDirectory to gloConv2000# sDir
80595>>>>>>>end_procedure
80596>>>>>>>procedure Y2K_Add_RootNamesInDirectories global string sDir
80598>>>>>>>  send Add_RootNamesInDirectories to gloConv2000# sDir
80599>>>>>>>end_procedure
80600>>>>>>>procedure Y2K_Add_Rootname global string sFileRootName
80602>>>>>>>  send Add_Rootname to gloConv2000# sFileRootName
80603>>>>>>>end_procedure
80604>>>>>>>procedure Y2K_Add_RootNamesInAllWS global
80606>>>>>>>  send Add_DataFilesInAllWS to gloConv2000#
80607>>>>>>>end_procedure
80608>>>>>>>
80608>>>>>>>// Test:
80608>>>>>>>
80608>>>>>>>//  object oReindexer is a cConv2000
80608>>>>>>>//    send Add_Rootname "s_prtcmm" DFTRUE
80608>>>>>>>//    send DoConv
80608>>>>>>>//  end_object
80608>>>>>Use GridUtil.utl // Grid and List utilities
80608>>>>>
80608>>>>>object oWaitWhileConv2000 is a StatusPanel
80610>>>>>  set allow_cancel_state to DFFALSE
80611>>>>>  procedure DoCaption string sCaption
80614>>>>>    set Caption_Text to sCaption
80615>>>>>    set Message_Text to ""
80616>>>>>    set Action_Text  to ""
80617>>>>>    set Title_Text   to ""
80618>>>>>  end_procedure
80619>>>>>  procedure UpdateWait1 string sStr
80622>>>>>    set Message_Text to sStr
80623>>>>>  end_procedure
80624>>>>>  procedure UpdateWait2 string sStr
80627>>>>>    set Action_Text to sStr
80628>>>>>  end_procedure
80629>>>>>//   set piCallbackObj of gloConv2000# to self
80629>>>>>  procedure Start_StatusPanel
80632>>>>>    send DoCaption "Converting tables"
80633>>>>>    forward send Start_StatusPanel
80635>>>>>  end_procedure
80636>>>>>end_object
80637>>>>>
80637>>>>> Use Aps
80637>>>>> Use RGB.utl      // Some color functions
80637>>>>> class cConv2000List is a aps.Grid
80638>>>>>  procedure construct_object integer img#
80640>>>>>    forward send construct_object img#
80642>>>>>    property integer piConv2000Object public gloConv2000# // Global integer defined in Conv2000.utl
80643>>>>>    send GridPrepare_AddCheckBoxColumn
80644>>>>>    send GridPrepare_AddColumn "Table"  AFT_ASCII40
80645>>>>>    send GridPrepare_AddColumn "Status" AFT_ASCII40
80646>>>>>    send GridPrepare_Apply self
80647>>>>>    set select_mode to MULTI_SELECT
80648>>>>>    set highlight_row_state to true
80649>>>>>    on_key KNEXT_ITEM     send switch
80650>>>>>    on_key KPREVIOUS_ITEM send switch_back
80651>>>>>  end_procedure
80652>>>>>
80652>>>>>  procedure select_toggling integer itm# integer i#
80654>>>>>    integer ci# iColumns
80654>>>>>    get Grid_Columns self to iColumns
80655>>>>>    get current_item to ci#
80656>>>>>    move ((ci#/iColumns)*iColumns) to ci# // Redirect to first column
80657>>>>>    forward send select_toggling ci# i#
80659>>>>>  end_procedure
80660>>>>>
80660>>>>>  procedure fill_list
80662>>>>>    integer iObj iRow iMax iBase iStatus
80662>>>>>    string sStatusText
80662>>>>>    send delete_data
80663>>>>>    set dynamic_update_state to false
80664>>>>>    get piConv2000Object to iObj
80665>>>>>    get row_count of iObj to iMax
80666>>>>>    decrement iMax
80667>>>>>    for iRow from 0 to iMax
80673>>>>>>
80673>>>>>      get item_count to iBase
80674>>>>>      send Grid_AddCheckBoxItem self DFTRUE
80675>>>>>      set aux_value item iBase to iRow
80676>>>>>      send add_item msg_none (psRootName.i(iObj,iRow))
80677>>>>>      get piStatus.i of iObj iRow to iStatus
80678>>>>>      move (Y2K_TableStatusText(iStatus)) to sStatusText
80679>>>>>      if iStatus eq Y2K_CONVERTED begin
80681>>>>>//      move (sStatusText+" (# dates in # records)") to sStatusText
80681>>>>>        move ("(# dates in # records)") to sStatusText
80682>>>>>        replace "#" in sStatusText with (piAux2.i(iObj,iRow)) to sStatusText
80684>>>>>        replace "#" in sStatusText with (piAux1.i(iObj,iRow)) to sStatusText
80686>>>>>      end
80686>>>>>>
80686>>>>>      send add_item msg_none sStatusText
80687>>>>>    loop
80688>>>>>>
80688>>>>>    send Grid_SetEntryState self DFFALSE
80689>>>>>    set dynamic_update_state to true
80690>>>>>    send update_total (iMax+1)
80691>>>>>  end_procedure
80692>>>>>
80692>>>>>  procedure update_total integer iItemsInList
80694>>>>>  end_procedure
80695>>>>>
80695>>>>>  procedure DoConv_Help integer iRow integer iBase
80697>>>>>    send Add_Rootname to (piConv2000Object(self)) (value(self,iBase+1))
80698>>>>>  end_procedure
80699>>>>>
80699>>>>>  procedure DoConv
80701>>>>>    integer iCallBackTmp iConv2000Object
80701>>>>>    get piConv2000Object to iConv2000Object
80702>>>>>    get piCallbackObj of iConv2000Object to iCallBackTmp
80703>>>>>    set piCallbackObj of iConv2000Object to (oWaitWhileConv2000(self))
80704>>>>>    send Start_StatusPanel to (oWaitWhileConv2000(self))
80705>>>>>    send reset to iConv2000Object
80706>>>>>    send Grid_RowCallBackSelected self msg_DoConv_Help
80707>>>>>    send DoConv to iConv2000Object
80708>>>>>    send Stop_StatusPanel to (oWaitWhileConv2000(self))
80709>>>>>    send fill_list
80710>>>>>    set piCallbackObj of iConv2000Object to iCallBackTmp
80711>>>>>  end_procedure
80712>>>>>  procedure Reset
80714>>>>>    send reset to (piConv2000Object(self))
80715>>>>>    send fill_list
80716>>>>>  end_procedure
80717>>>>>end_class // cConv2000List
80718>>>>>
80718>>>>>
80718>>>Use Spec0011.utl // Floating menues on the fly
Including file: spec0011.utl    (C:\Apps\VDFQuery\AppSrc\spec0011.utl)
80718>>>>>// Use Spec0011.utl // Floating menues on the fly
80718>>>>>
80718>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
80718>>>>>
80718>>>>>desktop_section
80723>>>>>  object oSpec0011Arr is a cArray
80725>>>>>    item_property_list
80725>>>>>      item_property integer piMsg.i
80725>>>>>      item_property string  psText.i
80725>>>>>    end_item_property_list
#REM 80762 DEFINE FUNCTION PSTEXT.I INTEGER LIROW RETURNS STRING
#REM 80767 DEFINE PROCEDURE SET PSTEXT.I INTEGER LIROW STRING VALUE
#REM 80772 DEFINE FUNCTION PIMSG.I INTEGER LIROW RETURNS INTEGER
#REM 80777 DEFINE PROCEDURE SET PIMSG.I INTEGER LIROW INTEGER VALUE
80783>>>>>    procedure add_item integer iMsg string sVal
80786>>>>>      integer iRow
80786>>>>>      get row_count to iRow
80787>>>>>      set piMsg.i  iRow to iMsg
80788>>>>>      set psText.i iRow to sVal
80789>>>>>    end_procedure
80790>>>>>  end_object
80791>>>>>end_desktop_section
80796>>>>>
80796>>>>>procedure FLOATMENU_PrepareAddItem global integer iMsg string sVal
80798>>>>>  send add_item to (oSpec0011Arr(self)) iMsg sVal
80799>>>>>end_procedure
80800>>>>>
80800>>>>>class cSpec0011FloatingPopupMenu is a FloatingPopupMenu
80801>>>>>  procedure popup
80803>>>>>    forward send popup
80805>>>>>    send request_destroy_object
80806>>>>>  end_procedure
80807>>>>>end_class
80808>>>>>
80808>>>>>function FLOATMENU_Apply global integer iObj returns integer
80810>>>>>  integer iSelf iArr iRow iMax iObjFM
80810>>>>>  move self to iSelf
80811>>>>>  move (oSpec0011Arr(self)) to iArr
80812>>>>>  get row_count of iArr to iMax
80813>>>>>  move desktop to self
80814>>>>>  object oSpec0011_FM is a cSpec0011FloatingPopupMenu
80816>>>>>    for iRow from 0 to (iMax-1)
80822>>>>>>
80822>>>>>      send add_item (piMsg.i(iArr,iRow)) (psText.i(iArr,iRow))
80823>>>>>      set aux_value item iRow to iObj
80824>>>>>    loop
80825>>>>>>
80825>>>>>    move self to iObjFM
80826>>>>>  end_object
80827>>>>>  move iSelf to self
80828>>>>>  send delete_data to iArr
80829>>>>>  function_return iObjFM
80830>>>>>end_function
80831>>>Use API_Attr.utl // Functions for querying API attributes
80831>>>Use Files.utl    // Utilities for handling file related stuff
80831>>>
/CONV2000.VW.INTRO
Image 19, CONV2000.VW.INTRO
 $Title$ Reindexing of tables
 With this utility you may reindex tables
/*
80831>>>
80831>>>activate_view Activate_Conv2000_Vw for oConv2000_Vw
80836>>>object oConv2000_Vw is a aps.View label "Year 2000 Convertions"
80839>>>  on_key KCANCEL send close_panel
80840>>>  object oLst is a cConv2000List
80842>>>    set size to 225 0
80843>>>    register_object oTotal
80843>>>    procedure update_total integer iItemsInList
80846>>>      set value of (oTotal(self)) to (string(iItemsInList)+" tables")
80847>>>    end_procedure
80848>>>  end_object
80849>>>  object oTotal is a aps.TextBox label "" snap SL_DOWN
80853>>>    set fixed_size to 12 60
80854>>>    set justification_mode to JMODE_LEFT
80855>>>  end_object
80856>>>  send update_total to (oLst(self)) 0
80857>>>  procedure DoConvTables
80860>>>    send DoConv to (oLst(self))
80861>>>  end_procedure
80862>>>  procedure DoGetTablesSelector_Help integer iFile integer iSelected integer iShaded
80865>>>    string sRoot
80865>>>    get API_AttrValue_FILELIST DF_FILE_ROOT_NAME iFile to sRoot
80866>>>    send Y2K_Add_Rootname sRoot
80867>>>  end_procedure
80868>>>  procedure DoGetTablesSelector
80871>>>    send cursor_wait to (cursor_control(self))
80872>>>    send DFMatrix_CallBack_Selected_Files msg_DoGetTablesSelector_Help self 1 0 1
80873>>>    send fill_list to (oLst(self))
80874>>>    send cursor_ready to (cursor_control(self))
80875>>>  end_procedure
80876>>>  procedure DoGetTablesDirectories
80879>>>    string sDir
80879>>>    get SEQ_SelectDirectory "Select directory structure" to sDir
80880>>>    if sDir ne "" begin
80882>>>      send cursor_wait to (cursor_control(self))
80883>>>      send Y2K_Add_RootNamesInDirectories sDir
80884>>>      send fill_list to (oLst(self))
80885>>>    send cursor_ready to (cursor_control(self))
80886>>>    end
80886>>>>
80886>>>  end_procedure
80887>>>  procedure DoGetTablesDirectory
80890>>>    string sDir
80890>>>    get SEQ_SelectDirectory "Select directory" to sDir
80891>>>    if sDir ne "" begin
80893>>>      send cursor_wait to (cursor_control(self))
80894>>>      send Y2K_Add_RootNamesInDirectory sDir
80895>>>      send fill_list to (oLst(self))
80896>>>      send cursor_ready to (cursor_control(self))
80897>>>    end
80897>>>>
80897>>>  end_procedure
80898>>>  procedure DoGetTablesAllWS
80901>>>    string sDir
80901>>>    send cursor_wait to (cursor_control(self))
80902>>>    get_profile_string "defaults" "VDFRootDir" to sDir
80905>>>    send Y2K_Add_RootNamesInAllWS
80906>>>    send Y2K_Add_RootNamesInDirectories sDir
80907>>>    send fill_list to (oLst(self))
80908>>>    send cursor_ready to (cursor_control(self))
80909>>>  end_procedure
80910>>>  procedure DoGetTableBrowse
80913>>>    string sRoot
80913>>>    get SEQ_SelectInFile "Select data file to convert" "DAT files|*.dat" to sRoot
80914>>>    if sRoot ne "" begin
80916>>>      send Y2K_Add_Rootname sRoot
80917>>>      send fill_list to (oLst(self))
80918>>>    end
80918>>>>
80918>>>  end_procedure
80919>>>  procedure DoProperties
80922>>>    send DoProperties to (oLst(self))
80923>>>  end_procedure
80924>>>  procedure DoReset
80927>>>    send reset to (oLst(self))
80928>>>  end_procedure
80929>>>  object oBtn1 is a aps.Multi_Button
80931>>>    procedure PopupFM
80934>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesSelector    "Get tables from table selector"
80935>>>      send FLOATMENU_PrepareAddItem msg_DoGetTableBrowse       "Browse for one table"
80936>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesDirectory   "Get all tables in folder"
80937>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesDirectories "Get all tables in folder and below"
80938>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesAllWS       "Get tables from all Work Spaces"
80939>>>      send popup to (FLOATMENU_Apply(self))
80940>>>    end_procedure
80941>>>    on_item "Add tables"  send PopupFM
80942>>>  end_object
80943>>>  object oBtn2 is a aps.Multi_Button
80945>>>    on_item "Convert tables" send DoConvTables
80946>>>  end_object
80947>>>  object oBtn3 is a aps.Multi_Button
80949>>>    on_item "Reset list"  send DoReset
80950>>>  end_object
80951>>>//object oBtn4 is a aps.Multi_Button
80951>>>//  on_item "Properties" send DoProperties
80951>>>//end_object
80951>>>  object oBtn5 is a aps.Multi_Button
80953>>>    on_item "Close" send close_panel
80954>>>  end_object
80955>>>  send aps_locate_multi_buttons
80956>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
80957>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
80960>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
80961>>>    send aps_auto_locate_control (oTotal(self)) SL_DOWN (oLst(self))
80962>>>    send aps_register_multi_button (oBtn1(self))
80963>>>    send aps_register_multi_button (oBtn2(self))
80964>>>    send aps_register_multi_button (oBtn3(self))
80965>>>//  send aps_register_multi_button (oBtn4(self))
80965>>>    send aps_register_multi_button (oBtn5(self))
80966>>>    send aps_locate_multi_buttons
80967>>>    send aps_auto_size_container
80968>>>  end_procedure
80969>>>end_object
80970>    Use SortUtil.vw  // Activate_SortUtil_Vw (for use in the DFMatrix environment)
Including file: sortutil.vw    (C:\Apps\VDFQuery\AppSrc\sortutil.vw)
80970>>>// Use SortUtil.vw  // Activate_SortUtil_Vw (for use in the DFMatrix environment)
80970>>>
80970>>>Use SortUtil.pkg // UI bricks for reindexing a set of tables
Including file: sortutil.pkg    (C:\Apps\VDFQuery\AppSrc\sortutil.pkg)
80970>>>>>// Use SortUtil.pkg // UI bricks for reindexing a set of tables
80970>>>>>
80970>>>>>Use SortUtil.utl // Basic code for reindexing a set of tables
Including file: sortutil.utl    (C:\Apps\VDFQuery\AppSrc\sortutil.utl)
80970>>>>>>>// Use SortUtil.utl // Basic code for reindexing a set of tables
80970>>>>>>>
80970>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
80970>>>>>>>Use DBMS.utl     // Basic DBMS functions
80970>>>>>>>Use Spec0008.utl // Small arrays with integer Codes (Dictionaries)
80970>>>>>>>Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles)
80970>>>>>>>Use SetTable.utl // cSetOfTables class
80970>>>>>>>Use Files.utl    // Utilities for handling file related stuff
80970>>>>>>>
80970>>>>>>>desktop_section
80975>>>>>>>  object oSortFilesStatusCodes is a cIntegerCodeToText
80977>>>>>>>    IntegerCodeList
80977>>>>>>>      Define_IntegerCode SC_TERMINATION_OK       "All is well"
80978>>>>>>>      Define_IntegerCode SC_UNINITIALISED        "Un-initialized"
80979>>>>>>>      Define_IntegerCode SC_NOT_A_DATAFLEX_FILE  "Not a DataFlex file"
80980>>>>>>>      Define_IntegerCode SC_COULD_NOT_OPEN       "File could not be opened"
80981>>>>>>>    End_IntegerCodeList
80981>>>>>>>  end_object
80982>>>>>>>  object oSortFileStatusCodes is a cIntegerCodeToText
80984>>>>>>>    IntegerCodeList
80984>>>>>>>      Define_IntegerCode SCB_UNINITIALISED        "Not sorted"
80985>>>>>>>      Define_IntegerCode SCB_NOT_A_DATAFLEX_FILE  "Not DataFlex file"
80986>>>>>>>      Define_IntegerCode SCB_COULD_NOT_OPEN       "Could not open"
80987>>>>>>>      Define_IntegerCode SCB_OK                   "Sorted OK"
80988>>>>>>>      Define_IntegerCode SCB_DUPLICATES           "Duplicate records"
80989>>>>>>>      Define_IntegerCode SCB_BAD                  "Bad data detected"
80990>>>>>>>    End_IntegerCodeList
80990>>>>>>>  end_object
80991>>>>>>>end_desktop_section
80996>>>>>>>
80996>>>>>>>function SU_TableStatusText global integer iStatus returns string
80998>>>>>>>  function_return (sText.i(oSortFileStatusCodes(self),iStatus))
80999>>>>>>>end_function
81000>>>>>>>
81000>>>>>>>desktop_section
81005>>>>>>>  object oSortProperties is a cArray NO_IMAGE
81007>>>>>>>    property integer piSortOptions public (DF_SORT_OPTION_NO_DATA_CHECK+DF_SORT_OPTION_DUP_DATA_FILE)
81009>>>>>>>    property integer piSortBuffer  public 0
81011>>>>>>>    procedure DoDefault
81014>>>>>>>      integer liNull liBuffer
81014>>>>>>>      string lsNull
81014>>>>>>>      move 0 to liNull
81015>>>>>>>      move "" to lsNull
81016>>>>>>>      call_driver liNull "DATAFLEX" function FLEX_GET_MAX_SORT_BUFFER callback liNull passing lsNull liNull liNull result liBuffer
81021>>>>>>>      set piSortBuffer to liBuffer
81022>>>>>>>    end_procedure
81023>>>>>>>    send DoDefault
81024>>>>>>>  end_object
81025>>>>>>>end_desktop_section
81030>>>>>>>
81030>>>>>>>class cReIndexer is a cSetOfTables
81031>>>>>>>  procedure construct_object
81033>>>>>>>    forward send construct_object
81035>>>>>>>    property integer piCallbackObj  public  self
81036>>>>>>>    property integer piSortBuffer   public  0  // Means what ever it was set to already
81037>>>>>>>    property integer piBatchOnly    public  DFFALSE // The use of this is not implemented!
81038>>>>>>>    property integer piStatus       public  SC_UNINITIALISED
81039>>>>>>>    property integer piCurrentRow   private "" // Row currently being sorted
81040>>>>>>>  end_procedure
81041>>>>>>>
81041>>>>>>>  procedure DoCaption string sCaption
81043>>>>>>>    // Apart from the call back function below this message MUST be
81043>>>>>>>    // understood by the callback object. (Per default we are our
81043>>>>>>>    // own callback object)
81043>>>>>>>  end_procedure
81044>>>>>>>
81044>>>>>>>  function callback string sText integer iType returns integer
81046>>>>>>>    if iType eq DF_MESSAGE_WARNING set piAux1.i (!$.piCurrentRow(self)) to 1
81049>>>>>>>//  if (iType ge DF_MESSAGE_HEADING_1 and iType le DF_MESSAGE_HEADING_5) begin
81049>>>>>>>//  end
81049>>>>>>>//  else if iType eq DF_MESSAGE_PROGRESS_TITLE begin
81049>>>>>>>//  end
81049>>>>>>>//  else if iType eq DF_MESSAGE_PROGRESS_VALUE begin
81049>>>>>>>//  end
81049>>>>>>>//  else if iType eq DF_MESSAGE_WARNING begin
81049>>>>>>>//  end
81049>>>>>>>//  function_return 0
81049>>>>>>>  end_function
81050>>>>>>>
81050>>>>>>>  procedure priv.DoSortRow integer iRow
81052>>>>>>>    integer iOpen iFile iOptions iCallbackObj
81052>>>>>>>    string sRootName
81052>>>>>>>
81052>>>>>>>    set !$.piCurrentRow to iRow
81053>>>>>>>    get psRootName.i iRow to sRootName
81054>>>>>>>    move 20 to iFile
81055>>>>>>>
81055>>>>>>>    move (DBMS_OpenFileAs(sRootName,iFile,DF_EXCLUSIVE,0)) to iOpen
81056>>>>>>>    if iOpen ne DBMS_DRIVER_ERROR begin
81058>>>>>>>      if iOpen eq DBMS_DRIVER_DATAFLEX begin // It must be a DataFlex file
81060>>>>>>>        get piSortOptions of (oSortProperties(self)) to iOptions
81061>>>>>>>        get piCallbackObj to iCallbackObj
81062>>>>>>>        send DoCaption to iCallbackObj sRootName
81063>>>>>>>        sort iFile '' iOptions iCallbackObj
81065>>>>>>>        set piStatus.i iRow to SCB_OK
81066>>>>>>>      end
81066>>>>>>>>
81066>>>>>>>      else set piStatus.i iRow to SCB_NOT_A_DATAFLEX_FILE
81068>>>>>>>      close iFile
81069>>>>>>>    end
81069>>>>>>>>
81069>>>>>>>    else set piStatus.i iRow to SCB_COULD_NOT_OPEN
81071>>>>>>>  end_procedure
81072>>>>>>>
81072>>>>>>>  procedure DoSort
81074>>>>>>>    integer iMax iRow
81074>>>>>>>    set piStatus to SC_UNINITIALISED
81075>>>>>>>    send OpenStat_RegisterFiles
81076>>>>>>>    send OpenStat_CloseAllFiles
81077>>>>>>>    send DoSetAllAux1 0 // Clear Aux1 column
81078>>>>>>>    get row_count to iMax
81079>>>>>>>    decrement iMax
81080>>>>>>>    for iRow from 0 to iMax
81086>>>>>>>>
81086>>>>>>>      send priv.DoSortRow iRow
81087>>>>>>>    loop
81088>>>>>>>>
81088>>>>>>>    send OpenStat_RestoreFiles
81089>>>>>>>  end_procedure
81090>>>>>>>
81090>>>>>>>  procedure Reset
81092>>>>>>>    forward send reset
81094>>>>>>>    set piStatus to SC_UNINITIALISED
81095>>>>>>>  end_procedure
81096>>>>>>>
81096>>>>>>>  procedure CloneTablesFromcReindexer integer iSourceObject
81098>>>>>>>    send Clone_Array iSourceObject self
81099>>>>>>>  end_procedure
81100>>>>>>>end_class // cReindexer
81101>>>>>>>
81101>>>>>>>// From here we just declare a default global thing and some
81101>>>>>>>// methods to operate it.
81101>>>>>>>
81101>>>>>>>integer gloReIndexer# // Global integer pointing to the default Reindexer object
81101>>>>>>>desktop_section
81106>>>>>>>  object oReIndexer is a cReIndexer no_image
81108>>>>>>>    move self to gloReIndexer#
81109>>>>>>>  end_object
81110>>>>>>>end_desktop_section
81115>>>>>>>
81115>>>>>>>
81115>>>>>>>procedure SU_ResetTableList global
81117>>>>>>>  send Reset to gloReIndexer#
81118>>>>>>>end_procedure
81119>>>>>>>procedure SU_DoSort global
81121>>>>>>>  send DoSort to gloReIndexer#
81122>>>>>>>end_procedure
81123>>>>>>>procedure SU_Add_RootNamesInDirectory global string sDir
81125>>>>>>>  send Add_RootNamesInDirectory to gloReIndexer# sDir
81126>>>>>>>end_procedure
81127>>>>>>>procedure SU_Add_RootNamesInDirectories global string sDir
81129>>>>>>>  send Add_RootNamesInDirectories to gloReIndexer# sDir
81130>>>>>>>end_procedure
81131>>>>>>>procedure SU_Add_Rootname global string sFileRootName
81133>>>>>>>  send Add_Rootname to gloReIndexer# sFileRootName
81134>>>>>>>end_procedure
81135>>>>>>>procedure SU_Add_RootNamesInAllWS global
81137>>>>>>>  send Add_DataFilesInAllWS to gloReIndexer#
81138>>>>>>>end_procedure
81139>>>>>>>// Test:
81139>>>>>>>
81139>>>>>>>//  object oReindexer is a cReindexer
81139>>>>>>>//    send Add_Rootname "s_prtcmm" DFTRUE
81139>>>>>>>//    send DoSort
81139>>>>>>>//  end_object
81139>>>>>Use GridUtil.utl // Grid and List utilities
81139>>>>>
81139>>>>>object oWaitWhileReindexing is a StatusPanel
81141>>>>>  set allow_cancel_state to DFFALSE
81142>>>>>  procedure DoCaption string sCaption
81145>>>>>    set Caption_Text to sCaption
81146>>>>>    set Message_Text to ""
81147>>>>>    set Action_Text  to ""
81148>>>>>    set Title_Text   to ""
81149>>>>>  end_procedure
81150>>>>>  function callback string sText integer iType returns integer
81153>>>>>    integer iRval
81153>>>>>    get callback of gloReIndexer# sText iType to iRval
81154>>>>>    if (iType ge DF_MESSAGE_HEADING_1 and iType le DF_MESSAGE_HEADING_5) begin
81156>>>>>      set Message_Text to sText
81157>>>>>    end
81157>>>>>>
81157>>>>>    else if iType eq DF_MESSAGE_PROGRESS_TITLE begin
81160>>>>>      set Action_Text to sText
81161>>>>>    end
81161>>>>>>
81161>>>>>    else if iType eq DF_MESSAGE_PROGRESS_VALUE begin
81164>>>>>      set Title_Text to sText
81165>>>>>    end
81165>>>>>>
81165>>>>>    else if iType eq DF_MESSAGE_WARNING begin
81168>>>>>      set Title_Text to sText
81169>>>>>    end
81169>>>>>>
81169>>>>>    function_return iRval
81170>>>>>  end_function
81171>>>>>  set piCallbackObj of gloReIndexer# to self
81172>>>>>  procedure Start_StatusPanel
81175>>>>>    send DoCaption "Reindexing files"
81176>>>>>    forward send Start_StatusPanel
81178>>>>>  end_procedure
81179>>>>>end_object
81180>>>>>
81180>>>>>register_object oSortBufferSize
81180>>>>>object oSortUtil_Prop_Pn is a aps.ModalPanel label "Properties"
81183>>>>>  property integer pResult public 0
81185>>>>>  set locate_mode to CENTER_ON_SCREEN
81186>>>>>  on_key kcancel send close_panel
81187>>>>>  procedure activate_next
81190>>>>>    send activate to (oSortBufferSize(self))
81191>>>>>  end_procedure
81192>>>>>  procedure activate_previous
81195>>>>>    send activate to (oBtn2(self))
81196>>>>>  end_procedure
81197>>>>>  object oRadio1 is a aps.RadioGroup label "Bad data"
81200>>>>>    on_key knext_item     send activate_next
81201>>>>>    on_key kprevious_item send activate_previous
81202>>>>>    object oRad1 is a aps.Radio label "No check"
81205>>>>>    end_object
81206>>>>>    object oRad2 is a aps.Radio label "Fill with spaces"
81209>>>>>    end_object
81210>>>>>    object oRad3 is a aps.Radio label "Write to file"
81213>>>>>    end_object
81214>>>>>    object oRad4 is a aps.Radio label "Abort on bad data"
81217>>>>>      set object_shadow_state to true
81218>>>>>    end_object
81219>>>>>  end_object
81220>>>>>  object oRadio2 is a aps.RadioGroup label "Duplicate records"
81223>>>>>    object oRad1 is a aps.Radio label "Write to file"
81226>>>>>      set object_shadow_state to true
81227>>>>>    end_object
81228>>>>>    object oRad2 is a aps.Radio label "Abort on duplicates"
81231>>>>>      set object_shadow_state to true
81232>>>>>    end_object
81233>>>>>  end_object
81234>>>>>  send aps_size_identical_max (oRadio1(self)) (oRadio2(self)) sl_vertical
81235>>>>>  send aps_goto_max_row
81236>>>>>  object oSortBufferSize is a aps.Form label "Sort buffer size (Kb):" abstract aft_numeric6.0
81240>>>>>    procedure switch_back
81243>>>>>      send activate to (oRadio1(self))
81244>>>>>    end_procedure
81245>>>>>    on_key kprevious_item send switch_back
81246>>>>>  end_object
81247>>>>>  send aps_align_by_moving (oSortBufferSize(self)) (oRadio2(self)) sl_align_left
81248>>>>>  object oBtn1 is a aps.Multi_Button
81250>>>>>    on_item t.btn.ok send close_panel_ok
81251>>>>>  end_object
81252>>>>>  object oBtn2 is a aps.Multi_Button
81254>>>>>    on_item t.btn.cancel send close_panel
81255>>>>>  end_object
81256>>>>>  send aps_locate_multi_buttons
81257>>>>>  procedure close_panel_ok
81260>>>>>    set pResult to true
81261>>>>>    send close_panel
81262>>>>>  end_procedure
81263>>>>>//procedure popup
81263>>>>>//  integer itm# grb# buffer#
81263>>>>>//  integer iNull
81263>>>>>//  string sNull
81263>>>>>//  move 0 to iNull
81263>>>>>//  move "" to sNull
81263>>>>>//  move 0 to itm#
81263>>>>>//  if (oVdfSort_SortOptions# iand DF_SORT_OPTION_NO_DATA_CHECK ) move 0 to itm#
81263>>>>>//  if (oVdfSort_SortOptions# iand DF_SORT_OPTION_BAD_DATA_FIXUP) move 1 to itm#
81263>>>>>//  if (oVdfSort_SortOptions# iand DF_SORT_OPTION_BAD_DATA_FILE ) move 2 to itm#
81263>>>>>//  if (oVdfSort_SortOptions# iand DF_SORT_OPTION_BAD_DATA_ABORT) move 3 to itm#
81263>>>>>//  set current_radio of (oRadio1(self)) to itm#
81263>>>>>//  move 0 to itm#
81263>>>>>//  if (oVdfSort_SortOptions# iand DF_SORT_OPTION_DUP_DATA_FILE ) move 0 to itm#
81263>>>>>//  if (oVdfSort_SortOptions# iand DF_SORT_OPTION_DUP_DATA_ABORT) move 1 to itm#
81263>>>>>//  set current_radio of (oRadio2(self)) to itm#
81263>>>>>//
81263>>>>>//  call_driver iNull "DATAFLEX" function FLEX_GET_MAX_SORT_BUFFER callback iNull passing sNull iNull iNull result buffer#
81263>>>>>//  set value of (oSortBufferSize(self)) item 0 to buffer#
81263>>>>>//
81263>>>>>//  set pResult to false
81263>>>>>//  forward send popup
81263>>>>>//  if (pResult(self)) begin
81263>>>>>//    move 0 to oVdfSort_SortOptions#
81263>>>>>//    get current_radio of (oRadio1(self)) to itm#
81263>>>>>//    if itm# eq 0 move DF_SORT_OPTION_NO_DATA_CHECK  to oVdfSort_SortOptions#
81263>>>>>//    if itm# eq 1 move DF_SORT_OPTION_BAD_DATA_FIXUP to oVdfSort_SortOptions#
81263>>>>>//    if itm# eq 2 move DF_SORT_OPTION_BAD_DATA_FILE  to oVdfSort_SortOptions#
81263>>>>>//    if itm# eq 3 move DF_SORT_OPTION_BAD_DATA_ABORT to oVdfSort_SortOptions#
81263>>>>>//    get current_radio of (oRadio2(self)) to itm#
81263>>>>>//    if itm# eq 0 move (DF_SORT_OPTION_DUP_DATA_FILE +oVdfSort_SortOptions#) to oVdfSort_SortOptions#
81263>>>>>//    if itm# eq 1 move (DF_SORT_OPTION_DUP_DATA_ABORT+oVdfSort_SortOptions#) to oVdfSort_SortOptions#
81263>>>>>//
81263>>>>>//    get value of (oSortBufferSize(self)) item 0 to buffer#
81263>>>>>//    call_driver iNull "DATAFLEX" function FLEX_SET_MAX_SORT_BUFFER callback iNull passing sNull iNull buffer# result grb#
81263>>>>>//  end
81263>>>>>//end_procedure
81263>>>>>end_object //oSortUtil_Prop_Pn
81264>>>>>
81264>>>>>Use Aps
81264>>>>>Use RGB.utl      // Some color functions
81264>>>>>class cSortUtilList is a aps.Grid
81265>>>>>  procedure construct_object integer img#
81267>>>>>    forward send construct_object img#
81269>>>>>    property integer piReIndexerObject public gloReIndexer# // Global integer defined in SortUtil.utl
81270>>>>>    send GridPrepare_AddCheckBoxColumn
81271>>>>>    send GridPrepare_AddColumn "Table"  AFT_ASCII60
81272>>>>>    send GridPrepare_AddColumn "Status" AFT_ASCII12
81273>>>>>    send GridPrepare_Apply self
81274>>>>>    set select_mode to MULTI_SELECT
81275>>>>>    set highlight_row_state to true
81276>>>>>    on_key KNEXT_ITEM     send switch
81277>>>>>    on_key KPREVIOUS_ITEM send switch_back
81278>>>>>  end_procedure
81279>>>>>
81279>>>>>  procedure select_toggling integer itm# integer i#
81281>>>>>    integer ci# iColumns
81281>>>>>    get Grid_Columns self to iColumns
81282>>>>>    get current_item to ci#
81283>>>>>    move ((ci#/iColumns)*iColumns) to ci# // Redirect to first column
81284>>>>>    forward send select_toggling ci# i#
81286>>>>>  end_procedure
81287>>>>>
81287>>>>>  procedure fill_list
81289>>>>>    integer iObj iRow iMax iBase
81289>>>>>    send delete_data
81290>>>>>    set dynamic_update_state to false
81291>>>>>    get piReIndexerObject to iObj
81292>>>>>    get row_count of iObj to iMax
81293>>>>>    decrement iMax
81294>>>>>    for iRow from 0 to iMax
81300>>>>>>
81300>>>>>      get item_count to iBase
81301>>>>>      send Grid_AddCheckBoxItem self DFTRUE
81302>>>>>      set aux_value item iBase to iRow
81303>>>>>      send add_item msg_none (psRootName.i(iObj,iRow))
81304>>>>>      send add_item msg_none (SU_TableStatusText(piStatus.i(iObj,iRow)))
81305>>>>>    loop
81306>>>>>>
81306>>>>>    send Grid_SetEntryState self DFFALSE
81307>>>>>    set dynamic_update_state to true
81308>>>>>    send update_total (iMax+1)
81309>>>>>  end_procedure
81310>>>>>
81310>>>>>  procedure update_total integer iItemsInList
81312>>>>>  end_procedure
81313>>>>>
81313>>>>>  procedure DoSort_Help integer iRow integer iBase
81315>>>>>    send Add_Rootname to (piReIndexerObject(self)) (value(self,iBase+1))
81316>>>>>  end_procedure
81317>>>>>
81317>>>>>  procedure DoProperties
81319>>>>>    send popup to (oSortUtil_Prop_Pn(self))
81320>>>>>  end_procedure
81321>>>>>
81321>>>>>  procedure DoSort
81323>>>>>    integer iCallBackTmp iReIndexerObject
81323>>>>>    get piReIndexerObject to iReIndexerObject
81324>>>>>    get piCallbackObj of iReIndexerObject to iCallBackTmp
81325>>>>>    set piCallbackObj of iReIndexerObject to (oWaitWhileReindexing(self))
81326>>>>>    send Start_StatusPanel to (oWaitWhileReindexing(self))
81327>>>>>    send reset to iReIndexerObject
81328>>>>>    send Grid_RowCallBackSelected self msg_DoSort_Help
81329>>>>>    send DoSort to iReIndexerObject
81330>>>>>    send Stop_StatusPanel to (oWaitWhileReindexing(self))
81331>>>>>    send fill_list
81332>>>>>    set piCallbackObj of iReIndexerObject to iCallBackTmp
81333>>>>>  end_procedure
81334>>>>>  procedure Reset
81336>>>>>    send reset to (piReIndexerObject(self))
81337>>>>>    send fill_list
81338>>>>>  end_procedure
81339>>>>>end_class // cSortUtilList
81340>>>>>
81340>>>>>
81340>>>Use Spec0011.utl // Floating menues on the fly
81340>>>Use API_Attr.utl // Functions for querying API attributes
81340>>>Use Files.utl    // Utilities for handling file related stuff
81340>>>
/SORTUTIL.VW.INTRO
Image 20, SORTUTIL.VW.INTRO
 $Title$ Reindexing of tables
 With this utility you may reindex tables
/*
81340>>>
81340>>>activate_view Activate_SortUtil_Vw for oSortUtil_Vw
81345>>>object oSortUtil_Vw is a aps.View label "Reindexing of tables"
81348>>>  on_key KCANCEL send close_panel
81349>>>  object oLst is a cSortUtilList
81351>>>    set size to 225 0
81352>>>    register_object oTotal
81352>>>    procedure update_total integer iItemsInList
81355>>>      set value of (oTotal(self)) to (string(iItemsInList)+" tables")
81356>>>    end_procedure
81357>>>  end_object
81358>>>  object oTotal is a aps.TextBox label "" snap SL_DOWN
81362>>>    set fixed_size to 12 60
81363>>>    set justification_mode to JMODE_LEFT
81364>>>  end_object
81365>>>  send update_total to (oLst(self)) 0
81366>>>  procedure DoSortTables
81369>>>    send DoSort to (oLst(self))
81370>>>  end_procedure
81371>>>  procedure DoGetTablesSelector_Help integer iFile integer iSelected integer iShaded
81374>>>    string sRoot
81374>>>    get API_AttrValue_FILELIST DF_FILE_ROOT_NAME iFile to sRoot
81375>>>    send SU_Add_Rootname sRoot
81376>>>  end_procedure
81377>>>  procedure DoGetTablesSelector
81380>>>    send cursor_wait to (cursor_control(self))
81381>>>    send DFMatrix_CallBack_Selected_Files msg_DoGetTablesSelector_Help self 1 0 1
81382>>>    send fill_list to (oLst(self))
81383>>>    send cursor_ready to (cursor_control(self))
81384>>>  end_procedure
81385>>>  procedure DoGetTablesDirectories
81388>>>    string sDir
81388>>>    get SEQ_SelectDirectory "Select directory structure" to sDir
81389>>>    if sDir ne "" begin
81391>>>      send cursor_wait to (cursor_control(self))
81392>>>      send SU_Add_RootNamesInDirectories sDir
81393>>>      send fill_list to (oLst(self))
81394>>>    send cursor_ready to (cursor_control(self))
81395>>>    end
81395>>>>
81395>>>  end_procedure
81396>>>  procedure DoGetTablesDirectory
81399>>>    string sDir
81399>>>    get SEQ_SelectDirectory "Select directory" to sDir
81400>>>    if sDir ne "" begin
81402>>>      send cursor_wait to (cursor_control(self))
81403>>>      send SU_Add_RootNamesInDirectory sDir
81404>>>      send fill_list to (oLst(self))
81405>>>      send cursor_ready to (cursor_control(self))
81406>>>    end
81406>>>>
81406>>>  end_procedure
81407>>>  procedure DoGetTablesAllWS
81410>>>    string sDir
81410>>>    send cursor_wait to (cursor_control(self))
81411>>>    get_profile_string "defaults" "VDFRootDir" to sDir
81414>>>    send SU_Add_RootNamesInAllWS
81415>>>    send SU_Add_RootNamesInDirectories sDir
81416>>>    send fill_list to (oLst(self))
81417>>>    send cursor_ready to (cursor_control(self))
81418>>>  end_procedure
81419>>>  procedure DoGetTableBrowse
81422>>>    string sRoot
81422>>>    get SEQ_SelectInFile "Select data file" "DAT files|*.dat" to sRoot
81423>>>    if sRoot ne "" begin
81425>>>      send SU_Add_Rootname sRoot
81426>>>      send fill_list to (oLst(self))
81427>>>    end
81427>>>>
81427>>>  end_procedure
81428>>>  procedure DoProperties
81431>>>    send DoProperties to (oLst(self))
81432>>>  end_procedure
81433>>>  procedure DoReset
81436>>>    send reset to (oLst(self))
81437>>>  end_procedure
81438>>>  object oBtn1 is a aps.Multi_Button
81440>>>    procedure PopupFM
81443>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesSelector    "Get tables from table selector"
81444>>>      send FLOATMENU_PrepareAddItem msg_DoGetTableBrowse       "Browse for one table"
81445>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesDirectory   "Get all tables in folder"
81446>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesDirectories "Get all tables in folder and below"
81447>>>      send FLOATMENU_PrepareAddItem msg_DoGetTablesAllWS       "Get tables from all Work Spaces"
81448>>>      send popup to (FLOATMENU_Apply(self))
81449>>>    end_procedure
81450>>>    on_item "Add tables"  send PopupFM
81451>>>  end_object
81452>>>  object oBtn2 is a aps.Multi_Button
81454>>>    on_item "Sort tables" send DoSortTables
81455>>>  end_object
81456>>>  object oBtn3 is a aps.Multi_Button
81458>>>    on_item "Reset list"  send DoReset
81459>>>  end_object
81460>>>//object oBtn4 is a aps.Multi_Button
81460>>>//  on_item "Properties" send DoProperties
81460>>>//end_object
81460>>>  object oBtn5 is a aps.Multi_Button
81462>>>    on_item "Close" send close_panel
81463>>>  end_object
81464>>>  send aps_locate_multi_buttons
81465>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
81466>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
81469>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
81470>>>    send aps_auto_locate_control (oTotal(self)) SL_DOWN (oLst(self))
81471>>>    send aps_register_multi_button (oBtn1(self))
81472>>>    send aps_register_multi_button (oBtn2(self))
81473>>>    send aps_register_multi_button (oBtn3(self))
81474>>>//  send aps_register_multi_button (oBtn4(self))
81474>>>    send aps_register_multi_button (oBtn5(self))
81475>>>    send aps_locate_multi_buttons
81476>>>    send aps_auto_size_container
81477>>>  end_procedure
81478>>>end_object
81479>    Use DirComp.vw   // Activate_Dircomp
Including file: dircomp.vw    (C:\Apps\VDFQuery\AppSrc\dircomp.vw)
81479>>>// Use DirComp.vw   // Activate_Dircomp_Vw
81479>>>
/DIRCOMP.VW.INTRO
Image 21, DIRCOMP.VW.INTRO
 $Title$ Comparing directory contents
 With this utility you may compare two folders. Either or both
 folders may be updated with the newest version of each file.
 This function is a stand-alone utility that does not interact with any
 other functions in DFMatrix. Consequently, it does not care what you
 have loaded in the table selector, or which work space (VDF) you may
 have selected.
/*
81479>>>
81479>>>Use DirComp.pkg  // List class for comparing directory contents (cDirCompList)
Including file: dircomp.pkg    (C:\Apps\VDFQuery\AppSrc\dircomp.pkg)
81479>>>>>// Use DirComp.pkg  // List class for comparing directory contents (cDirCompList)
81479>>>>>Use DirComp.nui  // Compare directory contents
Including file: dircomp.nui    (C:\Apps\VDFQuery\AppSrc\dircomp.nui)
81479>>>>>>>// Use DirComp.nui  // Compare (and update) directory contents
81479>>>>>>>
81479>>>>>>>Use Compare.nui  // Abstract class for comparing item based information
81479>>>>>>>Use SetDir.nui   // cSetOfDirectories class
Including file: setdir.nui    (C:\Apps\VDFQuery\AppSrc\setdir.nui)
81479>>>>>>>>>// Use SetDir.nui   // cSetOfDirectories class
81479>>>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
81479>>>>>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
81479>>>>>>>>>Use WildCard.nui // WildCardMatch function
81479>>>>>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
81479>>>>>>>>>Use ItemProp.nui // ITEM_PROPERTY command for use within arrays
Including file: itemprop.nui    (C:\Apps\VDFQuery\AppSrc\itemprop.nui)
81479>>>>>>>>>>>// Use ItemProp.nui // ITEM_PROPERTY command for use within arrays
81479>>>>>>>>>>>
81479>>>>>>>>>>>Use Strings.nui  // String manipulation for VDF
81479>>>>>>>>>>>Use Set.utl      // cArray, cSet and cStack classes
81479>>>>>>>>>>>Use Array.nui    // Item_Property command (No User Interface)
81479>>>>>>>>>>>
81479>>>>>>>>>>>// ************************************************
81479>>>>>>>>>>>// From here on down to the last couple of lines
81479>>>>>>>>>>>// is just one big private interface
81479>>>>>>>>>>>// ************************************************
81479>>>>>>>>>>>
81479>>>>>>>>>>>function SortValue_Number global number lnValue returns string
81481>>>>>>>>>>>  integer lbNeg
81481>>>>>>>>>>>  string lsValue
81481>>>>>>>>>>>  move (lnValue<0) to lbNeg
81482>>>>>>>>>>>  if lbNeg move (abs(lnValue)) to lnValue
81485>>>>>>>>>>>  get NumToStrR lnValue 8 23 to lsValue
81486>>>>>>>>>>>  // We use blank (for minus) and plus to make it sort right
81486>>>>>>>>>>>  // (and we need to move the sign to the end to make it work)
81486>>>>>>>>>>>  if lbNeg begin
81488>>>>>>>>>>>    get String_NegateSortOrder lsValue to lsValue
81489>>>>>>>>>>>    move (" "+lsValue) to lsValue
81490>>>>>>>>>>>  end
81490>>>>>>>>>>>>
81490>>>>>>>>>>>  else     move ("+"+lsValue) to lsValue
81492>>>>>>>>>>>  function_return lsValue
81493>>>>>>>>>>>end_function
81494>>>>>>>>>>>function SortValue_Real global real lrValue returns string
81496>>>>>>>>>>>  string lsSortValue lsExponent
81496>>>>>>>>>>>  move lrValue to lsSortValue
81497>>>>>>>>>>>  move (ExtractWord(lsSortValue,"e",2)) to lsExponent
81498>>>>>>>>>>>  if lsExponent ne "" replace ("e"+lsExponent) in lsSortValue with ""
81502>>>>>>>>>>>  else move "    " to lsSortValue
81504>>>>>>>>>>>  function_return (append(lsExponent,lsSortValue))
81505>>>>>>>>>>>end_function
81506>>>>>>>>>>>function SortValue_Date global date ldValue returns string
81508>>>>>>>>>>>  function_return (NumToStrR(integer(ldValue),0,6))
81509>>>>>>>>>>>end_function
81510>>>>>>>>>>>function SortValue_Integer global integer liValue returns string
81512>>>>>>>>>>>  integer lbNeg
81512>>>>>>>>>>>  string lsValue
81512>>>>>>>>>>>  move (liValue<0) to lbNeg
81513>>>>>>>>>>>  if lbNeg move (abs(liValue)) to liValue
81516>>>>>>>>>>>  get NumToStrR liValue 0 10 to lsValue
81517>>>>>>>>>>>  // We use blank (for minus) and plus to make it sort right
81517>>>>>>>>>>>  // (and we need to move the sign to the end to make it work)
81517>>>>>>>>>>>  if lbNeg begin
81519>>>>>>>>>>>    get String_NegateSortOrder lsValue to lsValue
81520>>>>>>>>>>>    move (" "+lsValue) to lsValue
81521>>>>>>>>>>>  end
81521>>>>>>>>>>>>
81521>>>>>>>>>>>  else     move ("+"+lsValue) to lsValue
81523>>>>>>>>>>>  function_return lsValue
81524>>>>>>>>>>>end_function
81525>>>>>>>>>>>
81525>>>>>>>>>>>function SortValueAuto global integer liType string lsValue returns string
81527>>>>>>>>>>>  if liType eq ITMP_INTEGER function_return (SortValue_Integer(lsValue))
81530>>>>>>>>>>>  if liType eq ITMP_STRING  function_return (lsValue+" ")
81533>>>>>>>>>>>  if liType eq ITMP_REAL    function_return (SortValue_Real(lsValue))
81536>>>>>>>>>>>  if liType eq ITMP_NUMBER  function_return (SortValue_Number(lsValue))
81539>>>>>>>>>>>  if liType eq ITMP_DATE    function_return (SortValue_Date(lsValue))
81542>>>>>>>>>>>end_function
81543>>>>>>>>>>>
81543>>>>>>>>>>>function SortValue_ToNumber global string lsValue returns number
81545>>>>>>>>>>>  function_return (number(trim(lsValue)))
81546>>>>>>>>>>>end_function
81547>>>>>>>>>>>function SortValue_ToReal global string lsValue returns real
81549>>>>>>>>>>>  string lsExponent
81549>>>>>>>>>>>  move (left(lsValue,4)) to lsExponent
81550>>>>>>>>>>>  replace lsExponent in lsValue with ""
81552>>>>>>>>>>>  if lsExponent eq "" function_return (real(lsValue))
81555>>>>>>>>>>>  function_return (real(lsValue+"e"+lsExponent))
81556>>>>>>>>>>>end_function
81557>>>>>>>>>>>function SortValue_ToDate global string lsValue returns date
81559>>>>>>>>>>>  function_return (date(trim(lsValue)))
81560>>>>>>>>>>>end_function
81561>>>>>>>>>>>function SortValue_ToInteger global string lsValue returns integer
81563>>>>>>>>>>>  function_return (integer(trim(lsValue)))
81564>>>>>>>>>>>end_function
81565>>>>>>>>>>>
81565>>>>>>>>>>>desktop_section
81570>>>>>>>>>>>  object ITMP_DataArray is a cArray
81572>>>>>>>>>>>  end_object
81573>>>>>>>>>>>  object ITMP_SortArray is a cArray
81575>>>>>>>>>>>  end_object
81576>>>>>>>>>>>  object ITMP_SortSegments is a cArray
81578>>>>>>>>>>>    property integer pbDescending public 0
81580>>>>>>>>>>>    item_property_list // See? It's taking its own medicine!
81580>>>>>>>>>>>      item_property integer piColumn.i
81580>>>>>>>>>>>      item_property integer piType.i
81580>>>>>>>>>>>      item_property integer pbUppercase.i
81580>>>>>>>>>>>    end_item_property_list
#REM 81620 DEFINE FUNCTION PBUPPERCASE.I INTEGER LIROW RETURNS INTEGER
#REM 81625 DEFINE PROCEDURE SET PBUPPERCASE.I INTEGER LIROW INTEGER VALUE
#REM 81630 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 81635 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
#REM 81640 DEFINE FUNCTION PICOLUMN.I INTEGER LIROW RETURNS INTEGER
#REM 81645 DEFINE PROCEDURE SET PICOLUMN.I INTEGER LIROW INTEGER VALUE
81651>>>>>>>>>>>    register_function item_property_type integer liColumn returns integer
81651>>>>>>>>>>>    procedure DoColumnTypes integer lhObj
81654>>>>>>>>>>>      integer liMax liRow
81654>>>>>>>>>>>      get row_count to liMax
81655>>>>>>>>>>>      decrement liMax
81656>>>>>>>>>>>      for liRow from 0 to liMax
81662>>>>>>>>>>>>
81662>>>>>>>>>>>        set piType.i liRow to (item_property_type(lhObj,piColumn.i(self,liRow)))
81663>>>>>>>>>>>      loop
81664>>>>>>>>>>>>
81664>>>>>>>>>>>    end_procedure
81665>>>>>>>>>>>    procedure DoSortData integer lhObj
81668>>>>>>>>>>>      integer lhData lhSort liColumnCount liDataRowCount liDataRow
81668>>>>>>>>>>>      integer liColumn liType liRow liMaxSegment liSegment lbUppercase
81668>>>>>>>>>>>      string lsSortValue
81668>>>>>>>>>>>      move (ITMP_DataArray(self)) to lhData
81669>>>>>>>>>>>      move (ITMP_SortArray(self)) to lhSort
81670>>>>>>>>>>>      send delete_data to lhData
81671>>>>>>>>>>>      send delete_data to lhSort
81672>>>>>>>>>>>
81672>>>>>>>>>>>      send DoColumnTypes lhObj
81673>>>>>>>>>>>
81673>>>>>>>>>>>      get column_count of lhObj to liColumnCount
81674>>>>>>>>>>>      send Clone_Array lhObj lhData
81675>>>>>>>>>>>
81675>>>>>>>>>>>      get row_count of lhObj to liDataRowCount
81676>>>>>>>>>>>      decrement liDataRowCount
81677>>>>>>>>>>>
81677>>>>>>>>>>>      if (row_count(self)=1) begin // Fast
81679>>>>>>>>>>>        get piColumn.i 0 to liColumn
81680>>>>>>>>>>>        get piType.i 0 to liType
81681>>>>>>>>>>>        get pbUppercase.i 0 to lbUppercase
81682>>>>>>>>>>>        for liRow from 0 to liDataRowCount
81688>>>>>>>>>>>>
81688>>>>>>>>>>>          get SortValueAuto liType (value(lhObj,liRow*liColumnCount+liColumn)) to lsSortValue
81689>>>>>>>>>>>          if lbUppercase move (uppercase(lsSortValue)) to lsSortValue
81692>>>>>>>>>>>          set value of lhSort item liRow to (lsSortValue+pad(string(liRow),10))
81693>>>>>>>>>>>        loop
81694>>>>>>>>>>>>
81694>>>>>>>>>>>      end
81694>>>>>>>>>>>>
81694>>>>>>>>>>>      else begin // Not so fast
81695>>>>>>>>>>>        get row_count to liMaxSegment
81696>>>>>>>>>>>        decrement liMaxSegment
81697>>>>>>>>>>>        for liRow from 0 to liDataRowCount
81703>>>>>>>>>>>>
81703>>>>>>>>>>>          move "" to lsSortValue
81704>>>>>>>>>>>          for liSegment from 0 to liMaxSegment
81710>>>>>>>>>>>>
81710>>>>>>>>>>>            get piColumn.i liSegment to liColumn
81711>>>>>>>>>>>            get piType.i liSegment to liType
81712>>>>>>>>>>>            get pbUppercase.i liSegment to lbUppercase
81713>>>>>>>>>>>            if lbUppercase ;              move (lsSortValue+uppercase(SortValueAuto(liType,value(lhObj,liRow*liColumnCount+liColumn)))) to lsSortValue
81716>>>>>>>>>>>            else ;              move (lsSortValue+SortValueAuto(liType,value(lhObj,liRow*liColumnCount+liColumn))) to lsSortValue
81718>>>>>>>>>>>          loop
81719>>>>>>>>>>>>
81719>>>>>>>>>>>          set value of lhSort item liRow to (lsSortValue+pad(string(liRow),10))
81720>>>>>>>>>>>        loop
81721>>>>>>>>>>>>
81721>>>>>>>>>>>      end
81721>>>>>>>>>>>>
81721>>>>>>>>>>>
81721>>>>>>>>>>>      if (pbDescending(self)) send sort_items to lhSort DESCENDING
81724>>>>>>>>>>>      else send sort_items to lhSort
81726>>>>>>>>>>>      set pbDescending to DFFALSE
81727>>>>>>>>>>>
81727>>>>>>>>>>>      // Put the data back:
81727>>>>>>>>>>>      for liRow from 0 to liDataRowCount
81733>>>>>>>>>>>>
81733>>>>>>>>>>>        get value of lhSort item liRow to lsSortValue
81734>>>>>>>>>>>        move (right(lsSortValue,10)) to liDataRow
81735>>>>>>>>>>>        for liColumn from 0 to (liColumnCount-1)
81741>>>>>>>>>>>>
81741>>>>>>>>>>>          set value of lhObj item (liRow*liColumnCount+liColumn) to (value(lhData,liDataRow*liColumnCount+liColumn))
81742>>>>>>>>>>>        loop
81743>>>>>>>>>>>>
81743>>>>>>>>>>>      loop
81744>>>>>>>>>>>>
81744>>>>>>>>>>>      send delete_data to lhData
81745>>>>>>>>>>>      send delete_data to lhSort
81746>>>>>>>>>>>    end_procedure
81747>>>>>>>>>>>  end_object
81748>>>>>>>>>>>end_desktop_section
81753>>>>>>>>>>>
81753>>>>>>>>>>>procedure ITMP_Sort_DoReset global
81755>>>>>>>>>>>  send delete_data to (ITMP_SortSegments(self))
81756>>>>>>>>>>>  set pbDescending of (ITMP_SortSegments(self)) to DFFALSE
81757>>>>>>>>>>>end_procedure
81758>>>>>>>>>>>procedure ITMP_Sort_DoAddSegment global integer liColumn integer lbUppercase
81760>>>>>>>>>>>  integer lbTemp liRow
81760>>>>>>>>>>>  if (NUM_ARGUMENTS>1) move lbUppercase to lbTemp
81763>>>>>>>>>>>  else move DFFALSE to lbTemp
81765>>>>>>>>>>>  get row_count of (ITMP_SortSegments(self)) to liRow
81766>>>>>>>>>>>  set piColumn.i of (ITMP_SortSegments(self)) liRow to liColumn
81767>>>>>>>>>>>  set pbUppercase.i of (ITMP_SortSegments(self)) liRow to lbTemp
81768>>>>>>>>>>>end_procedure
81769>>>>>>>>>>>procedure ITMP_Sort_DoSortData global integer lhObj
81771>>>>>>>>>>>  send DoSortData to (ITMP_SortSegments(self)) lhObj
81772>>>>>>>>>>>end_procedure
81773>>>>>>>>>>>
81773>>>>>>>>>>>// **************************
81773>>>>>>>>>>>// Last couple of lines:
81773>>>>>>>>>>>// **************************
81773>>>>>>>>>>>
81773>>>>>>>>>>>// To sort the rows of an item_property array by the value
81773>>>>>>>>>>>// of the first subsequently the third "column",
81773>>>>>>>>>>>//
81773>>>>>>>>>>>//  send sort_rows of oMyArray 0 2
81773>>>>>>>>>>>//
81773>>>>>>>>>>>procedure sort_rows for Array integer liTemp // Actually takes a variable count of parameters
81775>>>>>>>>>>>  integer liArg liColumn
81775>>>>>>>>>>>  send ITMP_Sort_DoReset
81776>>>>>>>>>>>  for liArg from 1 to num_arguments
81782>>>>>>>>>>>>
81782>>>>>>>>>>>    move liArg& to liColumn // tricky way to parse passed arguments
81783>>>>>>>>>>>    send ITMP_Sort_DoAddSegment liColumn
81784>>>>>>>>>>>  loop
81785>>>>>>>>>>>>
81785>>>>>>>>>>>  send ITMP_Sort_DoSortData self
81786>>>>>>>>>>>end_procedure
81787>>>>>>>>>>>
81787>>>>>>>>>>>// Does the same as the one above, but sorts the rows of the array in
81787>>>>>>>>>>>// descending order:
81787>>>>>>>>>>>procedure sort_rows_descending for Array integer liTemp // Variable parameter count
81789>>>>>>>>>>>  integer liArg liColumn
81789>>>>>>>>>>>  send ITMP_Sort_DoReset
81790>>>>>>>>>>>  set pbDescending of (ITMP_SortSegments(self)) to DFTRUE
81791>>>>>>>>>>>  for liArg from 1 to num_arguments
81797>>>>>>>>>>>>
81797>>>>>>>>>>>    move liArg& to liColumn // tricky way to parse passed arguments
81798>>>>>>>>>>>    send ITMP_Sort_DoAddSegment liColumn
81799>>>>>>>>>>>  loop
81800>>>>>>>>>>>>
81800>>>>>>>>>>>  send ITMP_Sort_DoSortData self
81801>>>>>>>>>>>end_procedure
81802>>>>>>>>>
81802>>>>>>>>>//  cSetOfDirectories, public interface:
81802>>>>>>>>>//  ------------------------------------
81802>>>>>>>>>//
81802>>>>>>>>>//  Reset the array
81802>>>>>>>>>//    procedure DoReset
81802>>>>>>>>>//
81802>>>>>>>>>//  Add a directory
81802>>>>>>>>>//    procedure DoAddDirectory string lsDir
81802>>>>>>>>>//
81802>>>>>>>>>//  Add a number of directories
81802>>>>>>>>>//    procedure DoAddSearchPath string lsPath
81802>>>>>>>>>//
81802>>>>>>>>>//  Add a directory and all its subdirectories
81802>>>>>>>>>//    procedure DoAddSubDirectories string lsDir
81802>>>>>>>>>//
81802>>>>>>>>>//  Remove a directory from the list
81802>>>>>>>>>//    procedure DoRemoveDirectory string lsDir
81802>>>>>>>>>//
81802>>>>>>>>>//  Search for a file (mask) in all directories and call back. Parameter
81802>>>>>>>>>//  lsFileMask determines whether the same file name is called back more
81802>>>>>>>>>//  than once (if present in more than one directory)
81802>>>>>>>>>//    procedure DoFindFileCallback string lsFileMask integer lbFirstOnly ;
81802>>>>>>>>>//                                        integer liMsg integer liObj
81802>>>>>>>>>//
81802>>>>>>>>>//  Search for all files included by a mask in a set of masks. Such a set
81802>>>>>>>>>//  must be defined using the cSetOfMasks class defined in WildCard.nui
81802>>>>>>>>>//
81802>>>>>>>>>//    procedure DoFindFileBySetOfMasksCallback integer lhSetOfMasks ;
81802>>>>>>>>>//                         integer lbFirstOnly integer liMsg integer liObj
81802>>>>>>>>>//
81802>>>>>>>>>//  Search for all source files included by compiler in a *.PR? file
81802>>>>>>>>>//  ("WebApp.prn" for example)
81802>>>>>>>>>//
81802>>>>>>>>>//    procedure DoFindFilesCompilerListingCallback string lsPrnFile ;
81802>>>>>>>>>//                         integer lbFirstOnly integer liMsg integer liObj
81802>>>>>>>>>//
81802>>>>>>>>>class cSetOfDirectories is a cArray
81803>>>>>>>>>  procedure construct_object integer liImage
81805>>>>>>>>>    forward send construct_object liImage
81807>>>>>>>>>    property integer piCbMessage   public 0
81808>>>>>>>>>    property integer piCbObject    public 0
81809>>>>>>>>>    property integer pbCbFirstOnly public DFFALSE
81810>>>>>>>>>    object oDirStackTmp is a cStack NO_IMAGE
81812>>>>>>>>>    end_object
81813>>>>>>>>>    object oDirTmp is a cArray NO_IMAGE
81815>>>>>>>>>    end_object
81816>>>>>>>>>    object oFileNameSet is a cSet NO_IMAGE
81818>>>>>>>>>    end_object
81819>>>>>>>>>    object oWildCardMatcherArray is a cWildCardMatcherArray NO_IMAGE
81821>>>>>>>>>    end_object
81822>>>>>>>>>    property integer pi.prv.SuspendSentinelUpdate public DFFALSE
81823>>>>>>>>>  end_procedure
81824>>>>>>>>>
81824>>>>>>>>>  procedure OnWait_On string lsCaption
81826>>>>>>>>>  end_procedure
81827>>>>>>>>>  procedure OnWait_SetText1 string lsValue
81829>>>>>>>>>  end_procedure
81830>>>>>>>>>  procedure OnWait_SetText2 string lsValue
81832>>>>>>>>>  end_procedure
81833>>>>>>>>>  procedure OnWait_Off
81835>>>>>>>>>  end_procedure
81836>>>>>>>>>
81836>>>>>>>>>  procedure DoReset
81838>>>>>>>>>    send delete_data
81839>>>>>>>>>  end_procedure
81840>>>>>>>>>
81840>>>>>>>>>            function iFindDir.s string lsDir returns integer
81842>>>>>>>>>              integer liMax liItem
81842>>>>>>>>>              move (lowercase(trim(lsDir))) to lsDir
81843>>>>>>>>>              get item_count to liMax
81844>>>>>>>>>              decrement liMax
81845>>>>>>>>>              for liItem from 0 to liMax
81851>>>>>>>>>>
81851>>>>>>>>>                if (lowercase(value(self,liItem))=lsDir) function_return liItem
81854>>>>>>>>>              loop
81855>>>>>>>>>>
81855>>>>>>>>>              function_return -1
81856>>>>>>>>>            end_function
81857>>>>>>>>>
81857>>>>>>>>>  procedure DoRemoveDirectory string lsDir
81859>>>>>>>>>    integer liItem
81859>>>>>>>>>    get iFindDir.s lsDir to liItem
81860>>>>>>>>>    if (liItem<>-1) send delete_item liItem
81863>>>>>>>>>  end_procedure
81864>>>>>>>>>
81864>>>>>>>>>  procedure DoAddDirectory string lsDir
81866>>>>>>>>>    integer liItem
81866>>>>>>>>>    move (trim(lsDir)) to lsDir
81867>>>>>>>>>    get SEQ_TranslatePathToAbsolute lsDir to lsDir
81868>>>>>>>>>    get iFindDir.s lsDir to liItem
81869>>>>>>>>>    if (liItem=-1) set value item (item_count(self)) to lsDir
81872>>>>>>>>>  end_procedure
81873>>>>>>>>>
81873>>>>>>>>>  procedure DoAddSearchPath string lsPath
81875>>>>>>>>>    send SEQ_CallBack_DirsInPath lsPath msg_DoAddDirectory self
81876>>>>>>>>>  end_procedure
81877>>>>>>>>>
81877>>>>>>>>>            procedure AddSubDirectories_Help3 string lsDir
81879>>>>>>>>>              integer lhDirTmp
81879>>>>>>>>>              move (oDirTmp(self)) to lhDirTmp
81880>>>>>>>>>              set value of lhDirTmp item (item_count(lhDirTmp)) to lsDir
81881>>>>>>>>>              send OnWait_SetText2 lsDir
81882>>>>>>>>>            end_procedure
81883>>>>>>>>>            procedure AddSubDirectories_Help2 string lsDir string lsPath
81885>>>>>>>>>              if (lsDir<>"[.]" and lsDir<>"[..]") begin
81887>>>>>>>>>                replace "[" in lsDir with ""
81889>>>>>>>>>                replace "]" in lsDir with ""
81891>>>>>>>>>                move (SEQ_ComposeAbsoluteFileName(lsPath,lsDir)) to lsPath
81892>>>>>>>>>                send push.s to (oDirStackTmp(self)) lsPath
81893>>>>>>>>>                send AddSubDirectories_Help3 (SEQ_TranslatePathToAbsolute(lsPath))
81894>>>>>>>>>              end
81894>>>>>>>>>>
81894>>>>>>>>>            end_procedure
81895>>>>>>>>>            procedure AddSubDirectories_Help1 string lsDir
81897>>>>>>>>>              integer lhDirStack liItmStart liItmStop liItem
81897>>>>>>>>>              move (oDirStackTmp(self)) to lhDirStack
81898>>>>>>>>>              get item_count of lhDirStack to liItmStart
81899>>>>>>>>>              send SEQ_Load_ItemsInDir lsDir
81900>>>>>>>>>              send SEQ_CallBack_ItemsInDir SEQCB_DIRS_ONLY msg_AddSubDirectories_Help2 self
81901>>>>>>>>>              get item_count of lhDirStack to liItmStop
81902>>>>>>>>>              for liItem from liItmStart to (liItmStop-1)
81908>>>>>>>>>>
81908>>>>>>>>>                send AddSubDirectories_Help1 (sPop(lhDirStack))
81909>>>>>>>>>              loop
81910>>>>>>>>>>
81910>>>>>>>>>            end_procedure
81911>>>>>>>>>
81911>>>>>>>>>  procedure DoAddSubDirectories string lsDir
81913>>>>>>>>>    integer lhDirTmp liMax liItem
81913>>>>>>>>>    send OnWait_On "Adding sub-folders"
81914>>>>>>>>>    move (oDirTmp(self)) to lhDirTmp
81915>>>>>>>>>    send delete_data to lhDirTmp
81916>>>>>>>>>    send OnWait_SetText1 "Searching"
81917>>>>>>>>>    send AddSubDirectories_Help3 lsDir
81918>>>>>>>>>    send AddSubDirectories_Help1 lsDir
81919>>>>>>>>>    send OnWait_SetText1 "Sorting..."
81920>>>>>>>>>    send sort_items to lhDirTmp
81921>>>>>>>>>    get item_count of lhDirTmp to liMax
81922>>>>>>>>>    decrement liMax
81923>>>>>>>>>    send OnWait_SetText1 "Writing search result"
81924>>>>>>>>>    send OnWait_SetText2 ""
81925>>>>>>>>>    for liItem from 0 to liMax
81931>>>>>>>>>>
81931>>>>>>>>>      send DoAddDirectory (value(lhDirTmp,liItem))
81932>>>>>>>>>    loop
81933>>>>>>>>>>
81933>>>>>>>>>    send delete_data to lhDirTmp
81934>>>>>>>>>    send OnWait_Off
81935>>>>>>>>>  end_procedure
81936>>>>>>>>>
81936>>>>>>>>>            procedure DoFindFileCallback_Help string lsFileName string lsDir
81938>>>>>>>>>              integer liCbMessage liCbObject
81938>>>>>>>>>              if (iMatch.s(oWildCardMatcherArray(self),lowercase(lsFileName))) begin
81940>>>>>>>>>                if (pbCbFirstOnly(self)) begin
81942>>>>>>>>>                  if (element_find(oFileNameSet(self),lowercase(lsFileName))=-1) begin
81944>>>>>>>>>                    send element_add to (oFileNameSet(self)) (lowercase(lsFileName))
81945>>>>>>>>>                    get piCbMessage to liCbMessage
81946>>>>>>>>>                    get piCbObject  to liCbObject
81947>>>>>>>>>                    send liCbMessage to liCbObject lsFileName lsDir
81948>>>>>>>>>                    send OnWait_SetText2 ("Found "+lsFileName)
81949>>>>>>>>>                  end
81949>>>>>>>>>>
81949>>>>>>>>>                end
81949>>>>>>>>>>
81949>>>>>>>>>                else begin
81950>>>>>>>>>                  get piCbMessage to liCbMessage
81951>>>>>>>>>                  get piCbObject  to liCbObject
81952>>>>>>>>>                  send liCbMessage to liCbObject lsFileName lsDir
81953>>>>>>>>>                  send OnWait_SetText2 ("Found "+lsFileName)
81954>>>>>>>>>                end
81954>>>>>>>>>>
81954>>>>>>>>>              end
81954>>>>>>>>>>
81954>>>>>>>>>            end_procedure
81955>>>>>>>>>
81955>>>>>>>>>  procedure DoFindFileCallback string lsFileMask integer lbFirstOnly integer liMsg integer liObj
81957>>>>>>>>>    integer liMax liItem lhoWildCardMatcherArray liSentinalUpdate
81957>>>>>>>>>    string lsDir lsFileName
81957>>>>>>>>>
81957>>>>>>>>>    move (not(pi.prv.SuspendSentinelUpdate(self))) to liSentinalUpdate
81958>>>>>>>>>
81958>>>>>>>>>    move (oWildCardMatcherArray(self)) to lhoWildCardMatcherArray
81959>>>>>>>>>    send DoReset to lhoWildCardMatcherArray
81960>>>>>>>>>    send BreakDownMask to lhoWildCardMatcherArray (lowercase(lsFileMask))
81961>>>>>>>>>    get item_count to liMax
81962>>>>>>>>>    decrement liMax
81963>>>>>>>>>
81963>>>>>>>>>    if (iAnyWildCards(lhoWildCardMatcherArray)) begin // Wildcard search, slow way
81965>>>>>>>>>      set piCbMessage to liMsg
81966>>>>>>>>>      set piCbObject  to liObj
81967>>>>>>>>>      set pbCbFirstOnly to lbFirstOnly
81968>>>>>>>>>      send delete_data to (oFileNameSet(self))
81969>>>>>>>>>      if liSentinalUpdate send OnWait_On "Find file"
81972>>>>>>>>>      for liItem from 0 to liMax
81978>>>>>>>>>>
81978>>>>>>>>>        if liSentinalUpdate send OnWait_SetText1 lsDir
81981>>>>>>>>>        get value item liItem to lsDir
81982>>>>>>>>>        send SEQ_Load_ItemsInDir lsDir
81983>>>>>>>>>        send SEQ_CallBack_ItemsInDir SEQCB_FILES_ONLY msg_DoFindFileCallback_Help self
81984>>>>>>>>>      loop
81985>>>>>>>>>>
81985>>>>>>>>>      send delete_data to (oFileNameSet(self))
81986>>>>>>>>>      if liSentinalUpdate send OnWait_Off
81989>>>>>>>>>    end
81989>>>>>>>>>>
81989>>>>>>>>>    else begin // No wildcards, fast way
81990>>>>>>>>>      if liSentinalUpdate send OnWait_On "Find file"
81993>>>>>>>>>      for liItem from 0 to liMax
81999>>>>>>>>>>
81999>>>>>>>>>        get value item liItem to lsDir
82000>>>>>>>>>        if liSentinalUpdate send OnWait_SetText1 lsDir
82003>>>>>>>>>        //get SEQ_ComposeAbsoluteFileName lsDir lsFileMask to lsFileName
82003>>>>>>>>>        get Files_AppendPath lsDir lsFileMask to lsFileName
82004>>>>>>>>>        if (SEQ_FileExists(lsFileName)=SEQIT_FILE) begin
82006>>>>>>>>>          if liSentinalUpdate send OnWait_SetText2 lsFileMask
82009>>>>>>>>>          send liMsg to liObj lsFileMask lsDir
82010>>>>>>>>>          if lbFirstOnly begin
82012>>>>>>>>>            if liSentinalUpdate send OnWait_Off
82015>>>>>>>>>            procedure_return
82016>>>>>>>>>          end
82016>>>>>>>>>>
82016>>>>>>>>>        end
82016>>>>>>>>>>
82016>>>>>>>>>      loop
82017>>>>>>>>>>
82017>>>>>>>>>      if liSentinalUpdate send OnWait_Off
82020>>>>>>>>>    end
82020>>>>>>>>>>
82020>>>>>>>>>    send DoReset to lhoWildCardMatcherArray
82021>>>>>>>>>  end_procedure
82022>>>>>>>>>
82022>>>>>>>>>  procedure DoFindFileBySetOfMasksCallback integer lhSetOfMasks integer lbFirstOnly integer liMsg integer liObj
82024>>>>>>>>>    integer lhoWildCardMatcherArray liMax liItem
82024>>>>>>>>>    string lsDir
82024>>>>>>>>>    move (oWildCardMatcherArray(self)) to lhoWildCardMatcherArray
82025>>>>>>>>>    send DoReset to lhoWildCardMatcherArray
82026>>>>>>>>>    set piCbMessage to liMsg
82027>>>>>>>>>    set piCbObject  to liObj
82028>>>>>>>>>    set pbCbFirstOnly to lbFirstOnly
82029>>>>>>>>>    send delete_data to (oFileNameSet(self))
82030>>>>>>>>>    send BreakDownSetOfMasks to lhoWildCardMatcherArray lhSetOfMasks
82031>>>>>>>>>
82031>>>>>>>>>    get item_count to liMax
82032>>>>>>>>>    decrement liMax
82033>>>>>>>>>    send OnWait_On ("Special find: "+psName(lhSetOfMasks))
82034>>>>>>>>>    for liItem from 0 to liMax
82040>>>>>>>>>>
82040>>>>>>>>>      get value item liItem to lsDir
82041>>>>>>>>>      send OnWait_SetText1 lsDir
82042>>>>>>>>>      send SEQ_Load_ItemsInDir lsDir
82043>>>>>>>>>      send SEQ_CallBack_ItemsInDir SEQCB_FILES_ONLY msg_DoFindFileCallback_Help self
82044>>>>>>>>>    loop
82045>>>>>>>>>>
82045>>>>>>>>>    send OnWait_Off
82046>>>>>>>>>    send DoReset to lhoWildCardMatcherArray
82047>>>>>>>>>    send delete_data to (oFileNameSet(self))
82048>>>>>>>>>  end_procedure
82049>>>>>>>>>
82049>>>>>>>>>  procedure DoFindFilesCompilerListingCallback string lsPrnFile integer lbFirstOnly integer liMsg integer liObj
82051>>>>>>>>>    integer liChannel liSeqEof liPos
82051>>>>>>>>>    string lsLine
82051>>>>>>>>>    get SEQ_DirectInput lsPrnFile to liChannel
82052>>>>>>>>>    if liChannel ge 0 begin
82054>>>>>>>>>      send OnWait_On ("Scanning "+lsPrnFile)
82055>>>>>>>>>      set pi.prv.SuspendSentinelUpdate to DFTRUE
82056>>>>>>>>>      repeat
82056>>>>>>>>>>
82056>>>>>>>>>        readln channel liChannel lsLine
82058>>>>>>>>>        move (SeqEof) to liSeqEof
82059>>>>>>>>>        ifnot liSeqEof begin
82061>>>>>>>>>          if (StringBeginsWith(lsLine,"INCLUDING FILE: ")) begin
82063>>>>>>>>>            replace "INCLUDING FILE: " in lsLine with ""
82065>>>>>>>>>            move (pos("(",lsLine)) to liPos
82066>>>>>>>>>            if liPos begin
82068>>>>>>>>>              move (left(lsLine,liPos-1)) to lsLine
82069>>>>>>>>>              move (trim(lsLine)) to lsLine
82070>>>>>>>>>            end
82070>>>>>>>>>>
82070>>>>>>>>>            ifnot ".PKI" in lsLine begin
82072>>>>>>>>>              ifnot ".PKD" in lsLine begin
82074>>>>>>>>>                send OnWait_SetText1 ("Locating "+lsLine)
82075>>>>>>>>>                send DoFindFileCallback lsLine lbFirstOnly liMsg liObj
82076>>>>>>>>>              end
82076>>>>>>>>>>
82076>>>>>>>>>            end
82076>>>>>>>>>>
82076>>>>>>>>>          end
82076>>>>>>>>>>
82076>>>>>>>>>        end
82076>>>>>>>>>>
82076>>>>>>>>>      until liSeqEof
82078>>>>>>>>>      send OnWait_Off
82079>>>>>>>>>      set pi.prv.SuspendSentinelUpdate to DFFALSE
82080>>>>>>>>>      send SEQ_CloseInput liChannel
82081>>>>>>>>>    end
82081>>>>>>>>>>
82081>>>>>>>>>  end_procedure
82082>>>>>>>>>end_class // cSetOfDirectories
82083>>>>>>>>>
82083>>>>>>>>>enumeration_list
82083>>>>>>>>>  define SOF_ORDERING_NAME
82083>>>>>>>>>  define SOF_ORDERING_TYPE
82083>>>>>>>>>  define SOF_ORDERING_PATH
82083>>>>>>>>>  define SOF_ORDERING_SIZE
82083>>>>>>>>>  define SOF_ORDERING_TIME
82083>>>>>>>>>end_enumeration_list
82083>>>>>>>>>
82083>>>>>>>>>class cSetOfFilesNew is a cArray
82084>>>>>>>>>  procedure construct_object integer liImage
82086>>>>>>>>>    forward send construct_object liImage
82088>>>>>>>>>    property integer piSOD_Object public 0
82089>>>>>>>>>  end_procedure
82090>>>>>>>>>  item_property_list
82090>>>>>>>>>    item_property string  psFileName.i // File name
82090>>>>>>>>>    item_property string  psFileType.i // File extention
82090>>>>>>>>>    item_property string  psFilePath.i // Path to file
82090>>>>>>>>>    item_property integer piFileSize.i // File size
82090>>>>>>>>>    item_property number  pnFileTime.i // Time stamp
82090>>>>>>>>>  end_item_property_list cSetOfFilesNew
#REM 82131 DEFINE FUNCTION PNFILETIME.I INTEGER LIROW RETURNS NUMBER
#REM 82135 DEFINE PROCEDURE SET PNFILETIME.I INTEGER LIROW NUMBER VALUE
#REM 82139 DEFINE FUNCTION PIFILESIZE.I INTEGER LIROW RETURNS INTEGER
#REM 82143 DEFINE PROCEDURE SET PIFILESIZE.I INTEGER LIROW INTEGER VALUE
#REM 82147 DEFINE FUNCTION PSFILEPATH.I INTEGER LIROW RETURNS STRING
#REM 82151 DEFINE PROCEDURE SET PSFILEPATH.I INTEGER LIROW STRING VALUE
#REM 82155 DEFINE FUNCTION PSFILETYPE.I INTEGER LIROW RETURNS STRING
#REM 82159 DEFINE PROCEDURE SET PSFILETYPE.I INTEGER LIROW STRING VALUE
#REM 82163 DEFINE FUNCTION PSFILENAME.I INTEGER LIROW RETURNS STRING
#REM 82167 DEFINE PROCEDURE SET PSFILENAME.I INTEGER LIROW STRING VALUE
82172>>>>>>>>>  procedure DoReset
82174>>>>>>>>>    send delete_data
82175>>>>>>>>>  end_procedure
82176>>>>>>>>>//function item_property_type integer liColumn returns integer
82176>>>>>>>>>//  if liColumn eq 0 function_return ITMP_STRING
82176>>>>>>>>>//  if liColumn eq 1 function_return ITMP_STRING
82176>>>>>>>>>//  if liColumn eq 2 function_return ITMP_STRING
82176>>>>>>>>>//  if liColumn eq 3 function_return ITMP_INTEGER
82176>>>>>>>>>//  if liColumn eq 4 function_return ITMP_NUMBER
82176>>>>>>>>>//end_function
82176>>>>>>>>>  function iTotalSize returns integer
82178>>>>>>>>>    integer liRval liMax liRow
82178>>>>>>>>>    move 0 to liRval
82179>>>>>>>>>    get row_count to liMax
82180>>>>>>>>>    decrement liMax
82181>>>>>>>>>    for liRow from 0 to liMax
82187>>>>>>>>>>
82187>>>>>>>>>      move (liRval+piFileSize.i(self,liRow)) to liRval
82188>>>>>>>>>    loop
82189>>>>>>>>>>
82189>>>>>>>>>    function_return liRval
82190>>>>>>>>>  end_function
82191>>>>>>>>>  function sFileName.i integer liRow returns string
82193>>>>>>>>>    string sName sExt
82193>>>>>>>>>    get psFileName.i liRow to sName
82194>>>>>>>>>    get psFileType.i liRow to sExt
82195>>>>>>>>>    if sExt eq "" function_return sName
82198>>>>>>>>>    function_return (sName+"."+sExt)
82199>>>>>>>>>  end_function
82200>>>>>>>>>  function iFindFile.ss string lsFileName string lsDir returns integer
82202>>>>>>>>>    integer liMax liRow
82202>>>>>>>>>    get row_count to liMax
82203>>>>>>>>>    decrement liMax
82204>>>>>>>>>    move (lowercase(lsFileName)) to lsFileName
82205>>>>>>>>>    move (lowercase(lsDir)) to lsDir
82206>>>>>>>>>    for liRow from 0 to liMax
82212>>>>>>>>>>
82212>>>>>>>>>      if (lowercase(sFileName.i(self,liRow))=lsFileName and lowercase(psFilePath.i(self,liRow))=lsDir) function_return liRow
82215>>>>>>>>>    loop
82216>>>>>>>>>>
82216>>>>>>>>>    function_return -1
82217>>>>>>>>>  end_function
82218>>>>>>>>>  function sFileNameIncPath.i integer iItm returns string
82220>>>>>>>>>    string sFile sDir
82220>>>>>>>>>    get sFileName.i iItm to sFile
82221>>>>>>>>>    get psFilePath.i iItm to sDir
82222>>>>>>>>>    function_return (SEQ_ComposeAbsoluteFileName(sDir,sFile))
82223>>>>>>>>>  end_function
82224>>>>>>>>>  procedure DoAddFile string lsFileName string lsDir
82226>>>>>>>>>    integer liRow
82226>>>>>>>>>    string lsFileRootName
82226>>>>>>>>>//    showln lsDir "/" lsFileName
82226>>>>>>>>>//    procedure_return
82226>>>>>>>>>    if (iFindFile.ss(self,lsFileName,lsDir)=-1) begin
82228>>>>>>>>>      get row_count to liRow
82229>>>>>>>>>      if "." in lsFileName move (StripFromLastOccurance(lsFileName,".")) to lsFileRootName
82232>>>>>>>>>      else move lsFileName to lsFileRootName
82234>>>>>>>>>      set psFileName.i liRow to lsFileRootName
82235>>>>>>>>>      set psFilePath.i liRow to lsDir
82236>>>>>>>>>      set psFileType.i liRow to (replace(".",replace(lsFileRootName,lsFileName,""),""))
82237>>>>>>>>>      move (SEQ_ComposeAbsoluteFileName(lsDir,lsFileName)) to lsFileName
82238>>>>>>>>>      set piFileSize.i liRow to (SEQ_FileSize(lsFileName))
82239>>>>>>>>>      set pnFileTime.i liRow to (SEQ_FileModTime(lsFileName))
82240>>>>>>>>>    end
82240>>>>>>>>>>
82240>>>>>>>>>  end_procedure
82241>>>>>>>>>  procedure DoSort integer liOrdering
82243>>>>>>>>>    send ITMP_Sort_DoReset
82244>>>>>>>>>    if liOrdering eq SOF_ORDERING_NAME begin
82246>>>>>>>>>      send ITMP_Sort_DoAddSegment 0 DFTRUE
82247>>>>>>>>>      send ITMP_Sort_DoAddSegment 1 DFTRUE
82248>>>>>>>>>    end
82248>>>>>>>>>>
82248>>>>>>>>>    if liOrdering eq SOF_ORDERING_TYPE begin
82250>>>>>>>>>      send ITMP_Sort_DoAddSegment 1 DFTRUE
82251>>>>>>>>>      send ITMP_Sort_DoAddSegment 0 DFTRUE
82252>>>>>>>>>    end
82252>>>>>>>>>>
82252>>>>>>>>>    if liOrdering eq SOF_ORDERING_PATH send ITMP_Sort_DoAddSegment 2 DFTRUE
82255>>>>>>>>>    if liOrdering eq SOF_ORDERING_SIZE send ITMP_Sort_DoAddSegment 3 DFFALSE
82258>>>>>>>>>    if liOrdering eq SOF_ORDERING_TIME send ITMP_Sort_DoAddSegment 4 DFFALSE
82261>>>>>>>>>    send ITMP_Sort_DoSortData self
82262>>>>>>>>>  end_procedure
82263>>>>>>>>>  procedure DoFindFilesCompilerListing string lsPrnFile integer lbFirstOnly
82265>>>>>>>>>    send DoFindFilesCompilerListingCallback to (piSOD_Object(self)) lsPrnFile lbFirstOnly msg_DoAddFile self
82266>>>>>>>>>  end_procedure
82267>>>>>>>>>  procedure DoFindFileBySetOfMasks integer lhSetOfMasks integer lbFirstOnly
82269>>>>>>>>>    send DoFindFileBySetOfMasksCallback to (piSOD_Object(self)) lhSetOfMasks lbFirstOnly msg_DoAddFile self
82270>>>>>>>>>  end_procedure
82271>>>>>>>>>  procedure DoFindFile string lsFileMask integer lbFirstOnly
82273>>>>>>>>>    send DoFindFileCallback to (piSOD_Object(self)) lsFileMask lbFirstOnly msg_DoAddFile self
82274>>>>>>>>>  end_procedure
82275>>>>>>>>>
82275>>>>>>>>>  procedure DoCallback integer liMsg integer lhObj
82277>>>>>>>>>    integer liRow liMax
82277>>>>>>>>>    get row_count to liMax
82278>>>>>>>>>    decrement liMax
82279>>>>>>>>>    for liRow from 0 to liMax
82285>>>>>>>>>>
82285>>>>>>>>>      send liMsg to lhObj (sFileName.i(self,liRow)) (psFilePath.i(self,liRow))
82286>>>>>>>>>    loop
82287>>>>>>>>>>
82287>>>>>>>>>  end_procedure
82288>>>>>>>>>end_class // cSetOfFilesNew
82289>>>>>>>Use Spec0008.utl // Small arrays with integer Codes (Dictionaries)
82289>>>>>>>Use Files.utl    // Utilities for handling file related stuff
82289>>>>>>>Use WildCard.nui // WildCardMatch function
82289>>>>>>>
82289>>>>>>>//Use Array.dbg
82289>>>>>>>
82289>>>>>>>object oCopyActionArray is a cIntegerCodeToText
82291>>>>>>>  IntegerCodeList
82291>>>>>>>    Define_IntegerCode CA_NO_COPYING                     ""
82292>>>>>>>    Define_IntegerCode CA_COPY_ONE_LEFT_TO_RIGHT         "Copy left to right"
82293>>>>>>>    Define_IntegerCode CA_COPY_ONE_RIGHT_TO_LEFT         "Copy right to left"
82294>>>>>>>    Define_IntegerCode CA_COPY_ONE_NEWER                 "Update older file"
82295>>>>>>>    Define_IntegerCode CA_UPDATE_LEFT_DIR                "Update left folder"
82296>>>>>>>    Define_IntegerCode CA_UPDATE_RIGHT_DIR               "Update right folder"
82297>>>>>>>    Define_IntegerCode CA_UPDATE_BOTH_DIRS               "Update both folders"
82298>>>>>>>    Define_IntegerCode CA_UPDATE_LEFT_DIR_EXISTING_ONLY  "Update existing files in left folder"
82299>>>>>>>    Define_IntegerCode CA_UPDATE_RIGHT_DIR_EXISTING_ONLY "Update existing files in right folder"
82300>>>>>>>    Define_IntegerCode CA_UPDATE_BOTH_DIRS_EXISTING_ONLY "Update existing files in both folders"
82301>>>>>>>  End_IntegerCodeList
82301>>>>>>>end_object
82302>>>>>>>
82302>>>>>>>object oDirectoryCompareArray is a cArray
82304>>>>>>>  property string psPath1 public ""
82306>>>>>>>  property string psPath2 public ""
82308>>>>>>>  property number pnNewestFile1 public 0
82310>>>>>>>  property number pnNewestFile2 public 0
82312>>>>>>>  property number pnTimeTolerance public 0
82314>>>>>>>  item_property_list
82314>>>>>>>    item_property string  psFileName.i
82314>>>>>>>    item_property integer piExists1.i
82314>>>>>>>    item_property integer piFileSize1.i
82314>>>>>>>    item_property number  pnFileTime1.i
82314>>>>>>>    item_property integer piExists2.i
82314>>>>>>>    item_property integer piFileSize2.i
82314>>>>>>>    item_property number  pnFileTime2.i
82314>>>>>>>  end_item_property_list
#REM 82366 DEFINE FUNCTION PNFILETIME2.I INTEGER LIROW RETURNS NUMBER
#REM 82371 DEFINE PROCEDURE SET PNFILETIME2.I INTEGER LIROW NUMBER VALUE
#REM 82376 DEFINE FUNCTION PIFILESIZE2.I INTEGER LIROW RETURNS INTEGER
#REM 82381 DEFINE PROCEDURE SET PIFILESIZE2.I INTEGER LIROW INTEGER VALUE
#REM 82386 DEFINE FUNCTION PIEXISTS2.I INTEGER LIROW RETURNS INTEGER
#REM 82391 DEFINE PROCEDURE SET PIEXISTS2.I INTEGER LIROW INTEGER VALUE
#REM 82396 DEFINE FUNCTION PNFILETIME1.I INTEGER LIROW RETURNS NUMBER
#REM 82401 DEFINE PROCEDURE SET PNFILETIME1.I INTEGER LIROW NUMBER VALUE
#REM 82406 DEFINE FUNCTION PIFILESIZE1.I INTEGER LIROW RETURNS INTEGER
#REM 82411 DEFINE PROCEDURE SET PIFILESIZE1.I INTEGER LIROW INTEGER VALUE
#REM 82416 DEFINE FUNCTION PIEXISTS1.I INTEGER LIROW RETURNS INTEGER
#REM 82421 DEFINE PROCEDURE SET PIEXISTS1.I INTEGER LIROW INTEGER VALUE
#REM 82426 DEFINE FUNCTION PSFILENAME.I INTEGER LIROW RETURNS STRING
#REM 82431 DEFINE PROCEDURE SET PSFILENAME.I INTEGER LIROW STRING VALUE
82437>>>>>>>  // Function iIsChanged.i returns 0 if no change, -1 if left side is
82437>>>>>>>  // newer and +1 if right side is newer.
82437>>>>>>>  function iIsChanged.i integer liRow returns integer
82440>>>>>>>    integer liLeftSize liRightSize
82440>>>>>>>    number lnLeftTime lnRightTime lnTolerance
82440>>>>>>>    get pnTimeTolerance to lnTolerance
82441>>>>>>>    get pnFileTime1.i liRow to lnLeftTime
82442>>>>>>>    get pnFileTime2.i liRow to lnRightTime
82443>>>>>>>    if (abs(lnLeftTime-lnRightTime)<=lnTolerance) begin
82445>>>>>>>      get piFileSize1.i liRow to liLeftSize
82446>>>>>>>      get piFileSize2.i liRow to liRightSize
82447>>>>>>>      if liLeftSize eq liRightSize function_return 0 // No Change
82450>>>>>>>    end
82450>>>>>>>>
82450>>>>>>>    if (lnLeftTime>lnRightTime) function_return -1
82453>>>>>>>    function_return 1
82454>>>>>>>  end_function
82455>>>>>>>  procedure add_file string lsName integer liExists1 integer liSize1 number lnTime1 integer liExists2 integer liSize2 number lnTime2
82458>>>>>>>    integer liRow
82458>>>>>>>    get row_count to liRow
82459>>>>>>>    set psFileName.i  liRow to lsName
82460>>>>>>>    set piExists1.i   liRow to liExists1
82461>>>>>>>    set piFileSize1.i liRow to liSize1
82462>>>>>>>    set pnFileTime1.i liRow to lnTime1
82463>>>>>>>    set piExists2.i   liRow to liExists2
82464>>>>>>>    set piFileSize2.i liRow to liSize2
82465>>>>>>>    set pnFileTime2.i liRow to lnTime2
82466>>>>>>>    if lnTime1 gt (pnNewestFile1(self)) set pnNewestFile1 to lnTime1
82469>>>>>>>    if lnTime1 gt (pnNewestFile2(self)) set pnNewestFile2 to lnTime2
82472>>>>>>>  end_procedure
82473>>>>>>>  object oDir1 is a cSetOfFilesNew
82475>>>>>>>    object oSetOfDirectories is a cSetOfDirectories
82477>>>>>>>    end_object
82478>>>>>>>    set piSOD_Object to (oSetOfDirectories(self))
82479>>>>>>>    procedure DoReset
82482>>>>>>>      forward send DoReset
82484>>>>>>>      send DoReset to (oSetOfDirectories(self))
82485>>>>>>>    end_procedure
82486>>>>>>>  end_object
82487>>>>>>>  object oDir2 is a cSetOfFilesNew
82489>>>>>>>    object oSetOfDirectories is a cSetOfDirectories
82491>>>>>>>    end_object
82492>>>>>>>    set piSOD_Object to (oSetOfDirectories(self))
82493>>>>>>>    procedure DoReset
82496>>>>>>>      forward send DoReset
82498>>>>>>>      send DoReset to (oSetOfDirectories(self))
82499>>>>>>>    end_procedure
82500>>>>>>>  end_object
82501>>>>>>>  object oDirCompare is a cDoubleOrderedCompare NO_IMAGE
82503>>>>>>>    property integer piCurrentRow1 public 0
82505>>>>>>>    property integer piCurrentRow2 public 0
82507>>>>>>>    function iSeed1 returns integer
82510>>>>>>>      set piCurrentRow1 to 0
82511>>>>>>>      function_return (row_count(oDir1(self)))
82512>>>>>>>    end_function
82513>>>>>>>    function iSeed2 returns integer
82516>>>>>>>      set piCurrentRow2 to 0
82517>>>>>>>      function_return (row_count(oDir2(self)))
82518>>>>>>>    end_function
82519>>>>>>>    function sValue1 returns string
82522>>>>>>>      function_return (uppercase(sFileName.i(oDir1(self),piCurrentRow1(self))))
82523>>>>>>>    end_procedure
82524>>>>>>>    function sValue2 returns string
82527>>>>>>>      function_return (uppercase(sFileName.i(oDir2(self),piCurrentRow2(self))))
82528>>>>>>>    end_procedure
82529>>>>>>>    function iAdvance1 returns integer
82532>>>>>>>      set piCurrentRow1 to (piCurrentRow1(self)+1)
82533>>>>>>>      function_return (piCurrentRow1(self)>>>>>>    end_function
82535>>>>>>>    function iAdvance2 returns integer
82538>>>>>>>      set piCurrentRow2 to (piCurrentRow2(self)+1)
82539>>>>>>>      function_return (piCurrentRow2(self)>>>>>>    end_function
82541>>>>>>>    //> This is sent when items are found to be identical
82541>>>>>>>    procedure Match string value1# string value2#
82544>>>>>>>      integer liRow1 liRow2 liSize1 liSize2
82544>>>>>>>      number lnTime1 lnTime2
82544>>>>>>>      string lsName
82544>>>>>>>      get piCurrentRow1 to liRow1
82545>>>>>>>      get piCurrentRow2 to liRow2
82546>>>>>>>      get sFileName.i  of (oDir1(self)) liRow1 to lsName
82547>>>>>>>      get piFileSize.i of (oDir1(self)) liRow1 to liSize1
82548>>>>>>>      get pnFileTime.i of (oDir1(self)) liRow1 to lnTime1
82549>>>>>>>      get piFileSize.i of (oDir2(self)) liRow2 to liSize2
82550>>>>>>>      get pnFileTime.i of (oDir2(self)) liRow2 to lnTime2
82551>>>>>>>      send add_file lsName 1 liSize1 lnTime1 1 liSize2 lnTime2
82552>>>>>>>    end_procedure
82553>>>>>>>    //> This is sent when a right side (2) item cannot be matched
82553>>>>>>>    procedure NotMatched2 string value#
82556>>>>>>>      integer liRow liSize2
82556>>>>>>>      number lnTime2
82556>>>>>>>      string lsName
82556>>>>>>>      get piCurrentRow2 to liRow
82557>>>>>>>      get sFileName.i  of (oDir2(self)) liRow to lsName
82558>>>>>>>      get piFileSize.i of (oDir2(self)) liRow to liSize2
82559>>>>>>>      get pnFileTime.i of (oDir2(self)) liRow to lnTime2
82560>>>>>>>      send add_file lsName 0 0 0 1 liSize2 lnTime2
82561>>>>>>>    end_procedure
82562>>>>>>>    //> This is sent when a left side (1) item cannot be matched
82562>>>>>>>    procedure NotMatched1 string value#
82565>>>>>>>      integer liRow liSize1
82565>>>>>>>      number lnTime1
82565>>>>>>>      string lsName
82565>>>>>>>      get piCurrentRow1 to liRow
82566>>>>>>>      get sFileName.i  of (oDir1(self)) liRow to lsName
82567>>>>>>>      get piFileSize.i of (oDir1(self)) liRow to liSize1
82568>>>>>>>      get pnFileTime.i of (oDir1(self)) liRow to lnTime1
82569>>>>>>>      send add_file lsName 1 liSize1 lnTime1 0 0 0
82570>>>>>>>    end_procedure
82571>>>>>>>  end_object
82572>>>>>>>  procedure reset
82575>>>>>>>    set psPath1 to ""
82576>>>>>>>    set psPath2 to ""
82577>>>>>>>    set pnNewestFile1 to 0
82578>>>>>>>    set pnNewestFile2 to 0
82579>>>>>>>    send delete_data
82580>>>>>>>    send DoReset to (oDir1(self))
82581>>>>>>>    send DoReset to (oDir2(self))
82582>>>>>>>  end_procedure
82583>>>>>>>  procedure Fill_Array
82586>>>>>>>    integer iObj
82586>>>>>>>    move (oDirCompare(self)) to iObj
82587>>>>>>>    send run to iObj
82588>>>>>>>  end_procedure
82589>>>>>>>  procedure private.CopyFile integer iAction integer iRow
82592>>>>>>>    integer iOK
82592>>>>>>>    string sFileName sTargetFile sLeftPath sRightPath
82592>>>>>>>    get psFileName.i iRow to sFileName
82593>>>>>>>    get psPath1 to sLeftPath
82594>>>>>>>    get psPath2 to sRightPath
82595>>>>>>>    move -1 to iOK
82596>>>>>>>    if iAction eq CA_COPY_ONE_LEFT_TO_RIGHT begin
82598>>>>>>>      move (SEQ_ComposeAbsoluteFileName(sRightPath,sFileName)) to sTargetFile
82599>>>>>>>      move (SEQ_ComposeAbsoluteFileName(sLeftPath,sFileName)) to sFileName
82600>>>>>>>      get SEQ_CopyFile sFileName sTargetFile to iOK
82601>>>>>>>      if iOK begin
82603>>>>>>>        set piExists2.i   iRow to (piExists1.i(self,iRow))
82604>>>>>>>        set piFileSize2.i iRow to (piFileSize1.i(self,iRow))
82605>>>>>>>        set pnFileTime2.i iRow to (pnFileTime1.i(self,iRow))
82606>>>>>>>      end
82606>>>>>>>>
82606>>>>>>>    end
82606>>>>>>>>
82606>>>>>>>    if iAction eq CA_COPY_ONE_RIGHT_TO_LEFT begin
82608>>>>>>>      move (SEQ_ComposeAbsoluteFileName(sLeftPath,sFileName)) to sTargetFile
82609>>>>>>>      move (SEQ_ComposeAbsoluteFileName(sRightPath,sFileName)) to sFileName
82610>>>>>>>      get SEQ_CopyFile sFileName sTargetFile to iOK
82611>>>>>>>      if iOK begin
82613>>>>>>>        set piExists1.i   iRow to (piExists2.i(self,iRow))
82614>>>>>>>        set piFileSize1.i iRow to (piFileSize2.i(self,iRow))
82615>>>>>>>        set pnFileTime1.i iRow to (pnFileTime2.i(self,iRow))
82616>>>>>>>      end
82616>>>>>>>>
82616>>>>>>>    end
82616>>>>>>>>
82616>>>>>>>  end_procedure
82617>>>>>>>  procedure DoCopyFile integer iAction integer iRow
82620>>>>>>>    integer liChanged
82620>>>>>>>    if iRow ge 0 begin
82622>>>>>>>      if iAction eq CA_COPY_ONE_LEFT_TO_RIGHT send private.CopyFile CA_COPY_ONE_LEFT_TO_RIGHT iRow
82625>>>>>>>      if iAction eq CA_COPY_ONE_RIGHT_TO_LEFT send private.CopyFile CA_COPY_ONE_RIGHT_TO_LEFT iRow
82628>>>>>>>      if iAction eq CA_COPY_ONE_NEWER begin
82630>>>>>>>        get iIsChanged.i iRow to liChanged
82631>>>>>>>        if liChanged eq -1 send private.CopyFile CA_COPY_ONE_LEFT_TO_RIGHT iRow
82634>>>>>>>        if liChanged eq  1 send private.CopyFile CA_COPY_ONE_RIGHT_TO_LEFT iRow
82637>>>>>>>      end
82637>>>>>>>>
82637>>>>>>>    end
82637>>>>>>>>
82637>>>>>>>  end_procedure
82638>>>>>>>  procedure DoCopyFiles integer iAction
82641>>>>>>>    integer iRow iMax iExistingOnly iExists1 iExists2 liChanged
82641>>>>>>>    if (iAction=CA_UPDATE_LEFT_DIR or iAction=CA_UPDATE_RIGHT_DIR or iAction=CA_UPDATE_BOTH_DIRS) move 0 to iExistingOnly
82644>>>>>>>    else move 1 to iExistingOnly
82646>>>>>>>
82646>>>>>>>    if iAction eq CA_UPDATE_LEFT_DIR_EXISTING_ONLY  move CA_UPDATE_LEFT_DIR  to iAction
82649>>>>>>>    if iAction eq CA_UPDATE_RIGHT_DIR_EXISTING_ONLY move CA_UPDATE_RIGHT_DIR to iAction
82652>>>>>>>    if iAction eq CA_UPDATE_BOTH_DIRS_EXISTING_ONLY move CA_UPDATE_BOTH_DIRS to iAction
82655>>>>>>>
82655>>>>>>>    get row_count to iMax
82656>>>>>>>    decrement iMax
82657>>>>>>>
82657>>>>>>>    for iRow from 0 to iMax
82663>>>>>>>>
82663>>>>>>>      get iIsChanged.i iRow to liChanged
82664>>>>>>>      if (liChanged<>0) begin
82666>>>>>>>        get piExists1.i iRow to iExists1
82667>>>>>>>        get piExists2.i iRow to iExists2
82668>>>>>>>        if iAction eq CA_UPDATE_LEFT_DIR  if (liChanged=1 and (not(iExistingOnly) or iExists1)) ;                 send DoCopyFile CA_COPY_ONE_RIGHT_TO_LEFT iRow
82673>>>>>>>        if iAction eq CA_UPDATE_RIGHT_DIR if (liChanged=-1 and (not(iExistingOnly) or iExists2)) ;                 send DoCopyFile CA_COPY_ONE_LEFT_TO_RIGHT iRow
82678>>>>>>>        if iAction eq CA_UPDATE_BOTH_DIRS if ((iExists1 and iExists2) or not(iExistingOnly)) ;                 send DoCopyFile CA_COPY_ONE_NEWER iRow
82683>>>>>>>      end
82683>>>>>>>>
82683>>>>>>>    loop
82684>>>>>>>>
82684>>>>>>>  end_function
82685>>>>>>>  procedure DoCompareDirectories string sPath1 string sPath2 integer lhSetOfMasks
82688>>>>>>>    send reset
82689>>>>>>>    set psPath1 to sPath1
82690>>>>>>>    set psPath2 to sPath2
82691>>>>>>>    send DoAddDirectory to (oSetOfDirectories(oDir1(self))) sPath1
82692>>>>>>>    send DoAddDirectory to (oSetOfDirectories(oDir2(self))) sPath2
82693>>>>>>>    if (lhSetOfMasks and row_count(lhSetOfMasks)) begin
82695>>>>>>>      send DoFindFileBySetOfMasks to (oDir1(self)) lhSetOfMasks DFFALSE
82696>>>>>>>      send DoFindFileBySetOfMasks to (oDir2(self)) lhSetOfMasks DFFALSE
82697>>>>>>>    end
82697>>>>>>>>
82697>>>>>>>    else begin
82698>>>>>>>      send DoFindFile to (oDir1(self)) "*" DFFALSE
82699>>>>>>>      send DoFindFile to (oDir2(self)) "*" DFFALSE
82700>>>>>>>    end
82700>>>>>>>>
82700>>>>>>>    send DoSort to (oDir1(self)) SOF_ORDERING_NAME
82701>>>>>>>    send DoSort to (oDir2(self)) SOF_ORDERING_NAME
82702>>>>>>>//    send Array_DoWriteToFile (oDir1(self)) "c:\Dir1.txt"
82702>>>>>>>//    send Array_DoWriteToFile (oDir2(self)) "c:\Dir2.txt"
82702>>>>>>>    send Fill_Array
82703>>>>>>>  end_procedure
82704>>>>>>>end_object // oDirectoryCompareArray
82705>>>>>>>
82705>>>>>>>procedure DirComp_DoCompare global string sLeftPath1 string sRightPath2 integer lhSetOfMasks
82707>>>>>>>  send DoCompareDirectories to (oDirectoryCompareArray(self)) sLeftPath1 sRightPath2 lhSetOfMasks
82708>>>>>>>end_procedure
82709>>>>>>>procedure DirComp_DoCopyFiles global integer iAction
82711>>>>>>>  send DoCopyFiles to (oDirectoryCompareArray(self)) iAction
82712>>>>>>>end_procedure
82713>>>>>Use GridUtil.utl // Grid and List utilities
82713>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
82713>>>>>Use Dates.nui    // Date routines (No User Interface)
82713>>>>>
82713>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
82713>>>>>Use Buttons.utl  // Button texts
82713>>>>>object oDirCompCopyPanel is a aps.ModalPanel label "Copy newer files"
82716>>>>>  set locate_mode to CENTER_ON_SCREEN
82717>>>>>  on_key ksave_record send close_panel_ok
82718>>>>>  on_key kcancel send close_panel
82719>>>>>  property integer piResult public 0
82721>>>>>  set p_left_margin to 30
82722>>>>>  send aps_init
82723>>>>>  object oRad is a aps.RadioContainer
82725>>>>>    object oRad1 is a aps.Radio label "Update left directory"
82728>>>>>    end_object
82729>>>>>    object oRad2 is a aps.Radio label "Update right directory" snap SL_DOWN
82733>>>>>      set p_extra_external_width to 30
82734>>>>>    end_object
82735>>>>>    object oRad3 is a aps.Radio label "Syncronize both" snap SL_DOWN
82739>>>>>    end_object
82740>>>>>  end_object
82741>>>>>  send aps_goto_max_row
82742>>>>>  send aps_make_row_space 4
82743>>>>>  object oUpdateExistingOnly is a aps.CheckBox label "Update existing files only"
82746>>>>>  end_object
82747>>>>>  object oBtn1 is a aps.Multi_Button
82749>>>>>    on_item t.btn.ok send close_panel_ok
82750>>>>>  end_object
82751>>>>>  object oBtn2 is a aps.Multi_Button
82753>>>>>    on_item t.btn.cancel send close_panel
82754>>>>>  end_object
82755>>>>>  send aps_locate_multi_buttons
82756>>>>>  procedure close_panel_ok
82759>>>>>    set piResult to 1
82760>>>>>    send close_panel
82761>>>>>  end_procedure
82762>>>>>  function iPopup returns integer
82765>>>>>    integer iCurrentRad
82765>>>>>    set piResult to 0
82766>>>>>    send popup
82767>>>>>    if (piResult(self)) begin
82769>>>>>      get current_radio of (oRad(self)) to iCurrentRad
82770>>>>>      if (checked_state(oUpdateExistingOnly(self))) begin
82772>>>>>        if iCurrentRad eq 0 function_return CA_UPDATE_LEFT_DIR_EXISTING_ONLY
82775>>>>>        if iCurrentRad eq 1 function_return CA_UPDATE_RIGHT_DIR_EXISTING_ONLY
82778>>>>>        if iCurrentRad eq 2 function_return CA_UPDATE_BOTH_DIRS_EXISTING_ONLY
82781>>>>>      end
82781>>>>>>
82781>>>>>      else begin
82782>>>>>        if iCurrentRad eq 0 function_return CA_UPDATE_LEFT_DIR
82785>>>>>        if iCurrentRad eq 1 function_return CA_UPDATE_RIGHT_DIR
82788>>>>>        if iCurrentRad eq 2 function_return CA_UPDATE_BOTH_DIRS
82791>>>>>      end
82791>>>>>>
82791>>>>>    end
82791>>>>>>
82791>>>>>    function_return CA_NO_COPYING
82792>>>>>  end_function
82793>>>>>end_object // oDirCompCopyPanel
82794>>>>>
82794>>>>>Use Aps
82794>>>>>Use RGB.utl      // Some color functions
82794>>>>>class cDirCompList is a aps.Grid
82795>>>>>  procedure construct_object integer img#
82797>>>>>    forward send construct_object img#
82799>>>>>    property integer piSetOfFilesObject public 0
82800>>>>>    set select_mode to NO_SELECT
82801>>>>>    send GridPrepare_AddColumn "Filename" AFT_ASCII20
82802>>>>>    send GridPrepare_AddColumn "Size"     AFT_ASCII12
82803>>>>>    send GridPrepare_AddColumn "Time"     AFT_ASCII20
82804>>>>>    send GridPrepare_AddColumn "Size"     AFT_ASCII12
82805>>>>>    send GridPrepare_AddColumn "Time"     AFT_ASCII20
82806>>>>>    send GridPrepare_Apply self
82807>>>>>    set CurrentCellColor to (rgb(255,128,128))
82808>>>>>    set highlight_row_state to true
82809>>>>>    on_key KNEXT_ITEM     send switch
82810>>>>>    on_key KPREVIOUS_ITEM send switch_back
82811>>>>>    on_key KEY_CTRL+KEY_W send DoWriteToFile
82812>>>>>    on_key KEY_CTRL+KEY_R send sort_data
82813>>>>>  end_procedure
82814>>>>>
82814>>>>>  function iSpecialSortValueOnColumn.i integer liColumn returns integer
82816>>>>>    if liColumn gt 0 function_Return 1
82819>>>>>  end_function
82820>>>>>
82820>>>>>  function sSortValue.ii integer liColumn integer liItem returns string
82822>>>>>    number lnValue
82822>>>>>    string lsValue
82822>>>>>    get value item liItem to lsValue
82823>>>>>    if (liColumn=1 or liColumn=3) begin
82825>>>>>      move (replaces(",",lsValue,"")) to lsValue
82826>>>>>      move (replaces(".",lsValue,"")) to lsValue
82827>>>>>      function_return (IntToStrR(lsValue,9))
82828>>>>>    end
82828>>>>>>
82828>>>>>    if (liColumn=2 or liColumn=4) begin
82830>>>>>      move (trim(lsValue)) to lsValue
82831>>>>>      if (length(lsValue)>10) get TS_Compose (date(left(lsValue,10))) (StringRightBut(lnValue,11)) to lnValue
82834>>>>>      else get TS_Compose 0 lsValue to lnValue
82836>>>>>      function_return (NumToStrR(lnValue,0,13))
82837>>>>>    end
82837>>>>>>
82837>>>>>  end_function
82838>>>>>
82838>>>>>  procedure sort_data.i integer column#
82840>>>>>    send Grid_SortByColumn self column#
82841>>>>>  end_procedure
82842>>>>>
82842>>>>>  procedure sort_data
82844>>>>>    integer cc#
82844>>>>>    get Grid_CurrentColumn self to cc#
82845>>>>>    send sort_data.i cc#
82846>>>>>  end_procedure
82847>>>>>  procedure header_mouse_click integer itm#
82849>>>>>    send sort_data.i itm#
82850>>>>>    forward send header_mouse_click itm#
82852>>>>>  end_procedure
82853>>>>>
82853>>>>>  procedure DoSetTimeTolerance
82855>>>>>    send DirComp_SetTimeTolerance (oDirectoryCompareArray(self))
82856>>>>>  end_procedure
82857>>>>>
82857>>>>>  procedure DoWriteToFile
82859>>>>>    send Grid_DoWriteToFile self
82860>>>>>  end_procedure
82861>>>>>
82861>>>>>  function iCurrentRow returns integer
82863>>>>>    integer iItm
82863>>>>>    if (item_count(self)) begin
82865>>>>>      get Grid_BaseItem self to iItm
82866>>>>>      function_return (aux_value(self,iItm))
82867>>>>>    end
82867>>>>>>
82867>>>>>    function_return -1
82868>>>>>  end_function
82869>>>>>
82869>>>>>  procedure UpdateRow
82871>>>>>    integer iBase iRow iObj
82871>>>>>    if (item_count(self)) begin
82873>>>>>      move (oDirectoryCompareArray(self)) to iObj
82874>>>>>      get Grid_BaseItem self to iBase
82875>>>>>      get aux_value item iBase to iRow
82876>>>>>      set value item (iBase+1) to (IntToStrTS(piFileSize1.i(iObj,iRow)))
82877>>>>>      set value item (iBase+2) to (TS_ConvertToString(pnFileTime1.i(iObj,iRow)))
82878>>>>>      set value item (iBase+3) to (IntToStrTS(piFileSize2.i(iObj,iRow)))
82879>>>>>      set value item (iBase+4) to (TS_ConvertToString(pnFileTime2.i(iObj,iRow)))
82880>>>>>      set ItemColor item (iBase+1) to clWhite
82881>>>>>      set ItemColor item (iBase+2) to clWhite
82882>>>>>      set ItemColor item (iBase+3) to clWhite
82883>>>>>      set ItemColor item (iBase+4) to clWhite
82884>>>>>    end
82884>>>>>>
82884>>>>>  end_procedure
82885>>>>>  procedure DoCopyNew
82887>>>>>    send DoCopyFile to (oDirectoryCompareArray(self)) CA_COPY_ONE_NEWER (iCurrentRow(self))
82888>>>>>    send UpdateRow
82889>>>>>  end_procedure
82890>>>>>  procedure DoCopyLeft
82892>>>>>    send DoCopyFile to (oDirectoryCompareArray(self)) CA_COPY_ONE_LEFT_TO_RIGHT (iCurrentRow(self))
82893>>>>>    send UpdateRow
82894>>>>>  end_procedure
82895>>>>>  procedure DoCopyRight
82897>>>>>    send DoCopyFile to (oDirectoryCompareArray(self)) CA_COPY_ONE_RIGHT_TO_LEFT (iCurrentRow(self))
82898>>>>>    send UpdateRow
82899>>>>>  end_procedure
82900>>>>>  procedure DoCopyAdvanced
82902>>>>>    integer iAction
82902>>>>>    get iPopup of (oDirCompCopyPanel(self)) to iAction
82903>>>>>    if iAction ne CA_NO_COPYING begin
82905>>>>>      send DoCopyFiles to (oDirectoryCompareArray(self)) iAction
82906>>>>>      send fill_list.i 0
82907>>>>>    end
82907>>>>>>
82907>>>>>  end_procedure
82908>>>>>  procedure add_row
82910>>>>>  end_procedure
82911>>>>>  procedure fill_list.i integer liChangesOnly
82913>>>>>    integer liObj liMax liRow liSize1 liSize2 liExists1 liExists2
82913>>>>>    integer liGreen liBase liChanged
82913>>>>>    number lnTime1 lnTime2
82913>>>>>    string lsName
82913>>>>>    send delete_data
82914>>>>>    set dynamic_update_state to false
82915>>>>>    move (oDirectoryCompareArray(self)) to liObj
82916>>>>>    get row_count of liObj to liMax
82917>>>>>    decrement liMax
82918>>>>>    move (RGB_Brighten(clGreen,75)) to liGreen
82919>>>>>    for liRow from 0 to liMax
82925>>>>>>
82925>>>>>      get psFileName.i  of liObj liRow to lsName
82926>>>>>      get piExists1.i   of liObj liRow to liExists1
82927>>>>>      get piFileSize1.i of liObj liRow to liSize1
82928>>>>>      get pnFileTime1.i of liObj liRow to lnTime1
82929>>>>>      get piExists2.i   of liObj liRow to liExists2
82930>>>>>      get piFileSize2.i of liObj liRow to liSize2
82931>>>>>      get pnFileTime2.i of liObj liRow to lnTime2
82932>>>>>      get iIsChanged.i  of liObj liRow to liChanged
82933>>>>>      if (not(liChangesOnly) or liChanged) begin
82935>>>>>        get item_count to liBase
82936>>>>>        send add_item msg_none lsName
82937>>>>>        set aux_value item liBase to liRow
82938>>>>>        if liExists1 begin
82940>>>>>          send add_item msg_none (IntToStrTS(liSize1))
82941>>>>>          send add_item msg_none (TS_ConvertToString(lnTime1))
82942>>>>>        end
82942>>>>>>
82942>>>>>        else begin
82943>>>>>          send add_item msg_none ""
82944>>>>>          send add_item msg_none ""
82945>>>>>        end
82945>>>>>>
82945>>>>>        if liExists2 begin
82947>>>>>          send add_item msg_none (IntToStrTS(liSize2))
82948>>>>>          send add_item msg_none (TS_ConvertToString(lnTime2))
82949>>>>>        end
82949>>>>>>
82949>>>>>        else begin
82950>>>>>          send add_item msg_none ""
82951>>>>>          send add_item msg_none ""
82952>>>>>        end
82952>>>>>>
82952>>>>>        if (liChanged=-1) begin // Left is newer
82954>>>>>          set ItemColor item (liBase+1) to liGreen
82955>>>>>          set ItemColor item (liBase+2) to liGreen
82956>>>>>        end
82956>>>>>>
82956>>>>>        if (liChanged=1) begin // Right is newer
82958>>>>>          set ItemColor item (liBase+3) to liGreen
82959>>>>>          set ItemColor item (liBase+4) to liGreen
82960>>>>>        end
82960>>>>>>
82960>>>>>      end
82960>>>>>>
82960>>>>>    loop
82961>>>>>>
82961>>>>>    send Grid_SetEntryState self DFFALSE
82962>>>>>    set dynamic_update_state to true
82963>>>>>  end_procedure
82964>>>>>end_class // cDirCompList
82965>>>>>
82965>>>>>object oDircompTimeTolerance is a aps.ModalPanel label "Timestamp tolerance"
82968>>>>>  set locate_mode to CENTER_ON_SCREEN
82969>>>>>  on_key ksave_record send close_panel_ok
82970>>>>>  on_key kcancel send close_panel
82971>>>>>  property integer piResult public 0
82973>>>>>  object oEdit is a aps.Edit
82975>>>>>    set object_shadow_state to DFTRUE
82976>>>>>    set border_style to BORDER_NONE
82977>>>>>    set size to 60 220
82978>>>>>    set scroll_bar_visible_state to DFFALSE
82979>>>>>    set value item 0 to "For reasons not understood at all, I (who made the"
82980>>>>>    set value item 1 to "program) frequently experience that the timestamp of"
82981>>>>>    set value item 2 to "identical files is offset by 1 or 2 seconds."
82982>>>>>    set value item 3 to "For that reason you may specify a time interval inside"
82983>>>>>    set value item 4 to "which the timestamps will be considered identical."
82984>>>>>  end_object
82985>>>>>  send aps_goto_max_row
82986>>>>>  object oFrm is a aps.Form abstract AFT_NUMERIC4.0 label "Tolerance in seconds:"
82990>>>>>    set p_extra_external_width to 100
82991>>>>>  end_object
82992>>>>>  object oBtn1 is a aps.Multi_Button
82994>>>>>    on_item t.btn.ok send close_panel_ok
82995>>>>>  end_object
82996>>>>>  object oBtn2 is a aps.Multi_Button
82998>>>>>    on_item t.btn.cancel send close_panel
82999>>>>>  end_object
83000>>>>>  send aps_locate_multi_buttons
83001>>>>>  procedure close_panel_ok
83004>>>>>    set piResult to 1
83005>>>>>    send close_panel
83006>>>>>  end_procedure
83007>>>>>  procedure popup.i integer lhObj
83010>>>>>    set piResult to 0
83011>>>>>    set value of (oFrm(self)) item 0 to (pnTimeTolerance(lhObj))
83012>>>>>    send popup
83013>>>>>    if (piResult(self)) set pnTimeTolerance of lhObj to (value(oFrm(self),0))
83016>>>>>  end_procedure
83017>>>>>end_object // oDircompTimeTolerance
83018>>>>>
83018>>>>>procedure DirComp_SetTimeTolerance global integer lhObj
83020>>>>>  send popup.i to (oDircompTimeTolerance(self)) lhObj
83021>>>>>end_procedure
83022>>>Use Files.utl    // Utilities for handling file related stuff
83022>>>Use Spec0011.utl // Floating menues on the fly
83022>>>Use API_Attr.utl // Functions for querying API attributes
83022>>>Use WildCard.pkg // WildCardMatch function
Including file: wildcard.pkg    (C:\Apps\VDFQuery\AppSrc\wildcard.pkg)
83022>>>>>Use WildCard.nui // WildCardMatch function
83022>>>>>Use GridUtil.utl // Grid and List utilities (not for dbGrid's or Table's)
83022>>>>>Use Masks_DF.nui // DataFlex related file masks
Including file: masks_df.nui    (C:\Apps\VDFQuery\AppSrc\masks_df.nui)
83022>>>>>>>// Use Masks_DF.nui // DataFlex related file masks
83022>>>>>>>Use WildCard.nui // WildCardMatch function
83022>>>>>>>
83022>>>>>>>class cSetOfMasks_DFSource is a cSetOfMasks
83023>>>>>>>  procedure construct_object integer liImage
83025>>>>>>>    forward send construct_object liImage
83027>>>>>>>    set psName to "DataFlex source codes"
83028>>>>>>>    send DoAddMask "*.pkg"      "Package file"
83029>>>>>>>    send DoAddMask "*.utl"      "Package (Sture)"
83030>>>>>>>    send DoAddMask "*.dd"       "DataDictionary source"
83031>>>>>>>    send DoAddMask "*.dg"       "Dialog source"
83032>>>>>>>    send DoAddMask "*.gui"      "Package, graphical UI"
83033>>>>>>>    send DoAddMask "*.inc"      "Include file"
83034>>>>>>>    send DoAddMask "*.nui"      "Package, no UI (Sture)"
83035>>>>>>>    send DoAddMask "*.sl"       "Prompt list source"
83036>>>>>>>    send DoAddMask "webapp.src" "WebApp application source"
83037>>>>>>>    send DoAddMask "*.src"      "Application source"
83038>>>>>>>    send DoAddMask "*.vw"       "View source"
83039>>>>>>>    send DoAddMask "*.wo"       "Web business object source"
83040>>>>>>>    send DoAddMask "*.bpo"      "Business process objects"
83041>>>>>>>    send DoAddMask "*.rpt"      "Report source"
83042>>>>>>>    send DoAddMask "*.mn"       "Menus"
83043>>>>>>>    send DoAddMask "*.rv"       "Report views"
83044>>>>>>>  end_procedure
83045>>>>>>>end_class // cSetOfMasks_DFSource
83046>>>>>>>
83046>>>>>>>class cSetOfMasks_DFRuntime is a cSetOfMasks
83047>>>>>>>  procedure construct_object integer liImage
83049>>>>>>>    forward send construct_object liImage
83051>>>>>>>    set psName to "DataFlex runtime files"
83052>>>>>>>    send DoAddMask "*.flx"        "Charactermode App"
83053>>>>>>>    send DoAddMask "*.vdf"        "VDF 4 App"
83054>>>>>>>    send DoAddMask "*.vd5"        "VDF 5 App"
83055>>>>>>>    send DoAddMask "*.vd6"        "VDF 6 App"
83056>>>>>>>    send DoAddMask "*.vd7"        "VDF 7 App"
83057>>>>>>>    send DoAddMask "filelist.cfg" "List of tables"
83058>>>>>>>    send DoAddMask "termlist.cfg" "DF License file"
83059>>>>>>>    send DoAddMask "*.dfr"        "DF License file"
83060>>>>>>>    send DoAddMask "*.qry"        "VDFQuery definition"
83061>>>>>>>    send DoAddMask "*.fdx"        "DFMatrix, Tables definition file"
83062>>>>>>>  end_procedure
83063>>>>>>>end_class // cSetOfMasks_DFRuntime
83064>>>>>>>
83064>>>>>>>class cSetOfMasks_DFData is a cSetOfMasks
83065>>>>>>>  procedure construct_object integer liImage
83067>>>>>>>    forward send construct_object liImage
83069>>>>>>>    set psName to "DataFlex Data files"
83070>>>>>>>    send DoAddMask "*.dat"        "Table data"
83071>>>>>>>    send DoAddMask "*.k*"         "Index file"
83072>>>>>>>    send DoAddMask "*.tag"        "Field names"
83073>>>>>>>    send DoAddMask "*.vld"        "Variable length data"
83074>>>>>>>    send DoAddMask "*.hdr"        "Header backup file"
83075>>>>>>>    send DoAddMask "*.fd"         "Table definition file"
83076>>>>>>>  end_procedure
83077>>>>>>>end_class // cSetOfMasks_DFRuntime
83078>>>>>>>
83078>>>>>>>class cSetOfMasks_IIS is a cSetOfMasks
83079>>>>>>>  procedure construct_object integer liImage
83081>>>>>>>    forward send construct_object liImage
83083>>>>>>>    set psName to "IIS Files"
83084>>>>>>>    send DoAddMask "*.asp"        "ASP files"
83085>>>>>>>    send DoAddMask "*.htm"        "HTML files"
83086>>>>>>>    send DoAddMask "*.inc"        "Include files"
83087>>>>>>>    send DoAddMask "*.wsc"        "Windows scripting files"
83088>>>>>>>  end_procedure
83089>>>>>>>end_class // cSetOfMasks_DFRuntime
83090>>>>>>>
83090>>>>>>>class cSetOfMasks_CommandFiles is a cSetOfMasks
83091>>>>>>>  procedure construct_object integer liImage
83093>>>>>>>    forward send construct_object liImage
83095>>>>>>>    set psName to "Commands"
83096>>>>>>>    send DoAddMask "*.exe"        "Executable"
83097>>>>>>>    send DoAddMask "*.com"        "Executable"
83098>>>>>>>    send DoAddMask "*.bat"        "Batch file"
83099>>>>>>>  end_procedure
83100>>>>>>>end_class // cSetOfMasks_DFRuntime
83101>>>>>>>
83101>>>>>>>desktop_section
83106>>>>>>>  object oSetOfMasks_DFSource is a cSetOfMasks_DFSource NO_IMAGE
83108>>>>>>>  end_object
83109>>>>>>>  object oSetOfMasks_DFRuntime is a cSetOfMasks_DFRuntime NO_IMAGE
83111>>>>>>>  end_object
83112>>>>>>>  object oSetOfMasks_DFData is a cSetOfMasks_DFData NO_IMAGE
83114>>>>>>>  end_object
83115>>>>>>>  object oSetOfMasks_DFAll is a cSetOfMasks NO_IMAGE
83117>>>>>>>    set psName to "All DF files"
83118>>>>>>>    send DoImport (oSetOfMasks_DFSource(self))
83119>>>>>>>    send DoImport (oSetOfMasks_DFRuntime(self))
83120>>>>>>>    send DoImport (oSetOfMasks_DFData(self))
83121>>>>>>>  end_object
83122>>>>>>>  object oSetOfMasks_CommandFiles is a cSetOfMasks_CommandFiles NO_IMAGE
83124>>>>>>>  end_object
83125>>>>>>>  object oSetOfMasks_IIS is a cSetOfMasks_IIS NO_IMAGE
83127>>>>>>>  end_object
83128>>>>>>>end_desktop_section
83133>>>>>Use Spec0011.utl // Floating menues on the fly
83133>>>>>
83133>>>>>use APS // Auto Positioning and Sizing classes for VDF
83133>>>>>class cSetOfMasksList is a aps.Grid
83134>>>>>  procedure construct_object integer img#
83136>>>>>    forward send construct_object img#
83138>>>>>    property integer phSetOfMasksObject public 0
83139>>>>>    send GridPrepare_AddColumn "Masks" AFT_ASCII20
83140>>>>>    send GridPrepare_AddColumn ""      AFT_ASCII30
83141>>>>>    send GridPrepare_Apply self
83142>>>>>    set gridline_mode to GRID_VISIBLE_NONE
83143>>>>>    set Header_Visible_State to DFFALSE
83144>>>>>    set highlight_row_state to DFTRUE
83145>>>>>    on_key KNEXT_ITEM              send switch
83146>>>>>    on_key KPREVIOUS_ITEM          send switch_back
83147>>>>>    on_key KEY_CTRL+KEY_W          send DoWriteToFile
83148>>>>>    on_key KEY_CTRL+KEY_UP_ARROW   send MoveItemUp
83149>>>>>    on_key KEY_CTRL+KEY_DOWN_ARROW send MoveItemDown
83150>>>>>    on_key KDELETE_RECORD          send DoRemoveOne
83151>>>>>    object oTempSetOfMasks is a cSetOfMasks NO_IMAGE
83153>>>>>    end_object
83154>>>>>  end_procedure
83155>>>>>
83155>>>>>  procedure MoveItemUp
83157>>>>>    send Grid_SwapCurrentRowUp self
83158>>>>>  end_procedure
83159>>>>>  procedure MoveItemDown
83161>>>>>    send Grid_SwapCurrentRowDown self
83162>>>>>  end_procedure
83163>>>>>
83163>>>>>  procedure fill_list
83165>>>>>    integer liMax liRow lhSetOfMasksObject
83165>>>>>    get phSetOfMasksObject to lhSetOfMasksObject
83166>>>>>    send delete_data
83167>>>>>    set dynamic_update_state to DFFALSE
83168>>>>>    get row_count of lhSetOfMasksObject to liMax
83169>>>>>    decrement liMax
83170>>>>>    for liRow from 0 to liMax
83176>>>>>>
83176>>>>>      send add_item msg_none (psMask.i(lhSetOfMasksObject,liRow))
83177>>>>>      send add_item msg_none (psDecription.i(lhSetOfMasksObject,liRow))
83178>>>>>    loop
83179>>>>>>
83179>>>>>    set dynamic_update_state to DFTRUE
83180>>>>>  end_procedure
83181>>>>>
83181>>>>>  procedure Update_SetOfMasksObject
83183>>>>>    integer liMax liRow lhSetOfMasksObject
83183>>>>>    get phSetOfMasksObject to lhSetOfMasksObject
83184>>>>>    send DoReset to lhSetOfMasksObject
83185>>>>>    get Grid_RowCount self to liMax
83186>>>>>    decrement liMax
83187>>>>>    for liRow from 0 to liMax
83193>>>>>>
83193>>>>>      send DoAddMask to lhSetOfMasksObject (value(self,Grid_RowBaseItem(self,liRow))) (value(self,Grid_RowBaseItem(self,liRow)+1))
83194>>>>>    loop
83195>>>>>>
83195>>>>>  end_procedure
83196>>>>>
83196>>>>>  procedure AddMask string lsMask string lsDescription
83198>>>>>    send add_item msg_none lsMask
83199>>>>>    send add_item msg_none lsDescription
83200>>>>>  end_procedure
83201>>>>>
83201>>>>>  procedure DoAddOne
83203>>>>>  end_procedure
83204>>>>>  procedure DoDFSource
83206>>>>>    send DoCallBack to (oSetOfMasks_DFSource (self)) msg_AddMask self
83207>>>>>  end_procedure
83208>>>>>  procedure DoDFData
83210>>>>>    send DoCallBack to (oSetOfMasks_DFData   (self)) msg_AddMask self
83211>>>>>  end_procedure
83212>>>>>  procedure DoDFRuntime
83214>>>>>    send DoCallBack to (oSetOfMasks_DFRuntime(self)) msg_AddMask self
83215>>>>>  end_procedure
83216>>>>>  procedure DoDFAll
83218>>>>>    send DoCallBack to (oSetOfMasks_DFAll(self)) msg_AddMask self
83219>>>>>  end_procedure
83220>>>>>  procedure DoCommandFiles
83222>>>>>    send DoCallBack to (oSetOfMasks_CommandFiles(self)) msg_AddMask self
83223>>>>>  end_procedure
83224>>>>>  procedure DoIIS
83226>>>>>    send DoCallBack to (oSetOfMasks_IIS(self)) msg_AddMask self
83227>>>>>  end_procedure
83228>>>>>  procedure DoReset
83230>>>>>    send delete_data
83231>>>>>  end_procedure
83232>>>>>  procedure DoRemoveOne
83234>>>>>    send Grid_DeleteCurrentRow self
83235>>>>>  end_procedure
83236>>>>>
83236>>>>>  procedure DoWriteToFile
83238>>>>>    send Grid_DoWriteToFile self
83239>>>>>  end_procedure
83240>>>>>end_class // cSetOfMasksList
83241>>>>>
83241>>>>>desktop_section
83246>>>>> Use APS          // Auto Positioning and Sizing classes for VDF
83246>>>>> Use Buttons.utl  // Button texts
83246>>>>> object oEditSetOfMasksPanel is a aps.ModalPanel label ""
83249>>>>>   set locate_mode to CENTER_ON_SCREEN
83250>>>>>   on_key ksave_record send close_panel_ok
83251>>>>>   on_key kcancel send close_panel
83252>>>>>   property integer piResult public 0
83254>>>>>   object oLst is a cSetOfMasksList
83256>>>>>   end_object
83257>>>>>
83257>>>>>   procedure DoAddOne
83260>>>>>     send DoAddOne to (oLst(self))
83261>>>>>   end_procedure
83262>>>>>   procedure DoDFSource
83265>>>>>     send DoDFSource to (oLst(self))
83266>>>>>   end_procedure
83267>>>>>   procedure DoDFData
83270>>>>>     send DoDFData to (oLst(self))
83271>>>>>   end_procedure
83272>>>>>   procedure DoDFRuntime
83275>>>>>     send DoDFRuntime to (oLst(self))
83276>>>>>   end_procedure
83277>>>>>   procedure DoDFAll
83280>>>>>     send DoDFAll to (oLst(self))
83281>>>>>   end_procedure
83282>>>>>   procedure DoReset
83285>>>>>     send DoReset to (oLst(self))
83286>>>>>   end_procedure
83287>>>>>   procedure DoCommandFiles
83290>>>>>     send DoCommandFiles to (oLst(self))
83291>>>>>   end_procedure
83292>>>>>   procedure DoIIS
83295>>>>>     send DoIIS to (oLst(self))
83296>>>>>   end_procedure
83297>>>>>   procedure DoRemoveOne
83300>>>>>     send DoRemoveOne to (oLst(self))
83301>>>>>   end_procedure
83302>>>>>
83302>>>>>   object oBtn1 is a aps.Multi_Button
83304>>>>>     on_item t.btn.ok send close_panel_ok
83305>>>>>   end_object
83306>>>>>   object oBtn2 is a aps.Multi_Button
83308>>>>>     procedure PopupFM
83311>>>>>       send FLOATMENU_PrepareAddItem msg_DoAddOne       "One mask"
83312>>>>>       send FLOATMENU_PrepareAddItem msg_none           ""
83313>>>>>       send FLOATMENU_PrepareAddItem msg_DoDFSource     "DF source code"
83314>>>>>       send FLOATMENU_PrepareAddItem msg_DoDFData       "DF data files"
83315>>>>>       send FLOATMENU_PrepareAddItem msg_DoDFRuntime    "DF runtime files"
83316>>>>>       send FLOATMENU_PrepareAddItem msg_DoDFAll        "All DF files"
83317>>>>>       send FLOATMENU_PrepareAddItem msg_DoCommandFiles "Command files"
83318>>>>>       send FLOATMENU_PrepareAddItem msg_DoIIS          "IIS files"
83319>>>>>       send FLOATMENU_PrepareAddItem msg_none           ""
83320>>>>>       send FLOATMENU_PrepareAddItem msg_DoReset        "Reset list"
83321>>>>>       send FLOATMENU_PrepareAddItem msg_DoRemoveOne    "Remove mask"
83322>>>>>       send popup to (FLOATMENU_Apply(self))
83323>>>>>     end_procedure
83324>>>>>     on_item "Add mask" send PopupFM
83325>>>>>   end_object
83326>>>>>   object oBtn3 is a aps.Multi_Button
83328>>>>>     on_item "Reset list" send DoReset
83329>>>>>   end_object
83330>>>>>   object oBtn4 is a aps.Multi_Button
83332>>>>>     on_item t.btn.cancel send close_panel
83333>>>>>   end_object
83334>>>>>   send aps_locate_multi_buttons
83335>>>>>   procedure close_panel_ok
83338>>>>>     set piResult to 1
83339>>>>>     send close_panel
83340>>>>>   end_procedure
83341>>>>>   set Border_Style to BORDER_THICK   // Make panel resizeable
83342>>>>>   procedure aps_onResize integer delta_rw# integer delta_cl#
83345>>>>>     send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
83346>>>>>     send aps_register_multi_button (oBtn1(self))
83347>>>>>     send aps_register_multi_button (oBtn2(self))
83348>>>>>     send aps_register_multi_button (oBtn3(self))
83349>>>>>     send aps_register_multi_button (oBtn4(self))
83350>>>>>     send aps_locate_multi_buttons
83351>>>>>     send aps_auto_size_container
83352>>>>>   end_procedure
83353>>>>>   procedure popup.i integer lhSetOfMasksObject
83356>>>>>     set phSetOfMasksObject of (oLst(self)) to lhSetOfMasksObject
83357>>>>>     set piResult to 0
83358>>>>>     set label to (psName(lhSetOfMasksObject))
83359>>>>>     send fill_list to (oLst(self))
83360>>>>>     forward send popup
83362>>>>>     if (piResult(self)) send Update_SetOfMasksObject to (oLst(self))
83365>>>>>   end_procedure
83366>>>>> end_object // oEditSetOfMasksPanel
83367>>>>>end_desktop_section
83372>>>>>
83372>>>>>procedure DoEditSetOfMasks global integer lhSetOfMasksObject
83374>>>>>  send popup.i to (oEditSetOfMasksPanel(self)) lhSetOfMasksObject
83375>>>>>end_procedure
83376>>>
83376>>>activate_view Activate_Dircomp_Vw for oDirComp_Vw
83381>>>object oDirComp_Vw is a aps.View label "Compare directory contents (based on file time stamps)"
83384>>>  set p_auto_column to 1
83385>>>  on_key kcancel send close_panel
83386>>>  register_object oDir2
83386>>>  on_key kuser send DoDoubleTSE
83387>>>  object oSetOfMasks is a cSetOfMasks NO_IMAGE
83389>>>    set psName to "File masks, comparing folders"
83390>>>  end_object
83391>>>
83391>>>  procedure DoSetFilter
83394>>>    send DoEditSetOfMasks (oSetOfMasks(self))
83395>>>  end_procedure
83396>>>
83396>>>  object oDir1 is a aps.SelectDirForm label "Left directory:" abstract AFT_ASCII80
83400>>>    set p_extra_internal_width to -100
83401>>>    set value item 0 to (API_OtherAttr_Value(OA_WORKDIR))
83402>>>    procedure next
83405>>>      send activate to (oDir2(self))
83406>>>    end_procedure
83407>>>  end_object
83408>>>  register_object oLst
83408>>>  register_object oBtn1
83408>>>  object oToleranceButton is a aps.Button snap SL_RIGHT_SPACE
83411>>>    on_item "Tolerance" send DoSetTimeTolerance to (oLst(self))
83412>>>  end_object
83413>>>  object oDir2 is a aps.SelectDirForm label "Right directory:" abstract AFT_ASCII80
83417>>>    set p_extra_internal_width to -100
83418>>>    procedure OnSetFocus
83421>>>      if (value(self,0)="") set value item 0 to (value(oDir1(self),0))
83424>>>    end_procedure
83425>>>    procedure next
83428>>>      send activate to (oBtn1(self))
83429>>>    end_procedure
83430>>>  end_object
83431>>>  object oFilterButton is a aps.Button snap SL_RIGHT_SPACE
83434>>>    on_item "Filter" send DoSetFilter to (oLst(self))
83435>>>  end_object
83436>>>  set p_auto_column to 0
83437>>>  send aps_goto_max_row
83438>>>  send aps_make_row_space 4
83439>>>  object oTxt1 is a aps.TextBox label ""
83442>>>    set fixed_size to 10 100
83443>>>    set Fontweight to 900
83444>>>    set justification_mode to JMODE_LEFT
83445>>>  end_object
83446>>>  object oTxtLeft is a aps.TextBox label ""
83449>>>    set fixed_size to 10 200
83450>>>    set Fontweight to 900
83451>>>    set justification_mode to JMODE_LEFT
83452>>>  end_object
83453>>>  object oTxtRight is a aps.TextBox label ""
83456>>>    set fixed_size to 10 200
83457>>>    set Fontweight to 900
83458>>>    set justification_mode to JMODE_LEFT
83459>>>  end_object
83460>>>  send aps_goto_max_row
83461>>>  object oLst is a cDirCompList
83463>>>    set size to 150 0
83464>>>  end_object
83465>>>  set location of (oTxtLeft(self)) to (hi(location(oTxtLeft(self)))) (aps_grid_column_start(self,oLst(self),1))
83466>>>  set location of (oTxtRight(self)) to (hi(location(oTxtRight(self))))  (aps_grid_column_start(self,oLst(self),3))
83467>>>  procedure DoDoubleTSE
83470>>>    integer lhArray liRow lhLst liBase
83470>>>    string lsPath1 lsPath2 lsFileName lsCommand
83470>>>    // Deep at the heart of this is a global array called oDirectoryCompareArray:
83470>>>    move (oDirectoryCompareArray(self)) to lhArray
83471>>>    move (oLst(self)) to lhLst
83472>>>
83472>>>    if (item_count(lhLst)) begin
83474>>>      // We start by figuring out which row in that array we should examine:
83474>>>      get Grid_BaseItem lhLst to liBase
83475>>>      get aux_value of lhLst item liBase to liRow
83476>>>
83476>>>      get psPath1 of lhArray to lsPath1
83477>>>      get psPath2 of lhArray to lsPath2
83478>>>      get psFileName.i of lhArray liRow to lsFileName
83479>>>
83479>>>      get Files_AppendPath lsPath1 lsFileName to lsPath1
83480>>>      get Files_AppendPath lsPath2 lsFileName to lsPath2
83481>>>
83481>>>      if (pos(" ",lsPath1)) move ('"'+lsPath1+'"') to lsPath1
83484>>>      if (pos(" ",lsPath2)) move ('"'+lsPath2+'"') to lsPath2
83487>>>
83487>>>      move "e.exe %1 %2" to lsCommand
83488>>>
83488>>>      move (replace("%1",lsCommand,lsPath1)) to lsCommand
83489>>>      move (replace("%2",lsCommand,lsPath2)) to lsCommand
83490>>>
83490>>>      send obs lsCommand
83491>>>//      runprogram wait lsCommand
83491>>>//      runprogram BACKGROUND lsCommand
83491>>>
83491>>>    end
83491>>>>
83491>>>  end_procedure
83492>>>  procedure DoShowChanges
83495>>>    set value of (oTxt1(self)) to " Changes only:"
83496>>>    send fill_list.i to (oLst(self)) 1
83497>>>  end_procedure
83498>>>  procedure DoShowAll
83501>>>    set value of (oTxt1(self)) to " All files:"
83502>>>    send fill_list.i to (oLst(self)) 0
83503>>>  end_procedure
83504>>>  procedure DoCompare
83507>>>    string sPath1 sPath2
83507>>>    get value of (oDir1(self)) to sPath1
83508>>>    get value of (oDir2(self)) to sPath2
83509>>>    if (SEQ_FileExists(sPath1)) eq SEQIT_DIRECTORY begin
83511>>>      if (SEQ_FileExists(sPath2)) eq SEQIT_DIRECTORY begin
83513>>>        if (lowercase(sPath1)<>lowercase(sPath2)) begin
83515>>>          send cursor_wait to (cursor_control(self))
83516>>>          set value of (oTxtLeft(self)) to (" "+SEQ_TranslatePathToAbsolute(sPath1))
83517>>>          set value of (oTxtRight(self)) to (" "+SEQ_TranslatePathToAbsolute(sPath2))
83518>>>          send DirComp_DoCompare sPath1 sPath2 (oSetOfMasks(self))
83519>>>          set value of (oTxt1(self)) to " All files:"
83520>>>          send fill_list.i to (oLst(self)) 0
83521>>>          send cursor_ready to (cursor_control(self))
83522>>>        end
83522>>>>
83522>>>        else send obs "You can't compare a directory to itself"
83524>>>      end
83524>>>>
83524>>>      else send obs "Directory not found!" ("("+sPath2+")")
83526>>>    end
83526>>>>
83526>>>    else send obs "Directory not found!" ("("+sPath1+")")
83528>>>  end_procedure
83529>>>  object oBtn1 is a aps.Multi_Button
83531>>>    on_item "Refresh" send DoCompare
83532>>>  end_object
83533>>>  object oBtn2 is a aps.Multi_Button
83535>>>    procedure PopupFM
83538>>>      send FLOATMENU_PrepareAddItem msg_DoShowChanges "Changes only"
83539>>>      send FLOATMENU_PrepareAddItem msg_DoShowAll     "Show all"
83540>>>      send popup to (FLOATMENU_Apply(self))
83541>>>    end_procedure
83542>>>    on_item "Show" send PopupFM
83543>>>  end_object
83544>>>  procedure DoCopyNew
83547>>>    send DoCopyNew to (oLst(self))
83548>>>  end_procedure
83549>>>  procedure DoCopyLeft
83552>>>    send DoCopyLeft to (oLst(self))
83553>>>  end_procedure
83554>>>  procedure DoCopyRight
83557>>>    send DoCopyRight to (oLst(self))
83558>>>  end_procedure
83559>>>  procedure DoCopyAdvanced
83562>>>    send DoCopyAdvanced to (oLst(self))
83563>>>  end_procedure
83564>>>  object oBtn3 is a aps.Multi_Button
83566>>>    procedure PopupFM
83569>>>      send FLOATMENU_PrepareAddItem msg_DoCopyNew      "Copy newer file"
83570>>>      send FLOATMENU_PrepareAddItem msg_DoCopyLeft     "Copy left to right"
83571>>>      send FLOATMENU_PrepareAddItem msg_DoCopyRight    "Copy right to left"
83572>>>      send FLOATMENU_PrepareAddItem msg_none           ""
83573>>>      send FLOATMENU_PrepareAddItem msg_DoCopyAdvanced "Advanced"
83574>>>      send popup to (FLOATMENU_Apply(self))
83575>>>    end_procedure
83576>>>    on_item "Copy file" send PopupFM
83577>>>  end_object
83578>>>  object oBtn4 is a aps.Multi_Button
83580>>>    on_item "Close" send close_panel
83581>>>  end_object
83582>>>  send aps_locate_multi_buttons
83583>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
83584>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
83587>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
83588>>>    send aps_register_multi_button (oBtn1(self))
83589>>>    send aps_register_multi_button (oBtn2(self))
83590>>>    send aps_register_multi_button (oBtn3(self))
83591>>>    send aps_register_multi_button (oBtn4(self))
83592>>>    send aps_locate_multi_buttons
83593>>>    send aps_auto_size_container
83594>>>  end_procedure
83595>>>end_object
83596>    Use SetDir.vw    // Activate_SetDirTestVw
Including file: setdir.vw    (C:\Apps\VDFQuery\AppSrc\setdir.vw)
83596>>>//Use SetDir.vw    // Find file view
83596>>>
83596>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
83596>>>Use Spec0011.utl // Floating menues on the fly
83596>>>Use Buttons.utl  // Button texts
83596>>>Use GridUtil.utl // Grid and List utilities
83596>>>Use Files.utl    // Utilities for handling file related stuff
83596>>>Use SetDir.pkg   // cSetOfDirectories class
Including file: setdir.pkg    (C:\Apps\VDFQuery\AppSrc\setdir.pkg)
83596>>>>>// Use SetDir.pkg   // cSetOfDirectories class
83596>>>>>Use SetDir.nui   // cSetOfDirectories class
83596>>>>>Use GridUtil.utl // Grid and List utilities
83596>>>>>Use Files.utl    // Utilities for handling file related stuff
83596>>>>>
83596>>>>>use APS // Auto Positioning and Sizing classes for VDF
83596>>>>>class cSetOfDirectoriesList is a aps.Grid
83597>>>>>  procedure construct_object integer img#
83599>>>>>    forward send construct_object img#
83601>>>>>    property integer piSetOfDirectoriesObject public 0
83602>>>>>    send GridPrepare_AddColumn "Folders" AFT_ASCII70
83603>>>>>    send GridPrepare_Apply self
83604>>>>>    set gridline_mode to GRID_VISIBLE_NONE
83605>>>>>    set Header_Visible_State to DFFALSE
83606>>>>>    set highlight_row_state to DFTRUE
83607>>>>>    on_key KNEXT_ITEM              send switch
83608>>>>>    on_key KPREVIOUS_ITEM          send switch_back
83609>>>>>    on_key KEY_CTRL+KEY_W          send DoWriteToFile
83610>>>>>    on_key KEY_CTRL+KEY_UP_ARROW   send MoveItemUp
83611>>>>>    on_key KEY_CTRL+KEY_DOWN_ARROW send MoveItemDown
83612>>>>>  end_procedure
83613>>>>>
83613>>>>>  procedure MoveItemUp
83615>>>>>//  send Grid_SwapCurrentRowUp self
83615>>>>>  end_procedure
83616>>>>>  procedure MoveItemDown
83618>>>>>//  send Grid_SwapCurrentRowDown self
83618>>>>>  end_procedure
83619>>>>>
83619>>>>>  procedure DoWriteToFile
83621>>>>>    send Grid_DoWriteToFile self
83622>>>>>  end_procedure
83623>>>>>  procedure fill_list string lsDir
83625>>>>>    integer liItem liMax lhObj liCurrentItem
83625>>>>>    string lsTemp lsValue
83625>>>>>    if NUM_ARGUMENTS move lsDir to lsTemp
83628>>>>>    else move "" to lsTemp
83630>>>>>    move (lowercase(lsTemp)) to lsTemp
83631>>>>>    send delete_data
83632>>>>>    move -1 to liCurrentItem
83633>>>>>    set dynamic_update_state to DFFALSE
83634>>>>>    get piSetOfDirectoriesObject to lhObj
83635>>>>>    get item_count of lhObj to liMax
83636>>>>>    decrement liMax
83637>>>>>    for liItem from 0 to liMax
83643>>>>>>
83643>>>>>      get value of lhObj item liItem to lsValue
83644>>>>>      send add_item msg_none lsValue
83645>>>>>      if (lowercase(lsValue)=lsTemp) move liItem to liCurrentItem
83648>>>>>    loop
83649>>>>>>
83649>>>>>    send Grid_SetEntryState self DFFALSE
83650>>>>>    if (liCurrentItem<>-1) set current_item to liCurrentItem
83653>>>>>    set dynamic_update_state to DFTRUE
83654>>>>>    send OnListChanged (item_count(self))
83655>>>>>  end_procedure
83656>>>>>  procedure OnListChanged integer liItems
83658>>>>>  end_procedure
83659>>>>>  procedure DoReset
83661>>>>>    send DoReset to (piSetOfDirectoriesObject(self))
83662>>>>>    send fill_list
83663>>>>>  end_procedure
83664>>>>>  procedure DoAddDirectory
83666>>>>>    string lsDir
83666>>>>>    get SEQ_SelectDirectory "Select folder" to lsDir
83667>>>>>    if (lsDir<>"") begin
83669>>>>>      send DoAddDirectory to (piSetOfDirectoriesObject(self)) lsDir
83670>>>>>      send fill_list lsDir
83671>>>>>    end
83671>>>>>>
83671>>>>>  end_procedure
83672>>>>>  procedure DoAddSubDirectories
83674>>>>>    string lsDir
83674>>>>>    get SEQ_SelectDirectory "Select root folder" to lsDir
83675>>>>>    if (lsDir<>"") begin
83677>>>>>      send DoAddSubDirectories to (piSetOfDirectoriesObject(self)) lsDir
83678>>>>>      send fill_list lsDir
83679>>>>>    end
83679>>>>>>
83679>>>>>  end_procedure
83680>>>>>  procedure DoRemoveDirectory
83682>>>>>    integer liItemCount liCurrentItem liNextItem
83682>>>>>    string lsDir lsNextDir
83682>>>>>    get item_count to liItemCount
83683>>>>>    if liItemCount begin
83685>>>>>      get current_item to liCurrentItem
83686>>>>>
83686>>>>>      move -1 to liNextItem
83687>>>>>      if (liCurrentItem<(liItemCount-1)) move (liCurrentItem+1) to liNextItem
83690>>>>>      else if (liCurrentItem>0) move (liCurrentItem-1) to liNextItem
83694>>>>>
83694>>>>>      get value item liCurrentItem to lsDir
83695>>>>>      send DoRemoveDirectory to (piSetOfDirectoriesObject(self)) lsDir
83696>>>>>      if (liNextItem<>-1) begin
83698>>>>>        get value item liNextItem to lsNextDir
83699>>>>>        send fill_list lsNextDir
83700>>>>>      end
83700>>>>>>
83700>>>>>      else send fill_list
83702>>>>>    end
83702>>>>>>
83702>>>>>  end_procedure
83703>>>>>  procedure DoAddSearchPath string lsPath
83705>>>>>    send DoAddSearchPath to (piSetOfDirectoriesObject(self)) lsPath
83706>>>>>    send fill_list
83707>>>>>  end_procedure
83708>>>>>  procedure DoFindFileCallback string lsFileMask integer lbFirstOnly integer liMsg integer liObj
83710>>>>>    send DoFindFileCallback to (piSetOfDirectoriesObject(self)) lsFileMask lbFirstOnly liMsg liObj
83711>>>>>  end_procedure
83712>>>>>  procedure DoFindFileBySetOfMasksCallback integer lhSetOfMasks integer lbFirstOnly integer liMsg integer liObj
83714>>>>>    send DoFindFileBySetOfMasksCallback to (piSetOfDirectoriesObject(self)) lhSetOfMasks lbFirstOnly liMsg liObj
83715>>>>>  end_procedure
83716>>>>>  procedure DoFindFilesCompilerListingCallback string lsPrnFile integer lbFirstOnly integer liMsg integer liObj
83718>>>>>    send DoFindFilesCompilerListingCallback to (piSetOfDirectoriesObject(self)) lsPrnFile lbFirstOnly liMsg liObj
83719>>>>>  end_procedure
83720>>>>>end_class // cSetOfDirectoriesList
83721>>>>>
83721>>>>>class cSetOfFilesListNew is a aps.Grid
83722>>>>>  procedure construct_object integer img#
83724>>>>>    forward send construct_object img#
83726>>>>>    property integer piSOF_Object    public 0
83727>>>>>    property string  psConstrainPath public ""
83728>>>>>    property string  prv.psDir       public ""
83729>>>>>    set select_mode to NO_SELECT
83730>>>>>    send GridPrepare_AddColumn "Filename"  AFT_ASCII12
83731>>>>>    send GridPrepare_AddColumn "Type"      AFT_ASCII4
83732>>>>>    send GridPrepare_AddColumn "Size"      AFT_ASCII6
83733>>>>>    send GridPrepare_AddColumn "Modified"  AFT_ASCII20
83734>>>>>    send GridPrepare_AddColumn "Folder"    AFT_ASCII60
83735>>>>>    send GridPrepare_Apply self
83736>>>>>    set gridline_mode to GRID_VISIBLE_NONE
83737>>>>>    set highlight_row_state to true
83738>>>>>    on_key KNEXT_ITEM     send switch
83739>>>>>    on_key KPREVIOUS_ITEM send switch_back
83740>>>>>    on_key KEY_CTRL+KEY_R send user_sort
83741>>>>>    on_key KEY_CTRL+KEY_W send DoWriteToFile
83742>>>>>    on_key KEY_CTRL+KEY_C send DoCopyFiles
83743>>>>>  end_procedure
83744>>>>>  procedure DoWriteToFile
83746>>>>>    send Grid_DoWriteToFile self
83747>>>>>  end_procedure
83748>>>>>  procedure DoCopyFiles
83750>>>>>    string lsTargetDir
83750>>>>>    get SEQ_SelectDirectory "Select target directory" to lsTargetDir
83751>>>>>    if (lsTargetDir<>"") begin
83753>>>>>      if (SEQ_FileExists(lsTargetDir)=SEQIT_DIRECTORY) send DoCopyFiles to (piSOF_Object(self)) lsTargetDir
83756>>>>>      else send obs "Illegal target directory"
83758>>>>>    end
83758>>>>>>
83758>>>>>  end_procedure
83759>>>>>  procedure fill_list
83761>>>>>    integer lhObj liRow liMax liFileCount liBase
83761>>>>>    number lnTotalBytes liFileSize
83761>>>>>    string lsConstrainPath lsPath
83761>>>>>    get psConstrainPath to lsConstrainPath
83762>>>>>    get piSOF_Object to lhObj
83763>>>>>    if lhObj begin
83765>>>>>      move 0 to lnTotalBytes
83766>>>>>      move 0 to liFileCount
83767>>>>>      get row_count of lhObj to liMax
83768>>>>>      decrement liMax
83769>>>>>      send delete_data
83770>>>>>      set dynamic_update_state to DFFALSE
83771>>>>>      for liRow from 0 to liMax
83777>>>>>>
83777>>>>>        move (psFilePath.i(lhObj,liRow)) to lsPath
83778>>>>>        if (lsConstrainPath="" or lsConstrainPath=lsPath) begin
83780>>>>>          get item_count to liBase
83781>>>>>          send add_item msg_none (psFileName.i(lhObj,liRow))
83782>>>>>          set aux_value item liBase to liRow
83783>>>>>          send add_item msg_none (psFileType.i(lhObj,liRow))
83784>>>>>          move (piFileSize.i(lhObj,liRow)) to liFileSize
83785>>>>>          send add_item msg_none (SEQ_FileSizeToString(liFileSize))
83786>>>>>          send add_item msg_none (TS_ConvertToString(pnFileTime.i(lhObj,liRow)))
83787>>>>>          send add_item msg_none lsPath
83788>>>>>          move (lnTotalBytes+liFileSize) to lnTotalBytes
83789>>>>>          increment liFileCount
83790>>>>>        end
83790>>>>>>
83790>>>>>      loop
83791>>>>>>
83791>>>>>      send Grid_SetEntryState self DFFALSE
83792>>>>>      set dynamic_update_state to DFTRUE
83793>>>>>      send OnListFilled liFileCount lnTotalBytes
83794>>>>>    end
83794>>>>>>
83794>>>>>  end_procedure
83795>>>>>  procedure OnListFilled integer liFileCount number lnBytes
83797>>>>>  end_procedure
83798>>>>>  procedure sort_by_column integer liColumn
83800>>>>>    if liColumn eq 0 send DoSort to (piSOF_Object(self)) SOF_ORDERING_NAME
83803>>>>>    if liColumn eq 1 send DoSort to (piSOF_Object(self)) SOF_ORDERING_TYPE
83806>>>>>    if liColumn eq 2 send DoSort to (piSOF_Object(self)) SOF_ORDERING_SIZE
83809>>>>>    if liColumn eq 3 send DoSort to (piSOF_Object(self)) SOF_ORDERING_TIME
83812>>>>>    if liColumn eq 4 send DoSort to (piSOF_Object(self)) SOF_ORDERING_PATH
83815>>>>>    send fill_list
83816>>>>>  end_procedure
83817>>>>>  procedure header_mouse_click integer liItem
83819>>>>>    send sort_by_column liItem
83820>>>>>    forward send header_mouse_click liItem
83822>>>>>  end_procedure
83823>>>>>  procedure user_sort
83825>>>>>    integer liItem
83825>>>>>    get current_item to liItem
83826>>>>>    send sort_by_column (liItem-((liItem/5)*5))
83827>>>>>  end_procedure
83828>>>>>  procedure DoReset
83830>>>>>    send DoReset to (piSOF_Object(self))
83831>>>>>    send fill_list
83832>>>>>  end_procedure
83833>>>>>  procedure DoCopyFilesToDirectory_help string lsFile string lsPath
83835>>>>>    integer liRval
83835>>>>>    string lsTargetDir
83835>>>>>    get prv.psDir to lsTargetDir
83836>>>>>    get SEQ_CopyFile (SEQ_ComposeAbsoluteFileName(lsPath,lsFile)) (SEQ_ComposeAbsoluteFileName(lsTargetDir,lsFile)) to liRval
83837>>>>>    ifnot liRval send obs "Error! File could not be copied." (SEQ_ComposeAbsoluteFileName(lsPath,lsFile)) "to" (SEQ_ComposeAbsoluteFileName(lsTargetDir,lsFile))
83840>>>>>  end_procedure
83841>>>>>  procedure DoCopyFilesToDirectory
83843>>>>>    string lsDir
83843>>>>>    if (item_count(self)) begin
83845>>>>>      get SEQ_SelectDirectory "Copy files to folder" to lsDir
83846>>>>>      if (lsDir<>"") begin
83848>>>>>        set prv.psDir to lsDir
83849>>>>>        send DoCallback to (piSOF_Object(self)) msg_DoCopyFilesToDirectory_help self
83850>>>>>      end
83850>>>>>>
83850>>>>>    end
83850>>>>>>
83850>>>>>    else send obs "No files to copy"
83852>>>>>  end_procedure
83853>>>>>end_class // cSetOfFilesListNew
83854>>>>>
83854>>>Use Masks_DF.nui // DataFlex related file masks
83854>>>Use Strings.nui
83854>>>
83854>>>
83854>>>// ******************************************************************
83854>>>//  Text search functions
83854>>>
83854>>>
83854>>>object oSetOfDirectories is a cSetOfDirectories NO_IMAGE
83856>>>    object oWait is a StatusPanel
83858>>>      set allow_cancel_state to DFFALSE
83859>>>    end_object
83860>>>    procedure OnWait_On string lsCaption
83863>>>      set caption_text of (oWait(self)) to lsCaption
83864>>>      set title_text   of (oWait(self)) to ""
83865>>>      set message_text of (oWait(self)) to ""
83866>>>      set action_text  of (oWait(self)) to ""
83867>>>      send Start_StatusPanel to (oWait(self))
83868>>>    end_procedure
83869>>>    procedure OnWait_SetText1 string lsValue
83872>>>      set Message_Text of (oWait(self)) to lsValue
83873>>>    end_procedure
83874>>>    procedure OnWait_SetText2 string lsValue
83877>>>      set Action_Text of (oWait(self)) to lsValue
83878>>>    end_procedure
83879>>>    procedure OnWait_Off
83882>>>      send Stop_StatusPanel to (oWait(self))
83883>>>    end_procedure
83884>>>end_object
83885>>>
83885>>>object oSetOfFilesNew is a cSetOfFilesNew NO_IMAGE
83887>>>  set piSOD_Object to (oSetOfDirectories(self))
83888>>>end_object
83889>>>
83889>>>Use Buttons.utl  // Button texts
83889>>>Use APS          // Auto Positioning and Sizing classes for VDF
83889>>>
83889>>>activate_view Activate_FindFileResultVw for oNewFindFileResultVw
83894>>>object oNewFindFileResultVw is a aps.View label "Find file, result"
83897>>>  on_key kuser send Activate_SetDirTestVw
83898>>>  on_key kcancel send close_panel
83899>>>  object oLst is a cSetOfFilesListNew
83901>>>    set size to 200 0
83902>>>    set piSOF_Object to (oSetOfFilesNew(self))
83903>>>    procedure OnListFilled integer liFileCount number lnBytes
83906>>>      send total_display (SEQ_FileSizeToString(lnBytes)+" in "+string(liFileCount)+" files")
83907>>>    end_procedure
83908>>>    procedure DoReset
83911>>>      forward send DoReset
83913>>>      send Activate_SetDirTestVw
83914>>>    end_procedure
83915>>>  end_object
83916>>>  send aps_goto_max_row
83917>>>
83917>>>  object oSelectTxt is a aps.TextBox
83919>>>  end_object
83920>>>  set auto_size_state of (oSelectTxt(self)) to DFTRUE
83921>>>  procedure total_display string lsValue
83924>>>    set value of (oSelectTxt(self)) to lsValue
83925>>>  end_procedure
83926>>>  object oBtn1 is a aps.Multi_Button
83928>>>    on_item "Reset list" send DoReset to (oLst(self))
83929>>>  end_object
83930>>>  object oBtn2 is a aps.Multi_Button
83932>>>    on_item "Copy files" send DoCopyFilesToDirectory to (oLst(self))
83933>>>  end_object
83934>>>  object oBtn3 is a aps.Multi_Button
83936>>>    on_item t.btn.close send close_panel
83937>>>  end_object
83938>>>  send aps_locate_multi_buttons
83939>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
83940>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
83943>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
83944>>>    send aps_auto_locate_control (oSelectTxt(self)) SL_DOWN (oLst(self))
83945>>>    send aps_register_multi_button (oBtn1(self))
83946>>>    send aps_register_multi_button (oBtn2(self))
83947>>>    send aps_register_multi_button (oBtn3(self))
83948>>>    send aps_locate_multi_buttons
83949>>>    send aps_auto_size_container
83950>>>  end_procedure
83951>>>  procedure fill_list
83954>>>    send fill_list to (oLst(self))
83955>>>  end_procedure
83956>>>end_object // oNewFindFileResultVw
83957>>>procedure Activate_FindFileResultVwReFill
83960>>>  send fill_list to (oNewFindFileResultVw(self))
83961>>>  send Activate_FindFileResultVw
83962>>>end_procedure
83963>>>
83963>>>activate_view Activate_SetDirTestVw for oNewFindFileVw
83968>>>object oNewFindFileVw is a aps.View label "Find file"
83971>>>  on_key kuser send Activate_FindFileResultVw
83972>>>  set pMinimumSize to 220 0
83973>>>  on_key kcancel send close_panel
83974>>>  object oLstHeader is a aps.Textbox label "Folders in search path"
83977>>>  end_object
83978>>>  object oLst is a cSetOfDirectoriesList snap SL_DOWN
83981>>>    set size to 170 0
83982>>>    set piSetOfDirectoriesObject to (oSetOfDirectories(self))
83983>>>    register_object oLstTotal
83983>>>    set Horz_Scroll_Bar_Visible_State to false
83984>>>
83984>>>    procedure OnListChanged integer liItems
83987>>>      set value of (oLstTotal(self)) to ("  "+string(liItems)+" folders")
83988>>>    end_procedure
83989>>>  end_object
83990>>>  object oLstTotal is a aps.Textbox label "  0 folders         "
83993>>>  end_object
83994>>>  send aps_goto_max_row
83995>>>  object oFrm is a aps.Form abstract AFT_ASCII80 label "Find this file (wildcards allowed):"
83999>>>    set p_extra_internal_width to -240
84000>>>    register_object oBtn4
84000>>>    on_key kenter send goto_search_button
84001>>>  end_object
84002>>>  procedure DoAddOne
84005>>>    send DoAddDirectory to (oLst(self))
84006>>>  end_procedure
84007>>>  procedure DoAddSub
84010>>>    send DoAddSubDirectories to (oLst(self))
84011>>>  end_procedure
84012>>>  procedure DoMakePath
84015>>>    integer lhoWorkSpace
84015>>>    string lsPath
84015>>>    get_profile_string "DfComp" "MakePath" to lsPath
84018>>>    if (DFMatrix_WorkSpaceLoaded()) begin
84020>>>      get phoWorkspace of ghoApplication To lhoWorkSpace
84021>>>      move (psAppSrcPath(lhoWorkSpace)+";"+psProgramPath(lhoWorkSpace)+";"+psDataPath(lhoWorkSpace)+";"+psDdSrcPath(lhoWorkSpace)+";"+psHelpPath(lhoWorkSpace)+";"+psSystemMakePath(lhoWorkSpace)) to lsPath
84022>>>    end
84022>>>>
84022>>>    send DoAddSearchPath to (oLst(self)) lsPath
84023>>>  end_procedure
84024>>>  procedure DoDFPath
84027>>>    integer lhoWorkSpace
84027>>>    string lsPath
84027>>>    get phoWorkspace of ghoApplication To lhoWorkSpace
84028>>>    if (DFMatrix_WorkSpaceLoaded()) move (psDfPath(lhoWorkSpace)) to lsPath
84031>>>    else move (API_AttrValue_GLOBAL(DF_OPEN_PATH)) to lsPath // Oem fixed!
84033>>>    move (ToOem(lsPath)) to lsPath
84034>>>    send DoAddSearchPath to (oLst(self)) lsPath
84035>>>  end_procedure
84036>>>  send DoDFPath // Default value
84037>>>  procedure DoPath
84040>>>    send DoAddSearchPath to (oLst(self)) (API_OtherAttr_Value(OA_PATH))
84041>>>  end_procedure
84042>>>  procedure DoReset
84045>>>    send DoReset to (oLst(self))
84046>>>  end_procedure
84047>>>  object oBtn1 is a aps.Button snap SL_RIGHT relative_to (oLst(self))
84055>>>    set size to 14 70
84056>>>    procedure PopupFM
84059>>>      send FLOATMENU_PrepareAddItem msg_DoAddOne   "One folder"
84060>>>      send FLOATMENU_PrepareAddItem msg_DoAddSub   "Sub-folders"
84061>>>      send FLOATMENU_PrepareAddItem msg_DoMakePath "MakePath"
84062>>>      send FLOATMENU_PrepareAddItem msg_DoDFPath   "DFPath"
84063>>>      send FLOATMENU_PrepareAddItem msg_DoPath     "EXE search path"
84064>>>      send FLOATMENU_PrepareAddItem msg_none       ""
84065>>>      send FLOATMENU_PrepareAddItem msg_DoReset    "Reset list"
84066>>>      send popup to (FLOATMENU_Apply(self))
84067>>>    end_procedure
84068>>>    on_item "Add folders" send PopupFM
84069>>>  end_object
84070>>>  object oBtn2 is a aps.Button snap SL_DOWN
84073>>>    set size to 14 70
84074>>>    on_item "Remove from list" send DoRemoveDirectory to (oLst(self))
84075>>>  end_object
84076>>>  object oBtn3 is a aps.Button snap SL_DOWN
84079>>>    set size to 14 70
84080>>>    on_item "Reset list" send DoReset
84081>>>  end_object
84082>>>  object oSpacer1 is a aps.Textbox label " " snap SL_DOWN
84086>>>  end_object
84087>>>  object oBtn4 is a aps.Button snap SL_DOWN
84090>>>    set size to 14 70
84091>>>    on_item "Find file" send DoFindFile
84092>>>  end_object
84093>>>  object oBtn4 is a aps.Button snap SL_DOWN
84096>>>    set size to 14 70
84097>>>    register_procedure DoFindDFSource
84097>>>    register_procedure DoFindDFData
84097>>>    register_procedure DoFindDFRuntime
84097>>>    register_procedure DoFindDFAll
84097>>>    procedure PopupFM
84100>>>      send FLOATMENU_PrepareAddItem msg_DoFindDFSource  "DF source code"
84101>>>      send FLOATMENU_PrepareAddItem msg_DoFindDFData    "DF data files"
84102>>>      send FLOATMENU_PrepareAddItem msg_DoFindDFRuntime "DF runtime files"
84103>>>      send FLOATMENU_PrepareAddItem msg_DoFindDFAll     "All DF files"
84104>>>      send popup to (FLOATMENU_Apply(self))
84105>>>    end_procedure
84106>>>    on_item "Special find (slow)" send PopupFM
84107>>>  end_object
84108>>>  procedure goto_search_button
84111>>>    send activate to (oBtn4(self))
84112>>>  end_procedure
84113>>>  object oBtn5 is a aps.Button snap SL_DOWN
84116>>>    set size to 14 70
84117>>>    on_item "Scan PR? file" send DoFindPrnFile
84118>>>  end_object
84119>>>  object oFirstOccuranceOnly is a aps.CheckBox label "1st occur. only" snap SL_DOWN
84123>>>  end_object
84124>>>  object oSpacer2 is a aps.Textbox label " " snap SL_DOWN
84128>>>  end_object
84129>>>  object oBtnClose is a aps.Button snap SL_DOWN
84132>>>    set size to 14 70
84133>>>    on_item t.btn.close send close_panel
84134>>>  end_object
84135>>>  procedure DoFindFile
84138>>>    integer lbFirstOnly
84138>>>    string lsFileMask
84138>>>    get value of (oFrm(self)) item 0 to lsFileMask
84139>>>    if (lsFileMask<>"") begin
84141>>>      get select_state of (oFirstOccuranceOnly(self)) to lbFirstOnly
84142>>>      send DoFindFile to (oSetOfFilesNew(self)) lsFileMask lbFirstOnly
84143>>>      send Activate_FindFileResultVwReFill
84144>>>    end
84144>>>>
84144>>>    else begin
84145>>>      send obs "You must enter a file name before finding."
84146>>>      send activate to (oFrm(self))
84147>>>    end
84147>>>>
84147>>>  end_procedure
84148>>>  procedure DoFindDFSource
84151>>>    integer lbFirstOnly
84151>>>    get select_state of (oFirstOccuranceOnly(self)) to lbFirstOnly
84152>>>    send DoFindFileBySetOfMasks to (oSetOfFilesNew(self)) (oSetOfMasks_DFSource(self)) lbFirstOnly
84153>>>    send Activate_FindFileResultVwReFill
84154>>>  end_procedure
84155>>>  procedure DoFindDFData
84158>>>    integer lbFirstOnly
84158>>>    get select_state of (oFirstOccuranceOnly(self)) to lbFirstOnly
84159>>>    send DoFindFileBySetOfMasks to (oSetOfFilesNew(self)) (oSetOfMasks_DFData(self)) lbFirstOnly
84160>>>    send Activate_FindFileResultVwReFill
84161>>>  end_procedure
84162>>>  procedure DoFindDFRuntime
84165>>>    integer lbFirstOnly
84165>>>    get select_state of (oFirstOccuranceOnly(self)) to lbFirstOnly
84166>>>    send DoFindFileBySetOfMasks to (oSetOfFilesNew(self)) (oSetOfMasks_DFRuntime(self)) lbFirstOnly
84167>>>    send Activate_FindFileResultVwReFill
84168>>>  end_procedure
84169>>>  procedure DoFindDFAll
84172>>>    integer lbFirstOnly
84172>>>    get select_state of (oFirstOccuranceOnly(self)) to lbFirstOnly
84173>>>    send DoFindFileBySetOfMasks to (oSetOfFilesNew(self)) (oSetOfMasks_DFAll(self)) lbFirstOnly
84174>>>    send Activate_FindFileResultVwReFill
84175>>>  end_procedure
84176>>>  procedure DoFindPrnFile
84179>>>    integer lbFirstOnly
84179>>>    string lsPrnFile
84179>>>    get SEQ_SelectFile "Select compiler listing file" "Compiler listing (*.prn)|*.PRN|Precompile listing (*.prp)|*.PRP" to lsPrnFile
84180>>>    if lsPrnFile ne "" begin
84182>>>      get select_state of (oFirstOccuranceOnly(self)) to lbFirstOnly
84183>>>      send DoFindFilesCompilerListing to (oSetOfFilesNew(self)) lsPrnFile lbFirstOnly
84184>>>      send Activate_FindFileResultVwReFill
84185>>>    end
84185>>>>
84185>>>  end_procedure
84186>>>  procedure aps_beautify
84189>>>    send aps_align_by_moving (oFrm(self)) (oLst(self)) SL_ALIGN_RIGHT
84190>>>    send aps_align_by_moving (oLstTotal(self)) (oLst(self)) SL_ALIGN_BOTTOM
84191>>>  end_procedure
84192>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
84193>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
84196>>>    send aps_resize (oLst(self)) delta_rw# 0 // delta_cl#
84197>>>    send aps_auto_locate_control (oFrm(self)) SL_DOWN (oLst(self))
84198>>>    send aps_beautify
84199>>>    send aps_register_max_rc (oBtn1(self))
84200>>>    send aps_auto_size_container
84201>>>  end_procedure
84202>>>end_object // oNewFindFileVw
84203>>>
84203>    Use DFM_ODBC.vw  // Activate_ODBCViewer
Including file: dfm_odbc.vw    (C:\Apps\VDFQuery\AppSrc\dfm_odbc.vw)
84203>>>use odbc.utl
Including file: odbc.utl    (C:\Apps\VDFQuery\AppSrc\odbc.utl)
84203>>>>>// Use ODBC.utl
84203>>>>>use aps
84203>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
84203>>>>>Use MsgBox.utl
84203>>>>>use gridutil.utl
84203>>>>>Use Language    // Set default languange if not set by compiler command line
84203>>>>>Use Seq_Chnl    // Defines global sequential device management operations (DAW)
84203>>>>>use buttons.utl
84203>>>>>use dbms.utl
84203>>>>>use files.utl
84203>>>>>Use FDX.nui
84203>>>>>use FDX2.utl
84203>>>>>Use Login.utl    // DBMS_GetDriverLogin function
84203>>>>>
84203>>>>>integer IntDummy
84203>>>>>use odbc_drv
Including file: odbc_drv.pkg    (c:\VDF12\Pkg\odbc_drv.pkg)
84203>>>>>>>//*****************************************************************************
84203>>>>>>>//*** ODBC_DRV.PKG                                                          ***
84203>>>>>>>//***                                                                       ***
84203>>>>>>>//*** Author: Ben Weijers                                                   ***
84203>>>>>>>//***         Data Access Nederland                                         ***
84203>>>>>>>//***         3 February 1998                                               ***
84203>>>>>>>//***                                                                       ***
84203>>>>>>>//*** Purpose:                                                              ***
84203>>>>>>>//***   Package that declares ODBC driver constants and functions.          ***
84203>>>>>>>//****                                                                      ***
84203>>>>>>>//***   This package can be used by developers who want to add Data Access  ***
84203>>>>>>>//***   ODBC Client specific code to a DataFlex application.                ***
84203>>>>>>>//*****************************************************************************
84203>>>>>>>
84203>>>>>>>Use Cli.pkg
Including file: cli.pkg    (c:\VDF12\Pkg\cli.pkg)
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>//*** CLI.PKG                                                               ***
84203>>>>>>>>>//***                                                                       ***
84203>>>>>>>>>//*** Author: Ben Weijers                                                   ***
84203>>>>>>>>>//***         Data Access Nederland                                         ***
84203>>>>>>>>>//***         10 September 1998                                             ***
84203>>>>>>>>>//***                                                                       ***
84203>>>>>>>>>//*** Purpose:                                                              ***
84203>>>>>>>>>//***   CLI specific functionality. There are several connectivity kits     ***
84203>>>>>>>>>//***   based on  SQL/92 CLI. Those are:                                    ***
84203>>>>>>>>>//***    - ODBC_DRV  The Data Access CK for ODBC                            ***
84203>>>>>>>>>//***    - DB2_DRV   The Data Access CK for DB2                             ***
84203>>>>>>>>>//***    - MSSQLDRV  The Data Access CK for Microsoft SQL Server            ***
84203>>>>>>>>>//***                                                                       ***
84203>>>>>>>>>//***   This package defines the common functionality for all CLI based     ***
84203>>>>>>>>>//***   drivers.                                                            ***
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>
84203>>>>>>>>>//*** This use is required for Visual DataFlex 12.0 (and higher)
84203>>>>>>>>>//#IFDEF IS$WINDOWS
84203>>>>>>>>>//    Use VDFBase.pkg
84203>>>>>>>>>//#ELSE
84203>>>>>>>>>//#ENDIF
84203>>>>>>>>>
84203>>>>>>>>>//*** We are not using ifndef below becuase that is not supported in Character Mode
84203>>>>>>>>>//*** Driver attributes
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*** Replacement for logical column number that indicates all columns
84203>>>>>>>>>
84203>>>>>>>>>//*** Possible DF_FILE_GENERATE_RECORD_ID_METHOD values
84203>>>>>>>>>
84203>>>>>>>>>//*** Possible DF_FIELD_READ_ONLY values
84203>>>>>>>>>
84203>>>>>>>>>//*** Possible SQL Column type values
84203>>>>>>>>>Define SQL_UNKNOWN_TYPE   For    0
84203>>>>>>>>>Define SQL_CHAR           For    1
84203>>>>>>>>>Define SQL_NUMERIC        For    2
84203>>>>>>>>>Define SQL_DECIMAL        For    3
84203>>>>>>>>>Define SQL_INTEGER        For    4
84203>>>>>>>>>Define SQL_SMALLINT       For    5
84203>>>>>>>>>Define SQL_FLOAT          For    6
84203>>>>>>>>>Define SQL_REAL           For    7
84203>>>>>>>>>Define SQL_DOUBLE         For    8
84203>>>>>>>>>Define SQL_DATETIME       For    9
84203>>>>>>>>>Define SQL_VARCHAR        For   12
84203>>>>>>>>>Define SQL_TYPE_DATE      For   91
84203>>>>>>>>>Define SQL_TYPE_TIME      For   92
84203>>>>>>>>>Define SQL_TYPE_TIMESTAMP For   93
84203>>>>>>>>>
84203>>>>>>>>>Define SQL_DATE           For    9
84203>>>>>>>>>Define SQL_INTERVAL       For   10
84203>>>>>>>>>Define SQL_TIME           For   10
84203>>>>>>>>>Define SQL_TIMESTAMP      For   11
84203>>>>>>>>>Define SQL_LONGVARCHAR    For  (-1)
84203>>>>>>>>>Define SQL_BINARY         For  (-2)
84203>>>>>>>>>Define SQL_VARBINARY      For  (-3)
84203>>>>>>>>>Define SQL_LONGVARBINARY  For  (-4)
84203>>>>>>>>>Define SQL_BIGINT         For  (-5)
84203>>>>>>>>>Define SQL_TINYINT        For  (-6)
84203>>>>>>>>>Define SQL_BIT            For  (-7)
84203>>>>>>>>>Define SQL_WCHAR          For  (-8)
84203>>>>>>>>>Define SQL_WVARCHAR       For  (-9)
84203>>>>>>>>>Define SQL_WLONGVARCHAR   For (-10)
84203>>>>>>>>>Define SQL_GUID           For (-11)
84203>>>>>>>>>
84203>>>>>>>>>//*** Driver level attributes
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*** Error number constants
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*** Call driver function identifiers
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*** Init data source types
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*** Dummy strings used in the commands
84203>>>>>>>>>    String  CLI$StrDummy 255
84203>>>>>>>>>    Integer CLI$IntDummy
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>//*** CLI_SetConstraint                                  ***
84203>>>>>>>>>//***                                                                       ***
84203>>>>>>>>>//***   Setup a constraint for a file.                                      ***
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>//*** CLI_Set_Driver_Atrtribute / CLI_Get_Driver_Attribute                  ***
84203>>>>>>>>>//***                                                                       ***
84203>>>>>>>>>//*** Set or get an attribute at driver level. These attributes, when set,  ***
84203>>>>>>>>>//*** will be set for the remainder of the session or until set again. To   ***
84203>>>>>>>>>//*** permanently set driver level attributes change the driver             ***
84203>>>>>>>>>//*** configuration file.                                                   ***
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>//*** Class  : cCLIHandler                                                  ***
84203>>>>>>>>>//*** Purpose: An instance of this class can be used as a broker object to  ***
84203>>>>>>>>>//***          call several CLI releated methods.                           ***
84203>>>>>>>>>//*****************************************************************************
84203>>>>>>>>>
84203>>>>>>>>>// { ClassLibrary=Common }
84203>>>>>>>>>Class cCLIHandler Is An Array
84204>>>>>>>>>
84204>>>>>>>>>    Procedure Construct_Object Integer iImage
84206>>>>>>>>>        Forward Send Construct_object iImage
84208>>>>>>>>>
84208>>>>>>>>>        Property String  psDriverID       Public ""
84209>>>>>>>>>    End_Procedure // Construct_Object
84210>>>>>>>>>
84210>>>>>>>>>
84210>>>>>>>>>
84210>>>>>>>>>    //***
84210>>>>>>>>>    //*** Fucntion: CKRevsion
84210>>>>>>>>>    //*** Purpose : The revsion of a CLI Connectivity Kit
84210>>>>>>>>>    //***
84210>>>>>>>>>
84210>>>>>>>>>    Function CKRevision Returns String
84212>>>>>>>>>        Local String  sDriverID
84212>>>>>>>>>        Local String  sRevision
84212>>>>>>>>>        Local String  sVoid
84212>>>>>>>>>        Local Integer iRetval
84212>>>>>>>>>
84212>>>>>>>>>        Get psDriverID To sDriverID
84213>>>>>>>>>        If (sDRiverID <> "") Begin
84215>>>>>>>>>            Move (Repeat(" ", 255)) To sRevision
84216>>>>>>>>>            Call_Driver 0 sDRiverID Function CLI_CKREVISION Callback 0 Passing sRevision sVoid 0 Result iRetval
84221>>>>>>>>>        End
84221>>>>>>>>>>
84221>>>>>>>>>
84221>>>>>>>>>        Function_Return sRevision
84222>>>>>>>>>    End_Function // CKRevision
84223>>>>>>>>>
84223>>>>>>>>>
84223>>>>>>>>>
84223>>>>>>>>>    //***
84223>>>>>>>>>    //*** Function: ExtractPartFromRevision
84223>>>>>>>>>    //*** Purpose : Extarct the Nth part of a a.b.c.d revsion string.
84223>>>>>>>>>    //***
84223>>>>>>>>>    //*** Returns : The part version number or -1 if there is no such part number.
84223>>>>>>>>>    //***
84223>>>>>>>>>
84223>>>>>>>>>    // { Visibility=Private }
84223>>>>>>>>>    Function ExtractPartFromRevision Integer iPartNum String sRevision Returns Integer
84225>>>>>>>>>        Local Integer iPartRev
84225>>>>>>>>>        Local Integer iCurrentPart
84225>>>>>>>>>        Local Integer iSeparatorPos
84225>>>>>>>>>
84225>>>>>>>>>        If (iPartNum > 4) ;            Function_Return -1
84228>>>>>>>>>
84228>>>>>>>>>        Move 0 To iCurrentPart
84229>>>>>>>>>        Repeat
84229>>>>>>>>>>
84229>>>>>>>>>            Move (Pos(".", sRevision)) To iSeparatorPos
84230>>>>>>>>>            If (iSeparatorPos > 0) Begin
84232>>>>>>>>>                Move (Left(sRevision, iSeparatorPos - 1)) To iPartRev
84233>>>>>>>>>                Move (Right(sRevision, Length(sRevision) - iSeparatorPos)) To sRevision
84234>>>>>>>>>                Increment iCurrentPart
84235>>>>>>>>>            End
84235>>>>>>>>>>
84235>>>>>>>>>            Else If (sRevision <> "") Begin
84238>>>>>>>>>                Move sRevision To iPartRev
84239>>>>>>>>>                Move "" To sRevision
84240>>>>>>>>>                Increment iCurrentPart
84241>>>>>>>>>            End
84241>>>>>>>>>>
84241>>>>>>>>>            Else ;                Move -1 To iPartRev
84243>>>>>>>>>        Until (iCurrentPart >= iPartNum Or iPartRev = -1)
84245>>>>>>>>>
84245>>>>>>>>>        Function_Return iPartRev
84246>>>>>>>>>    End_Function // EcxtractPartFromRevision
84247>>>>>>>>>
84247>>>>>>>>>
84247>>>>>>>>>
84247>>>>>>>>>    //***
84247>>>>>>>>>    //*** Function: CKMajorRevision
84247>>>>>>>>>    //*** Purpose : Returns the major revision of the CK
84247>>>>>>>>>    //***
84247>>>>>>>>>
84247>>>>>>>>>    Function CKMajorRevision Returns Integer
84249>>>>>>>>>        Function_Return (ExtractPartFromRevision (Current_Object, 1, CKRevision(Current_Object)))
84250>>>>>>>>>    End_Function // CKMajorRevision
84251>>>>>>>>>
84251>>>>>>>>>
84251>>>>>>>>>
84251>>>>>>>>>    //***
84251>>>>>>>>>    //*** Function: CKMinorRevision
84251>>>>>>>>>    //*** Purpose : Returns the minor revision of the CK
84251>>>>>>>>>    //***
84251>>>>>>>>>
84251>>>>>>>>>    Function CKMinorRevision Returns Integer
84253>>>>>>>>>        Function_Return (ExtractPartFromRevision (Current_Object, 2, CKRevision(Current_Object)))
84254>>>>>>>>>    End_Function // CKMinorRevision
84255>>>>>>>>>
84255>>>>>>>>>
84255>>>>>>>>>
84255>>>>>>>>>    //***
84255>>>>>>>>>    //*** Function: CKReleaseRevision
84255>>>>>>>>>    //*** Purpose : Returns the release revision of the CK
84255>>>>>>>>>    //***
84255>>>>>>>>>
84255>>>>>>>>>    Function CKReleaseRevision Returns Integer
84257>>>>>>>>>        Function_Return (ExtractPartFromRevision (Current_Object, 3, CKRevision(Current_Object)))
84258>>>>>>>>>    End_Function // CKReleaseRevision
84259>>>>>>>>>
84259>>>>>>>>>
84259>>>>>>>>>
84259>>>>>>>>>    //***
84259>>>>>>>>>    //*** Function: CKBuildRevision
84259>>>>>>>>>    //*** Purpose : Returns the major revision of the CK
84259>>>>>>>>>    //***
84259>>>>>>>>>
84259>>>>>>>>>    Function CKBuildRevision Returns Integer
84261>>>>>>>>>        Function_Return (ExtractPartFromRevision (Current_Object, 4, CKRevision(Current_Object)))
84262>>>>>>>>>    End_Function // CKBuildRevision
84263>>>>>>>>>
84263>>>>>>>>>
84263>>>>>>>>>
84263>>>>>>>>>    //***
84263>>>>>>>>>    //*** Function: IsMinimalRevision
84263>>>>>>>>>    //*** Purpose : Determines if the CK conforms to a passed minimal revsion.
84263>>>>>>>>>    //***
84263>>>>>>>>>
84263>>>>>>>>>    Function IsMinimalRevision Integer iMajor Integer iMinor Integer iRelease Integer iBuild Returns Integer
84265>>>>>>>>>        If (iMajor < CKMajorRevision(Current_object)) ;            Function_return (TRUE)
84268>>>>>>>>>        Else If (iMajor = CKMajorRevision(Current_object)) Begin
84271>>>>>>>>>            If (iMinor < CKMinorRevision(Current_object)) ;                Function_return (TRUE)
84274>>>>>>>>>            Else If (iMinor = CKMinorRevision(Current_object)) Begin
84277>>>>>>>>>                If (iRelease < CKReleaseRevision(Current_object)) ;                    Function_return (TRUE)
84280>>>>>>>>>                Else If (iRelease = CKReleaseRevision(Current_object) And iBuild <= CKBuildRevision(Current_object)) ;                    Function_return (TRUE)
84284>>>>>>>>>            End
84284>>>>>>>>>>
84284>>>>>>>>>        End
84284>>>>>>>>>>
84284>>>>>>>>>
84284>>>>>>>>>        Function_Return (FALSE)
84285>>>>>>>>>    End_Function // IsMinimalRevision
84286>>>>>>>>>
84286>>>>>>>>>
84286>>>>>>>>>
84286>>>>>>>>>    //***
84286>>>>>>>>>    //*** Function: RegistrationName
84286>>>>>>>>>    //*** Purpose : Returns the Connectiivty Kit registration name.
84286>>>>>>>>>    //***
84286>>>>>>>>>
84286>>>>>>>>>    Function RegistrationName Returns String
84288>>>>>>>>>        Local String  sRegistration
84288>>>>>>>>>        Local String  sDRiverId
84288>>>>>>>>>        Local String  sVoid
84288>>>>>>>>>        Local Integer iRetval
84288>>>>>>>>>
84288>>>>>>>>>        Get psDriverID To sDriverID
84289>>>>>>>>>        If (sDRiverID <> "") Begin
84291>>>>>>>>>            Move (Repeat(" ", 255)) To sRegistration
84292>>>>>>>>>            Call_Driver 0 sDRiverID Function CLI_GETREGNAME Callback 0 Passing sRegistration sVoid 0 Result iRetval
84297>>>>>>>>>        End
84297>>>>>>>>>>
84297>>>>>>>>>
84297>>>>>>>>>        Function_Return sRegistration
84298>>>>>>>>>    End_Function // RegistrationName
84299>>>>>>>>>
84299>>>>>>>>>
84299>>>>>>>>>
84299>>>>>>>>>    //***
84299>>>>>>>>>    //*** Function: SerialNumber
84299>>>>>>>>>    //*** Purpose : Returns the Connectiivty Kit serial number.
84299>>>>>>>>>    //***
84299>>>>>>>>>
84299>>>>>>>>>    Function SerialNumber Returns Integer
84301>>>>>>>>>        Local String  sDRiverId
84301>>>>>>>>>        Local String  sVoid
84301>>>>>>>>>        Local Integer iRetval
84301>>>>>>>>>
84301>>>>>>>>>        Get psDriverID To sDriverID
84302>>>>>>>>>        If (sDRiverID <> "") Begin
84304>>>>>>>>>            Call_Driver 0 sDRiverID Function CLI_GETSERIALNUM Callback 0 Passing sVoid sVoid 0 Result iRetval
84309>>>>>>>>>        End
84309>>>>>>>>>>
84309>>>>>>>>>
84309>>>>>>>>>        Function_Return iRetval
84310>>>>>>>>>    End_Function // SerialNumber
84311>>>>>>>>>
84311>>>>>>>>>
84311>>>>>>>>>
84311>>>>>>>>>    //***
84311>>>>>>>>>    //*** Function: MaxUsers
84311>>>>>>>>>    //*** Purpose : Returns the Connectiivty Kit maximum number of users.
84311>>>>>>>>>    //***
84311>>>>>>>>>
84311>>>>>>>>>    Function MaxUsers Returns Integer
84313>>>>>>>>>        Local String  sDRiverId
84313>>>>>>>>>        Local String  sVoid
84313>>>>>>>>>        Local Integer iRetval
84313>>>>>>>>>
84313>>>>>>>>>        Get psDriverID To sDriverID
84314>>>>>>>>>        If (sDRiverID <> "") Begin
84316>>>>>>>>>            Call_Driver 0 sDRiverID Function CLI_GETMAXUSERS Callback 0 Passing sVoid sVoid 0 Result iRetval
84321>>>>>>>>>        End
84321>>>>>>>>>>
84321>>>>>>>>>
84321>>>>>>>>>        Function_Return iRetval
84322>>>>>>>>>    End_Function // MaxUsers
84323>>>>>>>>>
84323>>>>>>>>>
84323>>>>>>>>>
84323>>>>>>>>>    //***
84323>>>>>>>>>    //*** Procedure: DumpStatus
84323>>>>>>>>>    //*** Purpose  : Dump the current status of the drver in the passed disk file.
84323>>>>>>>>>    //***
84323>>>>>>>>>
84323>>>>>>>>>    Procedure DumpStatus String sFileName
84325>>>>>>>>>        Local String  sVoid
84325>>>>>>>>>        Local String  sDriverID
84325>>>>>>>>>        Local Integer iVoid
84325>>>>>>>>>
84325>>>>>>>>>        Get psDriverID To sDriverID
84326>>>>>>>>>        If (sDriverID <> "") ;            Call_driver 0 sDriverID Function CLI_DUMPSTATUS Callback 0 Passing sFileName sVoid iVoid Result iVoid
84333>>>>>>>>>    End_Procedure // DumpStatus
84334>>>>>>>>>
84334>>>>>>>>>
84334>>>>>>>>>
84334>>>>>>>>>    //***
84334>>>>>>>>>    //*** Procedure: ReadConfiguration
84334>>>>>>>>>    //*** Purpose  : Reset all driver level configurable attributes to the
84334>>>>>>>>>    //***            default value and then reread the configuration.
84334>>>>>>>>>    //***
84334>>>>>>>>>
84334>>>>>>>>>    Procedure ReadConfiguration
84336>>>>>>>>>        Local String  sVoid
84336>>>>>>>>>        Local String  sDriverID
84336>>>>>>>>>        Local Integer iVoid
84336>>>>>>>>>
84336>>>>>>>>>        Get psDriverID To sDriverID
84337>>>>>>>>>        If (sDriverID <> "") ;            Call_driver 0 sDriverID Function CLI_READCONFIGURATION Callback 0 Passing sVoid sVoid iVoid Result iVoid
84344>>>>>>>>>    End_Procedure // ReadConfiguration
84345>>>>>>>>>
84345>>>>>>>>>
84345>>>>>>>>>
84345>>>>>>>>>    //***
84345>>>>>>>>>    //*** Function: TextToRIMValue
84345>>>>>>>>>    //*** Purpose : Convert a text to the corresponding
84345>>>>>>>>>    //***           Generate_Record_ID_Method attribute value
84345>>>>>>>>>    //***
84345>>>>>>>>>
84345>>>>>>>>>    Function TextToRIMValue String sText Returns Integer
84347>>>>>>>>>        If (sText = "None") ;            Function_return RIM_NONE
84350>>>>>>>>>        Else If (sText = "Identity Column") ;            Function_return RIM_IDENTITY_COLUMN
84354>>>>>>>>>        Else If (sText = "Dispenser Table") ;            Function_return RIM_DISPENSER_TABLE
84358>>>>>>>>>        Else If (sText = "External") ;            Function_return RIM_EXTERNAL
84362>>>>>>>>>    End_Function // TextToRIMValue
84363>>>>>>>>>
84363>>>>>>>>>
84363>>>>>>>>>
84363>>>>>>>>>    //***
84363>>>>>>>>>    //*** Function: RIMValueTotext
84363>>>>>>>>>    //*** Purpose : Convert a Generate_Record_ID_Method attribute value to the
84363>>>>>>>>>    //***           corresponding text.
84363>>>>>>>>>    //***
84363>>>>>>>>>
84363>>>>>>>>>    Function RIMValueToText Integer iAttrValue Returns String
84365>>>>>>>>>        If (iAttrValue = RIM_NONE) ;            Function_return "None"
84368>>>>>>>>>        Else If (iAttrValue = RIM_IDENTITY_COLUMN) ;            Function_return "Identity Column"
84372>>>>>>>>>        Else If (iAttrValue = RIM_DISPENSER_TABLE) ;            Function_return "Dispenser Table"
84376>>>>>>>>>        Else If (iAttrValue = RIM_EXTERNAL) ;            Function_return "External"
84380>>>>>>>>>    End_Function // RIMValueToText
84381>>>>>>>>>
84381>>>>>>>>>
84381>>>>>>>>>
84381>>>>>>>>>    //***
84381>>>>>>>>>    //*** Function: TextToROValue
84381>>>>>>>>>    //*** Purpose : Convert a text to the corresponding
84381>>>>>>>>>    //***           Generate_Record_ID_Method attribute value
84381>>>>>>>>>    //***
84381>>>>>>>>>
84381>>>>>>>>>    Function TextToROValue String sText Returns Integer
84383>>>>>>>>>        If (sText = "No") ;            Function_return RO_NO
84386>>>>>>>>>        Else If (sText = "Ignore Change") ;            Function_return RO_IGNORECHANGE
84390>>>>>>>>>        Else If (sText = "Accept Change") ;            Function_return RO_ACCEPTCHANGE
84394>>>>>>>>>        Else If (sText = "Error On Change") ;            Function_return RO_ERRORONCHANGE
84398>>>>>>>>>    End_Function // TextToRIMValue
84399>>>>>>>>>
84399>>>>>>>>>
84399>>>>>>>>>
84399>>>>>>>>>    //***
84399>>>>>>>>>    //*** Function: ROValueTotext
84399>>>>>>>>>    //*** Purpose : Convert a Generate_Record_ID_Method attribute value to the
84399>>>>>>>>>    //***           corresponding text.
84399>>>>>>>>>    //***
84399>>>>>>>>>
84399>>>>>>>>>    Function ROValueToText Integer iAttrValue Returns String
84401>>>>>>>>>        If (iAttrValue = RO_NO) ;            Function_return "No"
84404>>>>>>>>>        Else If (iAttrValue = RO_IGNORECHANGE) ;            Function_return "Ignore Change"
84408>>>>>>>>>        Else If (iAttrValue = RO_ACCEPTCHANGE) ;            Function_return "Accept Change"
84412>>>>>>>>>        Else If (iAttrValue = RO_ERRORONCHANGE) ;            Function_return "Error On Change"
84416>>>>>>>>>    End_Function // RIMValueToText
84417>>>>>>>>>
84417>>>>>>>>>
84417>>>>>>>>>
84417>>>>>>>>>    //***
84417>>>>>>>>>    //*** Function: LastDriverError
84417>>>>>>>>>    //*** Purpose : Return the text f the last error geneated by the driver.
84417>>>>>>>>>    //***
84417>>>>>>>>>
84417>>>>>>>>>    Function LastDriverError Returns String
84419>>>>>>>>>        Local String  sDriverID
84419>>>>>>>>>        Local String  sLastError
84419>>>>>>>>>        Local String  sLastErrorLength
84419>>>>>>>>>        Local Integer iLastErrorLength
84419>>>>>>>>>        Local Integer iVoid
84419>>>>>>>>>
84419>>>>>>>>>        //*** Initialize
84419>>>>>>>>>        Move "" To sLastError
84420>>>>>>>>>
84420>>>>>>>>>        Get psDriverID To sDriverID
84421>>>>>>>>>        If (sDriverID <> "") Begin
84423>>>>>>>>>            //*** Get the text of the last error
84423>>>>>>>>>            Move (Repeat(Character(" "), 14)) To sLastErrorlength
84424>>>>>>>>>            Call_driver 0 sDriverID Function CLI_GETDRIVERATTRIBUTE Callback 0 Passing sLastErrorLength iVoid DRVR_LASTERRORTEXTLENGTH Result iVoid
84429>>>>>>>>>            Move (Left(sLastErrorLength, Pos(Character(0), sLastErrorLength) - 1)) To iLastErrorLength
84430>>>>>>>>>
84430>>>>>>>>>            If (iLastErrorLength > 0) Begin
84432>>>>>>>>>                Move (Repeat(Character(" "), iLastErrorLength + 1)) To sLastError
84433>>>>>>>>>                Call_driver 0 sDriverID Function CLI_GETDRIVERATTRIBUTE Callback 0 Passing sLastError iVoid DRVR_LASTERRORTEXT Result iVoid
84438>>>>>>>>>                Move (Left(sLastError, Pos(Character(0), sLastError) - 1)) To sLastError
84439>>>>>>>>>            End
84439>>>>>>>>>>
84439>>>>>>>>>        End
84439>>>>>>>>>>
84439>>>>>>>>>
84439>>>>>>>>>        Function_Return sLastError
84440>>>>>>>>>    End_Function // LastDriverError
84441>>>>>>>>>
84441>>>>>>>>>
84441>>>>>>>>>
84441>>>>>>>>>    //***
84441>>>>>>>>>    //*** Function: EnumerateTables
84441>>>>>>>>>    //*** Purpose : Enumerate the tables in a database
84441>>>>>>>>>    //***
84441>>>>>>>>>
84441>>>>>>>>>    Function EnumerateTables String sLogin Returns Integer
84443>>>>>>>>>        Local String  sDriver
84443>>>>>>>>>        Local String  sVoid
84443>>>>>>>>>        Local Integer iNumTables
84443>>>>>>>>>        Local Integer iVoid
84443>>>>>>>>>
84443>>>>>>>>>        Get psDriverID To sDriver
84444>>>>>>>>>        If (sDriver <> "") ;            Call_driver 0 sDriver Function CLI_ENUMERATE_TABLES Callback 0 Passing sLogin sVoid iVoid Result iNumTables
84451>>>>>>>>>
84451>>>>>>>>>        Function_Return iNumTables
84452>>>>>>>>>    End_Function // EnumerateTables
84453>>>>>>>>>
84453>>>>>>>>>
84453>>>>>>>>>
84453>>>>>>>>>    //***
84453>>>>>>>>>    //*** Function: TableName
84453>>>>>>>>>    //*** Purpose : Returns the name of the table enumerated at the given position
84453>>>>>>>>>    //***
84453>>>>>>>>>
84453>>>>>>>>>    Function TableName Integer iIndex Returns String
84455>>>>>>>>>        Local String  sDriver
84455>>>>>>>>>        Local String  sTableName
84455>>>>>>>>>        Local String  sVoid
84455>>>>>>>>>        Local Integer iVoid
84455>>>>>>>>>
84455>>>>>>>>>        Get psDriverID To sDriver
84456>>>>>>>>>        If (sDriver <> "") Begin
84458>>>>>>>>>            Move (Repeat(" ", 255)) To sTableName
84459>>>>>>>>>            Call_driver 0 sDriver Function CLI_TABLENAME Callback 0 Passing sTableName sVoid iIndex Result iVoid
84464>>>>>>>>>        End
84464>>>>>>>>>>
84464>>>>>>>>>
84464>>>>>>>>>        Function_Return sTableName
84465>>>>>>>>>    End_Function // TableName
84466>>>>>>>>>
84466>>>>>>>>>
84466>>>>>>>>>
84466>>>>>>>>>    //***
84466>>>>>>>>>    //*** Function: SchemaName
84466>>>>>>>>>    //*** Purpose : Returns the name of the schema of the table enumerated at the given position
84466>>>>>>>>>    //***
84466>>>>>>>>>
84466>>>>>>>>>    Function SchemaName Integer iIndex Returns String
84468>>>>>>>>>        Local String  sDriver
84468>>>>>>>>>        Local String  sSchemaName
84468>>>>>>>>>        Local String  sVoid
84468>>>>>>>>>        Local Integer iVoid
84468>>>>>>>>>
84468>>>>>>>>>        Get psDriverID To sDriver
84469>>>>>>>>>        If (sDriver <> "") Begin
84471>>>>>>>>>            Move (Repeat(" ", 255)) To sSchemaName
84472>>>>>>>>>            Call_driver 0 sDriver Function CLI_TABLESCHEMA Callback 0 Passing sSchemaName sVoid iIndex Result iVoid
84477>>>>>>>>>        End
84477>>>>>>>>>>
84477>>>>>>>>>
84477>>>>>>>>>        Function_Return sSchemaName
84478>>>>>>>>>    End_Function // SchemaName
84479>>>>>>>>>
84479>>>>>>>>>
84479>>>>>>>>>
84479>>>>>>>>>    //***
84479>>>>>>>>>    //*** Function: TableType
84479>>>>>>>>>    //*** Purpose : Returns the type of the table enumerated at the given position.
84479>>>>>>>>>    //***           Types can be "TABLE", "VIEW", "SYSTEM TABLE", "GLOBAL TEMPORARY",
84479>>>>>>>>>    //***           "LOCAL TEMPORARY", "ALIAS", "SYNONYM"
84479>>>>>>>>>    //***
84479>>>>>>>>>
84479>>>>>>>>>    Function TableType Integer iIndex Returns String
84481>>>>>>>>>        Local String  sDriver
84481>>>>>>>>>        Local String  sTableType
84481>>>>>>>>>        Local String  sVoid
84481>>>>>>>>>        Local Integer iVoid
84481>>>>>>>>>
84481>>>>>>>>>        Get psDriverID To sDriver
84482>>>>>>>>>        If (sDriver <> "") Begin
84484>>>>>>>>>            Move (Repeat(" ", 25)) To sTableType
84485>>>>>>>>>            Call_driver 0 sDriver Function CLI_TABLETYPE Callback 0 Passing sTableType sVoid iIndex Result iVoid
84490>>>>>>>>>        End
84490>>>>>>>>>>
84490>>>>>>>>>
84490>>>>>>>>>        Function_Return sTableType
84491>>>>>>>>>    End_Function // TableType
84492>>>>>>>>>
84492>>>>>>>>>
84492>>>>>>>>>
84492>>>>>>>>>    //***
84492>>>>>>>>>    //*** Function: TableComment
84492>>>>>>>>>    //*** Purpose : Returns the comment of the table enumerated at the given position
84492>>>>>>>>>    //***
84492>>>>>>>>>
84492>>>>>>>>>    Function TableComment Integer iIndex Returns String
84494>>>>>>>>>        Local String  sDriver
84494>>>>>>>>>        Local String  sTableComment
84494>>>>>>>>>        Local String  sVoid
84494>>>>>>>>>        Local Integer iVoid
84494>>>>>>>>>
84494>>>>>>>>>        Get psDriverID To sDriver
84495>>>>>>>>>        If (sDriver <> "") Begin
84497>>>>>>>>>            Move (Repeat(" ", 255)) To sTableComment
84498>>>>>>>>>            Call_driver 0 sDriver Function CLI_TABLECOMMENT Callback 0 Passing sTableComment sVoid iIndex Result iVoid
84503>>>>>>>>>        End
84503>>>>>>>>>>
84503>>>>>>>>>
84503>>>>>>>>>        Function_Return sTableComment
84504>>>>>>>>>    End_Function // TableComment
84505>>>>>>>>>
84505>>>>>>>>>
84505>>>>>>>>>
84505>>>>>>>>>    //***
84505>>>>>>>>>    //*** Function: EnumerateColumns
84505>>>>>>>>>    //*** Purpose : Enumerate the columns in a table
84505>>>>>>>>>    //***
84505>>>>>>>>>
84505>>>>>>>>>    Function EnumerateColumns String sLogin String sTableName Returns Integer
84507>>>>>>>>>        Local String  sDriver
84507>>>>>>>>>        Local Integer iNumColumns
84507>>>>>>>>>        Local Integer iVoid
84507>>>>>>>>>
84507>>>>>>>>>        Get psDriverID To sDriver
84508>>>>>>>>>        If (sDriver <> "") ;            Call_driver 0 sDriver Function CLI_ENUMERATE_COLUMNS Callback 0 Passing sLogin sTablename iVoid Result iNumColumns
84515>>>>>>>>>
84515>>>>>>>>>        Function_Return iNumColumns
84516>>>>>>>>>    End_Function // EnumerateColumns
84517>>>>>>>>>
84517>>>>>>>>>
84517>>>>>>>>>
84517>>>>>>>>>    //***
84517>>>>>>>>>    //*** Function: ColumnName
84517>>>>>>>>>    //*** Purpose : Returns the name of the column enumerated at the given position
84517>>>>>>>>>    //***
84517>>>>>>>>>
84517>>>>>>>>>    Function ColumnName Integer iIndex Returns String
84519>>>>>>>>>        Local String  sDriver
84519>>>>>>>>>        Local String  sColumnName
84519>>>>>>>>>        Local String  sVoid
84519>>>>>>>>>        Local Integer iVoid
84519>>>>>>>>>
84519>>>>>>>>>        Get psDriverID To sDriver
84520>>>>>>>>>        If (sDriver <> "") Begin
84522>>>>>>>>>            Move (Repeat(" ", 255)) To sColumnName
84523>>>>>>>>>            Call_driver 0 sDriver Function CLI_COLUMNNAME Callback 0 Passing sColumnName sVoid iIndex Result iVoid
84528>>>>>>>>>        End
84528>>>>>>>>>>
84528>>>>>>>>>
84528>>>>>>>>>        Function_Return sColumnName
84529>>>>>>>>>    End_Function // ColumnName
84530>>>>>>>>>
84530>>>>>>>>>
84530>>>>>>>>>
84530>>>>>>>>>    //***
84530>>>>>>>>>    //*** Function: CLIDFDateToSQLDate
84530>>>>>>>>>    //*** Purpose : Convert a DataFlex date to a SQL date using the dummy zero date value.
84530>>>>>>>>>    //***
84530>>>>>>>>>
84530>>>>>>>>>    // { Visibility=Private }
84530>>>>>>>>>    Function CLIDFDateToSQLDate String sDRiver Date dDFDate Returns String
84532>>>>>>>>>        Local String sSQLDate
84532>>>>>>>>>        Local Integer iOrgDateFmt
84532>>>>>>>>>        Local Integer iOrgDateSep
84532>>>>>>>>>
84532>>>>>>>>>        //*** Change date format to military, SQL dates are military dates
84532>>>>>>>>>        Get_Attribute DF_DATE_FORMAT To iOrgDateFmt
84535>>>>>>>>>        Get_Attribute DF_DATE_SEPARATOR To iOrgDateSep
84538>>>>>>>>>        Set_Attribute DF_DATE_FORMAT To DF_DATE_MILITARY
84541>>>>>>>>>        Set_Attribute DF_DATE_SEPARATOR To (Ascii('-'))
84544>>>>>>>>>
84544>>>>>>>>>        //*** We only need to convert if the date is 0
84544>>>>>>>>>        If (Integer(dDFDate = 0)) ;            CLI_Get_Driver_Attribute sDRiver DRVR_DUMMY_ZERO_DATE_VALUE To sSQLDate
84553>>>>>>>>>        Else ;            Move dDFDate To sSQLDate
84555>>>>>>>>>
84555>>>>>>>>>        //*** Change date format back to original
84555>>>>>>>>>        Set_Attribute DF_DATE_FORMAT To iOrgDateFmt
84558>>>>>>>>>        Set_Attribute DF_DATE_SEPARATOR To iOrgDateSep
84561>>>>>>>>>
84561>>>>>>>>>        Function_Return sSQLDate
84562>>>>>>>>>    End_Function // CLIDFDateToSQLDate
84563>>>>>>>>>
84563>>>>>>>>>
84563>>>>>>>>>
84563>>>>>>>>>    //***
84563>>>>>>>>>    //*** Function: CLISQLDateToDFDate
84563>>>>>>>>>    //*** Purpose : Convert a SQL date to a DataFlex date using the dummy zero date value.
84563>>>>>>>>>    //***
84563>>>>>>>>>
84563>>>>>>>>>    // { Visibility=Private }
84563>>>>>>>>>    Function CLISQLDateToDFDate String sDRiver String sSQLDate Returns Date
84565>>>>>>>>>        Local Date dDFDate
84565>>>>>>>>>        Local String sDummyDateValue
84565>>>>>>>>>        Local Integer iOrgDateFmt
84565>>>>>>>>>        Local Integer iOrgDateSep
84565>>>>>>>>>
84565>>>>>>>>>        //*** Change date format to military, SQL dates are military dates
84565>>>>>>>>>        Get_Attribute DF_DATE_FORMAT To iOrgDateFmt
84568>>>>>>>>>        Get_Attribute DF_DATE_SEPARATOR To iOrgDateSep
84571>>>>>>>>>        Set_Attribute DF_DATE_FORMAT To DF_DATE_MILITARY
84574>>>>>>>>>        Set_Attribute DF_DATE_SEPARATOR To (Ascii('-'))
84577>>>>>>>>>
84577>>>>>>>>>        //*** We only need to convert if the date is the dummy zero date value
84577>>>>>>>>>        CLI_Get_Driver_Attribute sDRiver DRVR_DUMMY_ZERO_DATE_VALUE To sDummyDateValue
84584>>>>>>>>>        If (sDummyDateValue = sSQLDate) ;            Move 0 To dDFDate
84587>>>>>>>>>        Else ;            Move sSQLDate To dDFDate
84589>>>>>>>>>
84589>>>>>>>>>        //*** Change date format back to original
84589>>>>>>>>>        Set_Attribute DF_DATE_FORMAT To iOrgDateFmt
84592>>>>>>>>>        Set_Attribute DF_DATE_SEPARATOR To iOrgDateSep
84595>>>>>>>>>
84595>>>>>>>>>        Function_Return dDFDate
84596>>>>>>>>>    End_Function // CLISQLDateToDFDate
84597>>>>>>>>>
84597>>>>>>>>>    //***
84597>>>>>>>>>    //*** Function: RedirectConnection
84597>>>>>>>>>    //*** Purpose : Redirect an exisitng connection. The existing connection
84597>>>>>>>>>    //***           will point to another database but all tables will stay
84597>>>>>>>>>    //***           open!
84597>>>>>>>>>    //***
84597>>>>>>>>>
84597>>>>>>>>>    Function RedirectConnection String sOldConnection String sNewConnection Returns Integer
84599>>>>>>>>>        Local String  sDriver
84599>>>>>>>>>        Local String  sVoid
84599>>>>>>>>>        Local Integer iResult
84599>>>>>>>>>        Local Integer iVoid
84599>>>>>>>>>
84599>>>>>>>>>        Get psDriverID To sDriver
84600>>>>>>>>>        If (sDriver <> "") Begin
84602>>>>>>>>>            Call_driver 0 sDriver Function CLI_REDIRECTCONNECTION Callback 0 Passing sOldConnection sNewConnection iVoid Result iResult
84607>>>>>>>>>        End
84607>>>>>>>>>>
84607>>>>>>>>>        Function_Return iResult
84608>>>>>>>>>    End_Function // RedirectConnect
84609>>>>>>>>>
84609>>>>>>>>>End_Class // cCLIHandler
84610>>>>>>>
84610>>>>>>>//*** Driver Indentification
84610>>>>>>>
84610>>>>>>>//*** Error number constants
84610>>>>>>>
84610>>>>>>>//*** Call driver function identifiers
84610>>>>>>>
84610>>>>>>>//*** Extra ODBC commands
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCManage                                                            ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Start the ODBC manager.                                               ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCNumberOfDataSources To                                    ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Returns the number of data sources.                                   ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCDSNName  To                                   ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Returns the name of the data source.                                  ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCEnumerateTables  To                            ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Builds internal table array and returns the number of tables in the   ***
84610>>>>>>>//*** DSN.                                                                  ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCTableName  To                                ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Returns the name of the table.                                        ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCSchemaName  To                              ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Returns the schema name of the table.                                 ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCNumberOfFields   To                   ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Returns the number of fields.                                         ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBCFieldName  To                             ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//*** Returns the name of the field.                                  ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>//*****************************************************************************
84610>>>>>>>//*** ODBC_SetConstraint                           ***
84610>>>>>>>//***                                                                       ***
84610>>>>>>>//***   Setup a constraint for a file.                                      ***
84610>>>>>>>//*****************************************************************************
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>
84610>>>>>>>// { ClassLibrary=Common }
84610>>>>>>>Class cODBCHandler Is A cCLIHandler
84611>>>>>>>
84611>>>>>>>    Procedure Construct_Object
84613>>>>>>>        Forward Send Construct_Object
84615>>>>>>>
84615>>>>>>>        Set psDriverID To ODBC_DRV_ID
84616>>>>>>>    End_Procedure // Construct_Object
84617>>>>>>>
84617>>>>>>>
84617>>>>>>>
84617>>>>>>>    //***
84617>>>>>>>    //*** Procedure Set: DataSourceType
84617>>>>>>>    //*** Purpose      : Setup the type of data sources returned by the datasources function
84617>>>>>>>    //***
84617>>>>>>>
84617>>>>>>>    // { Visibility=Private }
84617>>>>>>>    Procedure Set DataSourceType Integer iNewType
84619>>>>>>>        Local String  sDriver
84619>>>>>>>        Local String  sVoid
84619>>>>>>>        Local Integer iRetval
84619>>>>>>>
84619>>>>>>>        Get psDriverID To sDriver
84620>>>>>>>        If (sDriver <> "") ;            Call_Driver 0 sDRiver Function CLI_INITDATASOURCES Callback 0 Passing sVoid sVoid iNewType Result iRetval
84627>>>>>>>    End_Procedure // Set DataSourceType
84628>>>>>>>
84628>>>>>>>
84628>>>>>>>
84628>>>>>>>    //***
84628>>>>>>>    //*** Function: DataSources
84628>>>>>>>    //*** Purpose : Call the driver's data sources function
84628>>>>>>>    //***
84628>>>>>>>
84628>>>>>>>    // { Visibility=Private }
84628>>>>>>>    Function DataSources Returns String
84630>>>>>>>        Local String  sDriver
84630>>>>>>>        Local String  sDataSource
84630>>>>>>>        Local String  sDescription
84630>>>>>>>        Local Integer iLength
84630>>>>>>>        Local Integer iRetval
84630>>>>>>>
84630>>>>>>>        Get psDriverID To sDriver
84631>>>>>>>        If (sDriver <> "") Begin
84633>>>>>>>            Move 8192 To iLength
84634>>>>>>>            Move (Repeat(" ", iLength)) To sDataSource
84635>>>>>>>            Move (Repeat(" ", iLength)) To sDescription
84636>>>>>>>            Call_Driver 0 sDRiver Function CLI_DATASOURCES Callback 0 Passing sDataSource sDescription iLength Result iRetval
84641>>>>>>>        End
84641>>>>>>>>
84641>>>>>>>
84641>>>>>>>        If (sDataSource <> "" Or sDescription <> "") ;            Function_Return (sDataSource + "," +  sDescription)
84644>>>>>>>        Else ;            Function_Return ""
84646>>>>>>>    End_Function// DataSources
84647>>>>>>>
84647>>>>>>>End_Class // cODBCHandler
84648>>>>>
84648>>>>>class cODBC_DataSources is a cArray
84649>>>>>  procedure AddSource integer liNumber string lsName
84651>>>>>    set value item liNumber to lsName
84652>>>>>  end_procedure
84653>>>>>  procedure FillArray
84655>>>>>    integer liMax liNumber
84655>>>>>    string lsName
84655>>>>>    send delete_data
84656>>>>>    ODBCEnumerateDataSources liMax
84661>>>>>    for liNumber from 1 to liMax
84667>>>>>>
84667>>>>>      ODBCDSNName liNumber to lsName
84680>>>>>      send AddSource liNumber lsName
84681>>>>>    loop
84682>>>>>>
84682>>>>>  end_procedure
84683>>>>>end_class // cODBC_DataSources
84684>>>>>
84684>>>>>class cODBC_Tables is a cArray
84685>>>>>  item_property_list
84685>>>>>    item_property string psTableName.i
84685>>>>>    item_property string psSchemaName.i
84685>>>>>  end_item_property_list cODBC_Tables
#REM 84717 DEFINE FUNCTION PSSCHEMANAME.I INTEGER LIROW RETURNS STRING
#REM 84721 DEFINE PROCEDURE SET PSSCHEMANAME.I INTEGER LIROW STRING VALUE
#REM 84725 DEFINE FUNCTION PSTABLENAME.I INTEGER LIROW RETURNS STRING
#REM 84729 DEFINE PROCEDURE SET PSTABLENAME.I INTEGER LIROW STRING VALUE
84734>>>>>  procedure AddTable integer liNumber string lsTableName string lsSchemaName
84736>>>>>    set psTableName.i  liNumber to lsTableName
84737>>>>>    set psSchemaName.i liNumber to lsSchemaName
84738>>>>>  end_procedure
84739>>>>>  procedure FillArray string lsDSNName
84741>>>>>    integer liMax liNumber
84741>>>>>    string lsTableName lsSchemaName
84741>>>>>    send delete_data
84742>>>>>    ODBCEnumerateTables lsDSNName to liMax
84747>>>>>    for liNumber from 1 to liMax
84753>>>>>>
84753>>>>>      ODBCTableName liNumber to lsTableName
84766>>>>>//      ODBCSchemaName liNumber to lsSchemaName
84766>>>>>      send AddTable liNumber lsTableName lsSchemaName
84767>>>>>    loop
84768>>>>>>
84768>>>>>  end_procedure
84769>>>>>end_class // cODBC_Tables
84770>>>>>
84770>>>>>class cODBC_Fields is a cArray
84771>>>>>  procedure AddField integer liNumber string lsName
84773>>>>>    set value item liNumber to lsName
84774>>>>>  end_procedure
84775>>>>>  procedure FillArray string lsDSNName string lsTableName
84777>>>>>    integer liMax liNumber
84777>>>>>    string lsName
84777>>>>>    send delete_data
84778>>>>>    ODBCEnumerateFields lsDSNName lsTableName to liMax
84783>>>>>    for liNumber from 1 to liMax
84789>>>>>>
84789>>>>>      ODBCTableName liNumber to lsName
84802>>>>>      send AddField liNumber lsName
84803>>>>>    loop
84804>>>>>>
84804>>>>>  end_procedure
84805>>>>>end_class // cODBC_Fields
84806>>>>>
84806>>>>>function ODBC_StartAdministrator global returns integer
84808>>>>>  integer liWndHandle
84808>>>>>  get Window_Handle to liWndHandle
84809>>>>>  ODBCAdministrator liWndHandle
84814>>>>>  function_return 1
84815>>>>>end_function
84816>>>>>
84816>>>>>function ODBC_OpenAs global integer liFile integer liMode string lsDataSource string lsTableName returns integer
84818>>>>>  string lsIntFileName
84818>>>>>  move ("temp"+string(liFile)+".INT") to lsIntFileName
84819>>>>>  direct_output channel 1 lsIntFileName
84821>>>>>  writeln channel 1 "DRIVER_NAME ODBC_DRV"
84824>>>>>  writeln "SERVER_NAME DSN=" lsDataSource
84827>>>>>  writeln "DATABASE_NAME " lsTableName
84830>>>>>  writeln "PRIMARY_INDEX 1"
84832>>>>>  writeln "INDEX_NUMBER 1"
84834>>>>>  writeln "INDEX_NUMBER_SEGMENTS 1"
84836>>>>>  writeln "INDEX_SEGMENT_FIELD 1"
84838>>>>>//  writeln "SCHEMA_NAME DBA"
84838>>>>>  close_output channel 1
84840>>>>>  close liFile
84841>>>>>  open lsIntFileName as liFile
84843>>>>>  function_return 1
84844>>>>>end_function
84845>>>>>
84845>>>>>procedure ODBC_Login global
84847>>>>>  integer rval# driver#
84847>>>>>  string server# user# pw#
84847>>>>>  get DBMS_GetDriverLogin 0 to rval#
84848>>>>>  if rval# begin
84850>>>>>    get DBMS_GetDriverLoginDriverID to driver#
84851>>>>>    get DBMS_GetDriverLoginServer   to server#
84852>>>>>    get DBMS_GetDriverLoginUserID   to user#
84853>>>>>    get DBMS_GetDriverLoginPassWord to pw#
84854>>>>>    login server# user# pw# (DBMS_TypeToDriverName(driver#))
84856>>>>>  end
84856>>>>>>
84856>>>>>end_procedure
84857>>>>>
84857>>>>>
84857>>>>>use gridutil.utl
84857>>>>>
84857>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
84857>>>>>Use Buttons.utl  // Button texts
84857>>>>>
84857>>>>>object oODBC_DataSources is a cODBC_DataSources
84859>>>>>end_object
84860>>>>>object oODBC_Tables is a cODBC_Tables
84862>>>>>end_object
84863>>>>>
84863>>>>>object oODBCTableSelector is a aps.ModalPanel label "ODBC table selector"
84866>>>>>  set locate_mode to CENTER_ON_SCREEN
84867>>>>>  on_key ksave_record send close_panel_ok
84868>>>>>  on_key kcancel send close_panel
84869>>>>>  property integer piResult public 0
84871>>>>>
84871>>>>>  object oDataSourceSelector is a aps.ComboFormAux
84873>>>>>    set form_margin item 0 to 40
84874>>>>>    set entry_state item 0 to DFFALSE
84875>>>>>    procedure fill_list
84878>>>>>      integer lhObj liMax liItem
84878>>>>>      move (oODBC_DataSources(self)) to lhObj
84879>>>>>      send Combo_Delete_Data
84880>>>>>      get item_count of lhObj to liMax
84881>>>>>      decrement liMax
84882>>>>>      for liItem from 1 to liMax
84888>>>>>>
84888>>>>>        send combo_add_item (value(lhObj,liItem)) liItem
84889>>>>>      loop
84890>>>>>>
84890>>>>>    end_procedure
84891>>>>>    procedure OnChange
84894>>>>>      send DoUpdateTables
84895>>>>>    end_procedure
84896>>>>>  end_object // oDataSourceSelector
84897>>>>>  send aps_goto_max_row
84898>>>>>
84898>>>>>  object oTables is a aps.Grid
84900>>>>>    send GridPrepare_AddColumn "Table name" AFT_ASCII40
84901>>>>>    send GridPrepare_Apply self
84902>>>>>    procedure fill_list
84905>>>>>      integer lhObj liMax liItem
84905>>>>>      set dynamic_update_state to DFFALSE
84906>>>>>      move (oODBC_Tables(self)) to lhObj
84907>>>>>      send Delete_Data
84908>>>>>      get row_count of lhObj to liMax
84909>>>>>      decrement liMax
84910>>>>>      for liItem from 1 to liMax
84916>>>>>>
84916>>>>>        send add_item MSG_NONE (psTableName.i(lhObj,liItem))
84917>>>>>      loop
84918>>>>>>
84918>>>>>      set dynamic_update_state to DFTRUE
84919>>>>>      send Grid_SetEntryState self DFFALSE
84920>>>>>    end_procedure
84921>>>>>  end_object
84922>>>>>
84922>>>>>  procedure DoUpdateTables
84925>>>>>    string lsDSNName
84925>>>>>    get value of (oDataSourceSelector(self)) item 0 to lsDSNName
84926>>>>>    if (lsDSNName<>"") begin
84928>>>>>      send FillArray to (oODBC_Tables(self)) lsDSNName
84929>>>>>      send fill_list to (oTables(self))
84930>>>>>    end
84930>>>>>>
84930>>>>>    else send delete_data to (oTables(self))
84932>>>>>  end_procedure
84933>>>>>
84933>>>>>  procedure DoOpen
84936>>>>>    integer liRval
84936>>>>>    string lsDataSource lsTableName
84936>>>>>    get value of (oDataSourceSelector(self)) item 0 to lsDataSource
84937>>>>>    get value of (oTables(self)) item CURRENT to lsTableName
84938>>>>>    send obs lsDataSource lsTableName
84939>>>>>    get ODBC_OpenAs 37 DF_SHARE lsDataSource lsTableName to liRval
84940>>>>>    send FDX_ModalDisplayFileAttributes 0 37
84941>>>>>  end_procedure
84942>>>>>  on_key KEY_CTRL+KEY_O send DoOpen
84943>>>>>
84943>>>>>  object oBtn1 is a aps.Multi_Button
84945>>>>>    on_item "Login" send ODBC_Login
84946>>>>>  end_object
84947>>>>>  object oBtn2 is a aps.Multi_Button
84949>>>>>    on_item "Open" send DoOpen
84950>>>>>  end_object
84951>>>>>  object oBtn3 is a aps.Multi_Button
84953>>>>>    on_item t.btn.cancel send close_panel
84954>>>>>  end_object
84955>>>>>
84955>>>>>  send aps_locate_multi_buttons
84956>>>>>  procedure close_panel_ok
84959>>>>>    set piResult to 1
84960>>>>>    send close_panel
84961>>>>>  end_procedure
84962>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
84963>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
84966>>>>>    send aps_resize (oTables(self)) delta_rw# 0 // delta_cl#
84967>>>>>    send aps_register_multi_button (oBtn1(self))
84968>>>>>    send aps_register_multi_button (oBtn2(self))
84969>>>>>    send aps_register_multi_button (oBtn3(self))
84970>>>>>    send aps_locate_multi_buttons
84971>>>>>    send aps_auto_size_container
84972>>>>>  end_procedure
84973>>>>>  procedure popup
84976>>>>>    integer liGarbage
84976>>>>>    set piResult to 0
84977>>>>>//    get ODBC_StartAdministrator to liGarbage
84977>>>>>    send FillArray to (oODBC_DataSources(self))
84978>>>>>    send fill_list to (oDataSourceSelector(self))
84979>>>>>    forward send popup
84981>>>>>    if (piResult(self)) begin
84983>>>>>    end
84983>>>>>>
84983>>>>>  end_procedure
84984>>>>>end_object // oODBCTableSelector
84985>>>>>
84985>>>>>//send popup to (oODBCTableSelector(self))
84985>>>//use VdfQuery.utl
84985>>>
84985>>>activate_view Activate_ODBCViewer for oODBCTableViewerView
84990>>>object oODBCTableViewerView is a aps.View label "ODBC table viewer"
84993>>>  on_key kcancel send close_panel
84994>>>
84994>>>  object oDataSourceSelector is a aps.ComboFormAux label "Select ODBC data source"
84997>>>    set label_justification_mode to JMODE_TOP
84998>>>    set form_margin item 0 to 40
84999>>>    set entry_state item 0 to DFFALSE
85000>>>    procedure fill_list
85003>>>      integer lhObj liMax liItem
85003>>>      move (oODBC_DataSources(self)) to lhObj
85004>>>      send Combo_Delete_Data
85005>>>      get item_count of lhObj to liMax
85006>>>      decrement liMax
85007>>>      for liItem from 1 to liMax
85013>>>>
85013>>>        send combo_add_item (value(lhObj,liItem)) liItem
85014>>>      loop
85015>>>>
85015>>>    end_procedure
85016>>>    procedure OnChange
85019>>>      send DoUpdateTables
85020>>>    end_procedure
85021>>>  end_object // oDataSourceSelector
85022>>>  send aps_goto_max_row
85023>>>
85023>>>  object oTables is a aps.Grid
85025>>>    set size to 200 0
85026>>>    send GridPrepare_AddColumn "Table name" AFT_ASCII40
85027>>>//    send GridPrepare_AddColumn "Schema name" AFT_ASCII40
85027>>>    send GridPrepare_Apply self
85028>>>    procedure fill_list
85031>>>      integer lhObj liMax liItem
85031>>>      set dynamic_update_state to DFFALSE
85032>>>      move (oODBC_Tables(self)) to lhObj
85033>>>      send Delete_Data
85034>>>      get row_count of lhObj to liMax
85035>>>      decrement liMax
85036>>>      for liItem from 1 to liMax
85042>>>>
85042>>>        send add_item MSG_NONE (psTableName.i(lhObj,liItem))
85043>>>//        send add_item MSG_NONE (psSchemaName.i(lhObj,liItem))
85043>>>      loop
85044>>>>
85044>>>      set dynamic_update_state to DFTRUE
85045>>>      send Grid_SetEntryState self DFFALSE
85046>>>    end_procedure
85047>>>  end_object
85048>>>
85048>>>  procedure DoUpdateTables
85051>>>    string lsDSNName
85051>>>    get value of (oDataSourceSelector(self)) item 0 to lsDSNName
85052>>>    if (lsDSNName<>"") begin
85054>>>      send FillArray to (oODBC_Tables(self)) lsDSNName
85055>>>      send fill_list to (oTables(self))
85056>>>    end
85056>>>>
85056>>>    else send delete_data to (oTables(self))
85058>>>  end_procedure
85059>>>
85059>>>  procedure DoOpen
85062>>>    integer liRval
85062>>>    string lsDataSource lsTableName
85062>>>    get value of (oDataSourceSelector(self)) item 0 to lsDataSource
85063>>>    get value of (oTables(self)) item CURRENT to lsTableName
85064>>>    get ODBC_OpenAs 37 DF_SHARE lsDataSource lsTableName to liRval
85065>>>    send FDX_ModalDisplayFileAttributes 0 37
85066>>>    close 37
85067>>>  end_procedure
85068>>>  procedure DoQuery
85071>>>//  integer liRval
85071>>>//  string lsDataSource lsTableName
85071>>>//  get value of (oDataSourceSelector(self)) item 0 to lsDataSource
85071>>>//  get value of (oTables(self)) item CURRENT to lsTableName
85071>>>//  get ODBC_OpenAs 37 DF_SHARE lsDataSource lsTableName to liRval
85071>>>//  send CreateNewQuery 37
85071>>>  end_procedure
85072>>>  on_key KEY_CTRL+KEY_O send DoOpen
85073>>>  on_key KEY_CTRL+KEY_Q send DoQuery
85074>>>
85074>>>  object oBtn1 is a aps.Multi_Button
85076>>>    on_item "Login" send ODBC_Login
85077>>>  end_object
85078>>>  object oBtn2 is a aps.Multi_Button
85080>>>    on_item "Read sources" send DoReadODBCSources
85081>>>  end_object
85082>>>  object oBtn3 is a aps.Multi_Button
85084>>>    on_item "Display def" send DoOpen
85085>>>  end_object
85086>>>//object oBtn4 is a aps.Multi_Button
85086>>>//  on_item "Query" send DoQuery
85086>>>//end_object
85086>>>  object oBtn5 is a aps.Multi_Button
85088>>>    on_item "Create DF table" send DoOpen
85089>>>  end_object
85090>>>  object oBtn6 is a aps.Multi_Button
85092>>>    on_item t.btn.close send close_panel
85093>>>  end_object
85094>>>  send aps_locate_multi_buttons SL_VERTICAL
85095>>>
85095>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
85096>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
85099>>>    send aps_resize (oTables(self)) delta_rw# 0 // delta_cl#
85100>>>    send aps_register_multi_button (oBtn1(self))
85101>>>    send aps_register_multi_button (oBtn2(self))
85102>>>    send aps_register_multi_button (oBtn3(self))
85103>>>//    send aps_register_multi_button (oBtn4(self))
85103>>>    send aps_register_multi_button (oBtn5(self))
85104>>>    send aps_register_multi_button (oBtn6(self))
85105>>>    send aps_locate_multi_buttons SL_VERTICAL
85106>>>    send aps_auto_size_container
85107>>>  end_procedure
85108>>>  procedure DoReadODBCSources
85111>>>    integer liGarbage
85111>>>//    get ODBC_StartAdministrator to liGarbage
85111>>>    send FillArray to (oODBC_DataSources(self))
85112>>>    send fill_list to (oDataSourceSelector(self))
85113>>>  end_procedure
85114>>>  procedure popup
85117>>>    forward send popup
85119>>>    send DoReadODBCSources
85120>>>  end_procedure
85121>>>end_object // oODBCTableSelector
85122>    Use dfm_importexport.vw
Including file: dfm_importexport.vw    (C:\Apps\VDFQuery\AppSrc\dfm_importexport.vw)
85122>>>// Use dfm_importexport.vw
85122>>>use aps.pkg
85122>>>Use Buttons.utl  // Button texts
85122>>>Use ToolUtilities.pkg // aps.YellowBox class
Including file: toolutilities.pkg    (C:\Apps\VDFQuery\AppSrc\toolutilities.pkg)
85122>>>>>// Use ToolUtilities.pkg // aps.YellowBox class
85122>>>>>
85122>>>>>use aps
85122>>>>>Use strings.utl  // sTextFromDfImage
85122>>>>>Use Spec0012.utl // Read image to string (sTextDfFromImage function)
85122>>>>>use rgb.utl      // RGB_Brighten
85122>>>>>
85122>>>>>class aps.YellowBox is a aps.Edit
85123>>>>>  procedure construct_object
85125>>>>>    forward send construct_object
85127>>>>>    set object_shadow_state to true
85128>>>>>    set border_style to BORDER_NONE
85129>>>>>    set color to (RGB_Brighten(clYellow,75))
85130>>>>>    set scroll_bar_visible_state to false
85131>>>>>    property integer piTextSourceImage public 0
85132>>>>>  end_procedure
85133>>>>>  procedure end_construct_object
85135>>>>>    integer liImg
85135>>>>>    string lsValue
85135>>>>>    forward send end_construct_object
85137>>>>>    get piTextSourceImage to liImg
85138>>>>>    if liImg begin
85140>>>>>      get sTextFromDfImage liImg to lsValue
85141>>>>>      send Text_SetEditObjectValue self lsValue
85142>>>>>    end
85142>>>>>>
85142>>>>>  end_procedure
85143>>>>>end_class // aps.YellowBox
85144>>>>>
85144>>>
85144>>>
85144>>>Use strings.utl
85144>>>Use Spec0012.utl // Read image to string (sTextDfFromImage function)
85144>>>Use files.utl
85144>>>use rgb.utl
85144>>>
85144>>>
85144>>>Use strings.utl
85144>>>Use files.utl
85144>>>Use Spec0012.utl // Read image to string (sTextDfFromImage function)
85144>>>
85144>>>
85144>>>use dfm_importexport.pkg
Including file: dfm_importexport.pkg    (C:\Apps\VDFQuery\AppSrc\dfm_importexport.pkg)
85144>>>>>// Use dfm_importexport.pkg // The low layer of import/export function
85144>>>>>
85144>>>>>Use FList.nui    // A lot of FLIST- procedures and functions
85144>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
85144>>>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
85144>>>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
85144>>>>>Use FDX.nui      // cFDX class
85144>>>>>Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles) (No User Interface)
85144>>>>>Use FdxCompa.nui // Class for comparing table definitions
85144>>>>>Use FDX_Attr.nui // FDX compatible attribute functions
85144>>>>>Use FdxFldMp.utl // Field mapping dialog
Including file: fdxfldmp.utl    (C:\Apps\VDFQuery\AppSrc\fdxfldmp.utl)
85144>>>>>>>// Use FdxFldMp.utl // Field mapping dialog
85144>>>>>>>
85144>>>>>>>Use Fdx_Attr.nui // FDX compatible attribute functions
85144>>>>>>>Use FdxField.nui // FDX Field things
85144>>>>>>>Use Mapper.nui   // Classes for (field) mapping
85144>>>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
85144>>>>>>>Use Mapper.pkg   // Dialog for mapping (fields)
Including file: mapper.pkg    (C:\Apps\VDFQuery\AppSrc\mapper.pkg)
85144>>>>>>>>>// Use Mapper.pkg   // Dialog for mapping (fields)
85144>>>>>>>>>Use Mapper.nui   // Classes for (field) mapping
85144>>>>>>>>>Use GridUtil.utl // Grid and List utilities (not for dbGrid's or Table's)
85144>>>>>>>>>
85144>>>>>>>>>class cMapperListLeft is a aps.Grid
85145>>>>>>>>>  procedure construct_object integer img#
85147>>>>>>>>>    forward send construct_object img#
85149>>>>>>>>>    send GridPrepare_AddColumn "Fields in input file" AFT_ASCII25
85150>>>>>>>>>    send GridPrepare_Apply self
85151>>>>>>>>>    set select_mode to NO_SELECT
85152>>>>>>>>>    on_key KNEXT_ITEM send switch
85153>>>>>>>>>    on_key KPREVIOUS_ITEM send switch_back
85154>>>>>>>>>    property integer phMapper       public 0
85155>>>>>>>>>    property integer pbUnmappedOnly public DFFALSE
85156>>>>>>>>>  end_procedure
85157>>>>>>>>>  procedure AddRow integer liAux string lsName string lsExtra
85159>>>>>>>>>    integer liBase
85159>>>>>>>>>    get item_count to liBase
85160>>>>>>>>>    send add_item MSG_NONE lsName
85161>>>>>>>>>    set aux_value item liBase to liAux
85162>>>>>>>>>  end_procedure
85163>>>>>>>>>  procedure fill_list
85165>>>>>>>>>    integer lhSelf
85165>>>>>>>>>    move self to lhSelf
85166>>>>>>>>>    set dynamic_update_state to DFFALSE
85167>>>>>>>>>    send delete_data
85168>>>>>>>>>    if (pbUnmappedOnly(self)) send DoCallback_UnmappedItems1 to (phMapper(self)) msg_AddRow lhSelf
85171>>>>>>>>>    else send DoCallback_AllItems1 to (phMapper(self)) msg_AddRow lhSelf
85173>>>>>>>>>    send Grid_SetEntryState self DFFALSE
85174>>>>>>>>>    set dynamic_update_state to DFTRUE
85175>>>>>>>>>  end_procedure
85176>>>>>>>>>  function iCurrentAux returns integer
85178>>>>>>>>>    integer liBase
85178>>>>>>>>>    get Grid_BaseItem self to liBase
85179>>>>>>>>>    function_return (aux_value(self,liBase))
85180>>>>>>>>>  end_function
85181>>>>>>>>>  procedure GotoAux integer liAux
85183>>>>>>>>>    integer liBase liRow liMax
85183>>>>>>>>>    get Grid_RowCount self to liMax
85184>>>>>>>>>    decrement liMax
85185>>>>>>>>>    for liRow from 0 to liMax
85191>>>>>>>>>>
85191>>>>>>>>>      get Grid_RowBaseItem self liRow to liBase
85192>>>>>>>>>      if (aux_value(self,liBase)=liAux) set current_item to liBase
85195>>>>>>>>>    loop
85196>>>>>>>>>>
85196>>>>>>>>>  end_procedure
85197>>>>>>>>>end_class // cMapperListLeft
85198>>>>>>>>>
85198>>>>>>>>>class cMapperListRight is a aps.Grid
85199>>>>>>>>>  procedure construct_object integer img#
85201>>>>>>>>>    forward send construct_object img#
85203>>>>>>>>>    property integer phMapper public 0
85204>>>>>>>>>    send GridPrepare_AddColumn "Field in table" AFT_ASCII25
85205>>>>>>>>>    send GridPrepare_AddColumn "Reads data from this column in file"  AFT_ASCII25
85206>>>>>>>>>    send GridPrepare_Apply self
85207>>>>>>>>>    set select_mode to NO_SELECT
85208>>>>>>>>>    on_key KNEXT_ITEM send switch
85209>>>>>>>>>    on_key KPREVIOUS_ITEM send switch_back
85210>>>>>>>>>  end_procedure
85211>>>>>>>>>  procedure AddRow integer liAux string lsName string lsExtra integer lbMapped integer liMapAux string lsMapName string lsMapExtra
85213>>>>>>>>>    integer liBase
85213>>>>>>>>>    get item_count to liBase
85214>>>>>>>>>    send add_item MSG_NONE lsName
85215>>>>>>>>>    send add_item MSG_NONE lsMapName
85216>>>>>>>>>    set aux_value item liBase     to liAux
85217>>>>>>>>>    set aux_value item (liBase+1) to liMapAux
85218>>>>>>>>>  end_procedure
85219>>>>>>>>>  procedure prepare_list
85221>>>>>>>>>    integer lhSelf
85221>>>>>>>>>    move self to lhSelf
85222>>>>>>>>>    set dynamic_update_state to DFFALSE
85223>>>>>>>>>    send delete_data
85224>>>>>>>>>    send DoCallback_AllItems2 to (phMapper(self)) msg_AddRow lhSelf
85225>>>>>>>>>    set dynamic_update_state to DFTRUE
85226>>>>>>>>>    send Grid_SetEntryState self DFFALSE
85227>>>>>>>>>  end_procedure
85228>>>>>>>>>
85228>>>>>>>>>  function iFindAux integer liAux returns integer
85230>>>>>>>>>    integer liBase liRow liMax
85230>>>>>>>>>    get Grid_RowCount self to liMax
85231>>>>>>>>>    decrement liMax
85232>>>>>>>>>    for liRow from 0 to liMax
85238>>>>>>>>>>
85238>>>>>>>>>      get Grid_RowBaseItem self liRow to liBase
85239>>>>>>>>>      if (aux_value(self,liBase)=liAux) function_return liBase
85242>>>>>>>>>    loop
85243>>>>>>>>>>
85243>>>>>>>>>    function_return -1
85244>>>>>>>>>  end_function
85245>>>>>>>>>
85245>>>>>>>>>  procedure AddUpdate integer liAux string lsName string lsExtra integer lbMapped integer liMapAux string lsMapName string lsMapExtra
85247>>>>>>>>>    integer liBase
85247>>>>>>>>>    get iFindAux liAux to liBase
85248>>>>>>>>>    set value item (liBase+1) to lsMapName
85249>>>>>>>>>    set aux_value item (liBase+1) to liMapAux
85250>>>>>>>>>  end_procedure
85251>>>>>>>>>
85251>>>>>>>>>  procedure fill_list
85253>>>>>>>>>    integer lhSelf
85253>>>>>>>>>    move self to lhSelf
85254>>>>>>>>>    send DoCallback_AllItems2 to (phMapper(self)) msg_AddUpdate lhSelf
85255>>>>>>>>>  end_procedure
85256>>>>>>>>>
85256>>>>>>>>>  procedure GotoAux integer liAux
85258>>>>>>>>>    integer liBase liRow liMax
85258>>>>>>>>>    get Grid_RowCount self to liMax
85259>>>>>>>>>    decrement liMax
85260>>>>>>>>>    for liRow from 0 to liMax
85266>>>>>>>>>>
85266>>>>>>>>>      get Grid_RowBaseItem self liRow to liBase
85267>>>>>>>>>      if (aux_value(self,liBase)=liAux) set current_item to liBase
85270>>>>>>>>>    loop
85271>>>>>>>>>>
85271>>>>>>>>>  end_procedure
85272>>>>>>>>>
85272>>>>>>>>>  function iCurrentAux returns integer
85274>>>>>>>>>    integer liBase
85274>>>>>>>>>    get Grid_BaseItem self to liBase
85275>>>>>>>>>    function_return (aux_value(self,liBase))
85276>>>>>>>>>  end_function
85277>>>>>>>>>end_class // cMapperListRight
85278>>>>>>>>>
85278>>>>>>>>>class cMapperGridController is a cArray
85279>>>>>>>>>  procedure construct_object integer liImage
85281>>>>>>>>>    forward send construct_object liImage
85283>>>>>>>>>    property integer phGridLeft  public 0
85284>>>>>>>>>    property integer phGridRight public 0
85285>>>>>>>>>    property integer phMapper    public 0
85286>>>>>>>>>  end_procedure
85287>>>>>>>>>  procedure DoInitialize
85289>>>>>>>>>    set phMapper of (phGridLeft(self))  to (phMapper(self))
85290>>>>>>>>>    set phMapper of (phGridRight(self)) to (phMapper(self))
85291>>>>>>>>>    send fill_list    to (phGridLeft(self))
85292>>>>>>>>>    send prepare_list to (phGridRight(self))
85293>>>>>>>>>    send fill_list    to (phGridRight(self))
85294>>>>>>>>>  end_procedure
85295>>>>>>>>>  procedure DoMap
85297>>>>>>>>>    integer liFileIdent liTableIdent
85297>>>>>>>>>    get iCurrentAux of (phGridLeft(self)) to liFileIdent
85298>>>>>>>>>    get iCurrentAux of (phGridRight(self)) to liTableIdent
85299>>>>>>>>>    send DoAddMap to (phMapper(self)) liFileIdent liTableIdent
85300>>>>>>>>>    send fill_list    to (phGridLeft(self))
85301>>>>>>>>>    send fill_list    to (phGridRight(self))
85302>>>>>>>>>    send key to (phGridRight(self)) kdownarrow
85303>>>>>>>>>  end_procedure
85304>>>>>>>>>  procedure DoMapClear
85306>>>>>>>>>    integer liFileIdent liTableIdent
85306>>>>>>>>>    get iCurrentAux of (phGridRight(self)) to liTableIdent
85307>>>>>>>>>    send DoClearMap to (phMapper(self)) liTableIdent
85308>>>>>>>>>    send fill_list    to (phGridLeft(self))
85309>>>>>>>>>    send fill_list    to (phGridRight(self))
85310>>>>>>>>>  end_procedure
85311>>>>>>>>>  procedure DoMapClearAll
85313>>>>>>>>>    send DoReset   to (phMapper(self))
85314>>>>>>>>>    send fill_list to (phGridLeft(self))
85315>>>>>>>>>    send fill_list to (phGridRight(self))
85316>>>>>>>>>  end_procedure
85317>>>>>>>>>  procedure DoAutoMap
85319>>>>>>>>>    send DoAutoMapName to (phMapper(self))
85320>>>>>>>>>    send fill_list to (phGridLeft(self))
85321>>>>>>>>>    send fill_list to (phGridRight(self))
85322>>>>>>>>>  end_procedure
85323>>>>>>>>>end_class
85324>>>>>>>>>
85324>>>>>>>>>object oMapperPanel is a aps.ModalPanel label "Map fields"
85327>>>>>>>>>  set locate_mode to CENTER_ON_SCREEN
85328>>>>>>>>>  on_key ksave_record send close_panel_ok
85329>>>>>>>>>  on_key kcancel send close_panel
85330>>>>>>>>>  property integer piResult public 0
85332>>>>>>>>>  register_object oMapperGridController
85332>>>>>>>>>
85332>>>>>>>>>  on_key kClear send DoMapClear to (oMapperGridController(self))
85333>>>>>>>>>  on_key kClear_All send DoMapClearAll to (oMapperGridController(self))
85334>>>>>>>>>
85334>>>>>>>>>  procedure close_panel_ok
85337>>>>>>>>>    set piResult to 1
85338>>>>>>>>>    send close_panel
85339>>>>>>>>>  end_procedure
85340>>>>>>>>>
85340>>>>>>>>>  object oUnmappedGrid is a cMapperListLeft
85342>>>>>>>>>    set size to 140 0
85343>>>>>>>>>    on_key kEnter send DoMap to (oMapperGridController(self))
85344>>>>>>>>>    set Horz_Scroll_Bar_Visible_State to false
85345>>>>>>>>>  end_object
85346>>>>>>>>>
85346>>>>>>>>>  object oRadio is a aps.RadioContainer
85348>>>>>>>>>    object oRad1 is a aps.Radio label "Unmapped only" snap SL_DOWN
85352>>>>>>>>>    end_object
85353>>>>>>>>>    object oRad2 is a aps.Radio label "All" snap SL_RIGHT_SPACE
85357>>>>>>>>>    end_object
85358>>>>>>>>>    procedure notify_select_state integer liTo integer liFrom
85361>>>>>>>>>      set pbUnmappedOnly of (oUnmappedGrid(self)) to (not(liTo))
85362>>>>>>>>>      send fill_list to (oUnmappedGrid(self))
85363>>>>>>>>>    end_procedure
85364>>>>>>>>>  end_object
85365>>>>>>>>>
85365>>>>>>>>>  set p_cur_row to (p_top_margin(self))
85366>>>>>>>>>
85366>>>>>>>>>  object oBtnClearAll is a aps.Button snap SL_RIGHT relative_to (oUnmappedGrid(self))
85374>>>>>>>>>    set size to 14 30
85375>>>>>>>>>    on_item ">" send DoMap to (oMapperGridController(self))
85376>>>>>>>>>  end_object
85377>>>>>>>>>  send aps_relocate (oBtnClearAll(self)) 20 0
85378>>>>>>>>>  object oBtnClearOne is a aps.Button snap SL_DOWN
85381>>>>>>>>>    set size to 14 30
85382>>>>>>>>>    on_item "<" send DoMapClear to (oMapperGridController(self))
85383>>>>>>>>>  end_object
85384>>>>>>>>>  object oBtnAddOne is a aps.Button snap SL_DOWN
85387>>>>>>>>>    set size to 14 30
85388>>>>>>>>>    on_item "<<" send DoMapClearAll to (oMapperGridController(self))
85389>>>>>>>>>  end_object
85390>>>>>>>>>
85390>>>>>>>>>  set p_cur_row to (p_top_margin(self))
85391>>>>>>>>>
85391>>>>>>>>>  object oMapGrid is a cMapperListRight
85393>>>>>>>>>    set size to 150 0
85394>>>>>>>>>  end_object
85395>>>>>>>>>
85395>>>>>>>>>  object oMapperGridController is a cMapperGridController
85397>>>>>>>>>    set phGridLeft  to (oUnmappedGrid(self))
85398>>>>>>>>>    set phGridRight to (oMapGrid(self))
85399>>>>>>>>>  end_object
85400>>>>>>>>>
85400>>>>>>>>>  object oBtn1 is a aps.multi_button
85402>>>>>>>>>    on_item "OK" send close_panel_ok
85403>>>>>>>>>  end_object
85404>>>>>>>>>  object oBtn2 is a aps.multi_button
85406>>>>>>>>>    on_item "Auto map" send DoAutoMap to (oMapperGridController(self))
85407>>>>>>>>>  end_object
85408>>>>>>>>>  object oBtn3 is a aps.multi_button
85410>>>>>>>>>    on_item "Clear map" send DoMapClearAll to (oMapperGridController(self))
85411>>>>>>>>>  end_object
85412>>>>>>>>>  object oBtn4 is a aps.multi_button
85414>>>>>>>>>    on_item "Cancel" send close_panel
85415>>>>>>>>>  end_object
85416>>>>>>>>>  send aps_locate_multi_buttons
85417>>>>>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
85418>>>>>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
85421>>>>>>>>>    send aps_resize (oMapGrid(self)) delta_rw# 0 // delta_cl#
85422>>>>>>>>>    send aps_resize (oUnmappedGrid(self)) delta_rw# 0 // delta_cl#
85423>>>>>>>>>    send aps_auto_locate_control (oRad1(oRadio(self))) SL_DOWN (oUnmappedGrid(self))
85424>>>>>>>>>    send aps_auto_locate_control (oRad2(oRadio(self))) SL_RIGHT_SPACE (oRad1(oRadio(self)))
85425>>>>>>>>>    send aps_register_multi_button (oBtn1(self))
85426>>>>>>>>>    send aps_register_multi_button (oBtn2(self))
85427>>>>>>>>>    send aps_register_multi_button (oBtn3(self))
85428>>>>>>>>>    send aps_register_multi_button (oBtn4(self))
85429>>>>>>>>>    send aps_locate_multi_buttons
85430>>>>>>>>>    send aps_auto_size_container
85431>>>>>>>>>  end_procedure
85432>>>>>>>>>  set pMinimumSize to 150 0
85433>>>>>>>>>  procedure popup.shsss string lsTitle integer lhMapper string lsHeader1 string lsHeader2 string lsHeader3
85436>>>>>>>>>    set piResult to 0
85437>>>>>>>>>    send DoPushStatus to lhMapper
85438>>>>>>>>>    set phMapper of (oMapperGridController(self)) to lhMapper
85439>>>>>>>>>    send DoInitialize to (oMapperGridController(self))
85440>>>>>>>>>    send popup
85441>>>>>>>>>    ifnot (piResult(self)) send DoPopStatus to lhMapper
85444>>>>>>>>>  end_procedure
85445>>>>>>>>>end_object
85446>>>>>>>>>
85446>>>>>>>>>procedure DoMapperDialog global string lsTitle integer lhMapper string lsHeader1 string lsHeader2 string lsHeader3
85448>>>>>>>>>  send popup.shsss to (oMapperPanel(self)) lsTitle lhMapper lsHeader1 lsHeader2 lsHeader3
85449>>>>>>>>>end_procedure
85450>>>>>>>
85450>>>>>>>
85450>>>>>>>class cFdxField_MapObject is a cMapObject
85451>>>>>>>  procedure construct_object integer lhObj
85453>>>>>>>    forward send construct_object lhObj
85455>>>>>>>    property integer phFdx public 0
85456>>>>>>>  end_procedure
85457>>>>>>>
85457>>>>>>>            Procedure HandleField integer liFile integer liField string lsName integer liType integer liLen integer liPrec integer liRelFile integer liRelField integer liIndex integer liOffSet
85459>>>>>>>              if (liType<>DF_OVERLAP) send DoAddItem liField lsName (StringFieldText(liType,liLen,liPrec))
85462>>>>>>>            End_Procedure
85463>>>>>>>  procedure read_fdx_file integer lhFdx integer liFile
85465>>>>>>>    set phFdx to lhFdx
85466>>>>>>>    send DoReset
85467>>>>>>>    send FDX_FieldCallBack lhFdx liFile MSG_HandleField self // Protected against relating file not present
85468>>>>>>>  end_procedure
85469>>>>>>>end_class // cFdxField_MapObject
85470>>>>>>>
85470>>>>>>>object oFdxFieldMapper is a cMapper
85472>>>>>>>  object oFieldsFrom is a cFdxField_MapObject
85474>>>>>>>  end_object
85475>>>>>>>  object oFieldsTo is a cFdxField_MapObject
85477>>>>>>>  end_object
85478>>>>>>>
85478>>>>>>>  set piMapMode to 0 // 0=random 1=sequential
85479>>>>>>>  set phObject1 to (oFieldsFrom(self))
85480>>>>>>>  set phObject2 to (oFieldsTo(self))
85481>>>>>>>  set psTitle1  to "Title 1"
85482>>>>>>>  set psTitle2  to "Title 2"
85483>>>>>>>  set psTitle3  to "Title 3"
85484>>>>>>>
85484>>>>>>>  procedure read_fdx_file_from integer lhFdx integer liFile
85487>>>>>>>    send read_fdx_file to (oFieldsFrom(self)) lhFdx liFile
85488>>>>>>>  end_procedure
85489>>>>>>>  procedure read_fdx_file_to integer lhFdx integer liFile
85492>>>>>>>    send read_fdx_file to (oFieldsTo(self)) lhFdx liFile
85493>>>>>>>  end_procedure
85494>>>>>>>
85494>>>>>>>  procedure read_current_map integer lhMap
85497>>>>>>>    integer liMax liIdentFrom liIdentTo
85497>>>>>>>    send DoReset
85498>>>>>>>    get item_count of lhMap to liMax
85499>>>>>>>    decrement liMax
85500>>>>>>>    for liIdentFrom from 0 to liMax
85506>>>>>>>>
85506>>>>>>>      get value of lhMap item liIdentFrom to liIdentTo
85507>>>>>>>      if (liIdentTo>=0) send DoAddMap liIdentFrom liIdentTo
85510>>>>>>>    loop
85511>>>>>>>>
85511>>>>>>>  end_procedure
85512>>>>>>>  procedure write_current_map integer lhMap
85515>>>>>>>    integer liMax liRow
85515>>>>>>>    send delete_data to lhMap
85516>>>>>>>    get row_count to liMax
85517>>>>>>>    decrement liMax
85518>>>>>>>    for liRow from 0 to liMax
85524>>>>>>>>
85524>>>>>>>      set value of lhMap item (piIdent1.i(self,liRow)) to (piIdent2.i(self,liRow))
85525>>>>>>>    loop
85526>>>>>>>>
85526>>>>>>>  end_procedure
85527>>>>>>>
85527>>>>>>>end_object // oFdxFieldMapper
85528>>>>>>>
85528>>>>>>>// Parameter lhCurrentMap is a simple array that for each ident in the map-from definition holds the ident (if any) in the map-to
85528>>>>>>>// definition.
85528>>>>>>>function DoFdxFieldMapperDialog global integer lhCurrentMap integer lhFdxFrom integer liFileFrom integer lhFdxTo integer liFileTo returns integer
85530>>>>>>>  ifnot lhCurrentMap begin
85532>>>>>>>    object oCurrentMap is a cArray
85534>>>>>>>      move self to lhCurrentMap
85535>>>>>>>    end_object
85536>>>>>>>  end
85536>>>>>>>>
85536>>>>>>>  send read_fdx_file_from to (oFdxFieldMapper(self)) lhFdxFrom liFileFrom
85537>>>>>>>  send read_fdx_file_to to (oFdxFieldMapper(self)) lhFdxTo liFileTo
85538>>>>>>>  send read_current_map to (oFdxFieldMapper(self)) lhCurrentMap
85539>>>>>>>  send DoMapperDialog "Main title" (oFdxFieldMapper(self)) "Header 1" "Header 2" "Header 3"
85540>>>>>>>  send write_current_map to (oFdxFieldMapper(self)) lhCurrentMap
85541>>>>>>>  function_return lhCurrentMap
85542>>>>>>>end_function
85543>>>>>>>
85543>>>>>Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface)
85543>>>>>Use Array.dbu    // Array Debugging (send Array_DoWriteToFile lhArray lsFileName)
Including file: array.dbu    (C:\Apps\VDFQuery\AppSrc\array.dbu)
85543>>>>>>>// Use ArrayExp.nui    // Export array to file (send Array_DoWriteToFile lhArray lsFileName)
85543>>>>>>>Use ItemProp.nui  // Sort values (No User Interface)
85543>>>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
85543>>>>>>>
85543>>>>>>>enumeration_list
85543>>>>>>>  define ARR_FORMAT
85543>>>>>>>  define ARR_COMMA
85543>>>>>>>  define ARR_SEMICOLON
85543>>>>>>>  define ARR_TAB
85543>>>>>>>end_enumeration_list
85543>>>>>>>
85543>>>>>>>desktop_section
85548>>>>>>>  object Array_WriteToFileColumnWidthArray is a cArray
85550>>>>>>>    item_property_list
85550>>>>>>>      item_property integer piWidth.i
85550>>>>>>>      item_property integer piRightAlign.i
85550>>>>>>>    end_item_property_list
#REM 85587 DEFINE FUNCTION PIRIGHTALIGN.I INTEGER LIROW RETURNS INTEGER
#REM 85592 DEFINE PROCEDURE SET PIRIGHTALIGN.I INTEGER LIROW INTEGER VALUE
#REM 85597 DEFINE FUNCTION PIWIDTH.I INTEGER LIROW RETURNS INTEGER
#REM 85602 DEFINE PROCEDURE SET PIWIDTH.I INTEGER LIROW INTEGER VALUE
85608>>>>>>>    procedure DoReadArray integer lhArray
85611>>>>>>>      integer liRows liColumns liRow liColumn liWidth liDecSep
85611>>>>>>>      string lsValue
85611>>>>>>>      get_attribute DF_DECIMAL_SEPARATOR to liDecSep
85614>>>>>>>      send delete_data
85615>>>>>>>      get column_count of lhArray to liColumns
85616>>>>>>>      get row_count of lhArray to liRows
85617>>>>>>>      for liColumn from 0 to (liColumns-1)
85623>>>>>>>>
85623>>>>>>>        set piRightAlign.i liColumn to DFTRUE
85624>>>>>>>      loop
85625>>>>>>>>
85625>>>>>>>      for liRow from 0 to (liRows-1)
85631>>>>>>>>
85631>>>>>>>        for liColumn from 0 to (liColumns-1)
85637>>>>>>>>
85637>>>>>>>          get value of lhArray item (liRow*liColumns+liColumn) to lsValue
85638>>>>>>>          move (rtrim(lsValue)) to lsValue
85639>>>>>>>          move (length(lsValue)) to liWidth
85640>>>>>>>          if (liWidth>integer(piWidth.i(self,liColumn))) set piWidth.i liColumn to liWidth
85643>>>>>>>          ifnot (StringIsNumber(lsValue,liDecSep)) set piRightAlign.i liColumn to DFFALSE
85646>>>>>>>        loop
85647>>>>>>>>
85647>>>>>>>      loop
85648>>>>>>>>
85648>>>>>>>    end_procedure
85649>>>>>>>  end_object
85650>>>>>>>end_desktop_section
85655>>>>>>>
85655>>>>>>>function Array_DataWidth global integer lhArray integer liColumn returns integer
85657>>>>>>>  function_return (piWidth.i(Array_WriteToFileColumnWidthArray(self),liColumn))
85658>>>>>>>end_function
85659>>>>>>>
85659>>>>>>>procedure Array_DoReadDataWidth global integer lhArray
85661>>>>>>>  send DoReadArray to (Array_WriteToFileColumnWidthArray(self)) lhArray
85662>>>>>>>end_procedure
85663>>>>>>>
85663>>>>>>>function Array_WriteToFile_Help global integer liFormat string lsValue integer liWidth integer liRightAlign returns string
85665>>>>>>>  if (liFormat=ARR_FORMAT) begin
85667>>>>>>>    if (length(lsValue)>liWidth) move (left(lsValue,liWidth)) to lsValue
85670>>>>>>>    if liRightAlign move (RightShift(lsValue,liWidth)) to lsValue
85673>>>>>>>    else move (pad(lsValue,liWidth)) to lsValue
85675>>>>>>>  end
85675>>>>>>>>
85675>>>>>>>  if (liFormat=ARR_COMMA) begin
85677>>>>>>>    if "," in lsValue begin
85679>>>>>>>      move (replaces('"',lsValue,"'")) to lsValue
85680>>>>>>>      move ('"'+lsValue+'"') to lsValue
85681>>>>>>>    end
85681>>>>>>>>
85681>>>>>>>  end
85681>>>>>>>>
85681>>>>>>>  if (liFormat=ARR_SEMICOLON) begin
85683>>>>>>>    if ";" in lsValue begin
85685>>>>>>>      move (replaces('"',lsValue,"'")) to lsValue
85686>>>>>>>      move ('"'+lsValue+'"') to lsValue
85687>>>>>>>    end
85687>>>>>>>>
85687>>>>>>>  end
85687>>>>>>>>
85687>>>>>>>  function_return lsValue
85688>>>>>>>end_function
85689>>>>>>>
85689>>>>>>>// This procedure will write the entire contents of the Grid passed as
85689>>>>>>>// object handle object to a
85689>>>>>>>// sequential
85689>>>>>>>procedure Array_WriteToFile global integer lhArray integer liChannel integer liFormat
85691>>>>>>>  integer liRows liColumns liRow liColumn liWidth liRightAlign
85691>>>>>>>  string lsValue
85691>>>>>>>  get column_count of lhArray to liColumns
85692>>>>>>>  get row_count of lhArray to liRows
85693>>>>>>>  send Array_DoReadDataWidth lhArray
85694>>>>>>>//  for liColumn from 0 to (liColumns-1)
85694>>>>>>>//    get header_label of lhArray liColumn to lsValue
85694>>>>>>>//    get Array_DataWidth lhArray liColumn to liWidth
85694>>>>>>>//    get piRightAlign.i of (Array_WriteToFileColumnWidthArray(self)) liColumn to liRightAlign
85694>>>>>>>//    get Array_WriteToFile_Help liFormat lsValue liWidth liRightAlign to lsValue
85694>>>>>>>//    write channel liChannel (ToAnsi(lsValue))
85694>>>>>>>//    if liColumn ne (liColumns-1) begin
85694>>>>>>>//      if (liFormat=ARR_FORMAT) write " "
85694>>>>>>>//      if (liFormat=ARR_COMMA ) write ","
85694>>>>>>>//      if (liFormat=ARR_TAB   ) write (character(8))
85694>>>>>>>//    end
85694>>>>>>>//  loop
85694>>>>>>>//  writeln channel liChannel ""
85694>>>>>>>  for liRow from 0 to (liRows-1)
85700>>>>>>>>
85700>>>>>>>    for liColumn from 0 to (liColumns-1)
85706>>>>>>>>
85706>>>>>>>      get value of lhArray item (liRow*liColumns+liColumn) to lsValue
85707>>>>>>>      get Array_DataWidth lhArray liColumn to liWidth
85708>>>>>>>      get piRightAlign.i of (Array_WriteToFileColumnWidthArray(self)) liColumn to liRightAlign
85709>>>>>>>      get Array_WriteToFile_Help liFormat lsValue liWidth liRightAlign to lsValue
85710>>>>>>>      write channel liChannel (ToAnsi(lsValue))
85712>>>>>>>      if liColumn ne (liColumns-1) begin
85714>>>>>>>        if (liFormat=ARR_FORMAT) write " "
85717>>>>>>>        if (liFormat=ARR_COMMA ) write ","
85720>>>>>>>        if (liFormat=ARR_SEMICOLON) write ";"
85723>>>>>>>        if (liFormat=ARR_TAB   ) write (character(8))
85726>>>>>>>      end
85726>>>>>>>>
85726>>>>>>>    loop
85727>>>>>>>>
85727>>>>>>>    writeln channel liChannel ""
85730>>>>>>>  loop
85731>>>>>>>>
85731>>>>>>>end_procedure
85732>>>>>>>
85732>>>>>>>// NOTE. Using this function during a transaction (or a lock) will
85732>>>>>>>//       generate an error "Can't RUNPROGRAM during transaction".
85732>>>>>>>procedure Array_DoWriteToFile global integer lhArray string lsFileName
85734>>>>>>>  integer liChannel
85734>>>>>>>  string lsTempFileName
85734>>>>>>>  get SEQ_FirstDirInDfPath to lsTempFileName
85735>>>>>>>  get SEQ_ComposeAbsoluteFileName lsTempFileName lsFileName to lsTempFileName
85736>>>>>>>  get SEQ_DirectOutput lsTempFileName to liChannel
85737>>>>>>>  if liChannel ge 0 begin
85739>>>>>>>    send Array_WriteToFile lhArray liChannel ARR_FORMAT
85740>>>>>>>    send SEQ_CloseOutput liChannel
85741>>>>>>>    runprogram BACKGROUND ("notepad "+lsTempFileName)
85742>>>>>>>  end
85742>>>>>>>>
85742>>>>>>>end_procedure
85743>>>>>Use files01.nui // SEQ_DoChannelPositionsToLineCount - stuff
Including file: files01.nui    (C:\Apps\VDFQuery\AppSrc\files01.nui)
85743>>>>>>>// Use files01.nui // SEQ_DoChannelPositionsToLineCount - stuff
85743>>>>>>>use files.nui
85743>>>>>>>
85743>>>>>>>object oSEQ_DoChannelPositionsToLineCount is a cArray
85745>>>>>>>  item_property_list
85745>>>>>>>    item_property integer piPosition.i
85745>>>>>>>    item_property integer piLine.i
85745>>>>>>>  end_item_property_list
#REM 85782 DEFINE FUNCTION PILINE.I INTEGER LIROW RETURNS INTEGER
#REM 85787 DEFINE PROCEDURE SET PILINE.I INTEGER LIROW INTEGER VALUE
#REM 85792 DEFINE FUNCTION PIPOSITION.I INTEGER LIROW RETURNS INTEGER
#REM 85797 DEFINE PROCEDURE SET PIPOSITION.I INTEGER LIROW INTEGER VALUE
85803>>>>>>>  procedure add_position integer liRow integer liPos
85806>>>>>>>    set piPosition.i liRow to liPos
85807>>>>>>>    set piLine.i     liRow to -1
85808>>>>>>>  end_procedure
85809>>>>>>>end_object
85810>>>>>>>
85810>>>>>>>procedure SEQ_DoChannelPositionsToLineCount_Reset global
85812>>>>>>>  send delete_data to (oSEQ_DoChannelPositionsToLineCount(self))
85813>>>>>>>end_procedure
85814>>>>>>>procedure SEQ_DoChannelPositionsToLineCount_Add global integer liRow integer liPos // This only works if channel positions are added in ascending order
85816>>>>>>>  send add_position to (oSEQ_DoChannelPositionsToLineCount(self)) liRow liPos
85817>>>>>>>end_procedure
85818>>>>>>>procedure SEQ_DoChannelPositionsToLineCount_Resolve global string lsFileName
85820>>>>>>>  integer liChannel liLineCount liRow lhArray liMax
85820>>>>>>>  integer liTestPos liPos lbSeqEof
85820>>>>>>>  string lsValue
85820>>>>>>>  move (oSEQ_DoChannelPositionsToLineCount(self)) to lhArray
85821>>>>>>>  get SEQ_DirectInput lsFileName to liChannel
85822>>>>>>>  if (liChannel>=0) begin
85824>>>>>>>
85824>>>>>>>    get row_count of lhArray to liMax
85825>>>>>>>    decrement liMax
85826>>>>>>>    move 0 to liRow
85827>>>>>>>    move 0 to liLineCount
85828>>>>>>>    get piPosition.i of lhArray liRow to liPos
85829>>>>>>>
85829>>>>>>>    repeat
85829>>>>>>>>
85829>>>>>>>      readln channel liChannel lsValue
85831>>>>>>>      move (seqeof) to lbSeqEof
85832>>>>>>>      get_channel_position liChannel to liTestPos
85833>>>>>>>>
85833>>>>>>>      increment liLineCount
85834>>>>>>>      repeat
85834>>>>>>>>
85834>>>>>>>        if (liTestPos>=liPos) begin
85836>>>>>>>          set piLine.i of lhArray liRow to liLineCount
85837>>>>>>>          increment liRow
85838>>>>>>>          if (liRow<=liMax) begin
85840>>>>>>>            get piPosition.i of lhArray liRow to liPos
85841>>>>>>>          end
85841>>>>>>>>
85841>>>>>>>        end
85841>>>>>>>>
85841>>>>>>>      until (liRow>liMax or liPos>liTestPos)
85843>>>>>>>
85843>>>>>>>    until (liRow>liMax or lbSeqEof<>0)
85845>>>>>>>
85845>>>>>>>    send SEQ_CloseInput liChannel
85846>>>>>>>  end
85846>>>>>>>>
85846>>>>>>>end_procedure
85847>>>>>>>
85847>>>>>>>function SEQ_DoChannelPositionsToLineCount global integer liRow returns integer
85849>>>>>>>  integer lhArray
85849>>>>>>>  move (oSEQ_DoChannelPositionsToLineCount(self)) to lhArray
85850>>>>>>>  function_return (piLine.i(lhArray,liRow))
85851>>>>>>>end_function
85852>>>>>>>
85852>>>>>>>//procedure test
85852>>>>>>>//  send SEQ_DoChannelPositionsToLineCount_Reset
85852>>>>>>>//  send SEQ_DoChannelPositionsToLineCount_Add 0 1000
85852>>>>>>>//  send SEQ_DoChannelPositionsToLineCount_Add 1 1001
85852>>>>>>>//  send SEQ_DoChannelPositionsToLineCount_Add 2 2000
85852>>>>>>>//  send SEQ_DoChannelPositionsToLineCount_Add 3 3000
85852>>>>>>>//  send SEQ_DoChannelPositionsToLineCount_Resolve "\apps\newsgroups\data\importexport\dfm-eaddress.asc"
85852>>>>>>>//  showln (SEQ_DoChannelPositionsToLineCount(0))
85852>>>>>>>//  showln (SEQ_DoChannelPositionsToLineCount(1))
85852>>>>>>>//  showln (SEQ_DoChannelPositionsToLineCount(2))
85852>>>>>>>//  showln (SEQ_DoChannelPositionsToLineCount(3))
85852>>>>>>>//  inkey windowindex
85852>>>>>>>//end_procedure
85852>>>>>>>//send test
85852>>>>>Use MsgBox.utl   // obs procedure
85852>>>>>
85852>>>>>function DFM_IE_SuggestFolder global returns string
85854>>>>>  string lsRval
85854>>>>>  get FLIST_CurrentFileListFolder to lsRval
85855>>>>>  get Files_AppendPath lsRval "DumpAndLoad" to lsRval
85856>>>>>  function_return lsRval
85857>>>>>end_function
85858>>>>>
85858>>>>>object DFM_IE_ControlBlock is a cArray
85860>>>>>  property integer pbExport public false
85862>>>>>  property integer pbErase  public false
85864>>>>>  property integer pbImport public false
85866>>>>>  property string  psFolder public (DFM_IE_SuggestFolder())
85868>>>>>  property integer pbPauseOnErrors public 0 false
85870>>>>>  procedure OnChangeFDX_Broadcasted // Sent by DFM
85873>>>>>    set delegation_mode to DELEGATE_TO_PARENT
85874>>>>>    set psFolder to (DFM_IE_SuggestFolder())
85875>>>>>  end_procedure
85876>>>>>  procedure Close_Query_View // Sent by FastView
85879>>>>>    set delegation_mode to DELEGATE_TO_PARENT
85880>>>>>    set psFolder to (DFM_IE_SuggestFolder())
85881>>>>>  end_procedure
85882>>>>>end_object // DFM_IE_ControlBlock
85883>>>>>
85883>>>>>define t.importexport.eoh  for "-- End of header. Do not edit below this line --" // End of header tag
85883>>>>>define t.importexport.eo2h for "-eoh2-" // End of 2nd header tag
85883>>>>>define t.importexport.eor  for "-eor-" // End of record tag
85883>>>>>
85883>>>>>object DFM_IE_WorkHorse is a cArray
85885>>>>>  item_property_list
85885>>>>>    item_property integer piFile.i             // Number of table
85885>>>>>    item_property string  psRootName.i         // Root name as found in filelist.cfg
85885>>>>>    item_property string  psRootOfRoot.i       // Root name stripped of path and driver specification
85885>>>>>    item_property integer piCanOpen.i          // Can the table be opened
85885>>>>>    item_property integer pbImportFileFound.i  // Can the import file be found
85885>>>>>    item_property integer piTableRecordCount.i // Number of records in the table
85885>>>>>    item_property integer piFileRecordCount.i  // Number of records in the .asc file
85885>>>>>    item_property integer phTableFdx.i         // Fdx image of the table definition
85885>>>>>    item_property integer phFileFdx.i          // Fdx image of the table definition as recorded in the input file
85885>>>>>    item_property integer pbDefinitionMatch.i  // Does the FDX images match in terms of sequence of fields
85885>>>>>    item_property integer phFieldMapper.i      // Pointer to a field mapping object
85885>>>>>    item_property number  pnDumpTime.i         // Time (in seconds) it took to dump the table
85885>>>>>    item_property number  pnLoadTime.i         // Time (in seconds) it took to load the file
85885>>>>>    item_property integer piLoadErrors.i       // Number of errors during load operation
85885>>>>>  end_item_property_list
#REM 85958 DEFINE FUNCTION PILOADERRORS.I INTEGER LIROW RETURNS INTEGER
#REM 85963 DEFINE PROCEDURE SET PILOADERRORS.I INTEGER LIROW INTEGER VALUE
#REM 85968 DEFINE FUNCTION PNLOADTIME.I INTEGER LIROW RETURNS NUMBER
#REM 85973 DEFINE PROCEDURE SET PNLOADTIME.I INTEGER LIROW NUMBER VALUE
#REM 85978 DEFINE FUNCTION PNDUMPTIME.I INTEGER LIROW RETURNS NUMBER
#REM 85983 DEFINE PROCEDURE SET PNDUMPTIME.I INTEGER LIROW NUMBER VALUE
#REM 85988 DEFINE FUNCTION PHFIELDMAPPER.I INTEGER LIROW RETURNS INTEGER
#REM 85993 DEFINE PROCEDURE SET PHFIELDMAPPER.I INTEGER LIROW INTEGER VALUE
#REM 85998 DEFINE FUNCTION PBDEFINITIONMATCH.I INTEGER LIROW RETURNS INTEGER
#REM 86003 DEFINE PROCEDURE SET PBDEFINITIONMATCH.I INTEGER LIROW INTEGER VALUE
#REM 86008 DEFINE FUNCTION PHFILEFDX.I INTEGER LIROW RETURNS INTEGER
#REM 86013 DEFINE PROCEDURE SET PHFILEFDX.I INTEGER LIROW INTEGER VALUE
#REM 86018 DEFINE FUNCTION PHTABLEFDX.I INTEGER LIROW RETURNS INTEGER
#REM 86023 DEFINE PROCEDURE SET PHTABLEFDX.I INTEGER LIROW INTEGER VALUE
#REM 86028 DEFINE FUNCTION PIFILERECORDCOUNT.I INTEGER LIROW RETURNS INTEGER
#REM 86033 DEFINE PROCEDURE SET PIFILERECORDCOUNT.I INTEGER LIROW INTEGER VALUE
#REM 86038 DEFINE FUNCTION PITABLERECORDCOUNT.I INTEGER LIROW RETURNS INTEGER
#REM 86043 DEFINE PROCEDURE SET PITABLERECORDCOUNT.I INTEGER LIROW INTEGER VALUE
#REM 86048 DEFINE FUNCTION PBIMPORTFILEFOUND.I INTEGER LIROW RETURNS INTEGER
#REM 86053 DEFINE PROCEDURE SET PBIMPORTFILEFOUND.I INTEGER LIROW INTEGER VALUE
#REM 86058 DEFINE FUNCTION PICANOPEN.I INTEGER LIROW RETURNS INTEGER
#REM 86063 DEFINE PROCEDURE SET PICANOPEN.I INTEGER LIROW INTEGER VALUE
#REM 86068 DEFINE FUNCTION PSROOTOFROOT.I INTEGER LIROW RETURNS STRING
#REM 86073 DEFINE PROCEDURE SET PSROOTOFROOT.I INTEGER LIROW STRING VALUE
#REM 86078 DEFINE FUNCTION PSROOTNAME.I INTEGER LIROW RETURNS STRING
#REM 86083 DEFINE PROCEDURE SET PSROOTNAME.I INTEGER LIROW STRING VALUE
#REM 86088 DEFINE FUNCTION PIFILE.I INTEGER LIROW RETURNS INTEGER
#REM 86093 DEFINE PROCEDURE SET PIFILE.I INTEGER LIROW INTEGER VALUE
86099>>>>>
86099>>>>>  procedure DisplayStopMessage integer lbExport integer lbErase integer lbImport integer lbCancel
86102>>>>>    integer lbErrors liMax liRow
86102>>>>>    string lsValue
86102>>>>>    move 0 to lbErrors
86103>>>>>    get row_count to liMax
86104>>>>>    decrement liMax
86105>>>>>    for liRow from 0 to liMax
86111>>>>>>
86111>>>>>      if (piLoadErrors.i(self,liRow)) move 1 to lbErrors
86114>>>>>    loop
86115>>>>>>
86115>>>>>
86115>>>>>    if lbErrors begin
86117>>>>>      send obs "Errors occured during loading of data." "Check the *.err files in the dump/load folder."
86118>>>>>    end
86118>>>>>>
86118>>>>>    else begin
86119>>>>>      move "" to lsValue
86120>>>>>      if lbExport move (lsValue+" Dump ") to lsValue
86123>>>>>      if lbErase  move (lsValue+" Erase ") to lsValue
86126>>>>>      if lbImport move (lsValue+" Load ") to lsValue
86129>>>>>      move (trim(replaces("  ",lsValue,", "))+" performed successfully") to lsValue
86130>>>>>      send obs lsValue
86131>>>>>    end
86131>>>>>>
86131>>>>>  end_procedure
86132>>>>>
86132>>>>>  procedure DoFieldMapperDialog integer liRow
86135>>>>>    integer lhFdxFrom lhFdxTo liFile lhMap
86135>>>>>    get piFile.i liRow to liFile
86136>>>>>    get phFileFdx.i liRow to lhFdxFrom
86137>>>>>    get phTableFdx.i liRow to lhFdxTo
86138>>>>>    if (lhFdxFrom and lhFdxTo) begin
86140>>>>>      get phFieldMapper.i liRow to lhMap
86141>>>>>      get DoFdxFieldMapperDialog lhMap lhFdxFrom liFile lhFdxTo liFile to lhMap
86142>>>>>      set phFieldMapper.i liRow to lhMap
86143>>>>>    end
86143>>>>>>
86143>>>>>  end_procedure
86144>>>>>
86144>>>>>  // This function returns true if a manual mapping has been specified
86144>>>>>  function bMappingSpecified.i integer liRow returns integer
86147>>>>>    integer lhObj
86147>>>>>    get phFieldMapper.i liRow to lhObj
86148>>>>>    if lhObj function_return (item_count(lhObj))
86151>>>>>    function_return 0
86152>>>>>  end_function
86153>>>>>
86153>>>>>  // This function returns true if there is a a table FDX and a file FDX
86153>>>>>  function bCanMapFields integer liRow returns integer
86156>>>>>    integer lhFdxFrom lhFdxTo
86156>>>>>    get phFileFdx.i liRow to lhFdxFrom
86157>>>>>    get phTableFdx.i liRow to lhFdxTo
86158>>>>>    function_return (lhFdxFrom and lhFdxTo)
86159>>>>>  end_function
86160>>>>>
86160>>>>>  procedure Reset
86163>>>>>    integer liMax liRow lhObj
86163>>>>>    get row_count to liMax
86164>>>>>    decrement liMax
86165>>>>>    for liRow from 0 to liMax
86171>>>>>>
86171>>>>>      get phFileFdx.i liRow to lhObj
86172>>>>>      if lhObj begin
86174>>>>>        send Reset to lhObj
86175>>>>>        send request_destroy_object to lhObj
86176>>>>>      end
86176>>>>>>
86176>>>>>      get phTableFdx.i liRow to lhObj
86177>>>>>      if lhObj begin
86179>>>>>        send Reset to lhObj
86180>>>>>        send request_destroy_object to lhObj
86181>>>>>      end
86181>>>>>>
86181>>>>>      get phFieldMapper.i liRow to lhObj
86182>>>>>      if lhObj begin
86184>>>>>        send request_destroy_object to lhObj
86185>>>>>      end
86185>>>>>>
86185>>>>>    loop
86186>>>>>>
86186>>>>>    send delete_data
86187>>>>>  end_procedure
86188>>>>>
86188>>>>>  procedure Callback_Filelist_Entry integer liFile integer lbSelected integer lbShaded
86191>>>>>    integer liRow
86191>>>>>    if (lbSelected and not(lbShaded)) begin
86193>>>>>      get row_count to liRow
86194>>>>>      set piFile.i liRow to liFile
86195>>>>>    end
86195>>>>>>
86195>>>>>  end_procedure
86196>>>>>
86196>>>>>  procedure fill_array_using_object integer hObj
86199>>>>>    send Reset
86200>>>>>    send Callback_General to hObj msg_CallBack_Filelist_Entry self 1 0
86201>>>>>  end_procedure
86202>>>>>
86202>>>>>  procedure fill_array
86205>>>>>    integer lhLst
86205>>>>>    get DFMatrix_SelectorObject to lhLst
86206>>>>>    send fill_array_using_object lhLst
86207>>>>>  end_procedure
86208>>>>>
86208>>>>>  function sSequentialFileName.i integer liRow returns string
86211>>>>>    string lsFileName lsFolder
86211>>>>>    get psFolder of (DFM_IE_ControlBlock(self)) to lsFolder
86212>>>>>    get psRootOfRoot.i liRow to lsFileName
86213>>>>>    move ("Dfm-"+lsFileName) to lsFileName
86214>>>>>    get Files_AppendPath lsFolder lsFileName to lsFileName
86215>>>>>    function_return (lsFileName+".dmp")
86216>>>>>  end_function
86217>>>>>
86217>>>>>  function sErrorFileName.i integer liRow returns string
86220>>>>>    string lsErrorFile
86220>>>>>    get sSequentialFileName.i liRow to lsErrorFile
86221>>>>>    function_return (replace(".dmp",lsErrorFile,".err"))
86222>>>>>  end_function
86223>>>>>
86223>>>>>            function iDirectInput.s string lsFileName returns string
86226>>>>>              integer liChannel lbFound
86226>>>>>              get SEQ_DirectInput lsFileName to liChannel
86227>>>>>              if (liChannel>=0) begin
86229>>>>>                get SEQ_ReadLnUntilValue liChannel t.importexport.eoh to lbFound
86230>>>>>                if lbFound get SEQ_ReadLnUntilValue liChannel t.importexport.eo2h to lbFound
86233>>>>>              end
86233>>>>>>
86233>>>>>              else move 1 to lbFound
86235>>>>>              ifnot lbFound begin
86237>>>>>                send SEQ_CloseInput liChannel
86238>>>>>                move -2 to liChannel // -2 will signal that its not a compatible file
86239>>>>>              end
86239>>>>>>
86239>>>>>              function_return liChannel
86240>>>>>            end_function
86241>>>>>
86241>>>>>            object oCompareResult is a cDummyCompareResultReciever
86243>>>>>            end_object
86244>>>>>
86244>>>>>  procedure PrepareValidate
86247>>>>>    integer liRow liMax liFile lbImport lbExport lbCanOpen liCount liChannel lhTableFdx lhFileFdx
86247>>>>>    integer lhCompareResult
86247>>>>>    string lsRoot lsFolder lsFileName
86247>>>>>
86247>>>>>    get pbExport of (DFM_IE_ControlBlock(self)) to lbExport
86248>>>>>    get pbImport of (DFM_IE_ControlBlock(self)) to lbImport
86249>>>>>    get psFolder of (DFM_IE_ControlBlock(self)) to lsFolder
86250>>>>>
86250>>>>>    get row_count to liMax
86251>>>>>    decrement liMax
86252>>>>>    for liRow from 0 to liMax
86258>>>>>>
86258>>>>>      get piFile.i liRow to liFile
86259>>>>>
86259>>>>>      get API_AttrValue_FILELIST DF_FILE_ROOT_NAME liFile to lsRoot
86260>>>>>      set psRootName.i   liRow to lsRoot
86261>>>>>      get DBMS_StripPathAndDriver lsRoot to lsRoot
86262>>>>>      set PsRootOfRoot.i liRow to lsRoot
86263>>>>>
86263>>>>>      // Can we open the table?
86263>>>>>      get DBMS_OpenFile liFile DF_SHARE 0 to lbCanOpen
86264>>>>>      set piCanOpen.i liRow to lbCanOpen
86265>>>>>      if lbCanOpen begin
86267>>>>>        get API_AttrValue_FILE DF_FILE_RECORDS_USED liFile to liCount
86268>>>>>        set piTableRecordCount.i liRow to liCount
86269>>>>>
86269>>>>>        // Read FDX Object:
86269>>>>>        object oTableFDX is a cFdxFileDef
86271>>>>>          send Read_File_Definition.i liFile
86272>>>>>          move self to lhTableFdx
86273>>>>>        end_object
86274>>>>>        set phTableFdx.i liRow to lhTableFdx
86275>>>>>
86275>>>>>        close liFile
86276>>>>>
86276>>>>>        set pbImportFileFound.i liRow to (SEQ_FileExists(sSequentialFileName.i(self,liRow))=SEQIT_FILE)
86277>>>>>
86277>>>>>        if (pbImportFileFound.i(self,liRow) and lbImport) begin
86279>>>>>          // We must open the file and read the table definition and number
86279>>>>>          get sSequentialFileName.i liRow to lsFileName
86280>>>>>          get iDirectInput.s lsFileName to liChannel
86281>>>>>          if (liChannel>=0) begin
86283>>>>>            // Read FDX Object:
86283>>>>>            object oFileFDX is a cFdxFileDef
86285>>>>>              send Seq_Read liChannel
86286>>>>>              move self to lhFileFdx
86287>>>>>            end_object
86288>>>>>            send SEQ_CloseInput liChannel
86289>>>>>
86289>>>>>            // This handles the eventuality that the file number we wrote is
86289>>>>>            // different than the one we want to compare it to:
86289>>>>>            set piMainFile of lhFileFdx to liFile
86290>>>>>
86290>>>>>            set phFileFdx.i liRow to lhFileFdx
86291>>>>>            get FDX_AttrValue_FILE lhFileFdx DF_FILE_RECORDS_USED liFile to liCount
86292>>>>>            set piFileRecordCount.i liRow to liCount
86293>>>>>
86293>>>>>            // Now we will compare the FDX of the table and the file
86293>>>>>            move (oCompareResult(self)) to lhCompareResult
86294>>>>>            get iFdxCompareTables.iiiiii lhCompareResult lhTableFdx liFile lhFileFdx liFile FDXCOMP_MODE_ALL to lhCompareResult
86295>>>>>            set pbDefinitionMatch.i liRow to (not(piField_Sequence_Change(lhCompareResult)))
86296>>>>>
86296>>>>>          end
86296>>>>>>
86296>>>>>          else if (liChannel=-2) send obs "Not a compatible file!" lsFileName
86300>>>>>        end
86300>>>>>>
86300>>>>>      end
86300>>>>>>
86300>>>>>    loop
86301>>>>>>
86301>>>>>  end_procedure
86302>>>>>
86302>>>>>            object oErrorHandler is a cErrorHandlerRedirector NO_IMAGE
86304>>>>>              property string  psCurrentFile    public ""
86306>>>>>              property integer piCurrentChannel public 0
86308>>>>>              property integer piErrorCount     public 0
86310>>>>>              property integer pbPauseOnErrors  public 0
86312>>>>>              item_property_list
86312>>>>>                item_property integer piError.i     // DataFlex error number
86312>>>>>                item_property string  psErrorText.i // DataFlex error text
86312>>>>>                item_property integer piErrorLine.i // Line in DFMatrix program
86312>>>>>                item_property integer piLine.i      // While reading this line in the input file
86312>>>>>              end_item_property_list
#REM 86355 DEFINE FUNCTION PILINE.I INTEGER LIROW RETURNS INTEGER
#REM 86360 DEFINE PROCEDURE SET PILINE.I INTEGER LIROW INTEGER VALUE
#REM 86365 DEFINE FUNCTION PIERRORLINE.I INTEGER LIROW RETURNS INTEGER
#REM 86370 DEFINE PROCEDURE SET PIERRORLINE.I INTEGER LIROW INTEGER VALUE
#REM 86375 DEFINE FUNCTION PSERRORTEXT.I INTEGER LIROW RETURNS STRING
#REM 86380 DEFINE PROCEDURE SET PSERRORTEXT.I INTEGER LIROW STRING VALUE
#REM 86385 DEFINE FUNCTION PIERROR.I INTEGER LIROW RETURNS INTEGER
#REM 86390 DEFINE PROCEDURE SET PIERROR.I INTEGER LIROW INTEGER VALUE
86396>>>>>              procedure OnError integer liError string lsErrorText integer liErrorLine
86399>>>>>                integer liRow liLine
86399>>>>>                get row_count to liRow
86400>>>>>                set piErrorCount to (piErrorCount(self)+1)
86401>>>>>                if (liRow<100) begin // we only log the first 100 errors
86403>>>>>                  set piError.i     liRow to liError
86404>>>>>                  set psErrorText.i liRow to lsErrorText
86405>>>>>                  set piErrorLine.i liRow to liErrorLine
86406>>>>>                  get_channel_position (piCurrentChannel(self)) to liLine
86407>>>>>>
86407>>>>>                  set piLine.i liRow to liLine // Overload
86408>>>>>                end
86408>>>>>>
86408>>>>>                if (pbPauseOnErrors(self)) send Forward_Error_Report
86411>>>>>              end_procedure
86412>>>>>              procedure DoActivate
86415>>>>>                forward send DoActivate
86417>>>>>                set piErrorCount to 0
86418>>>>>              end_procedure
86419>>>>>              procedure DoDeactivate
86422>>>>>                integer liMax liRow
86422>>>>>                forward send DoDeactivate
86424>>>>>                // This piece of code translates the recorded channel-positions
86424>>>>>                // into real line numbers (according the the readln command).
86424>>>>>                send SEQ_DoChannelPositionsToLineCount_Reset
86425>>>>>                get row_count to liMax
86426>>>>>                decrement liMax
86427>>>>>                for liRow from 0 to liMax
86433>>>>>>
86433>>>>>                  send SEQ_DoChannelPositionsToLineCount_Add liRow (piLine.i(self,liRow))
86434>>>>>                loop
86435>>>>>>
86435>>>>>                send SEQ_DoChannelPositionsToLineCount_Resolve (psCurrentFile(self))
86436>>>>>                for liRow from 0 to liMax
86442>>>>>>
86442>>>>>                  set piLine.i liRow to (SEQ_DoChannelPositionsToLineCount(liRow))
86443>>>>>                loop
86444>>>>>>
86444>>>>>              end_procedure
86445>>>>>              procedure write_to_file integer liChannel
86448>>>>>                integer liMax liRow
86448>>>>>                string lsErrorLine
86448>>>>>                get row_count to liMax
86449>>>>>                decrement liMax
86450>>>>>                for liRow from 0 to liMax
86456>>>>>>
86456>>>>>                  move "Error # (#) while reading line # (#)" to lsErrorLine
86457>>>>>                  move (replace("#",lsErrorLine,piError.i(self,liRow))) to lsErrorLine
86458>>>>>                  move (replace("#",lsErrorLine,piErrorLine.i(self,liRow))) to lsErrorLine
86459>>>>>                  move (replace("#",lsErrorLine,piLine.i(self,liRow))) to lsErrorLine
86460>>>>>                  move (replace("#",lsErrorLine,psErrorText.i(self,liRow))) to lsErrorLine
86461>>>>>                  writeln channel liChannel lsErrorLine
86464>>>>>                loop
86465>>>>>>
86465>>>>>              end_procedure
86466>>>>>            end_object
86467>>>>>            object oStatusPanel is a StatusPanel
86469>>>>>            end_object
86470>>>>>
86470>>>>>  function WriteTableData integer liRow integer liChannel returns integer
86473>>>>>    integer lhFdx liFile lbFound
86473>>>>>    integer lhStatusPanel liCount liMax lbCancel
86473>>>>>    get object_id of oStatusPanel to lhStatusPanel
86474>>>>>    get phTableFdx.i liRow to lhFdx
86475>>>>>    send Seq_Write to lhFdx liChannel
86476>>>>>    get piFile.i liRow to liFile
86477>>>>>
86477>>>>>    move 0 to liCount
86478>>>>>    get piTableRecordCount.i liRow to liMax
86479>>>>>
86479>>>>>    clear liFile
86480>>>>>    repeat
86480>>>>>>
86480>>>>>      vfind liFile 0 gt // Find next
86482>>>>>      move (found) to lbFound
86483>>>>>      if lbFound begin
86485>>>>>        send SEQ_WriteRecordBuffer_LD liChannel liFile
86486>>>>>        writeln t.importexport.eor
86488>>>>>        increment liCount
86489>>>>>
86489>>>>>        if (mod(liCount,100)=0) set action_text of lhStatusPanel to (string(liCount)+"/"+string(liMax))
86492>>>>>        get Check_StatusPanel of lhStatusPanel to lbCancel
86493>>>>>        if lbCancel begin
86495>>>>>          send Stop_StatusPanel to lhStatusPanel
86496>>>>>          get MB_Verify ("Cancel dump at "+string(liCount)+"/"+string(liMax)+"?") 0 to lbCancel
86497>>>>>          if lbCancel move 0 to lbFound
86500>>>>>          else send Start_StatusPanel to lhStatusPanel
86502>>>>>        end
86502>>>>>>
86502>>>>>
86502>>>>>      end
86502>>>>>>
86502>>>>>    until (not(lbFound))
86504>>>>>    set action_text of lhStatusPanel to (string(liCount)+"/"+string(liMax))
86505>>>>>    function_return lbCancel
86506>>>>>  end_function
86507>>>>>
86507>>>>>            object oFieldValuesArray is a cArray NO_IMAGE
86509>>>>>            end_object
86510>>>>>
86510>>>>>  function ReadTableData integer liRow integer liChannel returns integer
86513>>>>>    integer lhFdx liFile lbSeqEof lhFieldValuesArray lhMap liFileField
86513>>>>>    integer liMax liItem liField liGrb
86513>>>>>    integer lhStatusPanel liCount liMaxRead lbCancel
86513>>>>>    string lsThrowAway
86513>>>>>
86513>>>>>    get phFileFdx.i liRow to lhFdx
86514>>>>>    ifnot lhFdx begin
86516>>>>>      object oFileFDX is a cFdxFileDef
86518>>>>>        move self to lhFdx
86519>>>>>      end_object
86520>>>>>      set phFileFdx.i liRow to lhFdx
86521>>>>>    end
86521>>>>>>
86521>>>>>
86521>>>>>    send Seq_Read to lhFdx liChannel // Skip through the header
86522>>>>>    get piFile.i liRow to liFile
86523>>>>>    get object_id of oStatusPanel to lhStatusPanel
86524>>>>>
86524>>>>>    move 0 to liCount
86525>>>>>    get piFileRecordCount.i liRow to liMaxRead
86526>>>>>
86526>>>>>    if (bMappingSpecified.i(self,liRow)) begin
86528>>>>>      move (oFieldValuesArray(self)) to lhFieldValuesArray
86529>>>>>      get phFieldMapper.i liRow to lhMap
86530>>>>>      get item_count of lhMap to liMax
86531>>>>>      decrement liMax
86532>>>>>      lock
86533>>>>>>
86533>>>>>        repeat
86533>>>>>>
86533>>>>>          clear liFile
86534>>>>>          // Read a record according to the FDX information in the header of the file (clever)
86534>>>>>          send FDX_ReadRecordBufferToArray_LD lhFdx liChannel liFile lhFieldValuesArray
86535>>>>>          move (seqeof) to lbSeqEof
86536>>>>>          ifnot lbSeqEof begin
86538>>>>>            for liFileField from 1 to liMax // Not recnum!
86544>>>>>>
86544>>>>>              get value of lhMap item liFileField to liField
86545>>>>>              if (liField>0) set_field_value liFile liField to (value(lhFieldValuesArray,liFileField))
86550>>>>>            loop
86551>>>>>>
86551>>>>>            saverecord liFile
86552>>>>>
86552>>>>>            increment liCount
86553>>>>>            if (mod(liCount,100)=0) set action_text of lhStatusPanel to (string(liCount)+"/"+string(liMaxRead))
86556>>>>>            get Check_StatusPanel of lhStatusPanel to lbCancel
86557>>>>>            if lbCancel begin
86559>>>>>              send Stop_StatusPanel to lhStatusPanel
86560>>>>>              get MB_Verify ("Cancel read at "+string(liCount)+"/"+string(liMaxRead)+"?") 0 to lbCancel
86561>>>>>              if lbCancel move 1 to lbSeqEof
86564>>>>>              else send Start_StatusPanel to lhStatusPanel
86566>>>>>            end
86566>>>>>>
86566>>>>>            readln channel liChannel lsThrowAway // Hopefully the t.importexport.eor tag
86568>>>>>            ifnot (lsThrowAway=t.importexport.eor) begin
86570>>>>>              error 812 "Record layout error"
86571>>>>>>
86571>>>>>              get SEQ_ReadLnUntilValue liChannel t.importexport.eor to liGrb
86572>>>>>            end
86572>>>>>>
86572>>>>>          end
86572>>>>>>
86572>>>>>        until lbSeqEof
86574>>>>>      unlock
86575>>>>>>
86575>>>>>    end
86575>>>>>>
86575>>>>>    else begin
86576>>>>>      lock
86577>>>>>>
86577>>>>>        repeat
86577>>>>>>
86577>>>>>          clear liFile
86578>>>>>          send SEQ_ReadRecordBuffer_LD liChannel liFile
86579>>>>>          move (seqeof) to lbSeqEof
86580>>>>>          ifnot lbSeqEof begin
86582>>>>>            saverecord liFile
86583>>>>>
86583>>>>>            increment liCount
86584>>>>>            if (mod(liCount,100)=0) set action_text of lhStatusPanel to (string(liCount)+"/"+string(liMaxRead))
86587>>>>>            get Check_StatusPanel of lhStatusPanel to lbCancel
86588>>>>>            if lbCancel begin
86590>>>>>              send Stop_StatusPanel to lhStatusPanel
86591>>>>>              get MB_Verify ("Cancel read at "+string(liCount)+"/"+string(liMaxRead)+"?") 0 to lbCancel
86592>>>>>              if lbCancel move 1 to lbSeqEof
86595>>>>>              else send Start_StatusPanel to lhStatusPanel
86597>>>>>            end
86597>>>>>>
86597>>>>>            readln channel liChannel lsThrowAway // Hopefully the t.importexport.eor tag
86599>>>>>            ifnot (lsThrowAway=t.importexport.eor) begin
86601>>>>>              error 813 "Record layout error"
86602>>>>>>
86602>>>>>              get SEQ_ReadLnUntilValue liChannel t.importexport.eor to liGrb
86603>>>>>            end
86603>>>>>>
86603>>>>>          end
86603>>>>>>
86603>>>>>        until lbSeqEof
86605>>>>>      unlock
86606>>>>>>
86606>>>>>    end
86606>>>>>>
86606>>>>>    set action_text of lhStatusPanel to (string(liCount)+"/"+string(liMaxRead))
86607>>>>>    function_return lbCancel
86608>>>>>  end_function
86609>>>>>
86609>>>>>            object oTablesOpenStatus is a cTablesOpenStatus
86611>>>>>            end_object
86612>>>>>
86612>>>>>  function OpenAllTablesExclusive returns integer
86615>>>>>    integer liMax liRow liFile lbRval
86615>>>>>    send reset to (oTablesOpenStatus(self))
86616>>>>>    get row_count to liMax
86617>>>>>    decrement liMax
86618>>>>>    for liRow from 0 to liMax
86624>>>>>>
86624>>>>>      get piFile.i liRow to liFile
86625>>>>>      send prepare_open to (oTablesOpenStatus(self)) liFile DF_EXCLUSIVE 0 ""
86626>>>>>    loop
86627>>>>>>
86627>>>>>    get iOpen_Prepared of (oTablesOpenStatus(self)) to lbRval // Returns the number of the first file it could not open
86628>>>>>    function_return (not(lbRval))
86629>>>>>  end_function
86630>>>>>
86630>>>>>  procedure Execute
86633>>>>>    integer liRow liMax liFile lbExport lbImport lbErase liChannel
86633>>>>>    integer liInteger1 liInteger2 liInteger3 liInteger4 lbOk lhStatusPanel lbCancel lbPauseOnErrors
86633>>>>>    integer lhErrorHandler
86633>>>>>    string lsFileName lsDisplayName lsErrorFile
86633>>>>>
86633>>>>>    move (oErrorHandler(self)) to lhErrorHandler
86634>>>>>
86634>>>>>    get pbExport of (DFM_IE_ControlBlock(self)) to lbExport
86635>>>>>    get pbImport of (DFM_IE_ControlBlock(self)) to lbImport
86636>>>>>    get pbErase  of (DFM_IE_ControlBlock(self)) to lbErase
86637>>>>>    get pbPauseOnErrors of (DFM_IE_ControlBlock(self)) to lbPauseOnErrors
86638>>>>>
86638>>>>>    get_attribute DF_DATE_FORMAT to liInteger1
86641>>>>>    get_attribute DF_DATE_SEPARATOR to liInteger2
86644>>>>>    get_attribute DF_DECIMAL_SEPARATOR to liInteger3
86647>>>>>    get_date_attribute DATE4_STATE to liInteger4
86648>>>>>    set_attribute DF_DATE_FORMAT to DF_DATE_EUROPEAN
86651>>>>>    set_attribute DF_DATE_SEPARATOR to 45     // -
86654>>>>>    set_attribute DF_DECIMAL_SEPARATOR to 46  // .
86657>>>>>    set_date_attribute DATE4_STATE to 0
86658>>>>>
86658>>>>>
86658>>>>>    if lbErase get OpenAllTablesExclusive to lbOk
86661>>>>>    else move 1 to lbOk
86663>>>>>
86663>>>>>    if lbOk begin
86665>>>>>
86665>>>>>      get object_id of oStatusPanel to lhStatusPanel
86666>>>>>      send Initialize_StatusPanel to lhStatusPanel "Status" "" ""
86667>>>>>      send Start_StatusPanel to lhStatusPanel
86668>>>>>      move 0 to lbCancel
86669>>>>>
86669>>>>>      get row_count to liMax
86670>>>>>      decrement liMax
86671>>>>>      for liRow from 0 to liMax
86677>>>>>>
86677>>>>>        set piLoadErrors.i liRow to 0
86678>>>>>      loop
86679>>>>>>
86679>>>>>      for liRow from 0 to liMax
86685>>>>>>
86685>>>>>        get piFile.i liRow to liFile
86686>>>>>        get psRootOfRoot.i liRow to lsDisplayName
86687>>>>>
86687>>>>>        ifnot lbErase get DBMS_OpenFile liFile DF_SHARE 0 to lbOk
86690>>>>>        else move 1 to lbOk
86692>>>>>
86692>>>>>        if lbOk begin
86694>>>>>          get sSequentialFileName.i liRow to lsFileName
86695>>>>>          ifnot lbCancel begin
86697>>>>>            if lbExport begin
86699>>>>>              set title_text of lhStatusPanel to ("Dumping "+lsDisplayName)
86700>>>>>              set action_text of lhStatusPanel to ""
86701>>>>>              get SEQ_DirectOutput lsFileName to liChannel
86702>>>>>              if (liChannel>=0) begin
86704>>>>>                writeln channel liChannel t.importexport.eoh
86707>>>>>                writeln channel liChannel t.importexport.eo2h
86710>>>>>                get WriteTableData liRow liChannel to lbCancel
86711>>>>>                send SEQ_CloseOutput liChannel
86712>>>>>              end
86712>>>>>>
86712>>>>>            end
86712>>>>>>
86712>>>>>          end
86712>>>>>>
86712>>>>>          ifnot lbCancel begin
86714>>>>>            if lbErase begin
86716>>>>>              set title_text of lhStatusPanel to ("Erasing "+lsDisplayName)
86717>>>>>              set action_text of lhStatusPanel to ""
86718>>>>>              zerofile liFile
86719>>>>>            end
86719>>>>>>
86719>>>>>          end
86719>>>>>>
86719>>>>>          ifnot lbCancel begin
86721>>>>>            if lbImport begin
86723>>>>>              set title_text of lhStatusPanel to ("Loading "+lsDisplayName)
86724>>>>>              set action_text of lhStatusPanel to ""
86725>>>>>              get iDirectInput.s lsFileName to liChannel
86726>>>>>              if (liChannel>=0) begin
86728>>>>>                set psCurrentFile    of lhErrorHandler to lsFileName
86729>>>>>                set piCurrentChannel of lhErrorHandler to liChannel
86730>>>>>                set pbPauseOnErrors  of lhErrorHandler to lbPauseOnErrors
86731>>>>>
86731>>>>>                send Delete_data of lhErrorHandler
86732>>>>>                send DoActivate  of lhErrorHandler
86733>>>>>
86733>>>>>                get ReadTableData liRow liChannel to lbCancel
86734>>>>>                send DoDeActivate  of lhErrorHandler
86735>>>>>
86735>>>>>                send SEQ_CloseInput liChannel
86736>>>>>
86736>>>>>                set piLoadErrors.i liRow to (piErrorCount(lhErrorHandler))
86737>>>>>
86737>>>>>                if (piErrorCount(lhErrorHandler)) begin // If there were errors: write the file
86739>>>>>                  get sErrorFileName.i liRow to lsErrorFile
86740>>>>>                  get SEQ_DirectOutput lsErrorFile to liChannel
86741>>>>>                  if (liChannel>=0) begin
86743>>>>>                    send write_to_file to lhErrorHandler liChannel
86744>>>>>                    send SEQ_CloseOutput liChannel
86745>>>>>                  end
86745>>>>>>
86745>>>>>                end
86745>>>>>>
86745>>>>>              end
86745>>>>>>
86745>>>>>              else if (liChannel=-2) send obs "Not a compatible file!" lsFileName
86749>>>>>            end
86749>>>>>>
86749>>>>>          end
86749>>>>>>
86749>>>>>          close liFile
86750>>>>>        end
86750>>>>>>
86750>>>>>      loop
86751>>>>>>
86751>>>>>      ifnot lbCancel send Stop_StatusPanel to lhStatusPanel
86754>>>>>      send DisplayStopMessage lbExport lbErase lbImport lbCancel
86755>>>>>    end
86755>>>>>>
86755>>>>>    else send obs "Exclusive access could not be obtained"
86757>>>>>
86757>>>>>    set_attribute DF_DATE_FORMAT to liInteger1
86760>>>>>    set_attribute DF_DATE_SEPARATOR to liInteger2
86763>>>>>    set_attribute DF_DECIMAL_SEPARATOR to liInteger3
86766>>>>>    set_date_attribute DATE4_STATE to liInteger4
86767>>>>>  end_procedure
86768>>>>>
86768>>>>>end_object // DFM_IE_WorkHorse
86769>>>>>
86769>>>>>// Fill array and return number of tables
86769>>>>>function DFM_IE_GetListOfFiles global returns integer
86771>>>>>  integer lbRval
86771>>>>>  send fill_array to (DFM_IE_WorkHorse(self))
86772>>>>>  get row_count of (DFM_IE_WorkHorse(self)) to lbRval
86773>>>>>  function_return lbRval
86774>>>>>end_function
86775>>>>>
86775>>>>>// Validate
86775>>>>>procedure DFM_IE_ValidateFunction global
86777>>>>>  send PrepareValidate to (DFM_IE_WorkHorse(self))
86778>>>>>end_procedure
86779>>>>>
86779>>>>>procedure DFM_IE_ExecuteFunctions global
86781>>>>>  send Execute to (DFM_IE_WorkHorse(self))
86782>>>>>end_procedure
86783>>>
/DFM.IMPORTEXPORTCONFIRMDESCRIPTION
Image 22, DFM.IMPORTEXPORTCONFIRMDESCRIPTION
The tables in the list below will be processed. If a table displays "Map fields" in the status column it means that you are about to import data to a table that are not compatible in terms of columns sequence. You must then point to the table and click the "Map fields" button. You can not confirm the operation until all tables have a "Ready" in the status column.
/*
86783>>>
86783>>>
86783>>>object oDFM_ImportExport_Confirm is a aps.ModalPanel label "Dump/LoadData - Confirm"
86786>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
86787>>>  property integer piResult
86789>>>  on_key ksave_record send close_panel_ok
86790>>>  on_key kcancel send close_panel
86791>>>  property integer pbNoShowStoppers
86793>>>  object oEdit is a aps.YellowBox
86795>>>    set peAnchors to (anTop+anLeft+anRight)
86796>>>    set size to 30 415
86797>>>    set piTextSourceImage to DFM.ImportExportConfirmDescription.N
86798>>>  end_object
86799>>>  send aps_goto_max_row
86800>>>  object oGrid is a aps.Grid
86802>>>    set peAnchors to (anTop+anLeft+anRight+anBottom)
86803>>>    set peResizeColumn to rcAll
86804>>>    set size to 100 0
86805>>>    send GridPrepare_AddColumn "#"            AFT_NUMERIC4.0
86806>>>    send GridPrepare_AddColumn "Table"        AFT_ASCII12
86807>>>    send GridPrepare_AddColumn "Display name" AFT_ASCII32
86808>>>    send GridPrepare_AddColumn "Recs table"   AFT_NUMERIC8.0
86809>>>    send GridPrepare_AddColumn "Recs in file" AFT_NUMERIC8.0
86810>>>    send GridPrepare_AddColumn "Status"       AFT_ASCII10
86811>>>    send GridPrepare_Apply self
86812>>>    set select_mode to NO_SELECT
86813>>>
86813>>>    procedure row_change integer liRowFrom integer liRowTo
86816>>>      if (item_count(self)) send NowOnRow liRowTo
86819>>>    end_procedure
86820>>>    procedure item_change integer liItm1 integer liItm2 returns integer
86823>>>      integer liRval liColumns
86823>>>      get Grid_Columns self to liColumns
86824>>>      forward get msg_item_change liItm1 liItm2 to liRval
86826>>>      if (liItm1/liColumns) ne (liItm2/liColumns) send row_change (liItm1/liColumns) (liItm2/liColumns)
86829>>>      procedure_return liRval
86830>>>    end_procedure
86831>>>
86831>>>    function sStatusText.i integer liRow returns string
86834>>>      integer lhControl lbExport lbErase lbImport lbMappingSpecified lhArr
86834>>>      string lsStatus
86834>>>      get object_id of DFM_IE_ControlBlock to lhControl
86835>>>      get pbExport of lhControl to lbExport
86836>>>      get pbErase  of lhControl to lbErase
86837>>>      get pbImport of lhControl to lbImport
86838>>>
86838>>>      get object_id of DFM_IE_WorkHorse to lhArr
86839>>>      if (piCanOpen.i(lhArr,liRow)) begin
86841>>>        if lbImport begin
86843>>>          get bMappingSpecified.i of lhArr liRow to lbMappingSpecified
86844>>>          if lbExport move "Ready" to lsStatus
86847>>>          else begin
86848>>>            ifnot (pbImportFileFound.i(lhArr,liRow)) move "No file" to lsStatus
86851>>>            else if (pbDefinitionMatch.i(lhArr,liRow)) move "Ready" to lsStatus
86855>>>            else begin
86856>>>              if lbMappingSpecified move "Ready" to lsStatus
86859>>>              else move "Map fields" to lsStatus
86861>>>            end
86861>>>>
86861>>>          end
86861>>>>
86861>>>        end
86861>>>>
86861>>>        else move "Ready" to lsStatus
86863>>>        if lbMappingSpecified move (lsStatus+" (M)") to lsStatus
86866>>>      end
86866>>>>
86866>>>      else move "No table" to lsStatus
86868>>>      function_return lsStatus
86869>>>    end_function
86870>>>
86870>>>    procedure fill_list
86873>>>      integer lhControl lbExport lbErase lbImport
86873>>>      integer lhArr liMax liRow liBase liFile lbMappingSpecified
86873>>>      string lsDisplayName lsStatus
86873>>>
86873>>>      get object_id of DFM_IE_ControlBlock to lhControl
86874>>>      get pbExport of lhControl to lbExport
86875>>>      get pbErase  of lhControl to lbErase
86876>>>      get pbImport of lhControl to lbImport
86877>>>
86877>>>      set dynamic_update_state to DFFALSE
86878>>>      send delete_data
86879>>>      get object_id of DFM_IE_WorkHorse to lhArr
86880>>>      get row_count of lhArr to liMax
86881>>>      decrement liMax
86882>>>      for liRow from 0 to liMax
86888>>>>
86888>>>        get item_count to liBase
86889>>>
86889>>>        get piFile.i of lhArr liRow to liFile
86890>>>        get API_AttrValue_FILELIST DF_FILE_DISPLAY_NAME liFile to lsDisplayName
86891>>>
86891>>>        send add_item MSG_NONE liFile
86892>>>        set aux_value item liBase to liRow
86893>>>
86893>>>        send add_item MSG_NONE (psRootOfRoot.i(lhArr,liRow))
86894>>>        send add_item MSG_NONE lsDisplayName
86895>>>
86895>>>        if (piCanOpen.i(lhArr,liRow)) begin
86897>>>
86897>>>          send add_item MSG_NONE (piTableRecordCount.i(lhArr,liRow))
86898>>>          if lbImport begin
86900>>>            if lbExport send add_item MSG_NONE (piTableRecordCount.i(lhArr,liRow))
86903>>>            else        send add_item MSG_NONE (piFileRecordCount.i(lhArr,liRow))
86905>>>          end
86905>>>>
86905>>>          else send add_item MSG_NONE ""
86907>>>
86907>>>          if lbImport begin
86909>>>            if lbExport move "Ready" to lsStatus
86912>>>            else begin
86913>>>              ifnot (pbImportFileFound.i(lhArr,liRow)) begin
86915>>>                move "No file" to lsStatus
86916>>>                set pbNoShowStoppers to false
86917>>>              end
86917>>>>
86917>>>              else if (pbDefinitionMatch.i(lhArr,liRow)) move "Ready" to lsStatus
86921>>>              else begin
86922>>>                get bMappingSpecified.i of lhArr liRow to lbMappingSpecified
86923>>>                if lbMappingSpecified move "Ready" to lsStatus
86926>>>                else move "Map fields" to lsStatus
86928>>>              end
86928>>>>
86928>>>            end
86928>>>>
86928>>>          end
86928>>>>
86928>>>          else move "Ready" to lsStatus
86930>>>          send add_item MSG_NONE (sStatusText.i(self,liRow)) //lsStatus
86931>>>        end
86931>>>>
86931>>>        else begin
86932>>>          send add_item MSG_NONE "" // Reccount 1
86933>>>          send add_item MSG_NONE "" // Reccount 2
86934>>>          send add_item MSG_NONE "No table"
86935>>>          set pbNoShowStoppers to false
86936>>>        end
86936>>>>
86936>>>      loop
86937>>>>
86937>>>      send Grid_SetEntryState self DFFALSE
86938>>>      set dynamic_update_state to DFTRUE
86939>>>    end_procedure
86940>>>
86940>>>    procedure DoFieldMapping
86943>>>      integer lhArr liRow liBase
86943>>>      get Grid_BaseItem self to liBase
86944>>>      get aux_value item liBase to liRow
86945>>>      get object_id of DFM_IE_WorkHorse to lhArr
86946>>>      send DoFieldMapperDialog of lhArr liRow
86947>>>      set value item (liBase+5) to (sStatusText.i(self,liRow))
86948>>>    end_procedure
86949>>>
86949>>>  end_object
86950>>>  procedure close_panel_ok
86953>>>    set piResult to true
86954>>>    send close_panel
86955>>>  end_procedure
86956>>>  object oBtn1 is a aps.Multi_Button
86958>>>    on_item "OK" send close_panel_ok
86959>>>    set peAnchors to (anBottom+anRight)
86960>>>  end_object
86961>>>  object oMapFieldsBtn is a aps.Multi_Button
86963>>>    on_item "Map fields" send DoFieldMapping of oGrid
86964>>>    set peAnchors to (anBottom+anRight)
86965>>>  end_object
86966>>>  object oBtn3 is a aps.Multi_Button
86968>>>    on_item "Cancel" send close_panel
86969>>>    set peAnchors to (anBottom+anRight)
86970>>>  end_object
86971>>>
86971>>>  procedure NowOnRow integer liRow
86974>>>    integer lbOkToMap
86974>>>    get bCanMapFields of DFM_IE_WorkHorse liRow to lbOkToMap
86975>>>    set enabled_state of oMapFieldsBtn to lbOkToMap
86976>>>  end_procedure
86977>>>
86977>>>  send aps_locate_multi_buttons
86978>>>  function iPopup returns integer
86981>>>    integer lhControl lbExport lbErase lbImport
86981>>>    string lsLabel
86981>>>    get object_id of DFM_IE_ControlBlock to lhControl
86982>>>    get pbExport of lhControl to lbExport
86983>>>    get pbErase  of lhControl to lbErase
86984>>>    get pbImport of lhControl to lbImport
86985>>>
86985>>>    move "" to lsLabel
86986>>>    if lbExport move (lsLabel+" Dump ") to lsLabel
86989>>>    if lbErase  move (lsLabel+" Erase ") to lsLabel
86992>>>    if lbImport move (lsLabel+" Load ") to lsLabel
86995>>>    move ("Confirm "+trim(replaces("  ",lsLabel,", "))) to lsLabel
86996>>>    set label to lsLabel
86997>>>
86997>>>    set piResult to false
86998>>>    set pbNoShowStoppers to true
86999>>>    send fill_list of oGrid
87000>>>    send NowOnRow 0
87001>>>    set enabled_state of oBtn1 to (pbNoShowStoppers(self))
87002>>>//    set enabled_state of oBtn2 to lbImport
87002>>>
87002>>>    send popup
87003>>>    function_return (piResult(self))
87004>>>  end_procedure
87005>>>end_object // oDFM_ImportExport_Confirm
87006>>>send aps_SetMinimumDialogSize (oDFM_ImportExport_Confirm(self))
87007>>>
/DFM.IMPORTEXPORTDESCRIPTION
Image 23, DFM.IMPORTEXPORTDESCRIPTION
This function lets you dump, erase or load table data as selected in the table selector. You may perform more functions in one go.
When dumping data a copy of the table definition is stored as part of the header of the ascii file. This is used for reference when the file is later loaded. Tables remain locked during load.
/*
87007>>>
87007>>>activate_view Activate_ImportExport_View for oDFM_ImportExport_View
87012>>>object oDFM_ImportExport_View is a aps.View label "Dump/Load Data"
87015>>>  on_key kcancel send close_panel
87016>>>  on_key ksave_record send DoRun
87017>>>  property integer piResult public DFFALSE
87019>>>  object oEdit is a aps.YellowBox
87021>>>    set peAnchors to (anTop+anLeft+anRight+anBottom)
87022>>>    set size to 45 310
87023>>>    set piTextSourceImage to DFM.ImportExportDescription.N
87024>>>  end_object
87025>>>  send aps_goto_max_row
87026>>>  send aps_make_row_space 5
87027>>>  send tab_column_define 1 20 15 JMODE_LEFT // Default column setting
87028>>>  set p_auto_column to 1
87029>>>  object oExportCb is a aps.CheckBox label "Dump table data to files named implicitly as the tables themselves (but with ext. 'dmp')"
87032>>>    procedure OnChange
87035>>>      send UpdateShadowStates
87036>>>    end_procedure
87037>>>  end_object
87038>>>  object oEraseCb is a aps.CheckBox label "Erase data from the table (requires exclusive access to the tables)"
87041>>>    procedure OnChange
87044>>>      send UpdateShadowStates
87045>>>    end_procedure
87046>>>  end_object
87047>>>  object oImportCb is a aps.CheckBox label "Load table data (if formats are not compatible you will be prompted to map the fields)"
87050>>>    procedure OnChange
87053>>>      send UpdateShadowStates
87054>>>    end_procedure
87055>>>  end_object
87056>>>  send aps_goto_max_row
87057>>>  send aps_make_row_space 5
87058>>>  object oPauseOnErrorsCb is a aps.CheckBox label "Pause on errors (when loading data)"
87061>>>  end_object
87062>>>  set p_auto_column to 0
87063>>>  send aps_goto_max_row
87064>>>  send aps_make_row_space 5
87065>>>  object oDirectory is a aps.SelectDirForm label "Use this folder for dump/load files:" abstract AFT_ASCII255
87069>>>    set p_extra_internal_width to -1080
87070>>>  end_object
87071>>>
87071>>>  procedure DoRun
87074>>>    integer lhControl lbContinue
87074>>>    integer lbExport lbErase lbImport liCreate liError
87074>>>    string lsFolder
87074>>>    get checked_state of oExportCb to lbExport
87075>>>    get checked_state of oEraseCb  to lbErase
87076>>>    get checked_state of oImportCb to lbImport
87077>>>    get value of oDirectory to lsFolder
87078>>>
87078>>>    if (DFM_IE_GetListOfFiles()) begin
87080>>>      if (lbExport or lbErase or lbImport) begin
87082>>>        if (lbImport and not(lbExport)) get SEQ_ValidateFolder lsFolder VALIDFOLDER_CREATE_FALSE 0 to liError
87085>>>        if lbExport get SEQ_ValidateFolder lsFolder VALIDFOLDER_CREATE_PROMPT 0 to liError
87088>>>
87088>>>        ifnot liError begin
87090>>>          get object_id of DFM_IE_ControlBlock to lhControl
87091>>>          set pbExport of lhControl to lbExport
87092>>>          set pbErase  of lhControl to lbErase
87093>>>          set pbImport of lhControl to lbImport
87094>>>          set psFolder of lhControl to lsFolder
87095>>>
87095>>>          send cursor_wait to (cursor_control(self))
87096>>>          send DFM_IE_ValidateFunction
87097>>>          send cursor_ready to (cursor_control(self))
87098>>>
87098>>>          get iPopup of oDFM_ImportExport_Confirm to lbContinue
87099>>>          if lbContinue begin
87101>>>            send close_panel
87102>>>            send DFM_IE_ExecuteFunctions
87103>>>          end
87103>>>>
87103>>>        end
87103>>>>
87103>>>      end
87103>>>>
87103>>>      else send obs "No functions selected"
87105>>>    end
87105>>>>
87105>>>    else send obs "No tables selected"
87107>>>  end_procedure
87108>>>
87108>>>  procedure UpdateShadowStates
87111>>>    integer lbExport lbErase lbImport
87111>>>    get checked_state of oExportCb to lbExport
87112>>>    get checked_state of oEraseCb  to lbErase
87113>>>    get checked_state of oImportCb to lbImport
87114>>>    set enabled_state of oDirectory to (lbExport or lbImport)
87115>>>    set enabled_state of oPauseOnErrorsCb to lbImport
87116>>>  end_procedure
87117>>>
87117>>>  object oBtn1 is a aps.Multi_Button
87119>>>    on_item "OK" send DoRun
87120>>>    set peAnchors to (anBottom+anRight)
87121>>>  end_object
87122>>>  object oBtn2 is a aps.Multi_Button
87124>>>    on_item "Cancel" send close_panel
87125>>>    set peAnchors to (anBottom+anRight)
87126>>>  end_object
87127>>>  send aps_locate_multi_buttons
87128>>>
87128>>>  procedure OnChangeFDX_Broadcasted // Sent by DFM
87131>>>    set delegation_mode to DELEGATE_TO_PARENT
87132>>>    send close_panel
87133>>>  end_procedure
87134>>>  procedure Close_Query_View // Sent by FastView
87137>>>    set delegation_mode to DELEGATE_TO_PARENT
87138>>>    send close_panel
87139>>>  end_procedure
87140>>>
87140>>>  procedure popup
87143>>>    integer lhControl
87143>>>    if (DFMatrix_RealData_Check()) begin
87145>>>      get object_id of DFM_IE_ControlBlock to lhControl
87146>>>      ifnot (active_state(self)) begin
87148>>>        set checked_state of oExportCb to (pbExport(lhControl))
87149>>>        set checked_state of oEraseCb  to (pbErase(lhControl))
87150>>>        set checked_state of oImportCb to (pbImport(lhControl))
87151>>>        set value of oDirectory        to (psFolder(lhControl))
87152>>>      end
87152>>>>
87152>>>      send UpdateShadowStates
87153>>>      forward send popup
87155>>>    end
87155>>>>
87155>>>  end_procedure
87156>>>end_object // oDFM_ImportExport_View
87157>>>//send popup of oDFM_ImportExport_View
87157>>>
87157>    Use CompareTables.vw // Compare table data
Including file: comparetables.vw    (C:\Apps\VDFQuery\AppSrc\comparetables.vw)
87157>>>// Use CompareTables.vw // Compare table data
87157>>>Use Aps
87157>>>Use CompareTables.nui // cCompareTableData class
Including file: comparetables.nui    (C:\Apps\VDFQuery\AppSrc\comparetables.nui)
87157>>>>>// Use CompareTables.nui // cCompareTableData class
87157>>>>>
87157>>>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
87157>>>>>Use FdxCompa.nui // Class for comparing table definitions
87157>>>>>Use Compare.nui  // Abstract class for comparing item based information
87157>>>>>Use ApiIndex.nui // Switch indices offline and back online
Including file: apiindex.nui    (C:\Apps\VDFQuery\AppSrc\apiindex.nui)
87157>>>>>>>// Use ApiIndex.nui // Switch indices offline and back online
87157>>>>>>>// Part of VDFQuery by Sture ApS
87157>>>>>>>
87157>>>>>>>//> pkgdoc.begin
87157>>>>>>>//> This package may be used if you want to temporarily switch on-line indices on DF tables off-line.
87157>>>>>>>//> This may used to speed up importing records to a table when you are sure that there will be no
87157>>>>>>>//> duplicate records.
87157>>>>>>>//>
87157>>>>>>>//> For all methods in this package it is true that the table should be opened prior to calling the method.
87157>>>>>>>//> pkgdoc.end
87157>>>>>>>
87157>>>>>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
87157>>>>>>>Use FdxIndex.nui // Index analysing functions
87157>>>>>>>Use FdxField.nui
87157>>>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
87157>>>>>>>
87157>>>>>>>//> Rebuild all off-line index files on file.
87157>>>>>>>procedure DoReindexOfflineIndices global integer liFile
87159>>>>>>>  sort liFile (FDX_SetOfIndices(0,liFile,DF_INDEX_TYPE_BATCH))
87161>>>>>>>end_procedure
87162>>>>>>>
87162>>>>>>>//> Rebuild all on-line index files on file.
87162>>>>>>>procedure DoReindexOnlineIndices global integer liFile
87164>>>>>>>  sort liFile (FDX_SetOfIndices(0,liFile,DF_INDEX_TYPE_ONLINE))
87166>>>>>>>end_procedure
87167>>>>>>>
87167>>>>>>>//> Call this function to switch all on-line indices for a table to off-line. The function returns
87167>>>>>>>//> the set of indices that were switched off-line. The return value should be used when calling the
87167>>>>>>>//> DoSwitchIndicesOnline procedure below.
87167>>>>>>>function DoSwitchIndicesOffLine global integer liFile returns string
87169>>>>>>>  integer liType liItm liMax liIndex liReopenFile liOpenMode liOpen
87169>>>>>>>  string lsRval lsReopenRootName
87169>>>>>>>  move "" to lsRval
87170>>>>>>>
87170>>>>>>>  get DBMS_FileDriverType liFile to liType
87171>>>>>>>  if (liType=DBMS_DRIVER_DATAFLEX) begin
87173>>>>>>>    move liFile to liReopenFile
87174>>>>>>>    get_attribute DF_FILE_PHYSICAL_NAME of liFile to lsReopenRootName
87177>>>>>>>    get_attribute DF_FILE_OPEN_MODE     of liFile to liOpenMode
87180>>>>>>>    get FDX_SetOfIndices 0 liFile DF_INDEX_TYPE_ONLINE to lsRval
87181>>>>>>>    get HowManyIntegers lsRval to liMax
87182>>>>>>>    structure_start liFile
87183>>>>>>>    for liItm from 1 to liMax
87189>>>>>>>>
87189>>>>>>>      get ExtractInteger lsRval liItm to liIndex
87190>>>>>>>      set_attribute DF_INDEX_TYPE Of liFile liIndex To DF_INDEX_TYPE_BATCH
87193>>>>>>>    loop
87194>>>>>>>>
87194>>>>>>>    structure_end liFile DF_STRUCTEND_OPT_NONE
87196>>>>>>>    close liReopenFile
87197>>>>>>>    move (DBMS_OpenFileAs(lsReopenRootName,liReopenFile,liOpenMode,0)) to liOpen
87198>>>>>>>    ifnot liOpen error 721 "Table could not be opened after switching indices offline"
87201>>>>>>>  end
87201>>>>>>>>
87201>>>>>>>  function_return lsRval
87202>>>>>>>end_function
87203>>>>>>>
87203>>>>>>>//> Call this procedure to switch indices back online. The lsIndices parameter
87203>>>>>>>//> should be given the value the DoSwitchIndicesOffLine returned prior to calling
87203>>>>>>>//> this procedure.
87203>>>>>>>procedure DoSwitchIndicesOnline global integer liFile string lsIndices
87205>>>>>>>  integer liType liItm liMax liIndex liReopenFile liOpenMode liOpen
87205>>>>>>>  string lsRval lsReopenRootName
87205>>>>>>>  get DBMS_FileDriverType liFile to liType
87206>>>>>>>  if (liType=DBMS_DRIVER_DATAFLEX) begin
87208>>>>>>>    move liFile to liReopenFile
87209>>>>>>>    get_attribute DF_FILE_PHYSICAL_NAME of liFile to lsReopenRootName
87212>>>>>>>    get_attribute DF_FILE_OPEN_MODE     of liFile to liOpenMode
87215>>>>>>>    get HowManyIntegers lsIndices to liMax
87216>>>>>>>    structure_start liFile
87217>>>>>>>    for liItm from 1 to liMax
87223>>>>>>>>
87223>>>>>>>      get ExtractInteger lsIndices liItm to liIndex
87224>>>>>>>      set_attribute DF_INDEX_TYPE Of liFile liIndex To DF_INDEX_TYPE_ONLINE
87227>>>>>>>    loop
87228>>>>>>>>
87228>>>>>>>    structure_end liFile DF_STRUCTEND_OPT_NONE
87230>>>>>>>    close liReopenFile
87231>>>>>>>    move (DBMS_OpenFileAs(lsReopenRootName,liReopenFile,liOpenMode,0)) to liOpen
87232>>>>>>>    ifnot liOpen error 722 "Table could not be opened after switching indices online"
87235>>>>>>>  end
87235>>>>>>>>
87235>>>>>>>end_procedure
87236>>>>>>>
87236>>>>>>>
87236>>>>>>>//> Returns the concatenated values of the fields in sFields parameter
87236>>>>>>>//> separated by space characters. Overlap fields are ignored. (and so
87236>>>>>>>//> are Text and Binary fields)
87236>>>>>>>function API_FieldValues global integer liFile string lsFields returns string
87238>>>>>>>  integer liMaxPos liField liPos liType liLen liDec
87238>>>>>>>  string lsRval lsFieldValue
87238>>>>>>>  move "" to lsRval
87239>>>>>>>  move (length(lsFields)+3/4) to liMaxPos
87240>>>>>>>  for liPos from 1 to liMaxPos
87246>>>>>>>>
87246>>>>>>>    move (mid(lsFields,4,liPos-1*4+1)) to liField
87247>>>>>>>
87247>>>>>>>//  move (integer(FDX_AttrValue_FIELD(oFDX#,DF_FIELD_TYPE,liFile,liField))) to liType
87247>>>>>>>    get_attribute DF_FIELD_TYPE of liFile liField to liType
87250>>>>>>>
87250>>>>>>>    get_field_value liFile liField to lsFieldValue
87253>>>>>>>    if liType eq DF_ASCII move (lsRval+rtrim(lsFieldValue)) to lsRval
87256>>>>>>>    if liType eq DF_BCD begin
87258>>>>>>>      get_attribute DF_FIELD_LENGTH of liFile liField to liLen
87261>>>>>>>      get_attribute DF_FIELD_PRECISION of liFile liField to liDec
87264>>>>>>>      if liDec increment liLen // Make room for comma
87267>>>>>>>      move (lsRval+NumToStrR(lsFieldValue,liDec,liLen)) to lsRval
87268>>>>>>>    end
87268>>>>>>>>
87268>>>>>>>    if liType eq DF_DATE move (lsRval+IntToStrR(DateToInteger(lsFieldValue),8)) to lsRval
87271>>>>>>>    if liPos ne liMaxPos move (lsRval+" ") to lsRval
87274>>>>>>>  loop
87275>>>>>>>>
87275>>>>>>>  function_return lsRval
87276>>>>>>>end_function
87277>>>>>>>
87277>>>>>>>function API_IndexValue global integer liFile integer liIndex returns string
87279>>>>>>>  string lsFields lsValue
87279>>>>>>>  get FDX_IndexAsFields 0 liFile liIndex to lsFields
87280>>>>>>>  get FDX_FieldsTranslateOverlaps 0 liFile lsFields to lsFields
87281>>>>>>>  get API_FieldValues liFile lsFields to lsValue
87282>>>>>>>  function_return lsValue
87283>>>>>>>end_function
87284>>>>>USe FList.nui    // A lot of FLIST procedures and functions
87284>>>>>
87284>>>>>class cCompareTableDataHelp is a cDoubleOrderedCompare
87285>>>>>  //> Augment this function in order to seed the left buffer (1). Return true
87285>>>>>  //> if the seeding was succesful. For example:
87285>>>>>  function iSeed1 returns integer
87287>>>>>    integer liTable
87287>>>>>    get piTable1 to liTable
87288>>>>>    clear liTable
87289>>>>>    function_return TRUE
87290>>>>>  end_function
87291>>>>>  //> Augment this function in order to seed the right buffer (2). Return true
87291>>>>>  //> if the seeding was succesful.
87291>>>>>  function iSeed2 returns integer
87293>>>>>    integer liTable
87293>>>>>    get piTable2 to liTable
87294>>>>>    clear liTable
87295>>>>>    function_return TRUE
87296>>>>>  end_function
87297>>>>>  //> The function should be augmented to return the value for the left buffer (1) to be used for comparing. For example:
87297>>>>>  function sValue1 returns string
87299>>>>>    integer liTable liIndex
87299>>>>>    get piTable1 to liTable
87300>>>>>    get piIndex to liIndex
87301>>>>>    function_return (API_IndexValue(liTable,liIndex))
87302>>>>>  end_procedure
87303>>>>>  //> The function should be augmented to return the value for the right buffer (2) to be used for comparing.
87303>>>>>  function sValue2 returns string
87305>>>>>    integer liTable liIndex
87305>>>>>    get piTable2 to liTable
87306>>>>>    get piIndex to liIndex
87307>>>>>    function_return (API_IndexValue(liTable,liIndex))
87308>>>>>  end_procedure
87309>>>>>  //> Augment to "advance" the left buffer. Return true if advancing was succesful. Could be:
87309>>>>>  function iAdvance1 returns integer
87311>>>>>    integer liTable liIndex
87311>>>>>    get piTable1 to liTable
87312>>>>>    get piIndex to liIndex
87313>>>>>    vfind liTable liIndex GT
87315>>>>>    function_return (found)
87316>>>>>  end_function
87317>>>>>  //> Augment to "advance" the right buffer. Return true if advancing was succesful.
87317>>>>>  function iAdvance2 returns integer
87319>>>>>    integer liTable liIndex
87319>>>>>    get piTable2 to liTable
87320>>>>>    get piIndex to liIndex
87321>>>>>    vfind liTable liIndex GT
87323>>>>>    function_return (found)
87324>>>>>  end_function
87325>>>>>  //> This is sent when items are found to be identical.
87325>>>>>  procedure Match string lsValue1 string lsValue2
87327>>>>>    send IndexValueMatch lsValue1 lsValue2
87328>>>>>  end_procedure
87329>>>>>  //> This is sent when a left side (1) item cannot be matched.
87329>>>>>  procedure NotMatched1 string lsValue
87331>>>>>    send IndexValueNotMatched1 lsValue
87332>>>>>  end_procedure
87333>>>>>  //> This is sent when a right side (2) item cannot be matched.
87333>>>>>  procedure NotMatched2 string lsValue
87335>>>>>    send IndexValueNotMatched2 lsValue
87336>>>>>  end_procedure
87337>>>>>end_class // cCompareTableDataHelp
87338>>>>>
87338>>>>>enumeration_list
87338>>>>>  define CTP_ALL
87338>>>>>  define CTP_TABLE1_MISSING
87338>>>>>  define CTP_TABLE2_MISSING
87338>>>>>  define CTP_BOTH_PRESENT
87338>>>>>  define CTP_EITHER_MISSING
87338>>>>>end_enumeration_list
87338>>>>>
87338>>>>>class cCompareTableData is a cArray
87339>>>>>  procedure construct_object
87341>>>>>    forward send construct_object
87343>>>>>    property integer piTable1
87344>>>>>    property integer piTable2
87345>>>>>    property integer piIndex
87346>>>>>    property string psTable1
87347>>>>>    property string psTable2
87348>>>>>    property integer piCompMode public 0
87349>>>>>    object oComparer is a cCompareTableDataHelp
87351>>>>>    end_object
87352>>>>>    object oIgnoreFields is a cARray
87354>>>>>    end_object
87355>>>>>  end_procedure
87356>>>>>
87356>>>>>  procedure set IgnoreFieldState integer liField boolean lbState
87358>>>>>    set value of oIgnoreFields liField to lbState
87359>>>>>  end_procedure
87360>>>>>
87360>>>>>  function IgnoreFieldState integer liField returns boolean
87362>>>>>    function_return (value(oIgnoreFields,liField))
87363>>>>>  end_function
87364>>>>>
87364>>>>>  procedure IgnoreFieldsClearAll
87366>>>>>    send delete_Data of oIgnoreFields
87367>>>>>  end_procedure
87368>>>>>
87368>>>>>  item_property_list
87368>>>>>    item_property string  psIndex1.i
87368>>>>>    item_property integer piRecnum1.i
87368>>>>>    item_property string  psIndex2.i
87368>>>>>    item_property integer piRecnum2.i
87368>>>>>  end_item_property_list cCompareTableData
#REM 87406 DEFINE FUNCTION PIRECNUM2.I INTEGER LIROW RETURNS INTEGER
#REM 87410 DEFINE PROCEDURE SET PIRECNUM2.I INTEGER LIROW INTEGER VALUE
#REM 87414 DEFINE FUNCTION PSINDEX2.I INTEGER LIROW RETURNS STRING
#REM 87418 DEFINE PROCEDURE SET PSINDEX2.I INTEGER LIROW STRING VALUE
#REM 87422 DEFINE FUNCTION PIRECNUM1.I INTEGER LIROW RETURNS INTEGER
#REM 87426 DEFINE PROCEDURE SET PIRECNUM1.I INTEGER LIROW INTEGER VALUE
#REM 87430 DEFINE FUNCTION PSINDEX1.I INTEGER LIROW RETURNS STRING
#REM 87434 DEFINE PROCEDURE SET PSINDEX1.I INTEGER LIROW STRING VALUE
87439>>>>>
87439>>>>>   procedure add_row string lsIndex1 integer liRecnum1 string lsIndex2 integer liRecnum2
87441>>>>>    integer liRow liCompMode
87441>>>>>    boolean lbAdd
87441>>>>>    get piCompMode to liCompMode
87442>>>>>
87442>>>>>    if (liCompMode=CTP_ALL) move TRUE to lbAdd
87445>>>>>    if (liCompMode=CTP_TABLE1_MISSING and liRecnum1=0) move TRUE to lbAdd
87448>>>>>    if (liCompMode=CTP_TABLE2_MISSING and liRecnum2=0) move TRUE to lbAdd
87451>>>>>    if (liCompMode=CTP_BOTH_PRESENT and liRecnum1<>0 and liRecnum2<>0) move TRUE to lbAdd
87454>>>>>    if (liCompMode=CTP_EITHER_MISSING and (liRecnum1=0 or liRecnum2=0)) move TRUE to lbAdd
87457>>>>>
87457>>>>>    if lbAdd begin
87459>>>>>      get row_count to liRow
87460>>>>>      set psIndex1.i  liRow to lsIndex1
87461>>>>>      set piRecnum1.i liRow to liRecnum1
87462>>>>>      set psIndex2.i  liRow to lsIndex2
87463>>>>>      set piRecnum2.i liRow to liRecnum2
87464>>>>>    end
87464>>>>>>
87464>>>>>  end_procedure
87465>>>>>
87465>>>>>            procedure AutoSetTableNumbers
87467>>>>>              integer liFile
87467>>>>>              get FLIST_TemporaryEntry 500 to liFile
87468>>>>>              set piTable1 to liFile
87469>>>>>              get FLIST_TemporaryEntry liFile to liFile
87470>>>>>              set piTable2 to liFile
87471>>>>>            end_procedure
87472>>>>>
87472>>>>>            function OpenTable integer liFile string lsFile returns integer
87474>>>>>              integer liError
87474>>>>>              get DBMS_OpenFileAs lsFile liFile DF_SHARE 0 to liError
87475>>>>>
87475>>>>>              ifnot liError move 1 to liError // Table could not be opened
87478>>>>>              else move 0 to liError // No errors
87480>>>>>              function_return liError
87481>>>>>            end_function
87482>>>>>
87482>>>>>            procedure CloseTables
87484>>>>>              integer liTable
87484>>>>>              get piTable1 to liTable
87485>>>>>              send DBMS_CloseFile liTable
87486>>>>>              get piTable2 to liTable
87487>>>>>              send DBMS_CloseFile liTable
87488>>>>>            end_procedure
87489>>>>>
87489>>>>>  // If this function returns 0 we are ready to start comparing the contents
87489>>>>>  function bOpenTables string lsFile1 string lsFile2 returns integer
87491>>>>>    integer liError lhFdx1 lhFdx2 lhPgmObj
87491>>>>>    boolean lbChanged
87491>>>>>    send AutoSetTableNumbers
87492>>>>>    get OpenTable (piTable1(self)) lsFile1 to liError
87493>>>>>    ifnot liError get OpenTable (piTable2(self)) lsFile2 to liError
87496>>>>>    ifnot liError begin // Compare the tables. They must be identical!
87498>>>>>      get NewFdxObject (piTable1(self)) to lhFdx1
87499>>>>>      get NewFdxObject (piTable2(self)) to lhFdx2
87500>>>>>      get iFdxCompareTables.iiiiii lhPgmObj lhFdx1 (piTable1(self)) lhFdx2 (piTable2(self)) FDXCOMP_MODE_FILE to lhPgmObj
87501>>>>>
87501>>>>>      if (piProgramType(lhPgmObj)<>PGM_TYPE_EMPTY) move 2 to liError // Table definiitons are not identical
87504>>>>>
87504>>>>>      send destroy of lhFdx1
87505>>>>>      send destroy of lhFdx2
87506>>>>>      send destroy of lhPgmObj
87507>>>>>
87507>>>>>    end
87507>>>>>>
87507>>>>>    if liError send CloseTables
87510>>>>>    set psTable1 to lsFile1
87511>>>>>    set psTable2 to lsFile2
87512>>>>>    function_return liError
87513>>>>>  end_function
87514>>>>>
87514>>>>>//function bValidateTables string lsFile1 string lsFile2 returns integer
87514>>>>>//  integer liError
87514>>>>>//  get bOpenTables lsFile1 lsFile2 to liError
87514>>>>>//  send CloseTables
87514>>>>>//  function_return liError
87514>>>>>//end_function
87514>>>>>
87514>>>>>  procedure call_back_results integer lhMsg integer lhObj
87516>>>>>    integer liMax liRow
87516>>>>>    string lsIndexValue
87516>>>>>    get row_count to liMax
87517>>>>>    decrement liMax
87518>>>>>    for liRow from 0 to liMax
87524>>>>>>
87524>>>>>      get psIndex1.i liRow to lsIndexValue
87525>>>>>      if (lsIndexValue="") get psIndex2.i liRow to lsIndexValue
87528>>>>>      send lhMsg of lhObj lsIndexValue (piRecnum1.i(self,liRow)) (piRecnum2.i(self,liRow))
87529>>>>>    loop
87530>>>>>>
87530>>>>>  end_procedure
87531>>>>>
87531>>>>>  procedure run_table_comparison
87533>>>>>    send delete_data
87534>>>>>    send run of oComparer
87535>>>>>  end_procedure
87536>>>>>
87536>>>>>  function FieldValuesIdentical returns boolean
87538>>>>>    integer liField liMaxField liType
87538>>>>>    integer liTable1 liTable2
87538>>>>>    string lsValue1 lsValue2
87538>>>>>    get piTable1 to liTable1
87539>>>>>    get piTable2 to liTable2
87540>>>>>
87540>>>>>    get_Attribute DF_FILE_NUMBER_FIELDS of liTable1 to liMaxField
87543>>>>>    for liField from 1 to liMaxField
87549>>>>>>
87549>>>>>      ifnot (IgnoreFieldState(self,liField)) begin
87551>>>>>        get_Attribute DF_FIELD_TYPE of liTable1 liField to liType
87554>>>>>        if (liType<>DF_OVERLAP) begin
87556>>>>>          get_field_value liTable1 liField to lsValue1
87559>>>>>          get_field_value liTable2 liField to lsValue2
87562>>>>>          if (lsValue1<>lsValue2) function_return FALSE
87565>>>>>        end
87565>>>>>>
87565>>>>>      end
87565>>>>>>
87565>>>>>    loop
87566>>>>>>
87566>>>>>    function_Return TRUE
87567>>>>>  end_function
87568>>>>>
87568>>>>>  procedure IndexValueMatch string lsValue1 string lsValue2
87570>>>>>    integer liRecnum1 liRecnum2
87570>>>>>    ifnot (FieldValuesIdentical(self)) begin
87572>>>>>      get_field_value (piTable1(self)) 0 to liRecnum1
87575>>>>>      get_field_value (piTable2(self)) 0 to liRecnum2
87578>>>>>      send add_row lsValue1 liRecnum1 lsValue2 liRecnum2
87579>>>>>    end
87579>>>>>>
87579>>>>>  end_procedure
87580>>>>>
87580>>>>>  procedure IndexValueNotMatched1 string lsValue
87582>>>>>    integer liRecnum
87582>>>>>    get_field_value (piTable1(self)) 0 to liRecnum
87585>>>>>    send add_row lsValue liRecnum "" 0
87586>>>>>  end_procedure
87587>>>>>
87587>>>>>  procedure IndexValueNotMatched2 string lsValue
87589>>>>>    integer liRecnum
87589>>>>>    get_field_value (piTable2(self)) 0 to liRecnum
87592>>>>>    send add_row "" 0 lsValue liRecnum
87593>>>>>  end_procedure
87594>>>>>end_class // cCompareTableData
87595>>>Use ObjGroup.utl // Defining groups of objects
87595>>>
87595>>>Use ApsWiz.pkg   // APS wizard classes
Including file: apswiz.pkg    (C:\Apps\VDFQuery\AppSrc\apswiz.pkg)
87595>>>>>// Use ApsWiz.pkg   // APS wizard classes
87595>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
87595>>>>>Use Set.utl      // cArray, cSet and cStack classes
87595>>>>>Use Buttons.utl  // Button texts
87595>>>>>Use Language     // Default language setup
87595>>>>>
87595>>>>> define t.wizbtn.back   for "< Back"
87595>>>>> define t.wizbtn.next   for "Next >"
87595>>>>> define t.wizbtn.finish for "Finish"
87595>>>>>
87595>>>>>enumeration_list
87595>>>>>  define WIZSIZE_SMALL
87595>>>>>  define WIZSIZE_NORMAL
87595>>>>>  define WIZSIZE_LARGE
87595>>>>>end_enumeration_list
87595>>>>>
87595>>>>>register_object oLine
87595>>>>>register_function iPageValidate returns integer
87595>>>>>
87595>>>>>class aps.WizardPanel is a aps.BasicPanel
87596>>>>>  procedure construct_object
87598>>>>>    forward send construct_object
87600>>>>>    set sysmenu_icon  to false
87601>>>>>    set minimize_icon to false
87602>>>>>    set maximize_icon to false
87603>>>>>    set popup_state to true
87604>>>>>    set modal_state to true
87605>>>>>    on_key kcancel send close_panel
87606>>>>>    object oPages is a cArray
87608>>>>>    end_object
87609>>>>>    property integer piCurrentPage public -1
87610>>>>>    property integer piResult      public 0
87611>>>>>    property integer p_max_row_on_tabdialog    public 0
87612>>>>>    property integer p_max_column_on_tabdialog public 0
87613>>>>>    set locate_mode to CENTER_ON_SCREEN
87614>>>>>    set border_style to BORDER_DIALOG
87615>>>>>    send aps_init
87616>>>>>  end_procedure
87617>>>>>  procedure end_construct_object
87619>>>>>    set p_max_row    to (p_max_row_on_tabdialog(self))
87620>>>>>    set p_max_column to (p_max_column_on_tabdialog(self))
87621>>>>>    send aps_goto_max_row
87622>>>>>    object oLine is a aps.LineControl
87624>>>>>    end_object
87625>>>>>    set multi_button_size to 16 50
87626>>>>>    object oBtn1 is a aps.Multi_Button
87628>>>>>      on_item t.wizbtn.back send DoPageBack
87629>>>>>      set p_extra_external_width to (-p_column_space(self))
87630>>>>>    end_object
87631>>>>>    object oBtn2 is a aps.Multi_Button
87633>>>>>      on_item t.wizbtn.next send DoPageForward
87634>>>>>      set p_extra_external_width to (p_column_space(self))
87635>>>>>    end_object
87636>>>>>    object oBtn3 is a aps.Multi_Button
87638>>>>>      on_item t.btn.cancel send close_panel
87639>>>>>    end_object
87640>>>>>    send aps_locate_multi_buttons
87641>>>>>    forward send end_construct_object
87643>>>>>  end_procedure
87644>>>>>  procedure set minimum_size integer height# integer width#
87646>>>>>    set p_max_row_on_tabdialog    to height#
87647>>>>>    set p_max_column_on_tabdialog to width#
87648>>>>>  end_procedure
87649>>>>>  procedure make_nice_size integer tmp_size_class#
87651>>>>>    integer size_class#
87651>>>>>    if num_arguments move tmp_size_class# to size_class#
87654>>>>>    else move WizSize_Normal to size_class#
87656>>>>>    if size_class# eq WIZSIZE_SMALL  set minimum_size to 100 200
87659>>>>>    if size_class# eq WIZSIZE_NORMAL set minimum_size to 150 300
87662>>>>>    if size_class# eq WIZSIZE_LARGE  set minimum_size to 200 400
87665>>>>>  end_procedure
87666>>>>>  procedure Register_WizardPage integer obj#
87668>>>>>    set value of (oPages(self)) item (item_count(oPages(self))) to obj#
87669>>>>>  end_procedure
87670>>>>>  function iNextPage integer liCurrentPage returns integer
87672>>>>>    function_return (liCurrentPage+1)
87673>>>>>  end_function
87674>>>>>  procedure DoPageForward
87676>>>>>    string label# obj# liNextPage liCurrentPage
87676>>>>>    get label of (oBtn2(self)) to label#
87677>>>>>    get piCurrentPage to liCurrentPage
87678>>>>>    get value of (oPages(self)) item liCurrentPage to obj#
87679>>>>>    if (iPageValidate(obj#)) begin
87681>>>>>      if label# eq t.wizbtn.finish send close_panel_ok
87684>>>>>      else begin
87685>>>>>        get iNextPage liCurrentPage to liNextPage
87686>>>>>        get value of (oPages(self)) item liNextPage to obj#
87687>>>>>        send OnDisplayPageForwardNavigation to obj# liCurrentPage
87688>>>>>        set piPreviousPage of (integer(value(oPages(self),liNextPage))) to liCurrentPage
87689>>>>>        send DisplayPage liNextPage
87690>>>>>      end
87690>>>>>>
87690>>>>>    end
87690>>>>>>
87690>>>>>  end_procedure
87691>>>>>  procedure DoPageBack
87693>>>>>    integer liPreviousPage
87693>>>>>    get piPreviousPage of (integer(value(oPages(self),piCurrentPage(self)))) to liPreviousPage
87694>>>>>    send DisplayPage liPreviousPage
87695>>>>>  end_procedure
87696>>>>>  procedure DoFinish
87698>>>>>  end_procedure
87699>>>>>  procedure close_panel_ok
87701>>>>>    set piResult to 1
87702>>>>>    send close_panel
87703>>>>>  end_procedure
87704>>>>>  procedure popup
87706>>>>>    set piCurrentPage to -1
87707>>>>>    set piResult to 0
87708>>>>>    forward send popup
87710>>>>>    if (piResult(self)) send DoFinish
87713>>>>>  end_procedure
87714>>>>>
87714>>>>>  procedure aps_beautify
87716>>>>>    send aps_align_inside_container_by_sizing (oLine(self)) SL_ALIGN_RIGHT
87717>>>>>  end_procedure
87718>>>>>
87718>>>>>  procedure DisplayPage integer new_pg#
87720>>>>>    integer cur_pg# new_page_obj# cur_page_obj#
87720>>>>>    get piCurrentPage to cur_pg#
87721>>>>>    move (value(oPages(self),new_pg#)) to new_page_obj#
87722>>>>>    if cur_pg# ne -1 move (value(oPages(self),cur_pg#)) to cur_page_obj#
87725>>>>>    if (cur_page_obj# and new_page_obj#) send deactivate to cur_page_obj#
87728>>>>>    if new_page_obj# begin
87730>>>>>      send popup_group to new_page_obj#
87731>>>>>      move new_pg# to cur_pg#
87732>>>>>    end
87732>>>>>>
87732>>>>>    set object_shadow_state of (oBtn1(self)) to (cur_pg#=0)
87733>>>>>    if cur_pg# eq (item_count(oPages(self))-1) set label of (oBtn2(self)) to t.wizbtn.finish
87736>>>>>    else set label of (oBtn2(self)) to t.wizbtn.next
87738>>>>>    set piCurrentPage to cur_pg#
87739>>>>>  end_procedure
87740>>>>>  procedure page integer mode#
87742>>>>>    forward send page mode#
87744>>>>>    // Mode# must be 1, otherwise the object isn't created yet???
87744>>>>>    if (mode#=1 and piCurrentPage(self)=-1) send DisplayPage 0
87747>>>>>  end_procedure
87748>>>>>end_class // aps.WizardPanel
87749>>>>>
87749>>>>>class aps.WizardPage is a Container
87750>>>>>  // The APS functionality is a copy of that in a aps.TabPage
87750>>>>>  procedure construct_object
87752>>>>>    forward send construct_object
87754>>>>>    set popup_state to true         //
87755>>>>>    set caption_bar to false        //
87756>>>>>    send aps_init
87757>>>>>    set border_style to border_none // This is out of the Wizard.pkg (DAC)
87758>>>>>    property integer piPreviousPage public 0 // Is set dynamically as the user navigates the dialog
87759>>>>>    set attach_parent_state to true // This achieves proper navigation to the buttons
87760>>>>>    send aps_goto_max_row
87761>>>>>    send aps_new_field_row
87762>>>>>  end_procedure
87763>>>>>  procedure set page_title string str#
87765>>>>>//    set label of (oTitle(self)) to str#
87765>>>>>  end_procedure
87766>>>>>  function iPageValidate returns integer
87768>>>>>    function_return 1
87769>>>>>  end_function
87770>>>>>  procedure OnDisplayPageForwardNavigation integer piPrevPage
87772>>>>>  end_procedure
87773>>>>>  procedure end_construct_object
87775>>>>>    integer max_row# max_column# self#
87775>>>>>    get p_max_row to max_row#
87776>>>>>    get p_max_column to max_column#
87777>>>>>    if max_row# gt (p_max_row_on_tabdialog(self)) set p_max_row_on_tabdialog to max_row#
87780>>>>>    if max_column# gt (p_max_column_on_tabdialog(self)) set p_max_column_on_tabdialog to max_column#
87783>>>>>    forward send end_construct_object
87785>>>>>    move self to self#
87786>>>>>    send Register_WizardPage self# // Register with parent object:
87787>>>>>  end_procedure
87788>>>>>end_class
87789>>>>>
87789>>>>>class aps.WizardPageTitle is a aps.TextBox
87790>>>>>  procedure construct_object
87792>>>>>    forward send construct_object
87794>>>>>    set Typeface to "Arial"
87795>>>>>    set FontSize to 18 0
87796>>>>>    set FontWeight to 700
87797>>>>>  end_procedure
87798>>>>>  procedure end_construct_object
87800>>>>>    forward send end_construct_object
87802>>>>>    send aps_goto_max_row
87803>>>>>    send aps_new_field_row
87804>>>>>  end_procedure
87805>>>>>end_class
87806>>>>>
87806>>>>>//
87806>>>>>//  object oWizard is a aps.WizardPanel label "Hello wiz"
87806>>>>>//    send make_nice_size WIZSIZE_NORMAL
87806>>>>>//    object oPage1 is a aps.WizardPage
87806>>>>>//        object oFrm is a Form
87806>>>>>//        set value item 0  "Der kan man sgu bare se"
87806>>>>>//        set form_margin item 0 to 5
87806>>>>>//        set size to 12 50
87806>>>>>//        set location to 5 5
87806>>>>>//      end_object
87806>>>>>//    end_object
87806>>>>>//    object oPage2 is a aps.WizardPage
87806>>>>>//      object oFrm is a aps.Form label "Der kan man sgu bare se (2)" abstract aft_ascii20
87806>>>>>//      end_object
87806>>>>>//    end_object
87806>>>>>//    object oPage3 is a aps.WizardPage
87806>>>>>//      object oFrm is a aps.Form label "Der kan man sgu bare se for sidste gang" abstract aft_ascii20
87806>>>>>//      end_object
87806>>>>>//    end_object
87806>>>>>//  end_object
87806>>>>>//  send popup to (oWizard(self))
87806>>>Use FdxField.nui // FDX Field things
87806>>>Use MsgBox.utl   // obs procedure
87806>>>
87806>>>object oCompareTableData_Wiz is a aps.WizardPanel label "Compare table data"
87809>>>  send make_nice_size WIZSIZE_NORMAL
87810>>>  property string psTable1
87812>>>  property string psTable2
87814>>>
87814>>>  property string psPrevFolder1 public ""
87816>>>  property string psPrevFolder2 public ""
87818>>>
87818>>>  object oOpenDialog is a OpenDialog
87820>>>    set NoChangeDir_State to true
87821>>>  end_object
87822>>>
87822>>>  property integer phComparer
87824>>>
87824>>>  object oPage1 is a aps.WizardPage
87826>>>    object oYellow is a aps.YellowBox
87828>>>      set size to 55 100
87829>>>      set value item 0 to "Use this wizard to setup table data comparison."
87830>>>      set value item 1 to ""
87831>>>      set value item 2 to "Select two identically defined tables on disk and create a list of differences in their data content."
87832>>>    end_object
87833>>>    send aps_goto_max_row
87834>>>    send aps_make_row_space 20
87835>>>    object oTable1 is a aps.Form label "   Table 1:" abstract AFT_ASCII100
87839>>>      set enabled_state to false
87840>>>      set p_extra_internal_width to -300
87841>>>    end_object
87842>>>    object oBtn1 is a aps.Button snap SL_RIGHT
87845>>>      set size to 13 40
87846>>>      on_item "Select" send select_table1
87847>>>    end_object
87848>>>    send aps_goto_max_row
87849>>>    send aps_make_row_space 5
87850>>>    object oTable2 is a aps.Form label "   Table 2:" abstract AFT_ASCII100
87854>>>      set enabled_state to false
87855>>>      set p_extra_internal_width to -300
87856>>>    end_object
87857>>>    object oBtn2 is a aps.Button snap SL_RIGHT
87860>>>      set size to 13 40
87861>>>      on_item "Select" send select_table2
87862>>>    end_object
87863>>>
87863>>>    procedure update_display
87866>>>      set value of oTable1 to (psTable1(self))
87867>>>      set value of oTable2 to (psTable2(self))
87868>>>    end_procedure
87869>>>
87869>>>    function select_table string lsFolder string lsLookForTable returns string
87872>>>      string lsTable lsFilter
87872>>>      set Dialog_Caption of oOpenDialog to "Find a table"
87873>>>      move "DAT files|*.dat|All files|*.*" to lsFilter
87874>>>      if (lsLookForTable<>"") move (lsLookForTable+"|"+lsLookForTable+"|"+lsFilter) to lsFilter
87877>>>      set Filter_String  of oOpenDialog to lsFilter
87878>>>      if (lsFolder<>"") set Initial_Folder of oOpenDialog to lsFolder
87881>>>      if (Show_Dialog(oOpenDialog)) get File_Name of oOpenDialog to lsTable
87884>>>      else move "" to lsTable
87886>>>      function_return lsTable
87887>>>    end_function
87888>>>
87888>>>    procedure select_table1
87891>>>      string lsTable lsFolder lsLookForTable
87891>>>      get psPrevFolder1 to lsFolder
87892>>>
87892>>>      get psTable2 to lsLookForTable
87893>>>      get SEQ_RemovePathFromFileName lsLookForTable to lsLookForTable
87894>>>
87894>>>      get select_table lsFolder lsLookForTable to lsTable
87895>>>      if (lsTable<>"") begin
87897>>>        get SEQ_ExtractPathFromFileName lsTable to lsFolder
87898>>>        set psPrevFolder1 to lsFolder
87899>>>        set psTable1 to lsTable
87900>>>        send update_display
87901>>>      end
87901>>>>
87901>>>    end_procedure
87902>>>
87902>>>    procedure select_table2
87905>>>      string lsTable lsFolder lsLookForTable
87905>>>      get psPrevFolder2 to lsFolder
87906>>>
87906>>>      get psTable1 to lsLookForTable
87907>>>      get SEQ_RemovePathFromFileName lsLookForTable to lsLookForTable
87908>>>
87908>>>      get select_table lsFolder lsLookForTable to lsTable
87909>>>      if (lsTable<>"") begin
87911>>>        get SEQ_ExtractPathFromFileName lsTable to lsFolder
87912>>>        set psPrevFolder2 to lsFolder
87913>>>        set psTable2 to lsTable
87914>>>        send update_display
87915>>>      end
87915>>>>
87915>>>    end_procedure
87916>>>
87916>>>    function iPageValidate returns boolean
87919>>>      integer liError
87919>>>      string lsTable1 lsTable2
87919>>>      send CloseTables of (phComparer(self))
87920>>>      get bOpenTables of (phComparer(self)) (psTable1(self)) (psTable2(self)) to liError
87921>>>      if liError begin
87923>>>        if (liError=1) send obs "Tables couldn't be opened"
87926>>>        if (liError=2) send obs "Table definitions are not identical"
87929>>>        send obs "Select valid tables"
87930>>>      end
87930>>>>
87930>>>      function_return (liError=0)
87931>>>    end_function
87932>>>
87932>>>    procedure aps_beautify
87935>>>      send aps_align_inside_container_by_sizing (oYellow(self)) SL_ALIGN_RIGHT
87936>>>    end_procedure
87937>>>  end_object // oPage1
87938>>>
87938>>>  object oPage2 is a aps.WizardPage
87940>>>    object oYellow is a aps.YellowBox
87942>>>      set size to 55 100
87943>>>      set value item 0 to "Select the (unique) index to use when identifying records in the tables."
87944>>>      set value item 1 to ""
87945>>>      set value item 2 to ""
87946>>>    end_object
87947>>>
87947>>>    send aps_goto_max_row
87948>>>    send aps_make_row_space 10
87949>>>
87949>>>    object oIndex is a aps.ComboFormAux abstract AFT_ASCII50 label "Select index:"
87953>>>      set allow_blank_state to FALSE
87954>>>      set entry_state item to FALSE
87955>>>      set label_justification_mode to JMODE_TOP
87956>>>
87956>>>      procedure fill_list.i integer liTable
87959>>>        integer liMax liIndex liItm liAux
87959>>>        string lsIndices lsIndex
87959>>>        send Combo_Delete_Data
87960>>>        get FDX_SetOfIndices 0 liTable DF_INDEX_TYPE_ONLINE to lsIndices
87961>>>
87961>>>        send combo_add_item "Recnum" 0
87962>>>        move -1 to liAux
87963>>>
87963>>>        get HowManyIntegers lsIndices to liMax
87964>>>        for liItm from 1 to liMax
87970>>>>
87970>>>          get ExtractInteger lsIndices liItm to liIndex
87971>>>          if (FDX_IndexUnique(0,liTable,liIndex)) begin
87973>>>            get FDX_IndexAsFieldNames 0 liTable liIndex 0 to lsIndex
87974>>>            send combo_add_item (string(liIndex)+": "+lowercase(lsIndex)) liIndex
87975>>>            if (liAux=-1) move liIndex to liAux
87978>>>          end
87978>>>>
87978>>>        loop
87979>>>>
87979>>>        if (liAux<>-1) set Combo_Current_Aux_Value to liAux
87982>>>      end_procedure
87983>>>    end_object
87984>>>
87984>>>    function iPageValidate returns boolean
87987>>>      integer liTable liIndex
87987>>>      get Combo_Current_Aux_Value of oIndex to liIndex
87988>>>      set piIndex of (phComparer(self)) to liIndex
87989>>>      function_return TRUE
87990>>>    end_function
87991>>>
87991>>>    procedure aps_beautify
87994>>>      send aps_align_inside_container_by_sizing (oYellow(self)) SL_ALIGN_RIGHT
87995>>>      send aps_align_inside_container_by_moving (oINdex(self)) SL_ALIGN_CENTER
87996>>>    end_procedure
87997>>>
87997>>>    procedure DoInitialize
88000>>>      integer liTable
88000>>>      get piTable1 of (phComparer(self)) to liTable
88001>>>      send fill_list.i of oIndex liTable
88002>>>    end_procedure
88003>>>  end_object // oPage2
88004>>>
88004>>>  object oPage3 is a aps.WizardPage
88006>>>    object oYellow is a aps.YellowBox
88008>>>      set size to 30 100
88009>>>      set value item 0 to "When index-identical records are compared the default is to consider all columns in the tables."
88010>>>      set value item 1 to ""
88011>>>      set value item 2 to "If you want to ignore specific column indicate so in the list below."
88012>>>    end_object
88013>>>
88013>>>    send aps_goto_max_row
88014>>>    send aps_make_row_space 10
88015>>>
88015>>>    object oGrid is a aps.Grid
88017>>>      send GridPrepare_AddCheckBoxColumn ""
88018>>>      send GridPrepare_AddColumn "" AFT_ASCII15
88019>>>      send GridPrepare_AddColumn "" AFT_ASCII15
88020>>>      send GridPrepare_Apply self
88021>>>      set select_mode to MULTI_SELECT
88022>>>      on_key KNEXT_ITEM send switch
88023>>>      on_key KPREVIOUS_ITEM send switch_back
88024>>>      set Header_Visible_State to FALSE
88025>>>      set gridline_mode to GRID_VISIBLE_NONE
88026>>>      set size to 85 0
88027>>>      on_key KEY_CTRL+KEY_A send select_all
88028>>>      on_key KEY_CTRL+KEY_I send deselect_all
88029>>>
88029>>>      procedure select_all
88032>>>        send Grid_RowSelectAll self
88033>>>      end_procedure
88034>>>      procedure deselect_all
88037>>>        send Grid_RowDeselectAll self
88038>>>      end_procedure
88039>>>
88039>>>      procedure select_toggling integer liItem integer lbState
88042>>>        integer liCurrentItem liColumns
88042>>>        get Grid_Columns self to liColumns
88043>>>        get current_item to liCurrentItem
88044>>>        move ((liCurrentItem/liColumns)*liColumns) to liCurrentItem // Redirect to first column
88045>>>        forward send select_toggling liCurrentItem lbState
88047>>>      end_procedure
88048>>>
88048>>>      procedure HandleField integer liFile integer liField string lsName integer liType integer liLen integer liPrec integer liRelFile integer liRelField integer liIndex integer liOffSet
88051>>>        integer liBase
88051>>>        if (liType<>DF_OVERLAP) begin
88053>>>          get item_count to liBase
88054>>>          send Grid_AddCheckBoxItem self FALSE
88055>>>          send add_item MSG_NONE lsName
88056>>>          send add_item MSG_NONE (FDX_FieldTypeAndLengthName(0,liFile,liField))
88057>>>          set aux_value liBase to liField
88058>>>        end
88058>>>>
88058>>>      end_procedure
88059>>>
88059>>>      procedure fill_list.i integer liTable
88062>>>        send delete_data
88063>>>        send FDX_FieldCallBack 0 liTable MSG_HandleField self
88064>>>        send Grid_SetEntryState self FALSE
88065>>>      end_procedure
88066>>>
88066>>>      procedure HandleRow integer liRow integer liBase
88069>>>        integer liField
88069>>>        get aux_value liBase to liField
88070>>>        set IgnoreFieldState of (phComparer(self)) liField to TRUE
88071>>>      end_procedure
88072>>>    end_object
88073>>>
88073>>>    procedure aps_beautify
88076>>>      send aps_align_inside_container_by_sizing (oYellow(self)) SL_ALIGN_RIGHT
88077>>>      send aps_align_inside_container_by_moving (oGrid(self)) SL_ALIGN_CENTER
88078>>>    end_procedure
88079>>>
88079>>>    procedure DoInitialize
88082>>>      integer liTable
88082>>>      get piTable1 of (phComparer(self)) to liTable
88083>>>      send fill_list.i of oGrid liTable
88084>>>    end_procedure
88085>>>
88085>>>    function iPageValidate returns boolean
88088>>>      // Here we need to transfer the fields we want to ignore <--- OBS OBS OBS
88088>>>      send IgnoreFieldsClearAll of (phComparer(self))
88089>>>      send Grid_RowCallBackSelected (oGrid(self)) MSG_HandleRow (oGrid(self))
88090>>>      function_return TRUE
88091>>>    end_function
88092>>>
88092>>>  end_object // oPage3
88093>>>
88093>>>  object oPage4 is a aps.WizardPage
88095>>>
88095>>>    object oTable1 is a aps.Form label "   Table 1:" abstract AFT_ASCII100
88099>>>      set enabled_state to false
88100>>>      set p_extra_internal_width to -255
88101>>>    end_object
88102>>>    send aps_goto_max_row
88103>>>    object oTable2 is a aps.Form label "   Table 2:" abstract AFT_ASCII100
88107>>>      set enabled_state to false
88108>>>      set p_extra_internal_width to -255
88109>>>    end_object
88110>>>    send aps_goto_max_row
88111>>>    send aps_make_row_space 5
88112>>>    object oRad is a aps.RadioGroup label "Only find..."
88115>>>      object oRad1 is a aps.Radio label "All differences"
88118>>>      end_object
88119>>>      object oRad2 is a aps.Radio label "Records missing in table 1"
88122>>>      end_object
88123>>>      object oRad3 is a aps.Radio label "Records missing in table 2"
88126>>>      end_object
88127>>>      object oRad4 is a aps.Radio label "Records present in both tables"
88130>>>      end_object
88131>>>      object oRad5 is a aps.Radio label "Records missing in one of the tables"
88134>>>      end_object
88135>>>    end_object
88136>>>
88136>>>    procedure aps_beautify
88139>>>      send aps_align_inside_container_by_moving (oRad(self)) SL_ALIGN_CENTER
88140>>>    end_procedure
88141>>>
88141>>>    procedure DoInitialize
88144>>>      set value of oTable1 to (value(oTable1(oPage1)))
88145>>>      set value of oTable2 to (value(oTable2(oPage1)))
88146>>>    end_procedure
88147>>>
88147>>>    function iPageValidate returns boolean
88150>>>      // Here we need to transfer the fields we want to ignore <--- OBS OBS OBS
88150>>>      set piCompMode of (phComparer(self)) to (current_radio(oRad))
88151>>>      function_return TRUE
88152>>>    end_function
88153>>>
88153>>>  end_object // oPage4
88154>>>
88154>>>  procedure DisplayPage integer liPage
88157>>>    integer liCurrentPage
88157>>>    get piCurrentPage to liCurrentPage
88158>>>    if (liPage=1 and liCurrentPage<1) send DoInitialize of oPage2
88161>>>    if (liPage=2 and liCurrentPage<2) send DoInitialize of oPage3
88164>>>    if (liPage=3 and liCurrentPage<3) send DoInitialize of oPage4
88167>>>    forward send DisplayPage liPage
88169>>>  end_procedure
88170>>>
88170>>>  property boolean pbCancel
88172>>>
88172>>>  procedure DoFinish
88175>>>    set pbCancel to FALSE
88176>>>  end_procedure
88177>>>
88177>>>  procedure aps_beautify
88180>>>    forward send aps_beautify
88182>>>    send aps_beautify of oPage1
88183>>>    send aps_beautify of oPage2
88184>>>    send aps_beautify of oPage3
88185>>>    send aps_beautify of oPage4
88186>>>  end_procedure
88187>>>
88187>>>  function bPopup.i integer lhComparer returns boolean
88190>>>    set pbCancel to TRUE
88191>>>    set phComparer to lhComparer
88192>>>    set psTable1 to "" //"C:\Apps\Admin\Data\workhour.dat"
88193>>>    set psTable2 to "" //"\\Sture-6fzexs4wu\webapps\Backup\Admin\Data\workhour.dat"
88194>>>    send update_display of oPage1
88195>>>    send popup
88196>>>    function_return (not(pbCancel(self)))
88197>>>  end_function
88198>>>
88198>>>end_object // oCompareTableData_Wiz
88199>>>
88199>>>DEFINE_OBJECT_GROUP OG_CompareTableDataView
88200>>>  object oCompareTableData_View is a aps.View label "Compare table data"
88203>>>    set Border_Style to BORDER_THICK     // Make panel resizeable
88204>>>
88204>>>    property integer phComparer
88206>>>
88206>>>    object oGroup is a aps.Group label "Selected tables"
88209>>>      set peAnchors to (anLeft+anRight)
88210>>>      send tab_column_define 1 40 35 JMODE_RIGHT
88211>>>
88211>>>      object oTable1 is a aps.Form label "Table 1:" abstract AFT_ASCII100
88215>>>        set peAnchors to (anLeft+anRight)
88216>>>        set enabled_state to false
88217>>>        set p_extra_internal_width to -200
88218>>>      end_object
88219>>>      object oRecords1 is a aps.Form abstract AFT_NUMERIC8.0 snap SL_RIGHT
88223>>>        set peAnchors to (anRight)
88224>>>        set enabled_state to false
88225>>>      end_object
88226>>>
88226>>>      object oTable2 is a aps.Form label "Table 2:" abstract AFT_ASCII100
88230>>>        set peAnchors to (anLeft+anRight)
88231>>>        set enabled_state to false
88232>>>        set p_extra_internal_width to -200
88233>>>      end_object
88234>>>      object oRecords2 is a aps.Form abstract AFT_NUMERIC8.0 snap SL_RIGHT
88238>>>        set peAnchors to (anRight)
88239>>>        set enabled_state to false
88240>>>      end_object
88241>>>
88241>>>      object oIndex is a aps.Form label "Index:" abstract AFT_ASCII100
88245>>>        set peAnchors to (anLeft+anRight)
88246>>>        set enabled_state to false
88247>>>        set p_extra_internal_width to -150
88248>>>      end_object
88249>>>    end_object
88250>>>
88250>>>    send aps_goto_max_row
88251>>>
88251>>>    object oResultGrid is a aps.Grid
88253>>>      send GridPrepare_AddCheckBoxColumn ""
88254>>>      send GridPrepare_AddColumn "Index value" AFT_ASCII60
88255>>>      send GridPrepare_AddCheckBoxColumn "Table 1"
88256>>>      send GridPrepare_AddCheckBoxColumn "Table 2"
88257>>>      send GridPrepare_Apply self
88258>>>      set select_mode to MULTI_SELECT
88259>>>      on_key KNEXT_ITEM send switch
88260>>>      on_key KPREVIOUS_ITEM send switch_back
88261>>>      set gridline_mode to GRID_VISIBLE_NONE
88262>>>      set size to 150 0
88263>>>      set peAnchors to (anLeft+anRight)
88264>>>      set peResizeColumn to rcSelectedColumn // Resize mode (rcAll or rcSelectedColumn)
88265>>>      set piResizeColumn to 1                // This is the column to resize
88266>>>
88266>>>      set form_typeface 1 to "Courier New"
88267>>>      set form_fontheight 1 to 16
88268>>>
88268>>>      on_key KEY_CTRL+KEY_A send select_all
88269>>>      on_key KEY_CTRL+KEY_I send deselect_all
88270>>>
88270>>>      procedure select_all
88273>>>        send Grid_RowSelectAll self
88274>>>      end_procedure
88275>>>      procedure deselect_all
88278>>>        send Grid_RowDeselectAll self
88279>>>      end_procedure
88280>>>
88280>>>
88280>>>                          procedure HandleMoveTo1 integer liTable1 integer liField string lsName integer liType integer liLen integer liPrec integer liRelFile integer liRelField integer liIndex integer liOffSet
88283>>>                            integer liTable2
88283>>>                            string lsValue
88283>>>                            get piTable2 of (phComparer(self)) to liTable2
88284>>>                            if (liType<>DF_OVERLAP) begin
88286>>>                              get_field_value liTable2 liField to lsValue
88289>>>                              set_field_value liTable1 liField to lsValue
88292>>>                            end
88292>>>>
88292>>>                          end_procedure
88293>>>                          procedure HandleMoveTo2 integer liTable2 integer liField string lsName integer liType integer liLen integer liPrec integer liRelFile integer liRelField integer liIndex integer liOffSet
88296>>>                            integer liTable1
88296>>>                            string lsValue
88296>>>                            get piTable1 of (phComparer(self)) to liTable1
88297>>>                            if (liType<>DF_OVERLAP) begin
88299>>>                              get_field_value liTable1 liField to lsValue
88302>>>                              set_field_value liTable2 liField to lsValue
88305>>>                            end
88305>>>>
88305>>>                          end_procedure
88306>>>                procedure TransferRecord integer liRow integer liBase
88309>>>                  integer liCompMode liTable1 liTable2 lhComparer
88309>>>                  get phComparer to lhComparer
88310>>>                  get piCompMode of lhComparer to liCompMode
88311>>>                  get piTable1   of lhComparer to liTable1
88312>>>                  get piTable2   of lhComparer to liTable2
88313>>>                  send ActivateRecordsRow liRow
88314>>>                  if (liCompMode=CTP_TABLE1_MISSING) begin
88316>>>                    clear liTable1
88317>>>                    send FDX_FieldCallBack 0 liTable1 MSG_HandleMoveTo1 self
88318>>>                    saverecord liTable1
88319>>>                  end
88319>>>>
88319>>>                  if (liCompMode=CTP_TABLE2_MISSING) begin
88321>>>                    send FDX_FieldCallBack 0 liTable2 MSG_HandleMoveTo2 self
88322>>>                    saverecord liTable2
88323>>>                  end
88323>>>>
88323>>>                end_procedure
88324>>>      procedure CreateMissingRecords
88327>>>        boolean lbContinue
88327>>>        integer liCompMode liCount
88327>>>        string lsVal1 lsVal2 lsVal3 lsVal4
88327>>>        get piCompMode of (phComparer(self)) to liCompMode
88328>>>        if (liCompMode=CTP_TABLE1_MISSING or liCompMode=CTP_TABLE2_MISSING) begin
88330>>>          get Grid_SelectedRows self to liCount
88331>>>          if liCount begin
88333>>>            move ("Do you want to transfer "+string(liCount)+" records from table") to lsVal1
88334>>>            move "to table" to lsVal3
88335>>>            if (liCompMode=CTP_TABLE1_MISSING) begin
88337>>>              get psTable1 of (phComparer(self)) to lsVal4
88338>>>              get psTable2 of (phComparer(self)) to lsVal2
88339>>>            end
88339>>>>
88339>>>            if (liCompMode=CTP_TABLE2_MISSING) begin
88341>>>              get psTable1 of (phComparer(self)) to lsVal2
88342>>>              get psTable2 of (phComparer(self)) to lsVal4
88343>>>            end
88343>>>>
88343>>>            get MB_Verify4 lsVal1 lsVal2 lsVal3 (lsVal4+"?") FALSE to lbContinue
88344>>>            if lbContinue begin
88346>>>              begin_transaction
88347>>>                send Grid_RowCallBackSelected self MSG_TransferRecord self
88348>>>              end_transaction
88349>>>              get MB_Verify "Records transferred. Do you want to re-run the comparison?" FALSE to lbContinue
88350>>>              if lbContinue send run_compare
88353>>>            end
88353>>>>
88353>>>          end
88353>>>>
88353>>>          else send obs "No rows has been selected"
88355>>>        end
88355>>>>
88355>>>      end_procedure
88356>>>
88356>>>      procedure AddResult string lsIndex integer liRec1 integer liRec2
88359>>>        integer liBase liCompMode lbTransferEnabled
88359>>>
88359>>>        get piCompMode of (phComparer(self)) to liCompMode
88360>>>        move (liCompMode=CTP_TABLE1_MISSING or liCompMode=CTP_TABLE2_MISSING) to lbTransferEnabled
88361>>>
88361>>>        get item_count to liBase
88362>>>        if lbTransferEnabled send Grid_AddCheckBoxItem self FALSE
88365>>>        else send add_item MSG_NONE ""
88367>>>        send add_item MSG_NONE lsIndex
88368>>>        send Grid_AddCheckBoxItem self (liRec1<>0)
88369>>>        send Grid_AddCheckBoxItem self (liRec2<>0)
88370>>>        set aux_value (liBase+1) to liRec1
88371>>>        set aux_value (liBase+2) to liRec2
88372>>>      end_procedure
88373>>>
88373>>>      procedure fill_list
88376>>>        set dynamic_update_state to FALSE
88377>>>        send delete_data
88378>>>        send call_back_results of (phComparer(self)) MSG_AddResult self
88379>>>        send Grid_SetEntryState self FALSE
88380>>>        set dynamic_update_state to TRUE
88381>>>        send ActivateRecordsRow 0
88382>>>        send UpdateValueGrid
88383>>>      end_procedure
88384>>>
88384>>>      procedure select_toggling integer liItem integer lbState
88387>>>        integer liCurrentItem liColumns
88387>>>        get Grid_Columns self to liColumns
88388>>>        get current_item to liCurrentItem
88389>>>        move ((liCurrentItem/liColumns)*liColumns) to liCurrentItem // Redirect to first column
88390>>>        forward send select_toggling liCurrentItem lbState
88392>>>      end_procedure
88393>>>
88393>>>      procedure row_change integer liRowFrom integer liRowTo
88396>>>        send ActivateRecordsRow liRowTo
88397>>>        send UpdateValueGrid
88398>>>      end_procedure
88399>>>
88399>>>      procedure item_change integer liItm1 integer liItm2 returns integer
88402>>>        integer liRval liColumns
88402>>>        get Grid_Columns self to liColumns
88403>>>        forward get msg_item_change liItm1 liItm2 to liRval
88405>>>        if (liItm1/liColumns) ne (liItm2/liColumns) send row_change (liItm1/liColumns) (liItm2/liColumns)
88408>>>        procedure_return liRval
88409>>>      end_procedure
88410>>>
88410>>>      procedure ActivateRecordsRow integer liRow
88413>>>        integer liTable liBase liRecnum
88413>>>        get Grid_RowBaseItem self liRow to liBase
88414>>>
88414>>>        get piTable1 of (phComparer(self)) to liTable
88415>>>        clear liTable
88416>>>        if (item_count(self)) begin
88418>>>          get aux_value (liBase+1) to liRecnum
88419>>>          if liRecnum begin
88421>>>            set_field_value liTable 0 to liRecnum
88424>>>            vfind liTable 0 EQ
88426>>>          end
88426>>>>
88426>>>        end
88426>>>>
88426>>>
88426>>>        get piTable2 of (phComparer(self)) to liTable
88427>>>        clear liTable
88428>>>        if (item_count(self)) begin
88430>>>          get aux_value (liBase+2) to liRecnum
88431>>>          if liRecnum begin
88433>>>            set_field_value liTable 0 to liRecnum
88436>>>            vfind liTable 0 EQ
88438>>>          end
88438>>>>
88438>>>        end
88438>>>>
88438>>>      end_procedure
88439>>>
88439>>>      procedure ActivateRecordsCurrentRow
88442>>>        integer liRow
88442>>>        get Grid_CurrentColumn self to liRow
88443>>>        send ActivateRecordsRow liRow
88444>>>      end_procedure
88445>>>
88445>>>    end_object
88446>>>
88446>>>    send aps_goto_max_row
88447>>>    object oValueGrid is a aps.Grid
88449>>>      set peAnchors to (anTop+anLeft+anRight+anBottom)
88450>>>      send GridPrepare_AddColumn "Field name"    AFT_ASCII15
88451>>>      send GridPrepare_AddColumn "Value Table 1" AFT_ASCII30
88452>>>      send GridPrepare_AddColumn "Value Table 2" AFT_ASCII30
88453>>>      send GridPrepare_Apply self FALSE
88454>>>      set select_mode to NO_SELECT
88455>>>      on_key KNEXT_ITEM send switch
88456>>>      on_key KPREVIOUS_ITEM send switch_back
88457>>>      set gridline_mode to GRID_VISIBLE_NONE
88458>>>      set size to 85 0
88459>>>      set peResizeColumn to rcSelectedColumn // Resize mode (rcAll or rcSelectedColumn)
88460>>>      set piResizeColumn to 1                // This is the column to resize
88461>>>
88461>>>      procedure HandleField integer liFile integer liField string lsName integer liType integer liLen integer liPrec integer liRelFile integer liRelField integer liIndex integer liOffSet
88464>>>        integer liBase
88464>>>        if (liType<>DF_OVERLAP) begin
88466>>>          get item_count to liBase
88467>>>          send add_item MSG_NONE lsName
88468>>>          send add_item MSG_NONE ""
88469>>>          send add_item MSG_NONE ""
88470>>>          set aux_value (liBase+1) to liField
88471>>>          set aux_value (liBase+2) to liField
88472>>>          set ItemColor liBase to clBtnFace
88473>>>        end
88473>>>>
88473>>>      end_procedure
88474>>>
88474>>>      procedure fill_field_labels
88477>>>        integer liTable
88477>>>        set dynamic_update_state to FALSE
88478>>>        send delete_data
88479>>>        get piTable1 of (phComparer(self)) to liTable
88480>>>        send FDX_FieldCallBack 0 liTable MSG_HandleField self
88481>>>        send Grid_SetEntryState self FALSE
88482>>>        set dynamic_update_state to TRUE
88483>>>      end_procedure
88484>>>
88484>>>      procedure DisplayRow integer liRow integer liBase
88487>>>        integer liTable liField liType liColor1 liColor2
88487>>>        integer liRec1 liRec2
88487>>>        string lsValue1 lsValue2
88487>>>
88487>>>        get piTable1 of (phComparer(self)) to liTable
88488>>>        get aux_value (liBase+1) to liField
88489>>>        get_field_value liTable 0 to liRec1
88492>>>        if liRec1 get_field_value liTable liField to lsValue1
88497>>>        else move "" to lsValue1
88499>>>        set value (liBase+1) to lsValue1
88500>>>
88500>>>        get piTable2 of (phComparer(self)) to liTable
88501>>>        get_field_value liTable 0 to liRec2
88504>>>        get aux_value (liBase+2) to liField
88505>>>        if liRec2 get_field_value liTable liField to lsValue2
88510>>>        else move "" to lsValue2
88512>>>        set value (liBase+2) to lsValue2
88513>>>
88513>>>        if (lsValue1<>lsValue2) move (RGB_Compose(255,192,192)) to liColor1
88516>>>        else move (RGB_Compose(255,255,255)) to liColor1
88518>>>        move liColor1 to liColor2
88519>>>
88519>>>        ifnot liRec1 begin
88521>>>          move clBtnFace to liColor1
88522>>>          move (RGB_Compose(255,255,255)) to liColor2
88523>>>        end
88523>>>>
88523>>>        ifnot liRec2 begin
88525>>>          move (RGB_Compose(255,255,255)) to liColor1
88526>>>          move clBtnFace to liColor2
88527>>>        end
88527>>>>
88527>>>
88527>>>        set ItemColor (liBase+1) to liColor1
88528>>>        set ItemColor (liBase+2) to liColor2
88529>>>      end_procedure
88530>>>
88530>>>      procedure display_values
88533>>>        send Grid_RowCallBackAll self MSG_DisplayRow self
88534>>>      end_procedure
88535>>>
88535>>>    end_object // oValueGrid
88536>>>
88536>>>    procedure run_compare
88539>>>      integer liTable liIndex lhComp liCount
88539>>>      string lsIndex
88539>>>      get phComparer to lhComp
88540>>>      set value of oTable1 to (psTable1(lhComp))
88541>>>      set value of oTable2 to (psTable2(lhComp))
88542>>>
88542>>>      get piTable1 of lhComp to liTable
88543>>>      get piIndex of lhComp to liIndex
88544>>>
88544>>>      set value of oIndex to (piIndex(phComparer(self)))
88545>>>      get FDX_IndexAsFieldNames 0 liTable liIndex 0 to lsIndex
88546>>>      set value of oIndex to lsIndex
88547>>>
88547>>>      get_attribute DF_FILE_RECORDS_USED of liTable to liCount
88550>>>      set value of oRecords1 to liCount
88551>>>
88551>>>      get piTable2 of lhComp to liTable
88552>>>      get_attribute DF_FILE_RECORDS_USED of liTable to liCount
88555>>>      set value of oRecords2 to liCount
88556>>>
88556>>>      send run_table_comparison of (phComparer(self))
88557>>>
88557>>>      send fill_field_labels of oValueGrid
88558>>>      send fill_list of oResultGrid
88559>>>    end_procedure
88560>>>
88560>>>    object oBtn1 is a aps.Multi_Button
88562>>>      set size to 14 100
88563>>>      on_item "Create missing records" send CreateMissingRecords of oResultGrid
88564>>>      set peAnchors to (anRight+anBottom)
88565>>>    end_object
88566>>>    object oBtn2 is a aps.Multi_Button
88568>>>      on_item "Close" send close_panel
88569>>>      set peAnchors to (anRight+anBottom)
88570>>>    end_object
88571>>>    send aps_locate_multi_buttons
88572>>>
88572>>>    procedure UpdateValueGrid
88575>>>      integer liCompMode
88575>>>      send display_values of oValueGrid
88576>>>      get piCompMode of (phComparer(self)) to liCompMode
88577>>>      set enabled_state of oBtn1 to (liCompMode=CTP_TABLE1_MISSING or liCompMode=CTP_TABLE2_MISSING)
88578>>>    end_procedure
88579>>>
88579>>>    procedure aps_beautify
88582>>>    end_procedure
88583>>>
88583>>>    procedure Close_Panel // Release when closed!
88586>>>      Forward Send Close_Panel
88588>>>      send CloseTables of (phComparer(self))
88589>>>      send destroy of (phComparer(self))
88590>>>      send Deferred_Request_Destroy_Object
88591>>>    end_procedure
88592>>>
88592>>>    move self to OG_Current_Object# // global integer
88593>>>  end_object
88594>>>  send aps_SetMinimumDialogSize OG_Current_Object# // Set minimum size
88595>>>END_DEFINE_OBJECT_GROUP // OG_CompareTableDataView
88596>>>
88596>>>procedure Activate_CompareTables
88599>>>  boolean lbContinue
88599>>>  integer lhComparer
88599>>>
88599>>>  // Create a comparer object:
88599>>>  object oComparer is a cCompareTableData
88601>>>    move self to lhComparer
88602>>>  end_object
88603>>>
88603>>>  get bPopup.i of oCompareTableData_Wiz lhComparer to lbContinue
88604>>>
88604>>>  if lbContinue begin
88606>>>    CREATE_OBJECT_GROUP OG_CompareTableDataView
88609>>>    set phComparer of OG_Current_Object# to lhComparer
88610>>>    send popup to OG_Current_Object#
88611>>>    send run_compare of OG_Current_Object#
88612>>>  end
88612>>>>
88612>>>  else begin
88613>>>    send CloseTables of lhComparer
88614>>>    send destroy of lhComparer
88615>>>  end
88615>>>>
88615>>>end_procedure
88616>>>
88616>>>
88616>
88616>    Use FdxImpor.vw  // Activate_FdxImport_Vw
Including file: fdximpor.vw    (C:\Apps\VDFQuery\AppSrc\fdximpor.vw)
88616>>>Use APS          // Auto Positioning and Sizing classes for VDF
88616>>>Use FDXData.nui  // Class for reading and writing table data to files incl. definition
Including file: fdxdata.nui    (C:\Apps\VDFQuery\AppSrc\fdxdata.nui)
88616>>>>>// Use FDXData.nui  // Class for reading and writing table data to files incl. definition
88616>>>>>//  This file contains data from a #DataFlex# system in a machine readable
88616>>>>>//  format
88616>>>>>//  -- BEGIN HEADER --
88616>>>>>//  FDX DATA 1.0
88616>>>>>//  Date format.......:
88616>>>>>//  Date separator....:
88616>>>>>//  Decimal separator.:
88616>>>>>//  Table definition:
88616>>>>>//  -- END HEADER --
88616>>>>>//  -- BEGIN DATA --
88616>>>>>//    ...Data goes here...
88616>>>>>//  -- END DATA --
88616>>>>>
88616>>>>>use dfallent
88616>>>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
88616>>>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
88616>>>>>Use FDX.utl      // cFDX class
Including file: fdx.utl    (C:\Apps\VDFQuery\AppSrc\fdx.utl)
88616>>>>>>>Use FDX.nui      // cFDX class
88616>>>>>Use FdxCompa.nui // Class for comparing table definitions
88616>>>>>Use FdxIndex.utl // Index analysing functions
88616>>>>>
88616>>>>>desktop_section
88621>>>>>  // This object is used when figuring out whether there are any differences
88621>>>>>  // between a table definition in a sequential file and a particular table.
88621>>>>>  object oFDXDataTmpCompareResult is a cDummyCompareResultReciever NO_IMAGE
88623>>>>>  end_object
88624>>>>>end_desktop_section
88629>>>>>
88629>>>>>// A FieldMap-object is a simple array holding a number of field numbers
88629>>>>>// (in sequence).
88629>>>>>
88629>>>>>class cFdxRecordBuffer is a cArray
88630>>>>>  procedure construct_object integer liImage
88632>>>>>    forward send construct_object liImage
88634>>>>>    property integer phFDX_Object          public 0
88635>>>>>    property integer pbBinaryFieldsPresent public DFFALSE
88636>>>>>  end_procedure
88637>>>>>
88637>>>>>  // Sets pbBinaryFieldsPresent
88637>>>>>  procedure AnalyseFdx
88639>>>>>    integer lhFdx liFile liMaxField liField liType
88639>>>>>    get phFDX_Object to lhFdx
88640>>>>>    get piMainFile of lhFdx to liFile
88641>>>>>    set pbBinaryFieldsPresent to DFFALSE
88642>>>>>    get FDX_AttrValue_FILE lhFdx DF_FILE_NUMBER_FIELDS liFile to liMaxField
88643>>>>>
88643>>>>>    for liField from 1 to liMaxField
88649>>>>>>
88649>>>>>      get FDX_AttrValue_FIELD lhFdx DF_FIELD_TYPE liFile liField to liType
88650>>>>>      if liType eq DF_BINARY begin
88652>>>>>        set pbBinaryFieldsPresent to DFTRUE
88653>>>>>        procedure_return
88654>>>>>      end
88654>>>>>>
88654>>>>>    loop
88655>>>>>>
88655>>>>>  end_procedure
88656>>>>>
88656>>>>>  // Finds eq in liFile based on current values and lhFieldMap object.
88656>>>>>  function iFindEqIndex integer liFile integer liOrdering integer lhFieldMap returns integer
88658>>>>>    integer liItem liMax liField
88658>>>>>    clear liFile
88659>>>>>    get item_count of lhFieldMap to liMax
88660>>>>>    decrement liMax
88661>>>>>    for liItem from 0 to liMax
88667>>>>>>
88667>>>>>      get value of lhFieldMap item liItem to liField
88668>>>>>      if liField begin
88670>>>>>        set_field_value liFile liField to (value(self,liItem))
88673>>>>>      end
88673>>>>>>
88673>>>>>    loop
88674>>>>>>
88674>>>>>    vfind liFile liOrdering EQ
88676>>>>>    function_return (found)
88677>>>>>  end_function
88678>>>>>
88678>>>>>  function iReadRecordFromSeq integer liChannel returns integer
88680>>>>>    integer liPos lbSeqEof lbSneakMode liField liMaxField
88680>>>>>    integer lhFdx liFile liType liLen
88680>>>>>    string lsRval lsValue
88680>>>>>
88680>>>>>    send delete_data
88681>>>>>    get_channel_position liChannel to liPos
88682>>>>>>
88682>>>>>
88682>>>>>    get phFDX_Object to lhFdx
88683>>>>>    get piMainFile of lhFdx to liFile
88684>>>>>    get FDX_AttrValue_FILE lhFdx DF_FILE_NUMBER_FIELDS liFile to liMaxField
88685>>>>>
88685>>>>>    for liField from 1 to liMaxField
88691>>>>>>
88691>>>>>      get FDX_AttrValue_FIELD lhFdx DF_FIELD_TYPE liFile liField to liType
88692>>>>>      if liType ne DF_OVERLAP begin
88694>>>>>        if (liType=DF_BINARY or liType=DF_TEXT) begin
88696>>>>>          readln liLen
88697>>>>>          read_block lsValue liLen
88698>>>>>          if liType eq DF_TEXT set value item liField to lsValue
88701>>>>>        end
88701>>>>>>
88701>>>>>        else begin
88702>>>>>          readln lsValue
88703>>>>>          set value item liField to lsValue
88704>>>>>        end
88704>>>>>>
88704>>>>>      end
88704>>>>>>
88704>>>>>    loop
88705>>>>>>
88705>>>>>    move (seqeof) to lbSeqEof
88706>>>>>
88706>>>>>    if (pbBinaryFieldsPresent(self)) begin
88708>>>>>      // If binary fields are in the file we leave the channel posistion
88708>>>>>      // ready to reread.
88708>>>>>      move (liPos>0) to lbSneakMode
88709>>>>>      if lbSneakMode decrement liPos
88712>>>>>      set_channel_position liChannel to liPos
88713>>>>>>
88713>>>>>      if lbSneakMode read_block channel liChannel lsValue 1
88717>>>>>      indicate seqeof as lbSeqEof ne 0
88718>>>>>    end
88718>>>>>>
88718>>>>>    function_return (not(lbSeqEof))
88719>>>>>  end_function
88720>>>>>
88720>>>>>  procedure MoveToBuffer integer liChannel integer liFile integer lhFieldMap
88722>>>>>    integer liMaxField liField liMappedField liType liLen liMax liItem
88722>>>>>    integer lhFdx
88722>>>>>    string lsValue
88722>>>>>    if (pbBinaryFieldsPresent(self)) begin // Reread values from SEQ file
88724>>>>>      get phFDX_Object to lhFdx
88725>>>>>      get piMainFile of lhFdx to liFile
88726>>>>>      get FDX_AttrValue_FILE lhFdx DF_FILE_NUMBER_FIELDS liFile to liMaxField
88727>>>>>
88727>>>>>      for liField from 1 to liMaxField
88733>>>>>>
88733>>>>>        get FDX_AttrValue_FIELD lhFdx DF_FIELD_TYPE liFile liField to liType
88734>>>>>        if liType ne DF_OVERLAP begin
88736>>>>>          if (liType=DF_BINARY or liType=DF_TEXT) begin
88738>>>>>            readln liLen
88739>>>>>            read_block channel liChannel lsValue liLen
88741>>>>>          end
88741>>>>>>
88741>>>>>          else readln channel liChannel lsValue
88744>>>>>          get value of lhFieldMap item liField to liMappedField
88745>>>>>          if liMappedField begin
88747>>>>>            set_field_value liFile liMappedField to lsValue
88750>>>>>          end
88750>>>>>>
88750>>>>>        end
88750>>>>>>
88750>>>>>      loop
88751>>>>>>
88751>>>>>    end
88751>>>>>>
88751>>>>>    else begin // Read values from array
88752>>>>>      get item_count of lhFieldMap to liMax
88753>>>>>      decrement liMax
88754>>>>>      for liItem from 0 to liMax
88760>>>>>>
88760>>>>>        get value of lhFieldMap item liItem to liField
88761>>>>>        if liField begin
88763>>>>>          set_field_value liFile liField to (value(self,liItem))
88766>>>>>        end
88766>>>>>>
88766>>>>>      loop
88767>>>>>>
88767>>>>>    end
88767>>>>>>
88767>>>>>  end_procedure
88768>>>>>end_class // cFdxRecordBuffer
88769>>>>>
88769>>>>>class cFDXDataFile is a cArray
88770>>>>>  procedure construct_object integer liImage
88772>>>>>    forward send construct_object liImage
88774>>>>>    property integer piDateFormat     public 0 // DF_DATE_USA DF_DATE_EUROPEAN DF_DATE_MILITARY
88775>>>>>    property integer piDateSep        public 0 // DF_DATE_SEPARATOR
88776>>>>>    property integer piDecSep         public 0 // DF_DECIMAL_SEPARATOR
88777>>>>>    property string  psTitle          public "DataFlex"
88778>>>>>    property integer piOverwriteIndex public 0
88779>>>>>
88779>>>>>    property integer private.IdenticalDefinitions public DFFALSE
88780>>>>>    property integer pbReadInOneTransaction       public DFTRUE
88781>>>>>    property integer pbDisableIndicesWhileReading public DFFALSE
88782>>>>>    property integer pbNoCheckState               public DFFALSE
88783>>>>>
88783>>>>>    object oSeqFileFDX is a cFdxFileDef NO_IMAGE
88785>>>>>    end_object
88786>>>>>    object oTableFDX is a cFdxFileDef NO_IMAGE
88788>>>>>    end_object
88789>>>>>    object oTableReadFieldMap is a cArray NO_IMAGE
88791>>>>>      //
88791>>>>>    end_object
88792>>>>>    object oUniqueIndices is a cArray NO_IMAGE
88794>>>>>      // Note that there should never be more than one (unique) index
88794>>>>>      // intended for overwrite. The reason is that it is not possible
88794>>>>>      // to handle a record from the file conflicting with two different
88794>>>>>      // records on two different unique indices if both are in overwrite
88794>>>>>      // more.
88794>>>>>    end_object
88795>>>>>    object oReadValues is a cFdxRecordBuffer NO_IMAGE
88797>>>>>      set phFDX_Object to (oSeqFileFDX(self))
88798>>>>>    end_object
88799>>>>>  end_procedure
88800>>>>>
88800>>>>>  function iSeedBuffer integer liFile returns integer
88802>>>>>    integer liMax liRow lhUniqueIndices liIndex lhReadValues liFound
88802>>>>>    integer lhTableReadFieldMap
88802>>>>>    move (oUniqueIndices(self)) to lhUniqueIndices
88803>>>>>    move (oReadValues(self)) to lhReadValues
88804>>>>>    move (oTableReadFieldMap(self)) to lhTableReadFieldMap
88805>>>>>    get item_count of lhUniqueIndices to liMax
88806>>>>>    decrement liMax
88807>>>>>    for liRow from 0 to liMax
88813>>>>>>
88813>>>>>      get value of lhUniqueIndices to liIndex
88814>>>>>      get iFindEqIndex of lhReadValues liFile liIndex lhTableReadFieldMap to liFound
88815>>>>>      if liFound function_return 0
88818>>>>>    loop
88819>>>>>>
88819>>>>>    get piOverwriteIndex to liIndex
88820>>>>>    if liIndex get iFindEqIndex of lhReadValues liFile liIndex lhTableReadFieldMap to liFound
88823>>>>>    function_return 1
88824>>>>>  end_function
88825>>>>>
88825>>>>>  procedure DoReset
88827>>>>>    send delete_data to (oTableReadFieldMap(self))
88828>>>>>    send delete_data to (oUniqueIndices(self))
88829>>>>>    send delete_data to (oReadValues(self))
88830>>>>>    send Reset to (oTableFDX(self))
88831>>>>>    send Reset to (oSeqFileFDX(self))
88832>>>>>  end_procedure
88833>>>>>  procedure DoAutoSetupIndexHandling integer liOverwriteIndex
88835>>>>>    integer liIndex lhFDX liFile lhUniqueIndices liItem
88835>>>>>    move (oTableFDX(self)) to lhFDX
88836>>>>>    move (oUniqueIndices(self)) to lhUniqueIndices
88837>>>>>    send delete_data to lhUniqueIndices
88838>>>>>    get piMainFile of lhFDX to liFile
88839>>>>>    set piOverwriteIndex to 0
88840>>>>>    for liIndex from 1 to 15
88846>>>>>>
88846>>>>>      if (FDX_IndexUnique(lhFDX,liFile,liIndex)) begin
88848>>>>>        if (liIndex=liOverwriteIndex) set piOverwriteIndex to liIndex
88851>>>>>        else begin
88852>>>>>          get item_count of lhUniqueIndices to liItem
88853>>>>>          set value of lhUniqueIndices item liItem to liIndex
88854>>>>>        end
88854>>>>>>
88854>>>>>      end
88854>>>>>>
88854>>>>>    loop
88855>>>>>>
88855>>>>>  end_procedure
88856>>>>>  function iRecordExists integer liIndex returns integer
88858>>>>>  end_function
88859>>>>>
88859>>>>>           procedure DoWaitOn string lsValue
88861>>>>>           end_procedure
88862>>>>>           procedure DoWaitUpdate string lsValue
88864>>>>>           end_procedure
88865>>>>>           procedure DoWaitOff
88867>>>>>           end_procedure
88868>>>>>           function iCancel returns integer
88870>>>>>           end_function
88871>>>>>
88871>>>>>           // File must be open before calling this
88871>>>>>           procedure DoReadTableDefinition integer liFile
88873>>>>>             send Reset to (oTableFDX(self))
88874>>>>>             send Read_File_Definition.i to (oTableFDX(self)) liFile
88875>>>>>           end_procedure
88876>>>>>           procedure DoWriteHeader integer liChannel
88878>>>>>             set piDateFormat to (API_AttrValue_GLOBAL(DF_DATE_FORMAT))
88879>>>>>             set piDateSep    to (API_AttrValue_GLOBAL(DF_DATE_SEPARATOR))
88880>>>>>             set piDecSep     to (API_AttrValue_GLOBAL(DF_DECIMAL_SEPARATOR))
88881>>>>>             writeln channel liChannel ("This file contains data from a "+psTitle(self)+" system in a machine readable format.")
88884>>>>>             writeln "-- BEGIN HEADER --"
88886>>>>>             writeln "FDX DATA 1.0"
88888>>>>>             writeln ("Date format.......: "+string(piDateFormat(self)))
88890>>>>>             writeln ("Date separator....: "+string(piDateSep(self)))
88892>>>>>             writeln ("Decimal separator.: "+string(piDecSep(self)))
88894>>>>>             writeln "Table definition: "
88896>>>>>             send Seq_Write to (oTableFDX(self)) liChannel
88897>>>>>             writeln "-- END HEADER --"
88899>>>>>             writeln "-- BEGIN DATA --"
88901>>>>>           end_procedure
88902>>>>>           procedure DoWriteAllData integer liChannel integer liFile integer liOrdering
88904>>>>>             integer liIsSystemFile liFound liReccount liRecords
88904>>>>>             get_attribute DF_FILE_IS_SYSTEM_FILE of liFile to liIsSystemFile
88907>>>>>             if liIsSystemFile send SEQ_WriteRecordBuffer_LD liChannel liFile
88910>>>>>             else begin
88911>>>>>               get_attribute DF_FILE_RECORDS_USED of liFile to liRecords
88914>>>>>               send DoWaitOn "Writing table data"
88915>>>>>               clear liFile
88916>>>>>               move 0 to liReccount
88917>>>>>               repeat
88917>>>>>>
88917>>>>>                 vfind liFile liOrdering GT
88919>>>>>                 move (found) to liFound
88920>>>>>                 if liFound begin
88922>>>>>                   increment liReccount
88923>>>>>                   send DoWaitUpdate (string(liReccount)+"/"+string(liRecords))
88924>>>>>                   send SEQ_WriteRecordBuffer_LD liChannel liFile
88925>>>>>                 end
88925>>>>>>
88925>>>>>               until (not(liFound))
88927>>>>>             end
88927>>>>>>
88927>>>>>           end_procedure
88928>>>>>
88928>>>>>  procedure DoWriteTable integer liChannel integer liFile
88930>>>>>    send DoReadTableDefinition liFile
88931>>>>>    send DoWriteHeader liChannel
88932>>>>>    send DoWriteAllData liChannel liFile 0
88933>>>>>  end_procedure
88934>>>>>
88934>>>>>           // Return value: 0=OK 1=Incompatible format
88934>>>>>           function DoReadHeader integer liChannel returns integer
88936>>>>>             string lsValue
88936>>>>>             if (SEQ_ReadLnUntilValue(liChannel,"-- BEGIN HEADER --")) begin
88938>>>>>               if (SEQ_ReadLnUntilValue(liChannel,"FDX DATA 1.0")) begin
88940>>>>>                 readln channel liChannel lsValue
88942>>>>>                 set piDateFormat to (StringRightBut(lsValue,20))
88943>>>>>                 readln channel liChannel lsValue
88945>>>>>                 set piDateSep    to (StringRightBut(lsValue,20))
88946>>>>>                 readln channel liChannel lsValue
88948>>>>>                 set piDecSep     to (StringRightBut(lsValue,20))
88949>>>>>                 readln channel liChannel lsValue // Skip 'Table definition: '
88951>>>>>                 send Seq_Read to (oSeqFileFDX(self)) liChannel
88952>>>>>                 send AnalyseFdx to (oReadValues(self))
88953>>>>>                 if (SEQ_ReadLnUntilValue(liChannel,"-- END HEADER --")) function_return 0
88956>>>>>               end
88956>>>>>>
88956>>>>>             end
88956>>>>>>
88956>>>>>             function_return 1 // Incompatible format
88957>>>>>           end_function
88958>>>>>
88958>>>>>  function lbIsFdxDataFile string lsFileName returns integer
88960>>>>>    integer liChannel liRval
88960>>>>>    get SEQ_DirectInput lsFileName to liChannel
88961>>>>>    if (liChannel>=0) begin
88963>>>>>      get DoReadHeader liChannel to liRval
88964>>>>>      send SEQ_CloseInput liChannel
88965>>>>>    end
88965>>>>>>
88965>>>>>    else move DFFALSE to liRval
88967>>>>>    function_return (not(liRval))
88968>>>>>  end_function
88969>>>>>
88969>>>>>           // Function returns 1 if there's a difference in field definitions,
88969>>>>>           // otherwise 0
88969>>>>>           function iCompareFDXs returns integer
88971>>>>>             integer lhFDXDataTmpCompareResult liFile1 liFile2 lhFDX1 lhFDX2
88971>>>>>             move (oFDXDataTmpCompareResult(self)) to lhFDXDataTmpCompareResult
88972>>>>>             move (oSeqFileFDX(self)) to lhFDX1
88973>>>>>             move (oTableFDX(self)) to lhFDX2
88974>>>>>             get piMainFile of lhFDX1 to liFile1
88975>>>>>             get piMainFile of lhFDX2 to liFile2
88976>>>>>             get iFdxCompareTables.iiiiii lhFDXDataTmpCompareResult lhFDX1 liFile1 lhFDX2 liFile2 FDXCOMP_MODE_ALL to lhFDXDataTmpCompareResult
88977>>>>>             function_return (piField_Change(lhFDXDataTmpCompareResult))
88978>>>>>           end_function
88979>>>>>           //
88979>>>>>           function iReadAutoSetup returns integer
88981>>>>>             integer liChanged
88981>>>>>             get iCompareFDXs to liChanged
88982>>>>>             set private.IdenticalDefinitions to (not(liChanged))
88983>>>>>           end_function
88984>>>>>
88984>>>>>           procedure DisableIndices integer liFile
88986>>>>>           end_procedure
88987>>>>>           procedure EnableIndices integer liFile
88989>>>>>           end_procedure
88990>>>>>
88990>>>>>           procedure DoReadData integer liChannel integer liFile
88992>>>>>             integer lbDisableIndicesWhileReading
88992>>>>>             integer lbIdenticalDefinitions
88992>>>>>             integer lbReadInOneTransaction
88992>>>>>             integer lhReadValues liFinish liReccount
88992>>>>>             string lsValue
88992>>>>>
88992>>>>>             move (oReadValues(self)) to lhReadValues
88993>>>>>
88993>>>>>             readln channel liChannel lsValue // Skip '-- BEGIN DATA --'
88995>>>>>
88995>>>>>             get pbDisableIndicesWhileReading to lbDisableIndicesWhileReading
88996>>>>>             get private.IdenticalDefinitions to lbIdenticalDefinitions
88997>>>>>             get pbReadInOneTransaction       to lbReadInOneTransaction
88998>>>>>
88998>>>>>             if lbIdenticalDefinitions begin // No field mapping
89000>>>>>               if lbDisableIndicesWhileReading send DisableIndices liFile
89003>>>>>               if lbReadInOneTransaction lock
89006>>>>>
89006>>>>>                 if (pbNoCheckState(self)) begin // Do not check indices
89008>>>>>                   move DFFALSE to liFinish
89009>>>>>                   repeat
89009>>>>>>
89009>>>>>                     clear liFile
89010>>>>>                     send SEQ_ReadRecordBuffer_LD liFile
89011>>>>>                     move (SeqEof) to liFinish
89012>>>>>                     ifnot liFinish begin
89014>>>>>                       saverecord liFile
89015>>>>>                       increment liReccount
89016>>>>>                       send DoWaitUpdate (string(liReccount)+" records read")
89017>>>>>                     end
89017>>>>>>
89017>>>>>                   until liFinish
89019>>>>>                 end
89019>>>>>>
89019>>>>>                 else begin // Check indices
89020>>>>>                   while (iReadRecordFromSeq(lhReadValues))
89024>>>>>                     if (iSeedBuffer(lhReadValues,liFile)) begin
89026>>>>>
89026>>>>>                     end
89026>>>>>>
89026>>>>>                   end
89027>>>>>>
89027>>>>>                 end
89027>>>>>>
89027>>>>>
89027>>>>>               if lbReadInOneTransaction unlock
89030>>>>>               if lbDisableIndicesWhileReading send EnableIndices liFile
89033>>>>>             end
89033>>>>>>
89033>>>>>             else begin
89034>>>>>             end
89034>>>>>>
89034>>>>>           end_procedure
89035>>>>>
89035>>>>>end_class // cFDXDataFile
89036>>>>>
89036>>>>>/// open hkasag
89036>>>>>///
89036>>>>>/// object oTest is a cFDXDataFile NO_IMAGE
89036>>>>>///   direct_output channel 3 "Unload.txt"
89036>>>>>///   send DoWriteTable 3 hkasag.file_number
89036>>>>>///   close_output channel 3
89036>>>>>/// end_object
89036>>>Use TextData.pkg // Properties for text data file (Popup_TextDataProperties)
Including file: textdata.pkg    (C:\Apps\VDFQuery\AppSrc\textdata.pkg)
89036>>>>>// Use TextData.pkg // Properties for text data file (Popup_TextDataProperties)
89036>>>>>
89036>>>>>Use APS          // Auto Positioning and Sizing classes for VDF
89036>>>>>Use TextData.nui // cTextDataReader class
Including file: textdata.nui    (C:\Apps\VDFQuery\AppSrc\textdata.nui)
89036>>>>>>>// Use TextData.nui // cTextDataReader class
89036>>>>>>>
89036>>>>>>>Use DFAllent
89036>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
89036>>>>>>>Use Files.nui    // Utilities for handling file related stuff
89036>>>>>>>Use Spec0008.utl // Small arrays with integer Codes (Dictionaries)
89036>>>>>>>Use GlobalFunctionsProcedures.pkg // DAW thing
89036>>>>>>>Use Mapper.nui   // Classes for (field) mapping
89036>>>>>>>Use Spec0015.nui // Functions StringIsDate and StringIsDateTime
Including file: spec0015.nui    (C:\Apps\VDFQuery\AppSrc\spec0015.nui)
89036>>>>>>>>>// Use Spec0015.nui // Functions StringIsDate and StringIsDateTime
89036>>>>>>>>>Use Strings.nui  // String manipulation for VDF and 3.1 (No User Interface)
89036>>>>>>>>>Use Dates.nui    // Date routines (No User Interface)
89036>>>>>>>>>
89036>>>>>>>>>// Function returns DFTRUE if the string contains a legal date.
89036>>>>>>>>>function StringIsDate global string lsValue integer liDateSep integer liFormat returns integer
89038>>>>>>>>>  integer liCurrentDF liCurrentSep liLen
89038>>>>>>>>>  string lsDateSep lsYear lsMonth lsDay
89038>>>>>>>>>  move (trim(lsValue)) to lsValue
89039>>>>>>>>>  move (length(lsValue)) to liLen
89040>>>>>>>>>  if liLen eq 0 function_return DFTRUE
89043>>>>>>>>>
89043>>>>>>>>>  ifnot liDateSep begin
89045>>>>>>>>>    if (length(lsValue)=7) move (append("0",lsValue)) to lsValue
89048>>>>>>>>>    if (liFormat=DF_DATE_MILITARY) begin // YMD 05061962
89050>>>>>>>>>      insert "#" in lsValue at 7
89052>>>>>>>>>      insert "#" in lsValue at 5
89054>>>>>>>>>    end
89054>>>>>>>>>>
89054>>>>>>>>>    else begin
89055>>>>>>>>>      insert "#" in lsValue at 5
89057>>>>>>>>>      insert "#" in lsValue at 3
89059>>>>>>>>>    end
89059>>>>>>>>>>
89059>>>>>>>>>    move "#" to lsDateSep
89060>>>>>>>>>    if (liLen<7 or liLen>8) function_return DFFALSE
89063>>>>>>>>>  end
89063>>>>>>>>>>
89063>>>>>>>>>  else begin
89064>>>>>>>>>    move (character(liDateSep)) to lsDateSep
89065>>>>>>>>>    if (liLen<5 or liLen>10) function_return DFFALSE
89068>>>>>>>>>  end
89068>>>>>>>>>>
89068>>>>>>>>>  if (HowManyWords(lsValue,lsDateSep)<>3) function_return DFFALSE
89071>>>>>>>>>
89071>>>>>>>>>  if (liFormat=DF_DATE_EUROPEAN) begin // DMY
89073>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,1)) to lsDay
89074>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,2)) to lsMonth
89075>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,3)) to lsYear
89076>>>>>>>>>  end
89076>>>>>>>>>>
89076>>>>>>>>>  if (liFormat=DF_DATE_USA) begin      // MDY
89078>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,1)) to lsMonth
89079>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,2)) to lsDay
89080>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,3)) to lsYear
89081>>>>>>>>>  end
89081>>>>>>>>>>
89081>>>>>>>>>  if (liFormat=DF_DATE_MILITARY) begin // YMD
89083>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,1)) to lsYear
89084>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,2)) to lsMonth
89085>>>>>>>>>    move (ExtractWord(lsValue,lsDateSep,3)) to lsDay
89086>>>>>>>>>  end
89086>>>>>>>>>>
89086>>>>>>>>>  ifnot (StringIsInteger(lsDay)) function_return DFFALSE
89089>>>>>>>>>  ifnot (StringIsInteger(lsMonth)) function_return DFFALSE
89092>>>>>>>>>  ifnot (StringIsInteger(lsYear)) function_return DFFALSE
89095>>>>>>>>>  function_return (DateIsLegalComponents(lsDay,lsMonth,lsYear))
89096>>>>>>>>>end_function
89097>>>>>>>>>
89097>>>>>>>>>function StringFormatToDate global string lsValue integer liDateSep integer liFormat returns date
89099>>>>>>>>>  integer liDay liMonth liYear
89099>>>>>>>>>  if (liFormat=DF_DATE_EUROPEAN) begin // DMY
89101>>>>>>>>>    move (ExtractInteger(lsValue,1)) to liDay
89102>>>>>>>>>    move (ExtractInteger(lsValue,2)) to liMonth
89103>>>>>>>>>    move (ExtractInteger(lsValue,3)) to liYear
89104>>>>>>>>>  end
89104>>>>>>>>>>
89104>>>>>>>>>  if (liFormat=DF_DATE_USA) begin      // MDY
89106>>>>>>>>>    move (ExtractInteger(lsValue,1)) to liMonth
89107>>>>>>>>>    move (ExtractInteger(lsValue,2)) to liDay
89108>>>>>>>>>    move (ExtractInteger(lsValue,3)) to liYear
89109>>>>>>>>>  end
89109>>>>>>>>>>
89109>>>>>>>>>  if (liFormat=DF_DATE_MILITARY) begin // YMD
89111>>>>>>>>>    move (ExtractInteger(lsValue,1)) to liYear
89112>>>>>>>>>    move (ExtractInteger(lsValue,2)) to liMonth
89113>>>>>>>>>    move (ExtractInteger(lsValue,3)) to liDay
89114>>>>>>>>>  end
89114>>>>>>>>>>
89114>>>>>>>>>  function_return (DateCompose(liDay,liMonth,liYear))
89115>>>>>>>>>end_function
89116>>>>>>>>>
89116>>>>>>>>>function StringIsDateTime global string lsValue integer liDateSep integer liFormat returns integer
89118>>>>>>>>>  string lsDate lsTime lsHour lsMinute lsSecond
89118>>>>>>>>>  if (trim(lsValue)="") function_return DFTRUE
89121>>>>>>>>>  if (HowManyWords(lsValue," ")=2) begin
89123>>>>>>>>>    move (ExtractWord(lsValue," ",1)) to lsDate
89124>>>>>>>>>    move (ExtractWord(lsValue," ",2)) to lsTime
89125>>>>>>>>>    if (HowManyWords(lsTime,":")=3) begin
89127>>>>>>>>>      move (ExtractWord(lsTime,":",1)) to lsHour
89128>>>>>>>>>      move (ExtractWord(lsTime,":",2)) to lsMinute
89129>>>>>>>>>      move (ExtractWord(lsTime,":",3)) to lsSecond
89130>>>>>>>>>      ifnot (StringIsInteger(lsHour)) function_return DFFALSE
89133>>>>>>>>>      ifnot (StringIsInteger(lsMinute)) function_return DFFALSE
89136>>>>>>>>>      ifnot (StringIsInteger(lsSecond)) function_return DFFALSE
89139>>>>>>>>>      if (integer(lsHour)<24 and integer(lsMinute)<60 and integer(lsSecond)<60) function_return (StringIsDate(lsDate,liDateSep,liFormat))
89142>>>>>>>>>    end
89142>>>>>>>>>>
89142>>>>>>>>>  end
89142>>>>>>>>>>
89142>>>>>>>>>  function_return DFFALSE
89143>>>>>>>>>end_function
89144>>>>>>>>>
89144>>>>>>>
89144>>>>>>>
89144>>>>>>>enumeration_list // iFileOpen.s return codes
89144>>>>>>>  define TDATFO_OK
89144>>>>>>>  define TDATFO_FILE_NOT_FOUND
89144>>>>>>>  define TDATFO_FILE_EMPTY
89144>>>>>>>  define TDATFO_NO_ITEMS_ON_FIRST_LINE
89144>>>>>>>  define TDATFO_ILLEGAL_NUMBER_OF_COLUMN_NAMES
89144>>>>>>>end_enumeration_list
89144>>>>>>>
89144>>>>>>>enumeration_list // iReadNext returns codes
89144>>>>>>>  define TDATRN_OK
89144>>>>>>>  define TDATRN_EOF
89144>>>>>>>  define TDATRN_ERROR
89144>>>>>>>end_enumeration_list
89144>>>>>>>
89144>>>>>>>desktop_section
89149>>>>>>>  object oTextDataParameterList is a cIntegerCodeToText
89151>>>>>>>    IntegerCodeList
89151>>>>>>>      Define_IntegerCode TDAT_FIELD_SEP      "Field delimiter"
89152>>>>>>>      Define_IntegerCode TDAT_QUOTATION_CHAR "Quotation character"
89153>>>>>>>      Define_IntegerCode TDAT_DECIMAL_SEP    "Decimal separator"
89154>>>>>>>      Define_IntegerCode TDAT_DATE_SEP       "Date separator"
89155>>>>>>>      Define_IntegerCode TDAT_DATE_FORMAT    "Date format"
89156>>>>>>>      Define_IntegerCode TDAT_COLUMN_NAMES   "Column names in first row"
89157>>>>>>>      Define_IntegerCode TDAT_OEM_CHARSET    "OEM character conversion"
89158>>>>>>>      Define_IntegerCode TDAT_COLUMN_COUNT   "Number of columns"
89159>>>>>>>      Define_IntegerCode TDAT_FIXED_POS      "Fixed positions"
89160>>>>>>>    End_IntegerCodeList
89160>>>>>>>  end_object
89161>>>>>>>  object oTextDataColumnTypes is a cIntegerCodeToText
89163>>>>>>>    IntegerCodeList
89163>>>>>>>      Define_IntegerCode TDAT_CT_UNKNOWN   "Unknown (ASCII)"
89164>>>>>>>      Define_IntegerCode TDAT_CT_NUMBER    "Number"
89165>>>>>>>      Define_IntegerCode TDAT_CT_DATE      "Date"
89166>>>>>>>      Define_IntegerCode TDAT_CT_DATE_TIME "Date-Time"
89167>>>>>>>      Define_IntegerCode TDAT_CT_ASCII     "ASCII"
89168>>>>>>>      Define_IntegerCode TDAT_CT_TEXT      "Text"
89169>>>>>>>    End_IntegerCodeList
89169>>>>>>>  end_object
89170>>>>>>>end_desktop_section
89175>>>>>>>
89175>>>>>>>class cTextDataParameters is a cArray
89176>>>>>>>  procedure construct_object integer liImage
89178>>>>>>>    forward send construct_object
89180>>>>>>>    set value item TDAT_FIELD_SEP      to ";"
89181>>>>>>>    set value item TDAT_QUOTATION_CHAR to '"'
89182>>>>>>>    set value item TDAT_DECIMAL_SEP    to ","
89183>>>>>>>    set value item TDAT_DATE_SEP       to "-"
89184>>>>>>>    set value item TDAT_DATE_FORMAT    to DF_DATE_EUROPEAN
89185>>>>>>>    set value item TDAT_COLUMN_NAMES   to DFTRUE
89186>>>>>>>    set value item TDAT_OEM_CHARSET    to DFFALSE
89187>>>>>>>    set value item TDAT_COLUMN_COUNT   to 0 // Meaning determined by first column
89188>>>>>>>  end_procedure
89189>>>>>>>end_class // cTextDataParameters
89190>>>>>>>
89190>>>>>>>// cTextDataFixedColumnPosistions is a help class to be used from inside
89190>>>>>>>// the cTextDataReader class when reading fixed column data formats.
89190>>>>>>>class cTextDataFixedColumnPositions is a cArray
89191>>>>>>>  item_property_list
89191>>>>>>>    item_property integer piColumnStart.i
89191>>>>>>>    item_property integer piColumnWidth.i
89191>>>>>>>  end_item_property_list cTextDataFixedColumnPositions
#REM 89223 DEFINE FUNCTION PICOLUMNWIDTH.I INTEGER LIROW RETURNS INTEGER
#REM 89227 DEFINE PROCEDURE SET PICOLUMNWIDTH.I INTEGER LIROW INTEGER VALUE
#REM 89231 DEFINE FUNCTION PICOLUMNSTART.I INTEGER LIROW RETURNS INTEGER
#REM 89235 DEFINE PROCEDURE SET PICOLUMNSTART.I INTEGER LIROW INTEGER VALUE
89240>>>>>>>end_class // cTextDataFixedColumnPositions
89241>>>>>>>
89241>>>>>>>class cAnalyseLog is a cArray
89242>>>>>>>  item_property_list
89242>>>>>>>    item_property integer piColumn.i
89242>>>>>>>    item_property integer piLine.i
89242>>>>>>>    item_property string  psValue.i
89242>>>>>>>    item_property string  psComment.i
89242>>>>>>>  end_item_property_list cAnalyseLog
#REM 89280 DEFINE FUNCTION PSCOMMENT.I INTEGER LIROW RETURNS STRING
#REM 89284 DEFINE PROCEDURE SET PSCOMMENT.I INTEGER LIROW STRING VALUE
#REM 89288 DEFINE FUNCTION PSVALUE.I INTEGER LIROW RETURNS STRING
#REM 89292 DEFINE PROCEDURE SET PSVALUE.I INTEGER LIROW STRING VALUE
#REM 89296 DEFINE FUNCTION PILINE.I INTEGER LIROW RETURNS INTEGER
#REM 89300 DEFINE PROCEDURE SET PILINE.I INTEGER LIROW INTEGER VALUE
#REM 89304 DEFINE FUNCTION PICOLUMN.I INTEGER LIROW RETURNS INTEGER
#REM 89308 DEFINE PROCEDURE SET PICOLUMN.I INTEGER LIROW INTEGER VALUE
89313>>>>>>>  procedure DoAddLogEntry integer liLine integer liColumn string lsValue string lsComment
89315>>>>>>>    integer liRow
89315>>>>>>>    get row_count to liRow
89316>>>>>>>    set piColumn.i  liRow to liColumn
89317>>>>>>>    set piLine.i    liRow to liLine
89318>>>>>>>    set psValue.i   liRow to lsValue
89319>>>>>>>    set psComment.i liRow to lsComment
89320>>>>>>>  end_procedure
89321>>>>>>>  procedure DoReset
89323>>>>>>>    send delete_data
89324>>>>>>>  end_procedure
89325>>>>>>>end_class // cAnalyseLog
89326>>>>>>>
89326>>>>>>>class cTextDataColumnAnalyser is a cArray
89327>>>>>>>  item_property_list
89327>>>>>>>    item_property integer piDataType.i   //
89327>>>>>>>    item_property integer piMaxLength.i
89327>>>>>>>    item_property integer piMaxDecimals.i
89327>>>>>>>    item_property integer piCantBeNumber.i
89327>>>>>>>    item_property integer piCantBeDate.i
89327>>>>>>>    item_property integer piCantBeDateTime.i
89327>>>>>>>  end_item_property_list cTextDataColumnAnalyser
#REM 89371 DEFINE FUNCTION PICANTBEDATETIME.I INTEGER LIROW RETURNS INTEGER
#REM 89375 DEFINE PROCEDURE SET PICANTBEDATETIME.I INTEGER LIROW INTEGER VALUE
#REM 89379 DEFINE FUNCTION PICANTBEDATE.I INTEGER LIROW RETURNS INTEGER
#REM 89383 DEFINE PROCEDURE SET PICANTBEDATE.I INTEGER LIROW INTEGER VALUE
#REM 89387 DEFINE FUNCTION PICANTBENUMBER.I INTEGER LIROW RETURNS INTEGER
#REM 89391 DEFINE PROCEDURE SET PICANTBENUMBER.I INTEGER LIROW INTEGER VALUE
#REM 89395 DEFINE FUNCTION PIMAXDECIMALS.I INTEGER LIROW RETURNS INTEGER
#REM 89399 DEFINE PROCEDURE SET PIMAXDECIMALS.I INTEGER LIROW INTEGER VALUE
#REM 89403 DEFINE FUNCTION PIMAXLENGTH.I INTEGER LIROW RETURNS INTEGER
#REM 89407 DEFINE PROCEDURE SET PIMAXLENGTH.I INTEGER LIROW INTEGER VALUE
#REM 89411 DEFINE FUNCTION PIDATATYPE.I INTEGER LIROW RETURNS INTEGER
#REM 89415 DEFINE PROCEDURE SET PIDATATYPE.I INTEGER LIROW INTEGER VALUE
89420>>>>>>>  procedure DoReset
89422>>>>>>>    send delete_data
89423>>>>>>>  end_procedure
89424>>>>>>>  procedure DoAddCurrentRow integer lhAnalyseLog
89426>>>>>>>    integer liMax liRow lhParent liLen liDecPos liDateFormat liDecChar
89426>>>>>>>    integer lhTextDataParameters liLine liDateSep
89426>>>>>>>    string lsValue lsDecChar lsDateSep
89426>>>>>>>    move (parent(self)) to lhParent
89427>>>>>>>
89427>>>>>>>    get phTextDataParameters of lhParent to lhTextDataParameters
89428>>>>>>>    get value of lhTextDataParameters item TDAT_DECIMAL_SEP to lsDecChar
89429>>>>>>>    move (ascii(lsDecChar)) to liDecChar
89430>>>>>>>    get value of lhTextDataParameters item TDAT_DATE_SEP    to lsDateSep
89431>>>>>>>    move (ascii(lsDateSep)) to liDateSep
89432>>>>>>>    get value of lhTextDataParameters item TDAT_DATE_FORMAT to liDateFormat
89433>>>>>>>
89433>>>>>>>    //send obs "Format:" liDateFormat "Separator:" lsDateSep
89433>>>>>>>
89433>>>>>>>    get item_count  of lhParent to liMax
89434>>>>>>>    get piCurrentRowStartedInLine of lhParent to liLine
89435>>>>>>>    decrement liMax
89436>>>>>>>    for liRow from 0 to liMax
89442>>>>>>>>
89442>>>>>>>      get value of lhParent liRow to lsValue
89443>>>>>>>      move (length(lsValue)) to liLen
89444>>>>>>>      if (liLen>piMaxLength.i(self,liRow)) set piMaxLength.i liRow to liLen
89447>>>>>>>
89447>>>>>>>      // Is it a text field?
89447>>>>>>>      if (pos(character(10),lsValue)) begin
89449>>>>>>>        ifnot (piDataType.i(self,liRow)) begin // If not already determined
89451>>>>>>>          set piDataType.i liRow to TDAT_CT_TEXT
89452>>>>>>>          send DoAddLogEntry to lhAnalyseLog liLine liRow lsValue "contains text data"
89453>>>>>>>        end
89453>>>>>>>>
89453>>>>>>>      end
89453>>>>>>>>
89453>>>>>>>      else begin
89454>>>>>>>        move (pos(lsDecChar,lsValue)) to liDecPos
89455>>>>>>>        if (liDecPos and (liLen-liDecPos)>piMaxDecimals.i(self,liRow)) set piMaxDecimals.i liRow to (liLen-liDecPos)
89458>>>>>>>        ifnot (piDataType.i(self,liRow)) begin // If not already determined
89460>>>>>>>          ifnot (piCantBeNumber.i(self,liRow)) begin // It could still be a number
89462>>>>>>>            ifnot (StringIsNumber(lsValue,liDecChar)) begin
89464>>>>>>>              set piCantBeNumber.i liRow to DFTRUE
89465>>>>>>>              send DoAddLogEntry to lhAnalyseLog liLine liRow lsValue "can not be number"
89466>>>>>>>            end
89466>>>>>>>>
89466>>>>>>>          end
89466>>>>>>>>
89466>>>>>>>          ifnot (piCantBeDate.i(self,liRow)) begin // It could still be a date
89468>>>>>>>            ifnot (StringIsDate(lsValue,liDateSep,liDateFormat)) begin
89470>>>>>>>              set piCantBeDate.i liRow to DFTRUE
89471>>>>>>>              send DoAddLogEntry to lhAnalyseLog liLine liRow lsValue "can not be date"
89472>>>>>>>            end
89472>>>>>>>>
89472>>>>>>>          end
89472>>>>>>>>
89472>>>>>>>          ifnot (piCantBeDateTime.i(self,liRow)) begin // It could still be a date-time
89474>>>>>>>            ifnot (StringIsDateTime(lsValue,liDateSep,liDateFormat)) begin
89476>>>>>>>              set piCantBeDateTime.i liRow to DFTRUE
89477>>>>>>>              send DoAddLogEntry to lhAnalyseLog liLine liRow lsValue "can not be date-time"
89478>>>>>>>            end
89478>>>>>>>>
89478>>>>>>>          end
89478>>>>>>>>
89478>>>>>>>          if (piCantBeNumber.i(self,liRow) and piCantBeDate.i(self,liRow) and piCantBeDateTime.i(self,liRow)) begin
89480>>>>>>>            set piDataType.i liRow to TDAT_CT_ASCII
89481>>>>>>>            send DoAddLogEntry to lhAnalyseLog liLine liRow "" "must be ASCII (may change to TEXT)"
89482>>>>>>>          end
89482>>>>>>>>
89482>>>>>>>        end
89482>>>>>>>>
89482>>>>>>>      end
89482>>>>>>>>
89482>>>>>>>    loop
89483>>>>>>>>
89483>>>>>>>  end_procedure
89484>>>>>>>  procedure DoAnalyseFile string lsFileName integer lhAnalyseLog
89486>>>>>>>    integer liResult liMax liRow liCount
89486>>>>>>>    string lsValue
89486>>>>>>>    send DoReset
89487>>>>>>>    send DoReset to lhAnalyseLog
89488>>>>>>>    get iFileOpen.s lsFileName to liResult
89489>>>>>>>    if (liResult=TDATFO_OK) begin
89491>>>>>>>      send SentinelOn ("Analysing "+lsFileName)
89492>>>>>>>      move 0 to liCount
89493>>>>>>>      repeat
89493>>>>>>>>
89493>>>>>>>        get iReadNext to liResult
89494>>>>>>>        if (liResult=TDATRN_OK) begin
89496>>>>>>>          increment liCount
89497>>>>>>>          send DoAddCurrentRow lhAnalyseLog
89498>>>>>>>          send SentinelUpdate1 (string(liCount)+" rows have been read")
89499>>>>>>>        end
89499>>>>>>>>
89499>>>>>>>      until (liResult<>TDATRN_OK)
89501>>>>>>>      send SentinelOff
89502>>>>>>>      if (liResult=TDATRN_ERROR) begin
89504>>>>>>>        get sErrorText to lsValue
89505>>>>>>>        send obs lsValue
89506>>>>>>>      end
89506>>>>>>>>
89506>>>>>>>      get row_count to liMax
89507>>>>>>>      decrement liMax
89508>>>>>>>      for liRow from 0 to liMax
89514>>>>>>>>
89514>>>>>>>        ifnot (piDataType.i(self,liRow)) begin // If not already determined
89516>>>>>>>          if (piCantBeNumber.i(self,liRow)+piCantBeDate.i(self,liRow)+piCantBeDateTime.i(self,liRow)=2) begin
89518>>>>>>>            if (piCantBeNumber.i(self,liRow) and piCantBeDate.i(self,liRow) and not(piCantBeDateTime.i(self,liRow))) begin
89520>>>>>>>              set piDataType.i liRow to TDAT_CT_DATE_TIME
89521>>>>>>>              send DoAddLogEntry to lhAnalyseLog -1 liRow "" "must be date-time"
89522>>>>>>>            end
89522>>>>>>>>
89522>>>>>>>            if (piCantBeNumber.i(self,liRow) and not(piCantBeDate.i(self,liRow)) and piCantBeDateTime.i(self,liRow)) begin
89524>>>>>>>              set piDataType.i liRow to TDAT_CT_DATE
89525>>>>>>>              send DoAddLogEntry to lhAnalyseLog -1 liRow "" "must be date"
89526>>>>>>>            end
89526>>>>>>>>
89526>>>>>>>            if (not(piCantBeNumber.i(self,liRow)) and piCantBeDate.i(self,liRow) and piCantBeDateTime.i(self,liRow)) begin
89528>>>>>>>              set piDataType.i liRow to TDAT_CT_NUMBER
89529>>>>>>>              send DoAddLogEntry to lhAnalyseLog -1 liRow "" "must be number"
89530>>>>>>>            end
89530>>>>>>>>
89530>>>>>>>          end
89530>>>>>>>>
89530>>>>>>>        end
89530>>>>>>>>
89530>>>>>>>      loop
89531>>>>>>>>
89531>>>>>>>    end
89531>>>>>>>>
89531>>>>>>>  end_procedure
89532>>>>>>>end_class // cTextDataColumnAnalyser
89533>>>>>>>
89533>>>>>>>// An object of this class is able to read a line from a sequential file
89533>>>>>>>// and split it into items according to its properties
89533>>>>>>>class cTextDataReader is a cArray
89534>>>>>>>  procedure construct_object integer liImage
89536>>>>>>>    forward send construct_object
89538>>>>>>>
89538>>>>>>>    // Is data in fixed column positions? (if so we need the array):
89538>>>>>>>    property integer pbFixedPositions      public DFFALSE
89539>>>>>>>    // Convert line feeds to spaces:
89539>>>>>>>    property integer pbTransformLFtoSP     public DFFALSE
89540>>>>>>>    // Convert characters below 32 (other than 8, 10 and 13) to spaces:
89540>>>>>>>    property integer pbTransform31toSP     public DFTRUE
89541>>>>>>>    // Number of columns per records:
89541>>>>>>>    property integer piColumnCount         public -1
89542>>>>>>>    property integer piPrivate.OEM         public 0
89543>>>>>>>    //
89543>>>>>>>    property integer phTextDataParameters  public 0
89544>>>>>>>
89544>>>>>>>    // This is used if we are dealing with fixed column positions:
89544>>>>>>>    object oTextDataFixedColumnPositions is a cTextDataFixedColumnPositions
89546>>>>>>>    end_object
89547>>>>>>>    object oColumnHeaders is a cArray
89549>>>>>>>    end_object
89550>>>>>>>    object oTextDataColumnAnalyser is a cTextDataColumnAnalyser
89552>>>>>>>    end_object
89553>>>>>>>    object oAnalyseLog is a cAnalyseLog
89555>>>>>>>    end_object
89556>>>>>>>
89556>>>>>>>    property string  psFileName  public ""
89557>>>>>>>    property integer piLinesRead public 0
89558>>>>>>>    property integer piErrorLine public 0
89559>>>>>>>    property integer piChannel   public 0
89560>>>>>>>    property integer piCurrentRowStartedInLine public 0
89561>>>>>>>  end_procedure
89562>>>>>>>
89562>>>>>>>  procedure SentinelOn string lsCaption
89564>>>>>>>  end_procedure
89565>>>>>>>  procedure SentinelUpdate1 string lsValue
89567>>>>>>>  end_procedure
89568>>>>>>>  procedure SentinelUpdate2 string lsValue
89570>>>>>>>  end_procedure
89571>>>>>>>  procedure SentinelOff
89573>>>>>>>  end_procedure
89574>>>>>>>
89574>>>>>>>  function sErrorText returns string
89576>>>>>>>    function_return ("Illegal number of items on line "+string(piErrorLine(self)))
89577>>>>>>>  end_function
89578>>>>>>>
89578>>>>>>>  function sConvertedValue.i integer liItm returns string
89580>>>>>>>    integer liType liFormat
89580>>>>>>>    string lsValue lsDec
89580>>>>>>>    get value item liItm to lsValue
89581>>>>>>>    get piDataType.i of (oTextDataColumnAnalyser(self)) liItm to liType
89582>>>>>>>    // if TDAT_CT_UNKNOWN TDAT_CT_ASCII or TDAT_CT_TEXT we don't do a thing
89582>>>>>>>
89582>>>>>>>    if (liType=TDAT_CT_NUMBER) begin
89584>>>>>>>      get value of (phTextDataParameters(self)) item TDAT_DECIMAL_SEP to lsDec
89585>>>>>>>      move (replace(lsDec,lsValue,CurrentDecimalSeparator())) to lsValue
89586>>>>>>>    end
89586>>>>>>>>
89586>>>>>>>    else if (liType=TDAT_CT_DATE) begin
89589>>>>>>>      get value of (phTextDataParameters(self)) item TDAT_DATE_SEP    to lsDec
89590>>>>>>>      get value of (phTextDataParameters(self)) item TDAT_DATE_FORMAT to liFormat
89591>>>>>>>      move (StringFormatToDate(lsValue,ascii(lsDec),liFormat)) to lsValue
89592>>>>>>>    end
89592>>>>>>>>
89592>>>>>>>    else if (liType=TDAT_CT_DATE_TIME) begin
89595>>>>>>>      get value of (phTextDataParameters(self)) item TDAT_DATE_SEP    to lsDec
89596>>>>>>>      get value of (phTextDataParameters(self)) item TDAT_DATE_FORMAT to liFormat
89597>>>>>>>      move (StringFormatToDate(lsValue,ascii(lsDec),liFormat)) to lsValue
89598>>>>>>>    end
89598>>>>>>>>
89598>>>>>>>    function_return lsValue
89599>>>>>>>  end_function
89600>>>>>>>
89600>>>>>>>  function sTypeText.i integer liColumn returns string
89602>>>>>>>    integer lhTextDataColumnAnalyser liType
89602>>>>>>>    string lsType
89602>>>>>>>    move (oTextDataColumnAnalyser(self)) to lhTextDataColumnAnalyser
89603>>>>>>>    get piDataType.i of lhTextDataColumnAnalyser liColumn to liType
89604>>>>>>>    get psText.i of (oTextDataColumnTypes(self)) liType to lsType
89605>>>>>>>    move (lsType+", "+string(piMaxLength.i(lhTextDataColumnAnalyser,liColumn))) to lsType
89606>>>>>>>    if (liType=TDAT_CT_NUMBER) move (lsType+" ("+string(piMaxDecimals.i(lhTextDataColumnAnalyser,liColumn))+")") to lsType
89609>>>>>>>    function_return lsType
89610>>>>>>>  end_function
89611>>>>>>>
89611>>>>>>>  function sColumnName.i integer liColumn returns string
89613>>>>>>>    string lsRval
89613>>>>>>>    get value of (oColumnHeaders(self)) item liColumn to lsRval
89614>>>>>>>    if (lsRval="") move ("Column "+string(liColumn+1)) to lsRval
89617>>>>>>>    function_return lsRval
89618>>>>>>>  end_function
89619>>>>>>>
89619>>>>>>>  procedure DoTransferToMapableObject integer lhMapObject
89621>>>>>>>    integer liMax liRow
89621>>>>>>>    send DoReset to lhMapObject
89622>>>>>>>    get piColumnCount to liMax
89623>>>>>>>    decrement liMax
89624>>>>>>>    for liRow from 0 to liMax
89630>>>>>>>>
89630>>>>>>>      send DoAddItem to lhMapObject liRow (sColumnName.i(self,liRow)) ""
89631>>>>>>>    loop
89632>>>>>>>>
89632>>>>>>>  end_procedure
89633>>>>>>>
89633>>>>>>>  procedure DoSplitInItems string lsLine
89635>>>>>>>    integer lhTextDataParameters
89635>>>>>>>    integer liPos liLen liItem liIn
89635>>>>>>>    string lsFieldSep lsItem lsChar lsEndQuote lsQuotes
89635>>>>>>>    send delete_data
89636>>>>>>>    get phTextDataParameters to lhTextDataParameters
89637>>>>>>>    get value of lhTextDataParameters item TDAT_FIELD_SEP to lsFieldSep
89638>>>>>>>    get value of lhTextDataParameters item TDAT_QUOTATION_CHAR to lsQuotes
89639>>>>>>>    move (length(lsLine)) to liLen
89640>>>>>>>    move 0 to liItem
89641>>>>>>>    move "" to lsItem
89642>>>>>>>    move "" to lsEndQuote
89643>>>>>>>    for liPos from 1 to liLen
89649>>>>>>>>
89649>>>>>>>      move (mid(lsLine,1,liPos)) to lsChar
89650>>>>>>>      if lsEndQuote eq "" begin
89652>>>>>>>        if lsChar eq lsFieldSep begin
89654>>>>>>>          set value item liItem to lsItem
89655>>>>>>>          move "" to lsItem
89656>>>>>>>          increment liItem
89657>>>>>>>        end
89657>>>>>>>>
89657>>>>>>>        else begin
89658>>>>>>>          if (length(lsItem)=0 and lsQuotes contains lsChar) move lsChar to lsEndQuote
89661>>>>>>>          else move (lsItem+lsChar) to lsItem
89663>>>>>>>        end
89663>>>>>>>>
89663>>>>>>>      end
89663>>>>>>>>
89663>>>>>>>      else begin
89664>>>>>>>        if lsChar eq lsEndQuote begin
89666>>>>>>>          move (mid(lsLine,1,liPos+1)) to lsChar
89667>>>>>>>          if lsChar eq lsEndQuote begin
89669>>>>>>>            increment liPos
89670>>>>>>>            move (lsItem+lsChar) to lsItem
89671>>>>>>>          end
89671>>>>>>>>
89671>>>>>>>          else begin
89672>>>>>>>            move "" to lsEndQuote
89673>>>>>>>            set value item liItem to lsItem
89674>>>>>>>          end
89674>>>>>>>>
89674>>>>>>>        end
89674>>>>>>>>
89674>>>>>>>        else move (lsItem+lsChar) to lsItem
89676>>>>>>>      end
89676>>>>>>>>
89676>>>>>>>    loop
89677>>>>>>>>
89677>>>>>>>    if (lsItem<>"" or right(lsLine,1)=lsFieldSep) set value item liItem to lsItem
89680>>>>>>>  end_procedure
89681>>>>>>>
89681>>>>>>>  function iFileOpen.s string lsFileName returns integer
89683>>>>>>>    integer liRval liChannel lhTextDataParameters liColumnCount lbOEM
89683>>>>>>>    integer lbColumnNames
89683>>>>>>>    integer lhColumnHeaders liMax liItm
89683>>>>>>>    string lsLineValue
89683>>>>>>>    set psFileName to lsFileName
89684>>>>>>>    get SEQ_DirectInput lsFileName to liChannel
89685>>>>>>>    if liChannel ge 0 begin
89687>>>>>>>      get phTextDataParameters to lhTextDataParameters
89688>>>>>>>      get value of lhTextDataParameters item TDAT_COLUMN_COUNT to liColumnCount
89689>>>>>>>      get value of lhTextDataParameters item TDAT_OEM_CHARSET  to lbOEM
89690>>>>>>>      get value of lhTextDataParameters item TDAT_COLUMN_NAMES to lbColumnNames
89691>>>>>>>      set piPrivate.OEM to lbOEM
89692>>>>>>>      if (liColumnCount=0) begin
89694>>>>>>>        // If that is zero the column count is determined by the first line
89694>>>>>>>        // in the file.
89694>>>>>>>        readln channel liChannel lsLineValue
89696>>>>>>>        if (seqeof) begin
89698>>>>>>>          move TDATFO_FILE_EMPTY to liRval
89699>>>>>>>          send SEQ_CloseInput liChannel
89700>>>>>>>        end
89700>>>>>>>>
89700>>>>>>>        else begin
89701>>>>>>>          ifnot lbOEM get ToOEM lsLineValue to lsLineValue
89704>>>>>>>          send DoSplitInItems lsLineValue
89705>>>>>>>          if (item_count(self)) begin
89707>>>>>>>            move TDATFO_OK to liRval
89708>>>>>>>            move (oColumnHeaders(self)) to lhColumnHeaders
89709>>>>>>>            send delete_data to lhColumnHeaders
89710>>>>>>>            get item_count to liMax
89711>>>>>>>            move liMax to liColumnCount
89712>>>>>>>            decrement liMax
89713>>>>>>>            for liItm from 0 to liMax
89719>>>>>>>>
89719>>>>>>>              if lbColumnNames set value of lhColumnHeaders item liItm to (value(self,liItm))
89722>>>>>>>              else set value of lhColumnHeaders item liItm to ("Column "+string(liItm+1))
89724>>>>>>>            loop
89725>>>>>>>>
89725>>>>>>>            if lbColumnNames set piLinesRead to 1
89728>>>>>>>            else begin
89729>>>>>>>              set piLinesRead to 0
89730>>>>>>>              // At this point we have to restore the channel position. We do
89730>>>>>>>              // this the hard way:
89730>>>>>>>              close_input channel liChannel
89732>>>>>>>              direct_input channel liChannel lsFileName
89734>>>>>>>            end
89734>>>>>>>>
89734>>>>>>>          end
89734>>>>>>>>
89734>>>>>>>          else begin
89735>>>>>>>            move TDATFO_NO_ITEMS_ON_FIRST_LINE to liRval
89736>>>>>>>            send SEQ_CloseInput liChannel
89737>>>>>>>          end
89737>>>>>>>>
89737>>>>>>>        end
89737>>>>>>>>
89737>>>>>>>      end
89737>>>>>>>>
89737>>>>>>>      else begin // Fixed number of columns
89738>>>>>>>        if lbColumnNames begin
89740>>>>>>>          move (oColumnHeaders(self)) to lhColumnHeaders
89741>>>>>>>          readln channel liChannel lsLineValue
89743>>>>>>>          if (seqeof) begin
89745>>>>>>>            move TDATFO_FILE_EMPTY to liRval
89746>>>>>>>            send SEQ_CloseInput liChannel
89747>>>>>>>          end
89747>>>>>>>>
89747>>>>>>>          else begin
89748>>>>>>>            set piLinesRead to 1
89749>>>>>>>            ifnot lbOEM get ToOEM lsLineValue to lsLineValue
89752>>>>>>>            send DoSplitInItems lsLineValue
89753>>>>>>>            if (item_count(self)) begin
89755>>>>>>>              move (oColumnHeaders(self)) to lhColumnHeaders
89756>>>>>>>              send delete_data to lhColumnHeaders
89757>>>>>>>              get item_count to liMax
89758>>>>>>>              if (liMax=liColumnCount) begin
89760>>>>>>>                decrement liMax
89761>>>>>>>                for liItm from 0 to liMax
89767>>>>>>>>
89767>>>>>>>                  set value of lhColumnHeaders item liItm to (value(self,liItm))
89768>>>>>>>                loop
89769>>>>>>>>
89769>>>>>>>                move TDATFO_OK to liRval
89770>>>>>>>              end
89770>>>>>>>>
89770>>>>>>>              else begin
89771>>>>>>>                move TDATFO_ILLEGAL_NUMBER_OF_COLUMN_NAMES to liRval
89772>>>>>>>                send SEQ_CloseInput liChannel
89773>>>>>>>              end
89773>>>>>>>>
89773>>>>>>>            end
89773>>>>>>>>
89773>>>>>>>            else begin
89774>>>>>>>              move TDATFO_NO_ITEMS_ON_FIRST_LINE to liRval
89775>>>>>>>              send SEQ_CloseInput liChannel
89776>>>>>>>            end
89776>>>>>>>>
89776>>>>>>>          end
89776>>>>>>>>
89776>>>>>>>        end
89776>>>>>>>>
89776>>>>>>>        else begin
89777>>>>>>>          set piLinesRead to 0
89778>>>>>>>          move TDATFO_OK to liRval
89779>>>>>>>        end
89779>>>>>>>>
89779>>>>>>>      end
89779>>>>>>>>
89779>>>>>>>      set piColumnCount to liColumnCount
89780>>>>>>>      set piChannel to liChannel
89781>>>>>>>    end
89781>>>>>>>>
89781>>>>>>>    else move TDATFO_FILE_NOT_FOUND to liRval
89783>>>>>>>    function_return liRval
89784>>>>>>>  end_function // iFileOpen.s
89785>>>>>>>
89785>>>>>>>  function iReadNext returns integer
89787>>>>>>>    integer liColumnCount liColumnsRead liRval liChannel lbOEM
89787>>>>>>>    integer lhTextDataParameters liErrorLine lbFirst
89787>>>>>>>    string lsLineValue lsLine
89787>>>>>>>
89787>>>>>>>    get phTextDataParameters to lhTextDataParameters
89788>>>>>>>    get value of lhTextDataParameters item TDAT_COLUMN_COUNT to liColumnCount
89789>>>>>>>    get value of lhTextDataParameters item TDAT_OEM_CHARSET  to lbOEM
89790>>>>>>>
89790>>>>>>>    // If an error occurs we will attribute it to this line:
89790>>>>>>>    get piLinesRead to liErrorLine // +1 !
89791>>>>>>>    increment liErrorLine
89792>>>>>>>    set piCurrentRowStartedInLine to liErrorLine // overload
89793>>>>>>>
89793>>>>>>>    get piColumnCount to liColumnCount
89794>>>>>>>    get piChannel to liChannel
89795>>>>>>>    move 0 to liColumnsRead
89796>>>>>>>    move "" to lsLinevalue
89797>>>>>>>    move DFTRUE to lbFirst
89798>>>>>>>
89798>>>>>>>    send delete_data
89799>>>>>>>
89799>>>>>>>    repeat
89799>>>>>>>>
89799>>>>>>>      readln channel liChannel lsLine
89801>>>>>>>      if (seqeof) begin
89803>>>>>>>        if (item_count(self)) begin
89805>>>>>>>          set piErrorLine to liErrorLine
89806>>>>>>>          function_return TDATRN_ERROR
89807>>>>>>>        end
89807>>>>>>>>
89807>>>>>>>        else function_return TDATRN_EOF
89809>>>>>>>      end
89809>>>>>>>>
89809>>>>>>>      ifnot lbOEM get ToOEM lsLine to lsLine
89812>>>>>>>      set piLinesRead to (piLinesRead(self)+1)
89813>>>>>>>
89813>>>>>>>      ifnot lbFirst move (lsLineValue+character(10)) to lsLineValue
89816>>>>>>>      move (lsLineValue+lsLine) to lsLineValue
89817>>>>>>>
89817>>>>>>>      move DFFALSE to lbFirst
89818>>>>>>>      send DoSplitInItems lsLineValue
89819>>>>>>>      get item_count to liColumnsRead
89820>>>>>>>    until (liColumnsRead>=liColumnCount)
89822>>>>>>>
89822>>>>>>>    if (liColumnsRead=0 or liColumnsRead=liColumnCount) move TDATRN_OK to liRval
89825>>>>>>>    else begin
89826>>>>>>>      set piErrorLine to liErrorLine
89827>>>>>>>      move TDATRN_ERROR to liRval
89828>>>>>>>    end
89828>>>>>>>>
89828>>>>>>>
89828>>>>>>>    function_return liRval
89829>>>>>>>  end_function // iReadNext
89830>>>>>>>  procedure FileClose
89832>>>>>>>    send SEQ_CloseInput (piChannel(self))
89833>>>>>>>  end_procedure
89834>>>>>>>  procedure DoAnalyseFile string lsFileName
89836>>>>>>>    send DoAnalyseFile to (oTextDataColumnAnalyser(self)) lsFileName (oAnalyseLog(self))
89837>>>>>>>  end_procedure
89838>>>>>>>  procedure DoCallback string lsFileName integer liGet integer lhObj
89840>>>>>>>    integer liResult lbCancel
89840>>>>>>>    string lsValue
89840>>>>>>>    get iFileOpen.s lsFileName to liResult
89841>>>>>>>    if (liResult=TDATFO_OK) begin
89843>>>>>>>      repeat
89843>>>>>>>>
89843>>>>>>>        get iReadNext to liResult
89844>>>>>>>        if (liResult=TDATRN_OK) get liGet of lhObj to lbCancel
89847>>>>>>>      until (liResult<>TDATRN_OK or lbCancel)
89849>>>>>>>      if (liResult=TDATRN_ERROR) begin
89851>>>>>>>        get sErrorText to lsValue
89852>>>>>>>        send obs lsValue
89853>>>>>>>      end
89853>>>>>>>>
89853>>>>>>>      send FileClose
89854>>>>>>>    end
89854>>>>>>>>
89854>>>>>>>  end_procedure
89855>>>>>>>end_class // cTextDataReader
89856>>>>>>>
89856>>>>>>>//
89856>>>>>>>// object oTextDataParameters is a cTextDataParameters
89856>>>>>>>// end_object
89856>>>>>>>//
89856>>>>>>>// object oTextDataReader is a cTextDataReader
89856>>>>>>>//   set phTextDataParameters to (oTextDataParameters(self))
89856>>>>>>>// end_object
89856>>>>>Use GridUtil.utl // Grid and List utilities (not for dbGrid's or Table's)
89856>>>>>Use MsgBox.utl   // obs procedure
89856>>>>>Use Files.utl    // Utilities for handling file related stuff (No User Interface)
89856>>>>>
89856>>>>>object oTextDataDecisionLogPanel is a aps.ModalPanel label "Decision log"
89859>>>>>  set locate_mode to CENTER_ON_SCREEN
89860>>>>>  on_key kcancel send close_panel
89861>>>>>  object oLst is a aps.Grid
89863>>>>>    send GridPrepare_AddColumn "Line"      AFT_NUMERIC6.0
89864>>>>>    send GridPrepare_AddColumn "Column"    AFT_NUMERIC4.0
89865>>>>>    send GridPrepare_AddColumn "Value"     AFT_ASCII30
89866>>>>>    send GridPrepare_AddColumn "Deduction" AFT_ASCII40
89867>>>>>    send GridPrepare_Apply self
89868>>>>>    on_key KEY_CTRL+KEY_R send sort_data
89869>>>>>    on_key KEY_CTRL+KEY_W send DoWriteToFile
89870>>>>>    set size to 200 0
89871>>>>>    procedure DoWriteToFile
89874>>>>>      send Grid_DoWriteToFile self
89875>>>>>    end_procedure
89876>>>>>    procedure sort_data.i integer column#
89879>>>>>      send Grid_SortByColumn self column#
89880>>>>>    end_procedure
89881>>>>>    function iSpecialSortValueOnColumn.i integer column# returns integer
89884>>>>>      if column# le 1 function_return 1
89887>>>>>    end_function
89888>>>>>    function sSortValue.ii integer column# integer itm# returns string
89891>>>>>      if column# le 1 function_return (IntToStrR(value(self,itm#),6))
89894>>>>>    end_function
89895>>>>>    procedure sort_data
89898>>>>>      integer cc#
89898>>>>>      get Grid_CurrentColumn self to cc#
89899>>>>>      send sort_data.i cc#
89900>>>>>    end_procedure
89901>>>>>    procedure header_mouse_click integer itm#
89904>>>>>      send sort_data.i itm#
89905>>>>>      forward send header_mouse_click itm#
89907>>>>>    end_procedure
89908>>>>>    procedure fill_list.i integer lhArray
89911>>>>>      integer liMax liRow
89911>>>>>      send delete_data
89912>>>>>      get row_count of lhArray to liMax
89913>>>>>      decrement liMax
89914>>>>>      for liRow from 0 to liMax
89920>>>>>>
89920>>>>>        send add_item MSG_NONE (piLine.i(lhArray,liRow))
89921>>>>>        send add_item MSG_NONE (piColumn.i(lhArray,liRow))
89922>>>>>        send add_item MSG_NONE (psValue.i(lhArray,liRow))
89923>>>>>        send add_item MSG_NONE (psComment.i(lhArray,liRow))
89924>>>>>      loop
89925>>>>>>
89925>>>>>      send Grid_SetEntryState self DFFALSE
89926>>>>>    end_procedure
89927>>>>>  end_object
89928>>>>>  object oBtn1 is a aps.Multi_Button
89930>>>>>    on_item t.btn.close send close_panel
89931>>>>>  end_object
89932>>>>>  send aps_locate_multi_buttons
89933>>>>>  procedure popup.i integer lhParams
89936>>>>>    send fill_list.i to (oLst(self)) lhParams
89937>>>>>    send popup
89938>>>>>  end_procedure
89939>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
89940>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
89943>>>>>    send aps_resize (oLst(self)) delta_rw# delta_cl#
89944>>>>>    send aps_register_multi_button (oBtn1(self))
89945>>>>>    send aps_locate_multi_buttons
89946>>>>>    send aps_auto_size_container
89947>>>>>  end_procedure
89948>>>>>end_object // oTextDataDecisionLogPanel
89949>>>>>
89949>>>>>procedure Popup_TextDataDecisionLogPanel global integer lhArray
89951>>>>>  send popup.i to (oTextDataDecisionLogPanel(self)) lhArray
89952>>>>>end_procedure
89953>>>>>
89953>>>>>object oTextDataParamListPanel is a aps.ModalPanel label "Text data parameters"
89956>>>>>  set locate_mode to CENTER_ON_SCREEN
89957>>>>>  on_key kcancel send close_panel
89958>>>>>  object oLst is a aps.Grid
89960>>>>>    send GridPrepare_AddColumn "Parameter" AFT_ASCII30
89961>>>>>    send GridPrepare_AddColumn "Value"     AFT_ASCII30
89962>>>>>    send GridPrepare_Apply self
89963>>>>>    procedure fill_list.i integer lhParams
89966>>>>>      integer lhTextDataParameterList liMax liRow
89966>>>>>      move (oTextDataParameterList(self)) to lhTextDataParameterList
89967>>>>>      send delete_data
89968>>>>>      get row_count of lhTextDataParameterList to liMax
89969>>>>>      decrement liMax
89970>>>>>      for liRow from 0 to liMax
89976>>>>>>
89976>>>>>        send add_item MSG_NONE (psText.i(lhTextDataParameterList,liRow))
89977>>>>>        send add_item MSG_NONE (value(lhParams,liRow))
89978>>>>>      loop
89979>>>>>>
89979>>>>>      send Grid_SetEntryState self DFFALSE
89980>>>>>    end_procedure
89981>>>>>  end_object
89982>>>>>  object oBtn1 is a aps.Multi_Button
89984>>>>>    on_item t.btn.close send close_panel
89985>>>>>  end_object
89986>>>>>  send aps_locate_multi_buttons
89987>>>>>  procedure popup.i integer lhParams
89990>>>>>    send fill_list.i to (oLst(self)) lhParams
89991>>>>>    send popup
89992>>>>>  end_procedure
89993>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
89994>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
89997>>>>>    send aps_resize (oLst(self)) delta_rw# delta_cl#
89998>>>>>    send aps_register_multi_button (oBtn1(self))
89999>>>>>    send aps_locate_multi_buttons
90000>>>>>    send aps_auto_size_container
90001>>>>>  end_procedure
90002>>>>>end_object // oTextDataParamListPanel
90003>>>>>
90003>>>>>procedure Popup_TextDataParameterList global integer lhParams
90005>>>>>  send popup.i to (oTextDataParamListPanel(self)) lhParams
90006>>>>>end_procedure
90007>>>>>
90007>>>>>enumeration_list
90007>>>>>  define TDPG_READ_REFRESH
90007>>>>>  define TDPG_READ_FIRST
90007>>>>>  define TDPG_READ_NEXT
90007>>>>>  define TDPG_READ_PREVIOUS
90007>>>>>end_enumeration_list
90007>>>>>
90007>>>>>class cTextDataReaderSentinel is a cTextDataReader
90008>>>>>  procedure construct_object
90010>>>>>    forward send construct_object
90012>>>>>    object oSentinel is a StatusPanel
90014>>>>>      set allow_cancel_state to DFFALSE
90015>>>>>      set Message_Text to ""
90016>>>>>      set Action_Text  to ""
90017>>>>>      set Title_Text   to ""
90018>>>>>    end_object
90019>>>>>  end_procedure
90020>>>>>  procedure SentinelOn string lsCaption
90022>>>>>    set Caption_Text of (oSentinel(self)) to lsCaption
90023>>>>>    send Start_StatusPanel to (oSentinel(self))
90024>>>>>  end_procedure
90025>>>>>  procedure SentinelUpdate1 string lsValue
90027>>>>>    set Message_Text of (oSentinel(self)) to lsValue
90028>>>>>  end_procedure
90029>>>>>  procedure SentinelUpdate2 string lsValue
90031>>>>>  end_procedure
90032>>>>>  procedure SentinelOff
90034>>>>>    send Stop_StatusPanel to (oSentinel(self))
90035>>>>>  end_procedure
90036>>>>>end_class
90037>>>>>
90037>>>>>class cTextDataProbeGrid is a aps.Grid
90038>>>>>  procedure construct_object
90040>>>>>    forward send construct_object
90042>>>>>    send GridPrepare_AddColumn "#"           AFT_ASCII4
90043>>>>>    send GridPrepare_AddColumn "Column Name" AFT_ASCII20
90044>>>>>    send GridPrepare_AddColumn "Data type"   AFT_ASCII20
90045>>>>>    send GridPrepare_AddColumn "Value"       AFT_ASCII30
90046>>>>>    send GridPrepare_Apply self
90047>>>>>    property integer piCurrentRow public 0
90048>>>>>    set select_mode to NO_SELECT
90049>>>>>    object oTextDataReader is a cTextDataReaderSentinel
90051>>>>>    end_object
90052>>>>>  end_procedure
90053>>>>>
90053>>>>>  procedure fill_list.iis integer liAction integer lhParamList string lsFileName
90055>>>>>    integer lhTextDataReader liResult liColumnCount liColumn liCurrentRow liRow
90055>>>>>    move (oTextDataReader(self)) to lhTextDataReader
90056>>>>>    set phTextDataParameters of lhTextDataReader to lhParamList
90057>>>>>    set dynamic_update_state to DFFALSE
90058>>>>>    send delete_data
90059>>>>>    get iFileOpen.s of lhTextDataReader lsFileName to liResult
90060>>>>>    if (liResult=TDATFO_OK) begin
90062>>>>>
90062>>>>>      get piCurrentRow to liCurrentRow
90063>>>>>      if (liAction=TDPG_READ_FIRST)    move 1 to liCurrentRow
90066>>>>>      if (liAction=TDPG_READ_NEXT)     increment liCurrentRow
90069>>>>>      if (liAction=TDPG_READ_PREVIOUS) decrement liCurrentRow
90072>>>>>      if (liCurrentRow<1) move 1 to liCurrentRow
90075>>>>>      set piCurrentRow to liCurrentRow
90076>>>>>
90076>>>>>      move 0 to liRow
90077>>>>>      repeat
90077>>>>>>
90077>>>>>        get iReadNext of lhTextDataReader to liResult
90078>>>>>        increment liRow
90079>>>>>      until (liRow=liCurrentRow or liResult<>TDATRN_OK)
90081>>>>>
90081>>>>>      if (liResult=TDATRN_EOF) begin
90083>>>>>        send obs "End of file reached"
90084>>>>>        set piCurrentRow to (liRow-1)
90085>>>>>      end
90085>>>>>>
90085>>>>>      else if (liResult=TDATRN_ERROR) begin
90088>>>>>        send obs ("Error reading file on line "+string(piErrorLine(lhTextDataReader)))
90089>>>>>      end
90089>>>>>>
90089>>>>>
90089>>>>>      get piColumnCount of lhTextDataReader to liColumnCount
90090>>>>>      decrement liColumnCount
90091>>>>>      for liColumn from 0 to liColumnCount
90097>>>>>>
90097>>>>>        send add_item MSG_NONE (string(liColumn+1))
90098>>>>>        send add_item MSG_NONE (sColumnName.i(lhTextDataReader,liColumn))
90099>>>>>        send add_item MSG_NONE (sTypeText.i(lhTextDataReader,liColumn))
90100>>>>>        send add_item MSG_NONE (value(lhTextDataReader,liColumn))
90101>>>>>      loop
90102>>>>>>
90102>>>>>      send FileClose to lhTextDataReader
90103>>>>>    end
90103>>>>>>
90103>>>>>    else begin
90104>>>>>      if (liResult=TDATFO_FILE_NOT_FOUND) send obs "File not found" ("("+lsFileName+")")
90107>>>>>      if (liResult=TDATFO_FILE_EMPTY) send obs "The file contains no data."
90110>>>>>      if (liResult=TDATFO_NO_ITEMS_ON_FIRST_LINE) send obs "No items on first line in file."
90113>>>>>      if (liResult=TDATFO_ILLEGAL_NUMBER_OF_COLUMN_NAMES) send obs "Illegal number of column names"
90116>>>>>    end
90116>>>>>>
90116>>>>>    send Grid_SetEntryState self DFFALSE
90117>>>>>    set dynamic_update_state to DFTRUE
90118>>>>>  end_procedure
90119>>>>>  procedure DoAnalyseFile string lsFileName integer lhParamList
90121>>>>>    integer lhTextDataReader
90121>>>>>    move (oTextDataReader(self)) to lhTextDataReader
90122>>>>>    send DoAnalyseFile to lhTextDataReader lsFileName
90123>>>>>    send fill_list.iis TDPG_READ_FIRST lhParamList lsFileName
90124>>>>>    send Popup_TextDataDecisionLogPanel (oAnalyseLog(lhTextDataReader))
90125>>>>>  end_procedure
90126>>>>>end_class // cTextDataProbeGrid
90127>>>>>
90127>>>>>class cViewLargeTextFile is a aps.Edit
90128>>>>>  procedure construct_object integer liImage
90130>>>>>    forward send construct_object liImage
90132>>>>>    property string  prv.psFileName  public ""
90133>>>>>    property integer piCurrentPos public 0
90134>>>>>  end_procedure
90135>>>>>  procedure DoUpdate
90137>>>>>    integer liChannel liStartPos liCurPos
90137>>>>>    string lsLine
90137>>>>>    get SEQ_DirectInput (prv.psFileName(self)) to liChannel
90138>>>>>    if (liChannel>=0) begin
90140>>>>>      get piCurrentPos to liStartPos
90141>>>>>      set_channel_position liChannel to liStartPos
90142>>>>>>
90142>>>>>     // repeat
90142>>>>>
90142>>>>>      send SEQ_CloseInput liChannel
90143>>>>>    end
90143>>>>>>
90143>>>>>  end_procedure
90144>>>>>  procedure set psFileName string lsFileName
90146>>>>>    set prv.psFileName to lsFileName
90147>>>>>    set piCurrentPos to 0
90148>>>>>    send DoUpdate
90149>>>>>  end_procedure
90150>>>>>  function psFileName returns string
90152>>>>>    function_return (prv.psFileName(self))
90153>>>>>  end_function
90154>>>>>end_class // cViewLargeTextFile
90155>>>>>
90155>>>>>object oTextDataDisplay1st10Lines is a aps.ModalPanel label "First 32K"
90158>>>>>  set locate_mode to CENTER_ON_SCREEN
90159>>>>>  on_key ksave_record send close_panel
90160>>>>>  on_key kcancel send close_panel
90161>>>>>  property string psFileName public ""
90163>>>>>  object oLst is a cViewLargeTextFile
90165>>>>>    set size to 200 500
90166>>>>>    set Typeface to "Courier New"
90167>>>>>    //set FontSize to 18 0
90167>>>>>    procedure fill_list.si string lsFileName integer lbOEM
90170>>>>>      integer liChannel liItm liPosition lbSeqEof lhParent
90170>>>>>      string lsLine
90170>>>>>      send delete_data
90171>>>>>      get SEQ_DirectInput lsFileName to liChannel
90172>>>>>      move (parent(self)) to lhParent
90173>>>>>      set label of lhParent to lsFileName
90174>>>>>      set psFileName of lhParent to lsFileName
90175>>>>>      if (liChannel>=0) begin
90177>>>>>        move 0 to liPosition
90178>>>>>        move 0 to liItm
90179>>>>>        repeat
90179>>>>>>
90179>>>>>          get SEQ_ReadLn liChannel to lsLine
90180>>>>>          move (seqeof) to lbSeqEof
90181>>>>>          get_channel_position liChannel to liPosition
90182>>>>>>
90182>>>>>          if (liPosition>32000) begin
90184>>>>>            move DFTRUE to lbSeqEof
90185>>>>>            set label of lhParent to (lsFileName+" (First 32K)")
90186>>>>>          end
90186>>>>>>
90186>>>>>          ifnot lbSeqEof begin
90188>>>>>            ifnot lbOEM get ToOEM lsLine to lsLine
90191>>>>>            set value item liItm to lsLine
90192>>>>>            increment liItm
90193>>>>>          end
90193>>>>>>
90193>>>>>        until lbSeqEof
90195>>>>>        send SEQ_CloseInput liChannel
90196>>>>>      end
90196>>>>>>
90196>>>>>    end_procedure
90197>>>>>    set wrap_state to DFFALSE
90198>>>>>    set read_only_state to DFTRUE
90199>>>>>  end_object
90200>>>>>  procedure DoEditFile
90203>>>>>    runprogram BACKGROUND ("notepad "+psFileName(self))
90204>>>>>  end_procedure
90205>>>>>  on_key KEY_ALT+KEY_E send DoEditFile
90206>>>>>  object oBtn1 is a aps.Multi_Button
90208>>>>>    on_item "Notepad" send DoEditFile
90209>>>>>  end_object
90210>>>>>  object oBtn2 is a aps.Multi_Button
90212>>>>>    on_item t.btn.close send close_panel
90213>>>>>  end_object
90214>>>>>  send aps_locate_multi_buttons
90215>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
90216>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
90219>>>>>    send aps_resize (oLst(self)) delta_rw# delta_cl#
90220>>>>>    send aps_register_multi_button (oBtn1(self))
90221>>>>>    send aps_register_multi_button (oBtn2(self))
90222>>>>>    send aps_locate_multi_buttons
90223>>>>>    send aps_auto_size_container
90224>>>>>  end_procedure
90225>>>>>  procedure popup.si string lsFileName integer lbOEM
90228>>>>>    send fill_list.si to (oLst(self)) lsFileName lbOEM
90229>>>>>    send popup
90230>>>>>  end_procedure
90231>>>>>end_object // oTextDataDisplay1st10Lines
90232>>>>>
90232>>>>>object oTextDataProperties is a aps.ModalPanel label "Import file properties"
90235>>>>>  set locate_mode to CENTER_ON_SCREEN
90236>>>>>  property integer phTextDataParameters public 0
90238>>>>>  on_key KCANCEL      send close_panel
90239>>>>>  on_key KSAVE_RECORD send close_panel_ok
90240>>>>>  property integer piResult public 0
90242>>>>>  set pMinimumSize to 200 0
90243>>>>>
90243>>>>>  object oTextDataParameters is a cTextDataParameters
90245>>>>>  end_object
90246>>>>>  property integer phTextDataReader public 0
90248>>>>>
90248>>>>>  object oGroup is a aps.Group
90250>>>>>    send tab_column_define 1 95 70 jmode_left // Default column setting
90251>>>>>
90251>>>>>    register_object oFieldDelimiterExplicit
90251>>>>>    register_object oQuoteCharExplicit
90251>>>>>
90251>>>>>    object oFieldDelimiter is a aps.ComboFormAux abstract AFT_ASCII15 label "Field delimiter:"
90255>>>>>      set entry_state item 0 to DFFALSE
90256>>>>>      send combo_add_item "; (Semicolon)"     1
90257>>>>>      send combo_add_item ", (Comma)"         2
90258>>>>>      send combo_add_item "Tabulator"         3
90259>>>>>      send combo_add_item "Special character" 4
90260>>>>>      procedure OnChange
90263>>>>>        send DoFindFirst
90264>>>>>        set enabled_state of (oFieldDelimiterExplicit(self)) to (Combo_Current_Aux_Value(self)=4)
90265>>>>>      end_procedure
90266>>>>>      procedure set TheValue string lsValue
90269>>>>>        set value of (oFieldDelimiterExplicit(self)) item 0 to ""
90270>>>>>        if lsValue eq ";" set Combo_Current_Aux_Value to 1
90273>>>>>        else if lsValue eq "," set Combo_Current_Aux_Value to 2
90277>>>>>        else if lsValue eq (character(8)) set Combo_Current_Aux_Value to 3
90281>>>>>        else begin
90282>>>>>          set value of (oFieldDelimiterExplicit(self)) item 0 to lsValue
90283>>>>>          if lsValue eq ";" set Combo_Current_Aux_Value to 4
90286>>>>>        end
90286>>>>>>
90286>>>>>      end_procedure
90287>>>>>      function TheValue returns string
90290>>>>>        integer liAux
90290>>>>>        get Combo_Current_Aux_Value to liAux
90291>>>>>        if liAux eq 1 function_return ";"
90294>>>>>        if liAux eq 2 function_return ","
90297>>>>>        if liAux eq 3 function_return (character(8))
90300>>>>>        if liAux eq 4 function_return (value(oFieldDelimiterExplicit(self),0))
90303>>>>>      end_function
90304>>>>>    end_object
90305>>>>>    object oFieldDelimiterExplicit is a aps.Form abstract AFT_ASCII1 snap SL_RIGHT
90309>>>>>      set enabled_state to DFFALSE
90310>>>>>      procedure OnChange
90313>>>>>        send DoFindFirst
90314>>>>>      end_procedure
90315>>>>>    end_object
90316>>>>>    object oQuoteChar is a aps.ComboFormAux abstract AFT_ASCII15 label "Quotation character:"
90320>>>>>      set entry_state item 0 to DFFALSE
90321>>>>>      send combo_add_item '" (double qoute)'  1
90322>>>>>      send combo_add_item "' (single quote)"  2
90323>>>>>      send combo_add_item "Special character" 3
90324>>>>>      procedure OnChange
90327>>>>>        set enabled_state of (oQuoteCharExplicit(self)) to (Combo_Current_Aux_Value(self)=3)
90328>>>>>        send DoFindFirst
90329>>>>>      end_procedure
90330>>>>>      procedure set TheValue string lsValue
90333>>>>>        set value of (oQuoteCharExplicit(self)) item 0 to ""
90334>>>>>        if lsValue eq '"' set Combo_Current_Aux_Value to 1
90337>>>>>        else if lsValue eq "'" set Combo_Current_Aux_Value to 2
90341>>>>>        else begin
90342>>>>>          set value of (oQuoteCharExplicit(self)) item 0 to lsValue
90343>>>>>          if lsValue eq ";" set Combo_Current_Aux_Value to 3
90346>>>>>        end
90346>>>>>>
90346>>>>>      end_procedure
90347>>>>>      function TheValue returns string
90350>>>>>        integer liAux
90350>>>>>        get Combo_Current_Aux_Value to liAux
90351>>>>>        if liAux eq 1 function_return '"'
90354>>>>>        if liAux eq 2 function_return "'"
90357>>>>>        if liAux eq 3 function_return (value(oQuoteCharExplicit(self),0))
90360>>>>>      end_function
90361>>>>>    end_object
90362>>>>>    object oQuoteCharExplicit is a aps.Form abstract AFT_ASCII1 snap SL_RIGHT
90366>>>>>      set enabled_state to DFFALSE
90367>>>>>      procedure OnChange
90370>>>>>        send DoFindFirst
90371>>>>>      end_procedure
90372>>>>>    end_object
90373>>>>>    object oDecimalSeparatorChar is a aps.ComboFormAux abstract AFT_ASCII15 label "Decimal separator:"
90377>>>>>      set entry_state item 0 to DFFALSE
90378>>>>>      send combo_add_item ". (period)" 1
90379>>>>>      send combo_add_item ", (comma)"  2
90380>>>>>      procedure set TheValue string lsValue
90383>>>>>        if lsValue eq "." set Combo_Current_Aux_Value to 1
90386>>>>>        if lsValue eq "," set Combo_Current_Aux_Value to 2
90389>>>>>      end_procedure
90390>>>>>      function TheValue returns string
90393>>>>>        integer liAux
90393>>>>>        get Combo_Current_Aux_Value to liAux
90394>>>>>        if liAux eq 1 function_return "."
90397>>>>>        if liAux eq 2 function_return ","
90400>>>>>      end_function
90401>>>>>    end_object
90402>>>>>    object oDateSeparatorChar is a aps.ComboFormAux abstract AFT_ASCII15 label "Date separator:"
90406>>>>>      set entry_state item 0 to DFFALSE
90407>>>>>      send combo_add_item "/ (slash)"   1
90408>>>>>      send combo_add_item "- (hyphen)"  2
90409>>>>>      send combo_add_item ". (period)"  3
90410>>>>>      procedure set TheValue string lsValue
90413>>>>>        if lsValue eq "/" set Combo_Current_Aux_Value to 1
90416>>>>>        if lsValue eq "-" set Combo_Current_Aux_Value to 2
90419>>>>>        if lsValue eq "." set Combo_Current_Aux_Value to 3
90422>>>>>      end_procedure
90423>>>>>      function TheValue returns string
90426>>>>>        integer liAux
90426>>>>>        get Combo_Current_Aux_Value to liAux
90427>>>>>        if liAux eq 1 function_return "/"
90430>>>>>        if liAux eq 2 function_return "-"
90433>>>>>        if liAux eq 3 function_return "."
90436>>>>>      end_function
90437>>>>>    end_object
90438>>>>>    object oDateFormat is a aps.ComboFormAux abstract AFT_ASCII15 label "Date format:"
90442>>>>>      set entry_state item 0 to DFFALSE
90443>>>>>      send combo_add_item "dd mm yyyy"  DF_DATE_EUROPEAN
90444>>>>>      send combo_add_item "mm dd yyyy"  DF_DATE_USA
90445>>>>>      send combo_add_item "yyyy mm dd"  DF_DATE_MILITARY
90446>>>>>      procedure set TheValue string lsValue
90449>>>>>        if lsValue eq DF_DATE_EUROPEAN set Combo_Current_Aux_Value to DF_DATE_EUROPEAN
90452>>>>>        if lsValue eq DF_DATE_USA      set Combo_Current_Aux_Value to DF_DATE_USA
90455>>>>>        if lsValue eq DF_DATE_MILITARY set Combo_Current_Aux_Value to DF_DATE_MILITARY
90458>>>>>      end_procedure
90459>>>>>      function TheValue returns string
90462>>>>>        integer liAux
90462>>>>>        get Combo_Current_Aux_Value to liAux
90463>>>>>        if liAux eq DF_DATE_EUROPEAN function_return DF_DATE_EUROPEAN
90466>>>>>        if liAux eq DF_DATE_USA      function_return DF_DATE_USA
90469>>>>>        if liAux eq DF_DATE_MILITARY function_return DF_DATE_MILITARY
90472>>>>>      end_function
90473>>>>>    end_object
90474>>>>>
90474>>>>>    send tab_column_define 1 250 65 jmode_left // Default column setting
90475>>>>>    set p_cur_row to (p_top_margin(self))
90476>>>>>    set aps_container_mx.p_auto_column_just_set to 1
90477>>>>>    object oColumnNamesInFirstLine is a aps.CheckBox label "Column names in first record"
90480>>>>>      procedure OnChange
90483>>>>>        send DoFindFirst
90484>>>>>      end_procedure
90485>>>>>    end_object
90486>>>>>    object oCharacterSet is a aps.CheckBox label "File contains OEM characters"
90489>>>>>      procedure OnChange
90492>>>>>        send DoFindFirst
90493>>>>>      end_procedure
90494>>>>>    end_object
90495>>>>>    object oNumberOfColumns is a aps.RadioGroup Label "Number of columns" snap SL_DOWN
90499>>>>>      object oRad1 is a aps.Radio label "Determined by first record"
90502>>>>>      end_object
90503>>>>>      object oRad2 is a aps.Radio label "Fixed:"
90506>>>>>      end_object
90507>>>>>      object oFrm is a aps.Form abstract AFT_NUMERIC4.0 snap SL_RIGHT relative_to (oRad2(self))
90516>>>>>        set enabled_state to DFFALSE
90517>>>>>      end_object
90518>>>>>      procedure notify_select_state integer liTo integer liFrom
90521>>>>>        set enabled_state of (oFrm(self)) to (liTo=1)
90522>>>>>      end_procedure
90523>>>>>      procedure set TheValue string lsValue
90526>>>>>        if (integer(lsValue)) begin
90528>>>>>          set current_radio to 1
90529>>>>>          set value of (oFrm(self)) item 0 to lsValue
90530>>>>>        end
90530>>>>>>
90530>>>>>        else begin
90531>>>>>          set current_radio to 0
90532>>>>>          set value of (oFrm(self)) item 0 to ""
90533>>>>>        end
90533>>>>>>
90533>>>>>      end_procedure
90534>>>>>      function TheValue returns string
90537>>>>>        if (current_radio(self)=0) function_return 0
90540>>>>>        function_return (value(oFrm(self),0))
90541>>>>>      end_function
90542>>>>>    end_object
90543>>>>>  end_object
90544>>>>>
90544>>>>>  send aps_goto_max_row
90545>>>>>  send aps_make_row_space 5
90546>>>>>  object oTestFile is a aps.Form abstract AFT_ASCII80 label "Test settings with this file:"
90550>>>>>    set p_extra_internal_width to -220
90551>>>>>    procedure prompt
90554>>>>>      string lsFileName
90554>>>>>      get SEQ_SelectInFile "Select text data file" "Text files|*.txt|All files|*.*" to lsFileName
90555>>>>>      if lsFileName ne "" begin
90557>>>>>        set value item 0 to lsFileName
90558>>>>>        send DoFindFirst
90559>>>>>      end
90559>>>>>>
90559>>>>>    end_procedure
90560>>>>>    on_key kprompt send prompt
90561>>>>>  end_object
90562>>>>>
90562>>>>>  object oBrowse is a aps.Button snap SL_RIGHT
90565>>>>>    on_item "Browse" send prompt to (oTestFile(self))
90566>>>>>  end_object
90567>>>>>  object oView is a aps.Button snap SL_RIGHT
90570>>>>>    on_item "View (NotePad)" send ViewFile
90571>>>>>    procedure ViewFile
90574>>>>>      integer lbOEM
90574>>>>>      string lsFileName
90574>>>>>      get value of (oTestFile(self)) item 0 to lsFileName
90575>>>>>      get select_state of (oCharacterSet(oGroup(self))) to lbOEM
90576>>>>>      send popup.si to (oTextDataDisplay1st10Lines(self)) lsFileName lbOEM
90577>>>>>    end_procedure
90578>>>>>  end_object
90579>>>>>
90579>>>>>  on_key KFIND           send DoReFind
90580>>>>>  on_key KFIND_PREVIOUS  send DoFindPrevious
90581>>>>>  on_key KFIND_NEXT      send DoFindNext
90582>>>>>  on_key KBEGIN_OF_DATA  send DoFindFirst
90583>>>>>  on_key KEY_CTRL+KEY_A  send DoAnalyseFile
90584>>>>>
90584>>>>>  send aps_goto_max_row
90585>>>>>  send aps_make_row_space 5
90586>>>>>
90586>>>>>  object oGridLabel is a aps.TextBox
90588>>>>>    set fixed_size to 12 200
90589>>>>>    procedure DoUpdateLabel integer liLine
90592>>>>>      set value to ("Current records started in line "+string(liLine))
90593>>>>>    end_procedure
90594>>>>>
90594>>>>>  end_object
90595>>>>>
90595>>>>>  send aps_goto_max_row
90596>>>>>
90596>>>>>  object oProbeGrid is a cTextDataProbeGrid
90598>>>>>    procedure fill_list.iis integer liAction integer lhParamList string lsFileName
90601>>>>>      forward send fill_list.iis liAction lhParamList lsFileName
90603>>>>>      send DoUpdateLabel to oGridLabel (piCurrentRowStartedInLine(oTextDataReader(self)))
90604>>>>>    end_procedure
90605>>>>>  end_object
90606>>>>>
90606>>>>>  procedure DoRefreshGrid integer liAction
90609>>>>>    integer lhObj
90609>>>>>    string lsFileName
90609>>>>>    send cursor_wait to (cursor_control(self))
90610>>>>>    get value of (oTestFile(self)) item 0 to lsFileName
90611>>>>>    move (oTextDataParameters(self)) to lhObj
90612>>>>>    send TransferValuesToParamList lhObj
90613>>>>>    send fill_list.iis to (oProbeGrid(self)) liAction lhObj lsFileName
90614>>>>>    send cursor_ready to (cursor_control(self))
90615>>>>>  end_procedure
90616>>>>>
90616>>>>>  procedure DoAnalyseFile
90619>>>>>    integer lhObj
90619>>>>>    string lsFileName
90619>>>>>    send DoFindFirst
90620>>>>>    get value of (oTestFile(self)) item 0 to lsFileName
90621>>>>>    move (oTextDataParameters(self)) to lhObj
90622>>>>>    send TransferValuesToParamList lhObj
90623>>>>>    send DoAnalyseFile to (oProbeGrid(self)) lsFileName lhObj
90624>>>>>  end_procedure
90625>>>>>  procedure DoReFind
90628>>>>>    send DoRefreshGrid TDPG_READ_REFRESH
90629>>>>>  end_procedure
90630>>>>>  procedure DoFindFirst
90633>>>>>    send DoRefreshGrid TDPG_READ_FIRST
90634>>>>>  end_procedure
90635>>>>>  procedure DoFindNext
90638>>>>>    send DoRefreshGrid TDPG_READ_NEXT
90639>>>>>  end_procedure
90640>>>>>  procedure DoFindPrevious
90643>>>>>    send DoRefreshGrid TDPG_READ_PREVIOUS
90644>>>>>  end_procedure
90645>>>>>
90645>>>>>  object oProbeBtn1 is a aps.Multi_Button
90647>>>>>    on_item "First record" send DoFindFirst
90648>>>>>    set psExtraLabel to "Ctrl+Home"
90649>>>>>  end_object
90650>>>>>  object oProbeBtn2 is a aps.Multi_Button
90652>>>>>    on_item "Previous record" send DoFindPrevious
90653>>>>>    set psExtraLabel to "F7"
90654>>>>>  end_object
90655>>>>>  object oProbeBtn3 is a aps.Multi_Button
90657>>>>>    on_item "Next record" send DoFindNext
90658>>>>>    set psExtraLabel to "F8"
90659>>>>>  end_object
90660>>>>>  object oProbeBtn4 is a aps.Multi_Button
90662>>>>>    on_item "Refresh" send DoReFind
90663>>>>>    set psExtraLabel to "F9"
90664>>>>>  end_object
90665>>>>>  object oProbeBtn5 is a aps.Multi_Button
90667>>>>>    on_item "Analyse file" send DoAnalyseFile
90668>>>>>    set psExtraLabel to "Ctrl+A"
90669>>>>>  end_object
90670>>>>>  send aps_locate_multi_buttons
90671>>>>>  send aps_goto_max_row
90672>>>>>  send aps_make_row_space 3
90673>>>>>
90673>>>>>  object oLine is a aps.LineControl
90675>>>>>  end_object
90676>>>>>  object oBtn1 is a aps.Multi_Button
90678>>>>>    on_item "OK" send close_panel_ok
90679>>>>>  end_object
90680>>>>>  object oBtn2 is a aps.Multi_Button
90682>>>>>    on_item "Cancel" send close_panel
90683>>>>>  end_object
90684>>>>>  send aps_locate_multi_buttons
90685>>>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
90686>>>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
90689>>>>>    send aps_resize (oProbeGrid(self)) delta_rw# 0 // delta_cl#
90690>>>>>    send aps_register_multi_button (oProbeBtn1(self))
90691>>>>>    send aps_register_multi_button (oProbeBtn2(self))
90692>>>>>    send aps_register_multi_button (oProbeBtn3(self))
90693>>>>>    send aps_register_multi_button (oProbeBtn4(self))
90694>>>>>    send aps_register_multi_button (oProbeBtn5(self))
90695>>>>>    send aps_locate_multi_buttons
90696>>>>>    send aps_relocate (oLine(self)) delta_rw# 0
90697>>>>>    send aps_register_multi_button (oBtn1(self))
90698>>>>>    send aps_register_multi_button (oBtn2(self))
90699>>>>>    send aps_locate_multi_buttons
90700>>>>>    send aps_auto_size_container
90701>>>>>  end_procedure
90702>>>>>  procedure aps_beautify
90705>>>>>    send APS_ALIGN_INSIDE_CONTAINER_BY_SIZING (oLine(self)) SL_ALIGN_RIGHT
90706>>>>>    send APS_ALIGN_INSIDE_CONTAINER_BY_SIZING (oGroup(self)) SL_ALIGN_RIGHT
90707>>>>>  end_procedure
90708>>>>>  procedure close_panel_ok
90711>>>>>    set piResult to 1
90712>>>>>    send close_panel
90713>>>>>  end_procedure
90714>>>>>  procedure TransferValuesToParamList integer lhTextDataParameters
90717>>>>>    integer liGrp
90717>>>>>    move (oGroup(self)) to liGrp
90718>>>>>    set value of lhTextDataParameters item TDAT_FIELD_SEP      to (TheValue(oFieldDelimiter(liGrp)))
90719>>>>>    set value of lhTextDataParameters item TDAT_QUOTATION_CHAR to (TheValue(oQuoteChar(liGrp)))
90720>>>>>    set value of lhTextDataParameters item TDAT_DECIMAL_SEP    to (TheValue(oDecimalSeparatorChar(liGrp)))
90721>>>>>    set value of lhTextDataParameters item TDAT_DATE_SEP       to (TheValue(oDateSeparatorChar(liGrp)))
90722>>>>>    set value of lhTextDataParameters item TDAT_DATE_FORMAT    to (TheValue(oDateFormat(liGrp)))
90723>>>>>    set value of lhTextDataParameters item TDAT_COLUMN_NAMES   to (select_state(oColumnNamesInFirstLine(liGrp),0))
90724>>>>>    set value of lhTextDataParameters item TDAT_OEM_CHARSET    to (select_state(oCharacterSet(liGrp),0))
90725>>>>>    set value of lhTextDataParameters item TDAT_COLUMN_COUNT   to (TheValue(oNumberOfColumns(liGrp)))
90726>>>>>  end_procedure
90727>>>>>  procedure popup.si string lsFileName integer lhTextDataReader
90730>>>>>//  integer liGrp lhTextDataParametersPush lhTextDataParameters
90730>>>>>//  move (oGroup(self)) to liGrp
90730>>>>>//  set phTextDataReader to lhTextDataReader
90730>>>>>//  get phTextDataParameters of lhTextDataReader to lhTextDataParametersPush
90730>>>>>//  set piResult to 0
90730>>>>>//  set value of (oTestFile(self)) item 0 to lsFileName
90730>>>>>//  set phTextDataParameters of lhTextDataReader  to (oTextDataParameters(self))
90730>>>>>//
90730>>>>>//  set TheValue of (oFieldDelimiter(liGrp))       to (value(lhTextDataParametersPush,TDAT_FIELD_SEP))
90730>>>>>//  set TheValue of (oQuoteChar(liGrp))            to (value(lhTextDataParametersPush,TDAT_QUOTATION_CHAR))
90730>>>>>//  set TheValue of (oDecimalSeparatorChar(liGrp)) to (value(lhTextDataParametersPush,TDAT_DECIMAL_SEP))
90730>>>>>//  set TheValue of (oDateSeparatorChar(liGrp))    to (value(lhTextDataParametersPush,TDAT_DATE_SEP))
90730>>>>>//  set TheValue of (oDateFormat(liGrp))           to (value(lhTextDataParametersPush,TDAT_DATE_FORMAT))
90730>>>>>//  set select_state of (oColumnNamesInFirstLine(liGrp)) to (integer(value(lhTextDataParametersPush,TDAT_COLUMN_NAMES)))
90730>>>>>//  set select_state of (oCharacterSet(liGrp))     to (integer(value(lhTextDataParametersPush,TDAT_OEM_CHARSET)))
90730>>>>>//  set TheValue of (oNumberOfColumns(liGrp))      to (value(lhTextDataParametersPush,TDAT_COLUMN_COUNT))
90730>>>>>//  send popup
90730>>>>>//  if (piResult(self)) send TransferValuesToParamList lhTextDataParametersPush
90730>>>>>//  set phTextDataParameters of lhTextDataReader to lhTextDataParametersPush
90730>>>>>    integer liGrp lhTextDataParameters lhArrSource lhArrTarget
90730>>>>>    move (oGroup(self)) to liGrp
90731>>>>>    get phTextDataParameters of lhTextDataReader to lhTextDataParameters
90732>>>>>    set piResult to 0
90733>>>>>    set value of (oTestFile(self)) item 0 to lsFileName
90734>>>>>
90734>>>>>    set TheValue of (oFieldDelimiter(liGrp))       to (value(lhTextDataParameters,TDAT_FIELD_SEP))
90735>>>>>    set TheValue of (oQuoteChar(liGrp))            to (value(lhTextDataParameters,TDAT_QUOTATION_CHAR))
90736>>>>>    set TheValue of (oDecimalSeparatorChar(liGrp)) to (value(lhTextDataParameters,TDAT_DECIMAL_SEP))
90737>>>>>    set TheValue of (oDateSeparatorChar(liGrp))    to (value(lhTextDataParameters,TDAT_DATE_SEP))
90738>>>>>    set TheValue of (oDateFormat(liGrp))           to (value(lhTextDataParameters,TDAT_DATE_FORMAT))
90739>>>>>    set select_state of (oColumnNamesInFirstLine(liGrp)) to (integer(value(lhTextDataParameters,TDAT_COLUMN_NAMES)))
90740>>>>>    set select_state of (oCharacterSet(liGrp))     to (integer(value(lhTextDataParameters,TDAT_OEM_CHARSET)))
90741>>>>>    set TheValue of (oNumberOfColumns(liGrp))      to (value(lhTextDataParameters,TDAT_COLUMN_COUNT))
90742>>>>>    send popup
90743>>>>>    if (piResult(self)) begin
90745>>>>>      send TransferValuesToParamList lhTextDataParameters
90746>>>>>      move (oTextDataColumnAnalyser(oTextDataReader(oProbeGrid(self)))) to lhArrSource
90747>>>>>      move (oTextDataColumnAnalyser(lhTextDataReader)) to lhArrTarget
90748>>>>>      send Clone_Array lhArrSource lhArrTarget
90749>>>>>    end
90749>>>>>>
90749>>>>>  end_procedure
90750>>>>>end_object
90751>>>>>
90751>>>>>procedure Popup_TextDataProperties global string lsFileName integer lhTextDataReader
90753>>>>>  send popup.si to (oTextDataProperties(self)) lsFileName lhTextDataReader
90754>>>>>end_procedure
90755>>>>>
90755>>>Use FdxSelct.utl // Functions iFdxSelectOneFile and iFdxSelectOneField
90755>>>Use Fdx2.utl     // FDX aware object for displaying a table definition
90755>>>Use Mapper.pkg   // Dialog for mapping (fields)
90755>>>Use Files.nui    // Utilities for handling file related stuff (No User Interface)
90755>>>Use TableUpd.nui // Class for updating table data
Including file: tableupd.nui    (C:\Apps\VDFQuery\AppSrc\tableupd.nui)
90755>>>>>// Use TableUpd.nui // Class for updating table data
90755>>>>>
90755>>>>>use dfallent
90755>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
90755>>>>>Use Spec0008.utl // Small arrays with integer Codes (Dictionaries)
90755>>>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
90755>>>>>Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface)
90755>>>>>Use API_Attr.nui // Functions for querying API attributes (No User Interface)
90755>>>>>Use ApiIndex.nui // Switch indices offline and online
90755>>>>>
90755>>>>>desktop_section
90760>>>>>  object oTableUpdateLockModes is a cIntegerCodeToText
90762>>>>>    IntegerCodeList
90762>>>>>      Define_IntegerCode TUPD_LOCK_MODE_OPEN_EXCLUSIVE   "Lock mode"
90763>>>>>      Define_IntegerCode TUPD_LOCK_MODE_ONE_TRANSACTION  "All in one transaction"
90764>>>>>      Define_IntegerCode TUPD_LOCK_MODE_UNLOCK_EVERY     "Transaction size"
90765>>>>>      Define_IntegerCode TUPD_LOCK_MODE_NO_LOCK          "No locking"
90766>>>>>    End_IntegerCodeList
90766>>>>>  end_object
90767>>>>>
90767>>>>>  object oTableUpdateParameterList is a cIntegerCodeToText
90769>>>>>    IntegerCodeList
90769>>>>>      Define_IntegerCode TUPD_CREATE_NEW_TABLE     "Create new table"
90770>>>>>      Define_IntegerCode TUPD_ZEROFILE_TABLE       "Reset table before reading"
90771>>>>>      Define_IntegerCode TUPD_OVERWRITE_EXISTING   "Overwrite existing data"
90772>>>>>      Define_IntegerCode TUPD_DO_NOT_CHECK_INDEX   "Do not check for existing records"
90773>>>>>      Define_IntegerCode TUPD_SWITCH_INDEX_OFFLINE "Switch indices off-line"
90774>>>>>      Define_IntegerCode TUPD_LOCK_MODE            "Lock mode"
90775>>>>>      Define_IntegerCode TUPD_UNLOCK_COUNT         "Unlock every # record"
90776>>>>>    End_IntegerCodeList
90776>>>>>  end_object
90777>>>>>end_desktop_section
90782>>>>>
90782>>>>>class cTableUpdateParameters is a cArray
90783>>>>>  procedure construct_object integer liImage
90785>>>>>    forward send construct_object liImage
90787>>>>>    set value item TUPD_CREATE_NEW_TABLE     to DFFALSE
90788>>>>>    set value item TUPD_ZEROFILE_TABLE       to DFFALSE
90789>>>>>    set value item TUPD_OVERWRITE_EXISTING   to DFFALSE
90790>>>>>    set value item TUPD_DO_NOT_CHECK_INDEX   to DFFALSE
90791>>>>>    set value item TUPD_SWITCH_INDEX_OFFLINE to DFFALSE
90792>>>>>    set value item TUPD_LOCK_MODE            to TUPD_LOCK_MODE_UNLOCK_EVERY
90793>>>>>    // Transaction chunk size. Setting TUPD_LOCK_MODE to
90793>>>>>    // TUPD_LOCK_MODE_UNLOCK_EVERY and TUPD_UNLOCK_COUNT to 1
90793>>>>>    // will make the cTableUpdater respond to every lock request.
90793>>>>>    // Setting it to 500 will make the cTable updater unlock
90793>>>>>    // for every 500 update
90793>>>>>    set value item TUPD_UNLOCK_COUNT         to 500
90794>>>>>  end_procedure
90795>>>>>end_class // cTableUpdateParameters
90796>>>>>
90796>>>>>desktop_section // Return values for iBeginTransaction function
90801>>>>>  object oTableUpdateLockRtnVal is a cIntegerCodeToText
90803>>>>>    IntegerCodeList
90803>>>>>      Define_IntegerCode TUPD_ILOCK_RTN_OK                   "OK"
90804>>>>>      Define_IntegerCode TUPD_ILOCK_RTN_MISSING_PARAM_OBJECT "Control object not found"
90805>>>>>      Define_IntegerCode TUPD_ILOCK_RTN_TABLE_COULDNT_OPEN   "Table could not be opened"
90806>>>>>    End_IntegerCodeList
90806>>>>>  end_object
90807>>>>>end_desktop_section
90812>>>>>
90812>>>>>class cTableUpdater is a cArray
90813>>>>>
90813>>>>>  procedure construct_object integer liImage
90815>>>>>    forward send construct_object liImage
90817>>>>>    property integer phTableUpdateParameters public 0
90818>>>>>    property integer piFile                  public 0
90819>>>>>    // The name of the table including path. If the table should be opened
90819>>>>>    // via FileList only, this property should be left empty.
90819>>>>>    property string  psFilePathName          public ""
90820>>>>>    property integer piRequestSaveCount      public 0
90821>>>>>    property integer piErrorCount            public 0
90822>>>>>    property integer piLockRequestCount      public 0
90823>>>>>
90823>>>>>    // This property holds the transaction chunk size from the setup object
90823>>>>>    // once the transaction is started.
90823>>>>>    property integer piPrv.LockResponse      public 0
90824>>>>>    property integer piPrv.LockMode          public 0
90825>>>>>
90825>>>>>    property string  psPrv.Indices           public ""
90826>>>>>  end_procedure
90827>>>>>
90827>>>>>            // If file  is already open when this function os called
90827>>>>>            // no attempt is made to interpret the contents of property
90827>>>>>            // psFilePathName. In that case the file will remain open in its
90827>>>>>            // current mode.
90827>>>>>            function iOpen returns integer
90829>>>>>              integer liLockMode liRval liFile liOpenMode liOpenRes
90829>>>>>              string lsFilePathName
90829>>>>>
90829>>>>>              move TUPD_ILOCK_RTN_OK to liRval // No errors, default return value
90830>>>>>
90830>>>>>              get piFile         to liFile
90831>>>>>              get psFilePathName to lsFilePathName
90832>>>>>              get value of (phTableUpdateParameters(self)) item TUPD_LOCK_MODE to liLockMode
90833>>>>>              // If the file is not already open:
90833>>>>>              ifnot (integer(API_AttrValue_FILE(DF_FILE_OPENED,liFile))) begin
90835>>>>>                if (liLockMode=TUPD_LOCK_MODE_OPEN_EXCLUSIVE) move DF_EXCLUSIVE to liOpenMode
90838>>>>>                else move DF_SHARE to liOpenMode
90840>>>>>                if (lsFilePathName="") move (DBMS_OpenFile(liFile,liOpenMode,0)) to liOpenRes
90843>>>>>                else move (DBMS_OpenFileAs(lsFilePathName,liFile,liOpenMode,0)) to liOpenRes
90845>>>>>                ifnot liOpenRes move TUPD_ILOCK_RTN_TABLE_COULDNT_OPEN to liRval
90848>>>>>              end
90848>>>>>>
90848>>>>>              set piLockRequestCount to 0
90849>>>>>              set piRequestSaveCount to 0
90850>>>>>              set piErrorCount       to 0
90851>>>>>              set piPrv.LockResponse to (value(phTableUpdateParameters(self),TUPD_UNLOCK_COUNT))
90852>>>>>              set piPrv.LockMode     to (value(phTableUpdateParameters(self),TUPD_LOCK_MODE))
90853>>>>>              function_return liRval
90854>>>>>            end_function
90855>>>>>
90855>>>>>            procedure SwitchIndicesOffLine
90857>>>>>              integer liFile
90857>>>>>              string lsIndices
90857>>>>>              get piFile to liFile
90858>>>>>              get DoSwitchIndicesOffLine liFile to lsIndices
90859>>>>>              set psPrv.Indices to lsIndices
90860>>>>>            end_procedure
90861>>>>>            procedure SwitchIndicesOnLine
90863>>>>>              integer liFile
90863>>>>>              string lsIndices
90863>>>>>              get piFile to liFile
90864>>>>>              get psPrv.Indices to lsIndices
90865>>>>>              send DoSwitchIndicesOnline liFile lsIndices
90866>>>>>            end_procedure
90867>>>>>
90867>>>>>  function iBeginTransaction returns integer
90869>>>>>    integer lhTableUpdateParameters liRval liLockMode lbZerofile liFile
90869>>>>>    integer IbIndicesOffline
90869>>>>>    get piFile to liFile
90870>>>>>    get phTableUpdateParameters to lhTableUpdateParameters
90871>>>>>    if lhTableUpdateParameters begin
90873>>>>>      get iOpen to liRval
90874>>>>>      if (liRval=TUPD_ILOCK_RTN_OK) begin // It opened OK
90876>>>>>        get value of lhTableUpdateParameters item TUPD_ZEROFILE_TABLE to lbZerofile
90877>>>>>        if lbZerofile zerofile liFile
90880>>>>>
90880>>>>>        get value of lhTableUpdateParameters item TUPD_SWITCH_INDEX_OFFLINE to IbIndicesOffline
90881>>>>>        if IbIndicesOffline send SwitchIndicesOffLine
90884>>>>>
90884>>>>>        // If it has been specified that all should be done in one
90884>>>>>        // transaction, we lock the file here:
90884>>>>>        get value of lhTableUpdateParameters item TUPD_LOCK_MODE to liLockMode
90885>>>>>        if liLockMode eq TUPD_LOCK_MODE_ONE_TRANSACTION lock
90888>>>>>      end
90888>>>>>>
90888>>>>>    end
90888>>>>>>
90888>>>>>    else move TUPD_ILOCK_RTN_MISSING_PARAM_OBJECT to liRval
90890>>>>>    function_return liRval
90891>>>>>  end_function
90892>>>>>
90892>>>>>  function iEndTransaction returns integer
90894>>>>>    integer liLockMode IbIndicesOffline lhTableUpdateParameters
90894>>>>>    get phTableUpdateParameters to lhTableUpdateParameters
90895>>>>>    get piPrv.LockMode to liLockMode
90896>>>>>    if (liLockMode=TUPD_LOCK_MODE_ONE_TRANSACTION) unlock
90899>>>>>    if (liLockMode=TUPD_LOCK_MODE_UNLOCK_EVERY and piLockRequestCount(self)<>0) unlock
90902>>>>>
90902>>>>>    get value of lhTableUpdateParameters item TUPD_SWITCH_INDEX_OFFLINE to IbIndicesOffline
90903>>>>>    if IbIndicesOffline send SwitchIndicesOnLine
90906>>>>>
90906>>>>>    function_return 0 // All is well
90907>>>>>  end_function
90908>>>>>
90908>>>>>  procedure DoLock
90910>>>>>    integer liLockRequestCount
90910>>>>>    // We lock only if lock mode has been set to TUPD_LOCK_MODE_UNLOCK_EVERY
90910>>>>>    if (piPrv.LockMode(self)=TUPD_LOCK_MODE_UNLOCK_EVERY) begin
90912>>>>>      get piLockRequestCount to liLockRequestCount
90913>>>>>      ifnot liLockRequestCount lock
90916>>>>>      set piLockRequestCount to (liLockRequestCount+1)
90917>>>>>    end
90917>>>>>>
90917>>>>>  end_procedure
90918>>>>>
90918>>>>>  procedure DoUnlock
90920>>>>>    integer liLockRequestCount liTransactionChunkSize
90920>>>>>    get piLockRequestCount to liLockRequestCount
90921>>>>>    get piPrv.LockResponse to liTransactionChunkSize
90922>>>>>    if (liLockRequestCount>=liTransactionChunkSize) begin
90924>>>>>      unlock
90925>>>>>>
90925>>>>>      set piLockRequestCount to 0
90926>>>>>    end
90926>>>>>>
90926>>>>>  end_procedure
90927>>>>>
90927>>>>>  // The function returns the number of errors generated by the
90927>>>>>  // saverecord command.
90927>>>>>  function iSaveRecord returns integer
90929>>>>>    integer liFile liRval
90929>>>>>    get piFile to liFile
90930>>>>>    set piRequestSaveCount to (piRequestSaveCount(self)+1)
90931>>>>>//  send ErrorHnd_Quiet_Activate // Transfer error handling to quiet handler
90931>>>>>    saverecord liFile
90932>>>>>//  send ErrorHnd_Quiet_Deactivate // Reset to normal error handling
90932>>>>>//  move (ErrorHnd_Quiet_ErrorCount()) to liRval
90932>>>>>    if liRval set piErrorCount to (piErrorCount(self)+1)
90935>>>>>    function_return liRval
90936>>>>>  end_function
90937>>>>>end_class
90938>>>Use AppDB.utl    // Create data tables
Including file: appdb.utl    (C:\Apps\VDFQuery\AppSrc\appdb.utl)
90938>>>>>// Use AppDB.utl     // Create data tables
90938>>>>>
90938>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
90938>>>>>Use API_Attr.nui // Functions for querying API attributes
90938>>>>>Use FDX.nui      // cFDX class
90938>>>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
90938>>>>>Use StructEx.utl // Restructuring extensions
90938>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
90938>>>>>
90938>>>>>
90938>>>>>desktop_section
90943>>>>>  object oAppDB_FdxFileDef is a cFdxFileDef NO_IMAGE
90945>>>>>  end_object
90946>>>>>end_desktop_section
90951>>>>>
90951>>>>>class cListOfAppDb is a cArray
90952>>>>>  item_property_list
90952>>>>>    item_property integer phAppDb.i
90952>>>>>  end_item_property_list cListOfAppDb
#REM 90981 DEFINE FUNCTION PHAPPDB.I INTEGER LIROW RETURNS INTEGER
#REM 90985 DEFINE PROCEDURE SET PHAPPDB.I INTEGER LIROW INTEGER VALUE
90990>>>>>  procedure RegisterAppDb integer lhAppDb
90992>>>>>    integer liRow
90992>>>>>    get row_count to liRow
90993>>>>>    set phAppDb.i liRow to lhAppDb
90994>>>>>  end_procedure
90995>>>>>end_class // cListOfAppDb
90996>>>>>
90996>>>>>desktop_section
91001>>>>>  object oListOfAllAppDb is a cListOfAppDb NO_IMAGE
91003>>>>>  end_object
91004>>>>>end_desktop_section
91009>>>>>
91009>>>>>class cAppDbFieldList is a cArray
91010>>>>>  item_property_list
91010>>>>>    item_property string  psName.i       // Field name
91010>>>>>    item_property integer piType.i       // Field type
91010>>>>>    item_property integer piLength.i
91010>>>>>    item_property integer piPrecision.i
91010>>>>>    item_property integer piOverlapFrom.i
91010>>>>>    item_property integer piOverlapTo.i
91010>>>>>    item_property integer piMainIndex.i
91010>>>>>    item_property integer piRelFile.i
91010>>>>>    item_property integer piRelField.i
91010>>>>>    item_property integer piOverlapOffset.i
91010>>>>>  end_item_property_list cAppDbFieldList
#REM 91066 DEFINE FUNCTION PIOVERLAPOFFSET.I INTEGER LIROW RETURNS INTEGER
#REM 91070 DEFINE PROCEDURE SET PIOVERLAPOFFSET.I INTEGER LIROW INTEGER VALUE
#REM 91074 DEFINE FUNCTION PIRELFIELD.I INTEGER LIROW RETURNS INTEGER
#REM 91078 DEFINE PROCEDURE SET PIRELFIELD.I INTEGER LIROW INTEGER VALUE
#REM 91082 DEFINE FUNCTION PIRELFILE.I INTEGER LIROW RETURNS INTEGER
#REM 91086 DEFINE PROCEDURE SET PIRELFILE.I INTEGER LIROW INTEGER VALUE
#REM 91090 DEFINE FUNCTION PIMAININDEX.I INTEGER LIROW RETURNS INTEGER
#REM 91094 DEFINE PROCEDURE SET PIMAININDEX.I INTEGER LIROW INTEGER VALUE
#REM 91098 DEFINE FUNCTION PIOVERLAPTO.I INTEGER LIROW RETURNS INTEGER
#REM 91102 DEFINE PROCEDURE SET PIOVERLAPTO.I INTEGER LIROW INTEGER VALUE
#REM 91106 DEFINE FUNCTION PIOVERLAPFROM.I INTEGER LIROW RETURNS INTEGER
#REM 91110 DEFINE PROCEDURE SET PIOVERLAPFROM.I INTEGER LIROW INTEGER VALUE
#REM 91114 DEFINE FUNCTION PIPRECISION.I INTEGER LIROW RETURNS INTEGER
#REM 91118 DEFINE PROCEDURE SET PIPRECISION.I INTEGER LIROW INTEGER VALUE
#REM 91122 DEFINE FUNCTION PILENGTH.I INTEGER LIROW RETURNS INTEGER
#REM 91126 DEFINE PROCEDURE SET PILENGTH.I INTEGER LIROW INTEGER VALUE
#REM 91130 DEFINE FUNCTION PITYPE.I INTEGER LIROW RETURNS INTEGER
#REM 91134 DEFINE PROCEDURE SET PITYPE.I INTEGER LIROW INTEGER VALUE
#REM 91138 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 91142 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
91147>>>>>  procedure DoReset
91149>>>>>    send delete_data
91150>>>>>  end_procedure
91151>>>>>  function iFindFieldName.s string lsFieldName returns integer
91153>>>>>    integer liMax liRow
91153>>>>>    get row_count to liMax
91154>>>>>    decrement liMax
91155>>>>>    move (uppercase(lsFieldName)) to lsFieldName
91156>>>>>    for liRow from 0 to liMax
91162>>>>>>
91162>>>>>      if (uppercase(psName.i(self,liRow))=lsFieldName) function_return liRow
91165>>>>>    loop
91166>>>>>>
91166>>>>>    function_return -1
91167>>>>>  end_function
91168>>>>>  function iByteLengthFieldRange integer liFromRow integer liToRow returns integer
91170>>>>>    integer liRval liRow liType liLength
91170>>>>>    move 0 to liRval
91171>>>>>    for liRow from liFromRow to liToRow
91177>>>>>>
91177>>>>>      get piType.i liRow to liType
91178>>>>>      if (liType<>DF_OVERLAP) begin
91180>>>>>        get piLength.i liRow to liLength
91181>>>>>        if liType eq DF_BCD move (liLength/2) to liLength
91184>>>>>        move (liRval+liLength) to liRval
91185>>>>>      end
91185>>>>>>
91185>>>>>    loop
91186>>>>>>
91186>>>>>    function_return liRval
91187>>>>>  end_function
91188>>>>>  procedure DoEndDefinition
91190>>>>>    integer liRow liMax liFromRow liToRow liOffset liLength
91190>>>>>    get row_count to liMax
91191>>>>>    decrement liMax
91192>>>>>    for liRow from 0 to liMax // Dates
91198>>>>>>
91198>>>>>      if (piType.i(self,liRow)=DF_DATE) set piLength.i liRow to 3
91201>>>>>    loop
91202>>>>>>
91202>>>>>    for liRow from 0 to liMax
91208>>>>>>
91208>>>>>      if (piType.i(self,liRow)=DF_OVERLAP) begin
91210>>>>>        move (piOverlapFrom.i(self,liRow)-1) to liFromRow
91211>>>>>        move (piOverlapTo.i(self,liRow)-1) to liToRow
91212>>>>>        get iByteLengthFieldRange 0 (liFromRow-1) to liOffset
91213>>>>>        increment liOffSet
91214>>>>>        get iByteLengthFieldRange liFromRow liToRow to liLength
91215>>>>>        set piLength.i liRow to liLength
91216>>>>>        set piOverlapOffset.i liRow to liOffset
91217>>>>>      end
91217>>>>>>
91217>>>>>    loop
91218>>>>>>
91218>>>>>  end_procedure
91219>>>>>  procedure DoAddField string lsName integer liType number lnLength
91221>>>>>    integer liRow liPrecision
91221>>>>>//    if (length(lsName)>15) error 254 ("Field name too long ("+lsName+")")
91221>>>>>    get row_count to liRow
91222>>>>>    set psName.i   liRow to lsName
91223>>>>>    set piType.i   liRow to liType
91224>>>>>    if liType eq DF_BCD begin
91226>>>>>      move (lnLength-integer(lnLength)*10) to liPrecision
91227>>>>>      move (integer(lnLength)) to lnLength
91228>>>>>      set piLength.i liRow to (lnLength+liPrecision)
91229>>>>>      set piPrecision to liPrecision
91230>>>>>    end
91230>>>>>>
91230>>>>>    else set piLength.i liRow to lnLength
91232>>>>>  end_procedure
91233>>>>>  procedure Set piPrecision integer liPrecision
91235>>>>>    set piPrecision.i (row_count(self)-1) to liPrecision
91236>>>>>  end_procedure
91237>>>>>  procedure Set piMainIndex integer liIndex
91239>>>>>    set piMainIndex.i (row_count(self)-1) to liindex
91240>>>>>  end_procedure
91241>>>>>  procedure Set piOverlapFieldRange integer liFieldFrom integer liFieldTo
91243>>>>>    set piOverlapFrom.i (row_count(self)-1) to liFieldFrom
91244>>>>>    set piOverlapTo.i   (row_count(self)-1) to liFieldTo
91245>>>>>  end_procedure
91246>>>>>  procedure Set piRelation integer liFile integer liField
91248>>>>>    set piRelFile.i  (row_count(self)-1) to liFile
91249>>>>>    set piRelField.i (row_count(self)-1) to liField
91250>>>>>  end_procedure
91251>>>>>end_class // cAppDbFieldList
91252>>>>>
91252>>>>>class cAppDbIndexList is a cArray
91253>>>>>  procedure construct_object integer liImg
91255>>>>>    forward send construct_object liImg
91257>>>>>    property integer piCurrentDefiningIndex public -1
91258>>>>>  end_procedure
91259>>>>>  item_property_list
91259>>>>>    item_property integer piOnline.i // On-line/Batch
91259>>>>>    item_property string  psFields.i
91259>>>>>    item_property string  psUppercase.i
91259>>>>>    item_property string  psDirection.i
91259>>>>>  end_item_property_list cAppDbIndexList
#REM 91297 DEFINE FUNCTION PSDIRECTION.I INTEGER LIROW RETURNS STRING
#REM 91301 DEFINE PROCEDURE SET PSDIRECTION.I INTEGER LIROW STRING VALUE
#REM 91305 DEFINE FUNCTION PSUPPERCASE.I INTEGER LIROW RETURNS STRING
#REM 91309 DEFINE PROCEDURE SET PSUPPERCASE.I INTEGER LIROW STRING VALUE
#REM 91313 DEFINE FUNCTION PSFIELDS.I INTEGER LIROW RETURNS STRING
#REM 91317 DEFINE PROCEDURE SET PSFIELDS.I INTEGER LIROW STRING VALUE
#REM 91321 DEFINE FUNCTION PIONLINE.I INTEGER LIROW RETURNS INTEGER
#REM 91325 DEFINE PROCEDURE SET PIONLINE.I INTEGER LIROW INTEGER VALUE
91330>>>>>  function iSegments.i integer liIndex returns integer
91332>>>>>    function_return (length(psFields.i(self,liIndex))/4)
91333>>>>>  end_function
91334>>>>>  procedure DoReset
91336>>>>>    send delete_data
91337>>>>>  end_procedure
91338>>>>>  procedure DoAddIndex integer liIndex integer liOnLine
91340>>>>>    set piCurrentDefiningIndex to liIndex
91341>>>>>    set piOnline.i liIndex to liOnline
91342>>>>>  end_procedure
91343>>>>>  procedure DoAddSegment integer liField integer lbUppercased integer liDirection
91345>>>>>    integer liIndex
91345>>>>>    get piCurrentDefiningIndex to liIndex
91346>>>>>    set psFields.i    liIndex to (psFields.i(self,liIndex)+pad(string(liField),4))
91347>>>>>    set psUppercase.i liIndex to (psUppercase.i(self,liIndex)+pad(string(lbUppercased),4))
91348>>>>>    set psDirection.i liIndex to (psDirection.i(self,liIndex)+pad(string(liDirection),4))
91349>>>>>  end_procedure
91350>>>>>  function iHelpExtract.si string lsValue integer liSegment returns integer
91352>>>>>    function_return (mid(lsValue,4,liSegment-1*4+1))
91353>>>>>  end_function
91354>>>>>  function iIndexSegmentField integer liIndex integer liSegment returns integer
91356>>>>>    function_return (iHelpExtract.si(self,psFields.i(self,liIndex),liSegment))
91357>>>>>  end_function
91358>>>>>  function iIndexSegmentUppercase integer liIndex integer liSegment returns integer
91360>>>>>    function_return (iHelpExtract.si(self,psUppercase.i(self,liIndex),liSegment))
91361>>>>>  end_function
91362>>>>>  function iIndexSegmentDirection integer liIndex integer liSegment returns integer
91364>>>>>    function_return (iHelpExtract.si(self,psDirection.i(self,liIndex),liSegment))
91365>>>>>  end_function
91366>>>>>end_class // cAppDbIndexList
91367>>>>>
91367>>>>>class cAppDbTable is a cAppDbFieldList
91368>>>>>  procedure construct_object integer liImg
91370>>>>>    integer liSelf
91370>>>>>    forward send construct_object liImg
91372>>>>>    property integer piFile            public 0
91373>>>>>    property string  psRoot            public ""
91374>>>>>    property string  psLogicalName     public ""
91375>>>>>    property string  psUserName        public ""
91376>>>>>    property integer piMaxRecords      public 10000
91377>>>>>    property integer piMultiuser       public DF_FILE_USER_MULTI
91378>>>>>    property integer piReuse_deleted   public DF_FILE_DELETED_REUSE
91379>>>>>    property integer piCompression     public DF_FILE_COMPRESS_NONE
91380>>>>>    property integer piIntegrity_check public DFTRUE
91381>>>>>    property integer piTransaction     public DF_FILE_TRANSACTION_CLIENT_ATOMIC
91382>>>>>    property integer piLockType        public DF_LOCK_TYPE_FILE
91383>>>>>    object oAppDbIndexList is a cAppDbIndexList NO_IMAGE
91385>>>>>    end_object
91386>>>>>
91386>>>>>    property integer prv.DefineCalled public DFFALSE
91387>>>>>
91387>>>>>    move self to liSelf
91388>>>>>    send DoRegisterTableDefinition liSelf // Caught by enclosing cAppDb object
91389>>>>>  end_procedure
91390>>>>>
91390>>>>>  procedure OnDefine
91392>>>>>  end_procedure
91393>>>>>
91393>>>>>  procedure DoDefine
91395>>>>>    ifnot (prv.DefineCalled(self)) begin
91397>>>>>      set prv.DefineCalled to DFTRUE // Important that this is first.
91398>>>>>      send DoReset_Help DFFALSE
91399>>>>>      send OnDefine
91400>>>>>      send DoEndDefinition
91401>>>>>    end
91401>>>>>>
91401>>>>>  end_procedure
91402>>>>>
91402>>>>>  procedure DoReset_Help integer lbAll
91404>>>>>    forward send DoReset
91406>>>>>    send DoReset to (oAppDbIndexList(self))
91407>>>>>    if lbAll begin
91409>>>>>      set piFile            to 0
91410>>>>>      set psRoot            to ""
91411>>>>>      set psLogicalName     to ""
91412>>>>>      set psUserName        to ""
91413>>>>>      set piMaxRecords      to 10000
91414>>>>>      set piMultiuser       to DF_FILE_USER_MULTI
91415>>>>>      set piReuse_deleted   to DF_FILE_DELETED_REUSE
91416>>>>>      set piCompression     to DF_FILE_COMPRESS_NONE
91417>>>>>      set piIntegrity_check to DF_FILE_INTEGRITY_CHECK
91418>>>>>      set piTransaction     to DF_FILE_TRANSACTION_CLIENT_ATOMIC
91419>>>>>    end
91419>>>>>>
91419>>>>>  end_procedure
91420>>>>>
91420>>>>>  procedure DoReset
91422>>>>>    send DoReset_Help DFTRUE
91423>>>>>  end_procedure
91424>>>>>
91424>>>>>  procedure set FileListValues integer liFile string lsRoot string lsLogicalName string lsUserName
91426>>>>>    set piFile        to liFile
91427>>>>>    set psRoot        to lsRoot
91428>>>>>    set psLogicalName to lsLogicalName
91429>>>>>    set psUserName    to lsUserName
91430>>>>>  end_procedure
91431>>>>>
91431>>>>>  procedure DoAddIndex integer liIndex integer lbOnLine
91433>>>>>    send DoAddIndex to (oAppDbIndexList(self)) liIndex lbOnLine
91434>>>>>  end_procedure
91435>>>>>  procedure DoAddSegment integer liField integer lbUppercased integer liDirection
91437>>>>>    send DoAddSegment to (oAppDbIndexList(self)) liField lbUppercased liDirection
91438>>>>>  end_procedure
91439>>>>>  procedure DoAddOnlineIndex integer liIndex string lsFieldNames
91441>>>>>    integer liItem liSegments liField
91441>>>>>    integer lbUppercased lbDescending
91441>>>>>    string lsFieldName
91441>>>>>    send DoAddIndex liIndex DF_INDEX_TYPE_ONLINE
91442>>>>>    get HowManyWords lsFieldNames " ," to liSegments
91443>>>>>    for liItem from 1 to liSegments
91449>>>>>>
91449>>>>>      get ExtractWord lsFieldNames " ," liItem to lsFieldName
91450>>>>>
91450>>>>>      if (left(lsFieldName,1)="-") begin
91452>>>>>        move (StringRightBut(lsFieldName,1)) to lsFieldName
91453>>>>>        move DFTRUE to lbDescending
91454>>>>>      end
91454>>>>>>
91454>>>>>      else move DFFALSE to lbDescending
91456>>>>>
91456>>>>>      if (uppercase(lsFieldName)=lsFieldName) move DFTRUE to lbUppercased
91459>>>>>      else move DFFALSE to lbUppercased
91461>>>>>
91461>>>>>      get iFindFieldName.s lsFieldName to liField
91462>>>>>      increment liField
91463>>>>>
91463>>>>>      if (liField=0 and uppercase(lsFieldName)<>"RECNUM") move -1 to liField
91466>>>>>
91466>>>>>      if (liField<>-1) ;         send DoAddSegment liField ;           (if(lbUppercased,DF_CASE_IGNORED,DF_CASE_USED)) ;           (if(lbDescending,DF_DESCENDING,DF_ASCENDING))
91469>>>>>      else error 652 "Illegal fieldname in index spec (AppDB)"
91471>>>>>    loop
91472>>>>>>
91472>>>>>  end_procedure
91473>>>>>  procedure DoRelate string lsFileDotField
91475>>>>>    string lsDFFileName lsFieldName
91475>>>>>    integer lhObj liField
91475>>>>>    get ExtractWord lsFileDotField "." 1 to lsDFFileName
91476>>>>>    get ExtractWord lsFileDotField "." 2 to lsFieldName
91477>>>>>    if (lsDFFileName="" or lsFieldName="") error 653 ("Illegal relation name ("+lsFileDotField+")")
91480>>>>>    else begin
91481>>>>>      get iFindObjectTableName.s lsDFFileName to lhObj
91482>>>>>      if (lhObj=-1) error 654 ("Illegal relation name ("+lsFileDotField+")")
91485>>>>>      else begin
91486>>>>>        send DoDefine to lhObj
91487>>>>>        get iFindFieldName.s of lhObj lsFieldName to liField
91488>>>>>        if (liField=-1) error 655 ("Illegal relation name ("+lsFileDotField+")")
91491>>>>>        else set piRelation to (piFile(lhObj)) (liField+1)
91493>>>>>      end
91493>>>>>>
91493>>>>>    end
91493>>>>>>
91493>>>>>  end_procedure
91494>>>>>  function iIndexSegmentField integer liIndex integer liSegment returns integer
91496>>>>>    function_return (iIndexSegmentField(oAppDbIndexList(self),liIndex,liSegment))
91497>>>>>  end_function
91498>>>>>  function iIndexSegmentUppercase integer liIndex integer liSegment returns integer
91500>>>>>    function_return (iIndexSegmentUppercase(oAppDbIndexList(self),liIndex,liSegment))
91501>>>>>  end_function
91502>>>>>  function iIndexSegmentDirection integer liIndex integer liSegment returns integer
91504>>>>>    function_return (iIndexSegmentDirection(oAppDbIndexList(self),liIndex,liSegment))
91505>>>>>  end_function
91506>>>>>  function iIndexSegments integer liIndex returns integer
91508>>>>>    function_return (iSegments.i(oAppDbIndexList(self),liIndex))
91509>>>>>  end_function
91510>>>>>  function iIndexType integer liIndex returns integer
91512>>>>>    function_return (piOnline.i(oAppDbIndexList(self),liIndex))
91513>>>>>  end_function
91514>>>>>
91514>>>>>  procedure OnTableOpened
91516>>>>>  end_procedure
91517>>>>>  procedure OnTableCreated // Sent when a definition was created
91519>>>>>  end_procedure
91520>>>>>
91520>>>>>  // Function returns   1   if table can be opened,
91520>>>>>  //                    0   if not
91520>>>>>  //             and   -1   if incompatible FileList data exists
91520>>>>>  function iCheckFile returns integer
91522>>>>>    integer liFile liRval
91522>>>>>    string lsRoot lsFileListRoot
91522>>>>>    get piFile to liFile
91523>>>>>    get psRoot to lsRoot
91524>>>>>    get API_AttrValue_FILELIST DF_FILE_ROOT_NAME liFile to lsFileListRoot
91525>>>>>    if (lsFileListRoot="") begin // Maybe we should create the file
91527>>>>>      set_attribute DF_FILE_ROOT_NAME    of liFile to lsRoot
91530>>>>>      set_attribute DF_FILE_LOGICAL_NAME of liFile to (psLogicalName(self))
91533>>>>>      set_attribute DF_FILE_DISPLAY_NAME of liFile to (rtrim(psUserName(self)))
91536>>>>>    end
91536>>>>>>
91536>>>>>
91536>>>>>    get API_AttrValue_FILELIST DF_FILE_ROOT_NAME liFile to lsFileListRoot
91537>>>>>    if (uppercase(DBMS_StripPathAndDriver(lsRoot))<>uppercase(DBMS_StripPathAndDriver(lsFileListRoot))) function_return -1 // Incompatible FileList data
91540>>>>>
91540>>>>>    get DBMS_CanOpenFile liFile to liRval
91541>>>>>    if liRval move 1 to liRval // Otherwise liRval indicates the driver needed
91544>>>>>    else begin
91545>>>>>      send DoTransferDefToFdx self (oAppDB_FdxFileDef(self))
91546>>>>>      get RSX_CreateTableFromFDX (oAppDB_FdxFileDef(self)) liFile lsRoot to liRval
91547>>>>>      if liRval send OnTableCreated
91550>>>>>    end
91550>>>>>>
91550>>>>>
91550>>>>>    function_return liRval
91551>>>>>  end_function
91552>>>>>
91552>>>>>  function iOpen returns integer
91554>>>>>    integer liFile liRval
91554>>>>>    get piFile to liFile
91555>>>>>    get DBMS_OpenFile liFile to liRval
91556>>>>>    if liRval send OnTableOpened
91559>>>>>    function_return liFile
91560>>>>>  end_function
91561>>>>>end_class // cAppDbTable
91562>>>>>
91562>>>>>class cAppDb is a cArray
91563>>>>>  procedure construct_object integer liImg
91565>>>>>    forward send construct_object liImg
91567>>>>>    property string  psLocation     public ""
91568>>>>>    property integer piDescriptImg  public 0
91569>>>>>    send RegisterAppDb to (oListOfAllAppDb(self)) self
91570>>>>>  end_procedure
91571>>>>>
91571>>>>>  procedure DoReset
91573>>>>>    integer liItm liMax lhObj
91573>>>>>    get item_count to liMax
91574>>>>>    decrement liMax
91575>>>>>    for liItm from 0 to liMax
91581>>>>>>
91581>>>>>      get value item liItm to lhObj
91582>>>>>      if lhObj send request_destroy_object to lhObj
91585>>>>>    loop
91586>>>>>>
91586>>>>>    send delete_data
91587>>>>>  end_procedure
91588>>>>>
91588>>>>>  procedure DoRegisterTableDefinition integer lhObj
91590>>>>>    set value item (item_count(self)) to lhObj
91591>>>>>  end_procedure
91592>>>>>
91592>>>>>  function iFindObjectTableName.s string lsDFFileName returns integer
91594>>>>>    integer liItm liMax lhObj
91594>>>>>    get item_count to liMax
91595>>>>>    decrement liMax
91596>>>>>    move (uppercase(lsDFFileName)) to lsDFFileName
91597>>>>>    for liItm from 0 to liMax
91603>>>>>>
91603>>>>>      get value item liItm to lhObj
91604>>>>>      if (uppercase(psLogicalName(lhObj))=lsDFFileName) function_return lhObj
91607>>>>>    loop
91608>>>>>>
91608>>>>>    // function_return 0
91608>>>>>  end_function
91609>>>>>
91609>>>>>  function iFindTableRow.i integer liFile returns integer
91611>>>>>    integer liItm liMax
91611>>>>>    get item_count to liMax
91612>>>>>    decrement liMax
91613>>>>>    for liItm from 0 to liMax
91619>>>>>>
91619>>>>>      if (piFile(value(self,liItm))=liFile) function_return liItm
91622>>>>>    loop
91623>>>>>>
91623>>>>>    function_return -1
91624>>>>>  end_function
91625>>>>>
91625>>>>>  function iOperational returns integer
91627>>>>>    integer liItm liMax lhObj liStatus liRval
91627>>>>>    get item_count to liMax
91628>>>>>    decrement liMax
91629>>>>>    move 1 to liRval
91630>>>>>    for liItm from 0 to liMax
91636>>>>>>
91636>>>>>      get value item liItm to lhObj
91637>>>>>      get iCheckFile of lhObj to liStatus
91638>>>>>      if (liStatus<>1) move 0 to liRval
91641>>>>>    loop
91642>>>>>>
91642>>>>>    function_return liRval
91643>>>>>  end_function
91644>>>>>
91644>>>>>  function iOpen returns integer
91646>>>>>    integer liItm liMax lhObj liStatus liRval
91646>>>>>    get item_count to liMax
91647>>>>>    decrement liMax
91648>>>>>    move 1 to liRval
91649>>>>>    for liItm from 0 to liMax
91655>>>>>>
91655>>>>>      get value item liItm to lhObj
91656>>>>>      get iOpen of lhObj to liStatus
91657>>>>>      if (liStatus=0) move 0 to liRval
91660>>>>>    loop
91661>>>>>>
91661>>>>>    function_return liRval
91662>>>>>  end_function
91663>>>>>
91663>>>>>  function iCreateNewTableObject integer liFile string lsRoot string lsLogical string lsDisplay returns integer
91665>>>>>    integer liRval
91665>>>>>    object oAppDbTable is a cAppDbTable NO_IMAGE
91667>>>>>      set FileListValues to liFile lsRoot lsLogical lsDisplay
91668>>>>>      move self to liRval
91669>>>>>    end_object
91670>>>>>    function_return liRval
91671>>>>>  end_function
91672>>>>>end_class // cAppDb
91673>>>>>
91673>>>>>procedure DoTransferDefToFdx global integer lhAppDbTable integer lhFdx
91675>>>>>  integer liRow liMax liFile liFieldType liIndex liSegment liMaxSegment
91675>>>>>
91675>>>>>  send DoDefine to lhAppDbTable
91676>>>>>  send Reset to lhFdx
91677>>>>>  get piFile of lhAppDbTable to liFile
91678>>>>>  set piMainFile of lhFDX to liFile
91679>>>>>
91679>>>>>  set AttrValue_FILE of lhFDX DF_FILE_MAX_RECORDS     liFile to (piMaxRecords(self))
91680>>>>>  set AttrValue_FILE of lhFDX DF_FILE_MULTIUSER       liFile to (piMultiuser(self))
91681>>>>>  set AttrValue_FILE of lhFDX DF_FILE_REUSE_DELETED   liFile to (piReuse_deleted(self))
91682>>>>>  set AttrValue_FILE of lhFDX DF_FILE_COMPRESSION     liFile to (piCompression(self))
91683>>>>>  set AttrValue_FILE of lhFDX DF_FILE_INTEGRITY_CHECK liFile to (piIntegrity_check(self))
91684>>>>>  set AttrValue_FILE of lhFDX DF_FILE_TRANSACTION     liFile to (piTransaction(self))
91685>>>>>  set AttrValue_FILE of lhFDX DF_FILE_LOCK_TYPE       liFile to (piLockType(self))
91686>>>>>  set AttrValue_FILE of lhFDX DF_FILE_RECORD_LENGTH   liFile to 8 // Automatically incremented during field appending
91687>>>>>
91687>>>>>  get row_count of lhAppDbTable to liMax
91688>>>>>  set AttrValue_FILE of lhFDX DF_FILE_NUMBER_FIELDS liFile to liMax
91689>>>>>  decrement liMax
91690>>>>>  for liRow from 0 to liMax
91696>>>>>>
91696>>>>>    get piType.i of lhAppDbTable liRow to liFieldType
91697>>>>>    set AttrValue_FIELD of lhFDX DF_FIELD_NAME          liFile (liRow+1) to (psName.i(lhAppDbTable,liRow))
91698>>>>>    set AttrValue_FIELD of lhFDX DF_FIELD_TYPE          liFile (liRow+1) to liFieldType
91699>>>>>    set AttrValue_FIELD of lhFDX DF_FIELD_LENGTH        liFile (liRow+1) to (piLength.i(lhAppDbTable,liRow))
91700>>>>>    set AttrValue_FIELD of lhFDX DF_FIELD_PRECISION     liFile (liRow+1) to (piPrecision.i(lhAppDbTable,liRow))
91701>>>>>    set AttrValue_FIELD of lhFDX DF_FIELD_RELATED_FILE  liFile (liRow+1) to (piRelFile.i(lhAppDbTable,liRow))
91702>>>>>    set AttrValue_FIELD of lhFDX DF_FIELD_RELATED_FIELD liFile (liRow+1) to (piRelField.i(lhAppDbTable,liRow))
91703>>>>>    set AttrValue_FIELD of lhFDX DF_FIELD_INDEX         liFile (liRow+1) to (piMainIndex.i(lhAppDbTable,liRow))
91704>>>>>    if liFieldType eq DF_OVERLAP begin
91706>>>>>      set AttrValue_FIELD of lhFDX DF_FIELD_OFFSET      liFile (liRow+1) to (piOverlapOffset.i(lhAppDbTable,liRow))
91707>>>>>    end
91707>>>>>>
91707>>>>>  loop
91708>>>>>>
91708>>>>>
91708>>>>>  for liIndex from 1 to 15
91714>>>>>>
91714>>>>>    get iIndexSegments of lhAppDbTable liIndex to liMaxSegment
91715>>>>>    if liMaxSegment begin
91717>>>>>      set AttrValue_INDEX of lhFDX DF_INDEX_TYPE            liFile liIndex to (iIndexType(lhAppDbTable,liIndex))
91718>>>>>      set AttrValue_INDEX of lhFDX DF_INDEX_NUMBER_SEGMENTS liFile liIndex to liMaxSegment
91719>>>>>      for liSegment from 1 to liMaxSegment
91725>>>>>>
91725>>>>>        set AttrValue_IDXSEG of lhFDX DF_INDEX_SEGMENT_FIELD     liFile liIndex liSegment to (iIndexSegmentField(lhAppDbTable,liIndex,liSegment))
91726>>>>>        set AttrValue_IDXSEG of lhFDX DF_INDEX_SEGMENT_DIRECTION liFile liIndex liSegment to (iIndexSegmentDirection(lhAppDbTable,liIndex,liSegment))
91727>>>>>        set AttrValue_IDXSEG of lhFDX DF_INDEX_SEGMENT_CASE      liFile liIndex liSegment to (iIndexSegmentUppercase(lhAppDbTable,liIndex,liSegment))
91728>>>>>      loop
91729>>>>>>
91729>>>>>    end
91729>>>>>>
91729>>>>>  loop
91730>>>>>>
91730>>>>>//send FDX_ModalDisplayFileAttributes lhFdx liFile
91730>>>>>end_procedure
91731>>>>>procedure DoTransferFdxToDef global integer lhFdx integer lhAppDbTable
91733>>>>>end_procedure
91734>>>
91734>>>object oFdxImport_RoowName is a aps.ModalPanel label "Specify file root name for new table"
91737>>>  set locate_mode to CENTER_ON_SCREEN
91738>>>  on_key ksave_record send close_panel_ok
91739>>>  on_key kcancel send close_panel
91740>>>  property integer piResult public DFFALSE
91742>>>
91742>>>  object oFrm is a aps.Form abstract AFT_ASCII80
91745>>>    set p_extra_internal_width to -200
91746>>>  end_object
91747>>>  object oBtn1 is a aps.Multi_Button
91749>>>    on_item t.btn.ok send close_panel_ok
91750>>>  end_object
91751>>>  object oBtn2 is a aps.Multi_Button
91753>>>    on_item t.btn.cancel send close_panel
91754>>>  end_object
91755>>>  send aps_locate_multi_buttons
91756>>>  procedure close_panel_ok
91759>>>    set piResult to DFTRUE
91760>>>    send close_panel
91761>>>  end_procedure
91762>>>  function sPopup returns string
91765>>>    string lsRval
91765>>>    set piResult to DFFALSE
91766>>>    move "" to lsRval
91767>>>    send popup
91768>>>    if (piResult(self)) get value of oFrm item 0 to lsRval
91771>>>    function_return (trim(lsRval))
91772>>>  end_function
91773>>>end_object
91774>>>
91774>>>activate_view Activate_FdxImport_Vw for oFdxImport_Vw
91779>>>object oFdxImport_Vw is a aps.View label "Import data from text file"
91782>>>
91782>>>  object oTextDataParameters is a cTextDataParameters
91784>>>  end_object
91785>>>  object oTextDataReader is a cTextDataReader
91787>>>    set phTextDataParameters to (oTextDataParameters(self))
91788>>>    procedure DoSetup string lsFileName
91791>>>      integer liResult
91791>>>      get iFileOpen.s lsFileName to liResult
91792>>>      if (liResult=TDATFO_OK) send FileClose
91795>>>      else send obs "Not OK"
91797>>>    end_procedure
91798>>>  end_object
91799>>>
91799>>>  object oFDXDataFileImport is a cFDXDataFile
91801>>>  end_object
91802>>>
91802>>>  object oFileMapObject is a cMapObject
91804>>>  end_object
91805>>>  object oTableMapObject is a cMapObject
91807>>>  end_object
91808>>>  object oMapper is a cMapper
91810>>>    set phObject1 to (oFileMapObject(self))
91811>>>    set phObject2 to (oTableMapObject(self))
91812>>>  end_object
91813>>>
91813>>>  object oTableFDX is a cFdxFileDef
91815>>>  end_object
91816>>>
91816>>>  object oTableUpdateParameters is a cTableUpdateParameters NO_IMAGE
91818>>>  end_object
91819>>>  object oTableUpdater is a cTableUpdater NO_IMAGE
91821>>>    set phTableUpdateParameters to (oTableUpdateParameters(self))
91822>>>    function iUpdateRow returns integer
91825>>>      integer lhMapper lhTextDataReader liRow liMax liFile liColumn liField
91825>>>      integer liResult
91825>>>      string lsValue
91825>>>
91825>>>      move (oTextDataReader(self)) to lhTextDataReader
91826>>>      move (oMapper(self)) to lhMapper
91827>>>      get piFile to liFile
91828>>>      clear liFile
91829>>>      get row_count of lhMapper to liMax
91830>>>      decrement liMax
91831>>>//      showln "New row in file:"
91831>>>      for liRow from 0 to liMax
91837>>>>
91837>>>        get piIdent1.i of lhMapper liRow to liColumn
91838>>>        get piIdent2.i of lhMapper liRow to liField
91839>>>//        showln ("File: "+string(liFile)+", field: "+string(liField)) (" Column: "+string(liColumn)) ("  "+value(lhTextDataReader,liColumn))
91839>>>        get sConvertedValue.i of lhTextDataReader liColumn to lsValue
91840>>>        set_field_value liFile liField to lsValue
91843>>>      loop
91844>>>>
91844>>>      get iSaveRecord to liResult
91845>>>//      showln ("SAVE "+string(liResult)+" errors")
91845>>>      function_return 0 // Do not cancel
91846>>>    end_function
91847>>>    procedure DoUpdate string lsFileName string lsTableName
91850>>>      integer lhObj lhTextDataReader liResult
91850>>>      move (oTextDataReader(self)) to lhTextDataReader
91851>>>      move self to lhObj
91852>>>      set piFile         to 37
91853>>>      set psFilePathName to lsTableName
91854>>>      get iBeginTransaction to liResult
91855>>>      if (liResult=TUPD_ILOCK_RTN_OK) begin
91857>>>        send DoCallback to lhTextDataReader lsFileName get_iUpdateRow lhObj
91858>>>        get iEndTransaction to liResult // Always returns 0
91859>>>      end
91859>>>>
91859>>>      close 37
91860>>>    end_procedure
91861>>>  end_object // oTableUpdater
91862>>>
91862>>>  on_key kCancel send close_panel
91863>>>  object oGrp1 is a aps.Group label "Input file"
91866>>>    object oInputFile is a aps.Form abstract AFT_ASCII80 label "File Name"
91870>>>      set p_extra_internal_width to -250
91871>>>      procedure prompt
91874>>>        string lsFileName
91874>>>        get SEQ_SelectInFile "Select text data file" "Text files|*.txt|FDX data files|*.txd|All files|*.*" to lsFileName
91875>>>        if lsFileName ne "" set value item 0 to lsFileName
91878>>>      end_procedure
91879>>>      on_key kprompt send prompt
91880>>>    end_object
91881>>>    object oBtn1 is a aps.Button snap SL_RIGHT_SPACE
91884>>>      on_item "Browse" send prompt to (oInputFile(self))
91885>>>    end_object
91886>>>    object oBtn2 is a aps.Button snap SL_DOWN
91889>>>      on_item "Properties" send DoInputFileProperties
91890>>>    end_object
91891>>>    procedure DoInputFileProperties
91894>>>      integer liIsFdxData
91894>>>      string lsFileName
91894>>>      get value of (oInputFile(self)) item 0 to lsFileName
91895>>>      if (lsFileName<>"") begin
91897>>>        if (SEQ_FileExists(lsFileName)=SEQIT_FILE) begin
91899>>>          get lbIsFdxDataFile of (oFDXDataFileImport(self)) lsFileName to liIsFdxData
91900>>>          if liIsFdxData send obs "Display table definition"
91903>>>          else send Popup_TextDataProperties lsFileName (oTextDataReader(self))
91905>>>        end
91905>>>>
91905>>>        else send obs "File not found" ("("+lsFileName+")")
91907>>>      end
91907>>>>
91907>>>    end_procedure
91908>>>  end_object
91909>>>
91909>>>  send aps_goto_max_row
91910>>>  object oGrp2 is a aps.Group label "Target table"
91913>>>    property integer piFile public 0
91915>>>    object oRootName is a aps.Form abstract AFT_ASCII80 label "Table name"
91919>>>      set p_extra_internal_width to -250
91920>>>      procedure prompt
91923>>>        string lsFileName
91923>>>        get SEQ_SelectInFile "Select data file" "DataFlex data files|*.dat|Intermediate files|*.int" to lsFileName
91924>>>        if lsFileName ne "" set value item 0 to lsFileName
91927>>>      end_procedure
91928>>>      on_key kprompt send DoSelectDataFile
91929>>>    end_object
91930>>>    procedure DoSelectDataFile
91933>>>      integer liFile liCanOpen
91933>>>      string lsRootName
91933>>>      get piFile to liFile
91934>>>      get iFdxSelectOneFile 0 liFile to liFile
91935>>>      if liFile begin
91937>>>        set piFile to liFile
91938>>>        close liFile // In the (hopefully) unlikely event that it should be open
91939>>>        move (DBMS_OpenFile(liFile,DF_SHARE,0)) to liCanOpen
91940>>>        if liCanOpen begin
91942>>>          get DBMS_Rootname_Path liFile to lsRootName
91943>>>          set value of (oRootName(self)) item 0 to (lowercase(lsRootName))
91944>>>          close liFile
91945>>>        end
91945>>>>
91945>>>        else send obs "Table can not be opened"
91947>>>      end
91947>>>>
91947>>>    end_procedure
91948>>>    object oBtn1 is a aps.Button snap SL_RIGHT_SPACE
91951>>>      on_item "Filelist" send DoSelectDataFile
91952>>>    end_object
91953>>>//    object oDirectory is a aps.Form abstract AFT_ASCII30 label "Directory"
91953>>>//    end_object
91953>>>    object oBtn2 is a aps.Button snap SL_DOWN
91956>>>      on_item "Browse" send prompt to (oRootName(self))
91957>>>    end_object
91958>>>    object oBtn3 is a aps.Button snap SL_DOWN
91961>>>      procedure DoTableProperties
91964>>>        integer liIsFdxData liCanOpen
91964>>>        string lsFileName
91964>>>        get value of (oRootName(self)) item 0 to lsFileName
91965>>>        if (lsFileName<>"") begin
91967>>>          if (SEQ_FileExists(lsFileName)=SEQIT_FILE) begin
91969>>>            close 37
91970>>>            move (DBMS_OpenFileAs(lsFileName,37,DF_SHARE,0)) to liCanOpen
91971>>>            if liCanopen begin
91973>>>              send FDX_ModalDisplayFileAttributes 0 37
91974>>>              close 37
91975>>>            end
91975>>>>
91975>>>          end
91975>>>>
91975>>>          else send obs "File not found" ("("+lsFileName+")")
91977>>>        end
91977>>>>
91977>>>      end_procedure
91978>>>      on_item "Properties" send DoTableProperties
91979>>>    end_object
91980>>>    object oBtn4 is a aps.Button snap SL_DOWN
91983>>>      object oAppDb is a cAppDb
91985>>>      end_object
91986>>>
91986>>>      procedure DoCreateTable
91989>>>        integer lhObj
91989>>>        string lsRootName
91989>>>        get sPopup of oFdxImport_RoowName to lsRootName
91990>>>        if (lsRootName<>"") begin
91992>>>          send DoReset to oAppDb
91993>>>          get iCreateNewTableObject to lhObj
91994>>>        end
91994>>>>
91994>>>      end_procedure
91995>>>      on_item "Create table" send DoCreateTable
91996>>>    end_object
91997>>>  end_object
91998>>>  send aps_goto_max_row
91999>>>  object oGrp3 is a aps.Group label "Table update parameters"
92002>>>    send tab_column_define 1 30 25 jmode_left // Default column setting
92003>>>    object oCb1 is a aps.CheckBox label "Create new table"
92006>>>      set enabled_state to DFFALSE
92007>>>    end_object
92008>>>    object oCb2 is a aps.CheckBox label "Reset table data before reading"
92011>>>    end_object
92012>>>    object oCb3 is a aps.CheckBox label "Overwrite existing records"
92015>>>      set enabled_state to DFFALSE
92016>>>    end_object
92017>>>    object oCb4 is a aps.CheckBox label "Do not check indices"
92020>>>      set enabled_state to DFFALSE
92021>>>    end_object
92022>>>    object oCb5 is a aps.CheckBox label "Switch indices off-line"
92025>>>    end_object
92026>>>
92026>>>    set p_cur_row to (p_top_margin(self))
92027>>>    Object oLockMode is a aps.RadioGroup Label "Lock mode" snap SL_RIGHT_SPACE relative_to (oCb1(self))
92036>>>      set enabled_state to DFFALSE
92037>>>      object oRad1 is a aps.Radio label "Open exclusive"
92040>>>      end_object
92041>>>      object oRad2 is a aps.Radio label "All in one transaction"
92044>>>      end_object
92045>>>      object oRad3 is a aps.Radio label "Unlock every"
92048>>>      end_object
92049>>>      object oRad3 is a aps.Radio label "No lock"
92052>>>      end_object
92053>>>      object oFrm is a aps.Form abstract AFT_NUMERIC4.0 snap SL_RIGHT relative_to (oRad3(self))
92062>>>      end_object
92063>>>      object oTxt is a aps.TextBox label "record" snap SL_RIGHT
92067>>>      end_object
92068>>>    End_Object
92069>>>  end_object
92070>>>
92070>>>  procedure DoTransferDialogToTableUpdParameters
92073>>>    integer lhGrp lhTableUpdateParameters liLM
92073>>>    move (oTableUpdateParameters(self)) to lhTableUpdateParameters
92074>>>    move (oGrp3(self)) to lhGrp
92075>>>    set value of lhTableUpdateParameters item TUPD_CREATE_NEW_TABLE     to (select_state(oCb1(lhGrp)))
92076>>>    set value of lhTableUpdateParameters item TUPD_ZEROFILE_TABLE       to (select_state(oCb2(lhGrp)))
92077>>>    set value of lhTableUpdateParameters item TUPD_OVERWRITE_EXISTING   to (select_state(oCb3(lhGrp)))
92078>>>    set value of lhTableUpdateParameters item TUPD_DO_NOT_CHECK_INDEX   to (select_state(oCb4(lhGrp)))
92079>>>    set value of lhTableUpdateParameters item TUPD_SWITCH_INDEX_OFFLINE to (select_state(oCb5(lhGrp)))
92080>>>    get current_radio of (oLockMode(lhGrp)) to liLM
92081>>>
92081>>>    if liLM eq 0 set value of lhTableUpdateParameters item TUPD_LOCK_MODE to TUPD_LOCK_MODE_OPEN_EXCLUSIVE
92084>>>    if liLM eq 1 set value of lhTableUpdateParameters item TUPD_LOCK_MODE to TUPD_LOCK_MODE_ONE_TRANSACTION
92087>>>    if liLM eq 2 set value of lhTableUpdateParameters item TUPD_LOCK_MODE to TUPD_LOCK_MODE_UNLOCK_EVERY
92090>>>    if liLM eq 3 set value of lhTableUpdateParameters item TUPD_LOCK_MODE to TUPD_LOCK_MODE_NO_LOCK
92093>>>
92093>>>    set value of lhTableUpdateParameters item TUPD_UNLOCK_COUNT to (value(oFrm(oLockMode(lhGrp)),0))
92094>>>  end_procedure
92095>>>
92095>>>  function sTableName returns string
92098>>>    string lsFileName
92098>>>    get value of (oRootName(oGrp2(self))) item 0 to lsFileName
92099>>>    if (lsFileName<>"") begin
92101>>>      if (SEQ_FileExists(lsFileName)=SEQIT_FILE) begin
92103>>>        ifnot (DBMS_CanOpenFileAs(lsFileName,37)) begin
92105>>>          move "" to lsFileName
92106>>>          send obs "Table can not be opened" ("("+lsFileName+")")
92107>>>        end
92107>>>>
92107>>>      end
92107>>>>
92107>>>      else begin
92108>>>        move "" to lsFileName
92109>>>        send obs "Table not found" ("("+lsFileName+")")
92110>>>      end
92110>>>>
92110>>>    end
92110>>>>
92110>>>    function_return lsFileName
92111>>>  end_function
92112>>>  function sFileName returns string
92115>>>    string lsFileName
92115>>>    get value of (oInputFile(oGrp1(self))) item 0 to lsFileName
92116>>>    if (lsFileName<>"") begin
92118>>>      if (SEQ_FileExists(lsFileName)<>SEQIT_FILE) begin
92120>>>        move "" to lsFileName
92121>>>        send obs "File not found" ("("+lsFileName+")")
92122>>>      end
92122>>>>
92122>>>    end
92122>>>>
92122>>>    function_return lsFileName
92123>>>  end_function
92124>>>
92124>>>  send aps_size_identical_max (oGrp1(self)) (oGrp2(self)) SL_HORIZONTAL
92125>>>  send aps_size_identical_max (oGrp2(self)) (oGrp3(self)) SL_HORIZONTAL
92126>>>  send aps_align_inside_container_by_moving (oLockMode(oGrp3(self))) SL_ALIGN_RIGHT
92127>>>  procedure DoFieldMap
92130>>>    integer lhMapper liOpen
92130>>>    string lsFileName lsTableName
92130>>>    // First we setup the SEQ file mapper
92130>>>    get sFileName to lsFileName
92131>>>    if (lsFileName="") begin
92133>>>      send obs "Input file not found"
92134>>>      procedure_return
92135>>>    end
92135>>>>
92135>>>    send DoSetup to (oTextDataReader(self)) lsFileName
92136>>>    send DoTransferToMapableObject to (oTextDataReader(self)) (oFileMapObject(self))
92137>>>    // Then we setup the table object
92137>>>    get sTableName to lsTableName
92138>>>    if (lsTableName="") begin
92140>>>      send obs "Table not found"
92141>>>      procedure_return
92142>>>    end
92142>>>>
92142>>>
92142>>>    move (DBMS_OpenFileAs(lsTableName,37,DF_SHARE,0)) to liOpen
92143>>>    ifnot liOpen begin
92145>>>      send obs "Table could not be opened"
92146>>>      procedure_return
92147>>>    end
92147>>>>
92147>>>
92147>>>    send Read_File_Definition.i to (oTableFDX(self)) 37
92148>>>
92148>>>    send DoTransferToMapableObject to (oTableFDX(self)) (oTableMapObject(self))
92149>>>
92149>>>    move (oMapper(self)) to lhMapper
92150>>>    send DoMapperDialog "Field map" lhMapper "" "" ""
92151>>>  end_procedure
92152>>>
92152>>>  function sConfigurationFileName returns string
92155>>>    string lsFileName lsExt
92155>>>    get sFileName to lsFileName
92156>>>    if (lsFileName<>"") begin
92158>>>      get SEQ_ExtractExtensionFromFileName lsFileName to lsExt
92159>>>      if (lsExt<>"") move (StringLeftBut(lsFileName,length(lsExt))) to lsFileName
92162>>>      else move (lsFileName+".") to lsFileName
92164>>>      move (lsFileName+"icf") to lsFileName
92165>>>    end
92165>>>>
92165>>>    function_return lsFileName
92166>>>  end_function
92167>>>
92167>>>  procedure DoSaveDialogValues
92170>>>    string lsConfFile
92170>>>    get sConfigurationFileName to lsConfFile
92171>>>    send obs "Config file:" lsConfFile
92172>>>  end_procedure
92173>>>  procedure DoOpenDialogValues
92176>>>  end_procedure
92177>>>
92177>>>  procedure DoImportFile
92180>>>    integer lhMapper liOpen
92180>>>    string lsFileName lsTableName
92180>>>    // First we setup the SEQ file mapper
92180>>>    get sFileName to lsFileName
92181>>>    if (lsFileName="") begin
92183>>>      send obs "Input file not found"
92184>>>      procedure_return
92185>>>    end
92185>>>>
92185>>>    send DoSetup to (oTextDataReader(self)) lsFileName
92186>>>////    send DoTransferToMapableObject to (oTextDataReader(self)) (oFileMapObject(self))
92186>>>    // Then we setup the table object
92186>>>    get sTableName to lsTableName
92187>>>    if (lsTableName="") begin
92189>>>      send obs "Table not found"
92190>>>      procedure_return
92191>>>    end
92191>>>>
92191>>>
92191>>>    move (DBMS_OpenFileAs(lsTableName,37,DF_SHARE,0)) to liOpen
92192>>>    ifnot liOpen begin
92194>>>      send obs "Table could not be opened"
92195>>>      procedure_return
92196>>>    end
92196>>>>
92196>>>    send DoTransferDialogToTableUpdParameters
92197>>>    // Until this point its been identical to top of DoFieldMap procedure
92197>>>    send DoUpdate to (oTableUpdater(self)) lsFileName lsTableName
92198>>>  end_procedure
92199>>>
92199>>>  on_key KEY_CTRL+KEY_S send DoSaveDialogValues
92200>>>  on_key KEY_CTRL+KEY_O send DoOpenDialogValues
92201>>>
92201>>>  object oBtn1 is a aps.multi_button
92203>>>    on_item "Field map" send DoFieldMap
92204>>>  end_object
92205>>>  object oBtn2 is a aps.multi_button
92207>>>    on_item "Read data" send DoImportFile
92208>>>  end_object
92209>>>  object oBtn3 is a aps.multi_button
92211>>>    on_item "Cancel"    send Close_Panel
92212>>>  end_object
92213>>>  send aps_locate_multi_buttons
92214>>>end_object
92215>
92215>    Use DfmSmall.vw
Including file: dfmsmall.vw    (C:\Apps\VDFQuery\AppSrc\dfmsmall.vw)
92215>>>Use APS          // Auto Positioning and Sizing classes for VDF
92215>>>Use Buttons.utl  // Button texts
92215>>>Use GridUtil.utl // Grid and List utilities (not for dbGrid's or Table's)
92215>>>Use Collate.nui
Including file: collate.nui    (C:\Apps\VDFQuery\AppSrc\collate.nui)
92215>>>>>// Use Collate.nui  // A little collating thing
92215>>>>>
92215>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
92215>>>>>Use Strings.nui  // String manipulation for VDF (No User Interface)
92215>>>>>
92215>>>>>class cCollateArray is a cArray
92216>>>>>  procedure fill_current_sort_order
92218>>>>>    integer liCharacter
92218>>>>>    for liCharacter from 32 to 255
92224>>>>>>
92224>>>>>      set value item (liCharacter-32) to (character(liCharacter))
92225>>>>>    loop
92226>>>>>>
92226>>>>>    send sort_items
92227>>>>>  end_procedure
92228>>>>>  function sStringValue returns string
92230>>>>>    integer liMax liItem
92230>>>>>    string lsRval
92230>>>>>    get item_count to liMax
92231>>>>>    decrement liMax
92232>>>>>    move "" to lsRval
92233>>>>>    for liItem from 0 to liMax
92239>>>>>>
92239>>>>>      move (lsRval+value(self,liItem)) to lsRval
92240>>>>>    loop
92241>>>>>>
92241>>>>>    function_return lsRval
92242>>>>>  end_function
92243>>>>>end_class // cCollateArray
92244>>>>>
92244>>>>>desktop_section
92249>>>>>  object oCollateArray is a cCollateArray NO_IMAGE
92251>>>>>    property string psCollateString         public ""
92253>>>>>    property string psCollateStringReversed public ""
92255>>>>>    procedure Init
92258>>>>>      string lsValue
92258>>>>>      get sStringValue to lsValue
92259>>>>>      set psCollateString to lsValue
92260>>>>>      set psCollateStringReversed to (StringReverse(lsValue))
92261>>>>>    end_procedure
92262>>>>>    send fill_current_sort_order
92263>>>>>    send Init
92264>>>>>  end_object
92265>>>>>end_desktop_section
92270>>>>>
92270>>>>>function Collate_String global returns string
92272>>>>>  function_return (psCollateString(oCollateArray(self)))
92273>>>>>end_function
92274>>>>>function Collate_ReversedString global returns string
92276>>>>>  function_return (psCollateStringReversed(oCollateArray(self)))
92277>>>>>end_function
92278>>>>>
92278>>>>>string gs$ReversedCollateString 255
92278>>>>>move (repeat(" ",31)+Collate_ReversedString()) to gs$ReversedCollateString
92279>>>>>
92279>>>
92279>>>activate_view Activate_SmallDfmThings_Vw for oSmallDfmThings_Vw
92284>>>object oSmallDfmThings_Vw is a aps.View label "Miscellaneous"
92287>>>  on_key KCANCEL send close_panel
92288>>>  object oTabs is a aps.TabDialog
92290>>>    object oTab1 is a aps.TabPage label "Collate sequence"
92293>>>      set p_auto_column to FALSE
92294>>>      object oTestArray is a cCollateArray
92296>>>        send fill_current_sort_order
92297>>>      end_object
92298>>>      object oLst is a aps.Grid
92300>>>        send GridPrepare_AddColumn "Order"     AFT_ASCII5
92301>>>        send GridPrepare_AddColumn "ASCII"     AFT_ASCII5
92302>>>        send GridPrepare_AddColumn "Character" AFT_ASCII5
92303>>>        send GridPrepare_AddColumn "Uppercase" AFT_ASCII5
92304>>>        send GridPrepare_Apply self
92305>>>        set select_mode to NO_SELECT
92306>>>        on_key KNEXT_ITEM send switch
92307>>>        on_key KPREVIOUS_ITEM send switch_back
92308>>>        procedure fill_list
92311>>>          integer lhObj liMax liItem
92311>>>          set dynamic_update_state to DFFALSE
92312>>>          send delete_data
92313>>>          move (oTestArray(self)) to lhObj
92314>>>          get item_count of lhObj to liMax
92315>>>          decrement liMax
92316>>>          for liItem from 0 to liMax
92322>>>>
92322>>>            send add_item msg_none (string(liItem+1))
92323>>>            send add_item msg_none (ascii(value(lhObj,liItem)))
92324>>>            send add_item msg_none (value(lhObj,liItem))
92325>>>            send add_item msg_none (uppercase(value(lhObj,liItem)))
92326>>>          loop
92327>>>>
92327>>>          send Grid_SetEntryState self DFFALSE
92328>>>          set dynamic_update_state to DFTRUE
92329>>>        end_procedure
92330>>>        send fill_list
92331>>>        on_key KEY_CTRL+KEY_R send sort_data
92332>>>        on_key KEY_CTRL+KEY_W send DoWriteToFile
92333>>>        procedure DoWriteToFile
92336>>>          send Grid_DoWriteToFile self
92337>>>        end_procedure
92338>>>
92338>>>        function iSpecialSortValueOnColumn.i integer column# returns integer
92341>>>          if column# eq 0 function_Return 1
92344>>>          if column# eq 1 function_Return 1
92347>>>        end_function
92348>>>
92348>>>        function sSortValue.ii integer column# integer itm# returns string
92351>>>          if column# eq 0 function_return (IntToStrR(value(self,itm#),3))
92354>>>          if column# eq 1 function_return (IntToStrR(value(self,itm#),3))
92357>>>        end_function
92358>>>
92358>>>        procedure sort_data.i integer column#
92361>>>          send Grid_SortByColumn self column#
92362>>>        end_procedure
92363>>>
92363>>>        procedure sort_data
92366>>>          integer cc#
92366>>>          get Grid_CurrentColumn self to cc#
92367>>>          send sort_data.i cc#
92368>>>        end_procedure
92369>>>        procedure header_mouse_click integer itm#
92372>>>          send sort_data.i itm#
92373>>>          forward send header_mouse_click itm#
92375>>>        end_procedure
92376>>>      end_object // oLst
92377>>>    end_object
92378>>>  end_object
92379>>>  object oBtn is a aps.Multi_Button
92381>>>    on_item t.btn.close send close_panel
92382>>>  end_object
92383>>>  send aps_locate_multi_buttons
92384>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
92385>>>  procedure aps_onResize integer delta_rw# integer delta_cl#
92388>>>    send aps_resize (oTabs(self)) delta_rw# 0 // delta_cl#
92389>>>    send aps_resize (oLst(oTab1(oTabs(self)))) delta_rw# 0 // delta_cl#
92390>>>    send aps_register_multi_button (oBtn(self))
92391>>>    send aps_locate_multi_buttons
92392>>>    send aps_auto_size_container
92393>>>  end_procedure
92394>>>end_object
92395>
92395>    Use TestLock.Vw
Including file: TestLock.vw    (C:\Apps\VDFQuery\AppSrc\TestLock.vw)
92395>>>// Skriv lock count efter hver lock/unlock
92395>>>// Make panel resizable
92395>>>// Skriv DF-fejlmeddelser ind i listen
92395>>>// Giv mulighed for at logge sekvensen til fil (flles med en anden maskine). Nr denne funktion vlges
92395>>>// promptes brugeren for det navn som processen skal identificere sig med i loggen.
92395>>>// Hvis "Open (share)" og "Open (Excl)" lukker filerne fr de bner dem, s skriv det (i listen).
92395>>>// Skriv hvilken DB-driver hvergang en tabel bnes.
92395>>>// Indfr "Reset list" knap
92395>>>// Marker grafisk hvilke knapper, der er "Table operation" buttons.
92395>>>//
92395>>>// Reset list, Log to file,
92395>>>//
92395>>>//   TestLock is a utility that allows you to test the table locking function in DataFlex.
92395>>>//
92395>>>//   Select a table to test. Start another DFMatrix and select the same table. Then Perform
92395>>>//   the operations you desire by clicking the "table operation" buttons.
92395>>>//
92395>>>//   If any DF-errors occurs during operation, they will appear in the log-listing.
92395>>>//
92395>>>//   Finally, you may have more instances of TestLock (DFMatrix) writing to the same disk-file log at
92395>>>//   the same time. This may be used to help document a special sequence of events, that
92395>>>//   leads to an error situation.
92395>>>
92395>>>Use APS          // Auto Positioning and Sizing classes for VDF
92395>>>Use Buttons.utl  // Button texts
92395>>>Use Files.utl    // Utilities for handling file related stuff
92395>>>Use OpenStat.nui // cTablesOpenStatus class (formely cFileAllFiles) (No User Interface)
92395>>>Use DBMS.nui     // Basic DBMS functions (No User Interface)
92395>>>Use Version.nui
92395>>>
92395>>>enumeration_list
92395>>>  define TLOP_DoOpenShare
92395>>>  define TLOP_DoOpenExclusive
92395>>>  define TLOP_DoCloseTable
92395>>>  define TLOP_DoLock
92395>>>  define TLOP_DoUnlock
92395>>>end_enumeration_list
92395>>>
92395>>>object oTestLockVw is a aps.ModalPanel label "Test file locking"
92398>>>  set locate_mode to CENTER_ON_SCREEN
92399>>>  on_key kcancel send close_panel
92400>>>
92400>>>  object oRootName is a aps.Form abstract AFT_ASCII80 label "Table name"
92404>>>    set p_extra_internal_width to -150
92405>>>    procedure prompt
92408>>>      string lsFileName
92408>>>      get SEQ_SelectInFile "Select data file" "DataFlex data files|*.dat|Intermediate files|*.int" to lsFileName
92409>>>      if lsFileName ne "" set value item 0 to lsFileName
92412>>>    end_procedure
92413>>>    on_key kprompt send Prompt
92414>>>    set peAnchors to (anRight+anLeft+anTop)
92415>>>  end_object
92416>>>  object oPrompt is a aps.Button
92418>>>    on_item "Browse" send prompt to (oRootName(self))
92419>>>    set peAnchors to (anRight+anTop)
92420>>>  end_object
92421>>>  send aps_goto_max_row
92422>>>  object oLst is a aps.List
92424>>>    set size to 100 360
92425>>>    procedure Add_Line string lsValue
92428>>>      integer liItem
92428>>>      get item_count to liItem
92429>>>      send add_item MSG_NONE lsValue
92430>>>      set current_item to liItem
92431>>>    end_procedure
92432>>>    set peAnchors to (anRight+anLeft+anTop+anBottom)
92433>>>  end_object
92434>>>
92434>>>  send aps_goto_max_row
92435>>>
92435>>>  procedure TakeAction integer liOpCodesend
92438>>>    integer liResult
92438>>>    string lsFileName
92438>>>
92438>>>    if (liOpCodesend=TLOP_DoOpenShare) begin
92440>>>      get value of oRootName to lsFileName
92441>>>      get DBMS_OpenFileAs lsFileName 10 DF_SHARE 0 to liResult
92442>>>      send add_line to oLst (if(liResult,"Ok","Failure"))
92443>>>    end
92443>>>>
92443>>>    if (liOpCodesend=TLOP_DoOpenExclusive) begin
92445>>>      get value of oRootName to lsFileName
92446>>>      get DBMS_OpenFileAs lsFileName 10 DF_EXCLUSIVE 0 to liResult
92447>>>      send add_line to oLst (if(liResult,"Ok","Failure"))
92448>>>    end
92448>>>>
92448>>>    if (liOpCodesend=TLOP_DoCloseTable) begin
92450>>>      close 10
92451>>>    end
92451>>>>
92451>>>    if (liOpCodesend=TLOP_DoLock) begin
92453>>>      lock
92454>>>>
92454>>>    end
92454>>>>
92454>>>    if (liOpCodesend=TLOP_DoUnlock) begin
92456>>>      unlock
92457>>>>
92457>>>    end
92457>>>>
92457>>>    send add_line to oLst "Ready!"
92458>>>  end_procedure
92459>>>
92459>>>  procedure DoOpenShare
92462>>>    integer liResult
92462>>>    send add_line to (oLst(self)) "Open (shared)..."
92463>>>    send TakeAction TLOP_DoOpenShare
92464>>>
92464>>>  end_procedure
92465>>>  procedure DoOpenExclusive
92468>>>    send add_line to (oLst(self)) "Open (exclusive)..."
92469>>>    send TakeAction TLOP_DoOpenExclusive
92470>>>  end_procedure
92471>>>  procedure DoCloseTable
92474>>>    send add_line to (oLst(self)) "Close table..."
92475>>>    send TakeAction TLOP_DoCloseTable
92476>>>  end_procedure
92477>>>  procedure DoLock
92480>>>    send add_line to (oLst(self)) "Lock..."
92481>>>    send TakeAction TLOP_DoLock
92482>>>  end_procedure
92483>>>  procedure DoUnlock
92486>>>    send add_line to (oLst(self)) "Unlock..."
92487>>>    send TakeAction TLOP_DoUnlock
92488>>>  end_procedure
92489>>>
92489>>>  object oBtn1 is a aps.Multi_Button
92491>>>    on_item "Open (share)" send DoOpenShare
92492>>>    set peAnchors to (anRight+anBottom)
92493>>>  end_object
92494>>>  object oBtn2 is a aps.Multi_Button
92496>>>    on_item "Open (excl.)" send DoOpenExclusive
92497>>>    set peAnchors to (anRight+anBottom)
92498>>>  end_object
92499>>>  object oBtn3 is a aps.Multi_Button
92501>>>    on_item "Close table"  send DoCloseTable
92502>>>    set peAnchors to (anRight+anBottom)
92503>>>  end_object
92504>>>  send aps_locate_multi_buttons
92505>>>  object oBtn4 is a aps.Multi_Button
92507>>>    on_item "Lock"         send DoLock
92508>>>    set peAnchors to (anRight+anBottom)
92509>>>  end_object
92510>>>  object oBtn5 is a aps.Multi_Button
92512>>>    on_item "Unlock"       send DoUnlock
92513>>>    set peAnchors to (anRight+anBottom)
92514>>>  end_object
92515>>>  object oBtn6 is a aps.Multi_Button
92517>>>    on_item "Close panel"  send close_panel
92518>>>    set peAnchors to (anRight+anBottom)
92519>>>  end_object
92520>>>  send aps_locate_multi_buttons
92521>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
92522>>>  procedure popup
92525>>>    send OpenStat_RegisterFiles
92526>>>    send OpenStat_CloseAllFiles
92527>>>    forward send popup
92529>>>    send OpenStat_RestoreFiles
92530>>>  end_procedure
92531>>>end_object // oTestLockVw
92532>>>
92532>>>procedure Popup_TestLockPanel
92535>>>  send popup to (oTestLockVw(self))
92536>>>end_procedure
92537>    Use FolderTree.Vw
Including file: foldertree.vw    (C:\Apps\VDFQuery\AppSrc\foldertree.vw)
92537>>>// use foldertree.pkg // cFolderTree class
92537>>>use foldertree.nui // cFolderTree class
Including file: foldertree.nui    (C:\Apps\VDFQuery\AppSrc\foldertree.nui)
92537>>>>>// use foldertree.nui // cFolderTree class
92537>>>>>
92537>>>>>use treenode.nui // Defines the cTreeNode class.
Including file: treenode.nui    (C:\Apps\VDFQuery\AppSrc\treenode.nui)
92537>>>>>>>//use treenode.nui // Defines the cTreeNode class.
92537>>>>>>>
92537>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
92537>>>>>>>
92537>>>>>>>class cTreeNodeDataObject is a cArray
92538>>>>>>>  procedure DoReset
92540>>>>>>>    // This needs to be defined because the cTreeNode will send this
92540>>>>>>>    // message as preparation for destroying the object.
92540>>>>>>>  end_procedure
92541>>>>>>>  procedure SEQ_Read integer liChannel
92543>>>>>>>  end_procedure
92544>>>>>>>  procedure SEQ_Write integer liChannel
92546>>>>>>>  end_procedure
92547>>>>>>>  function TreeViewLabel returns string
92549>>>>>>>    function_return "No label"
92550>>>>>>>  end_function
92551>>>>>>>end_class // cTreeNodeDataObject
92552>>>>>>>
92552>>>>>>>class cTreeNode is a cArray
92553>>>>>>>  //> The items of this array holds pointers to child nodes
92553>>>>>>>  procedure construct_object
92555>>>>>>>    forward send construct_object
92557>>>>>>>    //> Pointer to the parent node. Only the ultimate parent will have a 0 value in this property
92557>>>>>>>    property integer phParentNode public 0
92558>>>>>>>
92558>>>>>>>    //> This Points to an object that holds the data of this particular node:
92558>>>>>>>    property integer phDataObject public 0
92559>>>>>>>
92559>>>>>>>    //> All data objects created as children of this object will be of this class:
92559>>>>>>>    property integer phDataClass  public U_cTreeNodeDataObject
92560>>>>>>>
92560>>>>>>>    //> All child node objects created as children of this object will be of this class:
92560>>>>>>>    property integer phNodeClass public U_cTreeNode
92561>>>>>>>  end_procedure
92562>>>>>>>
92562>>>>>>>                procedure insert_item integer liInsertItem
92564>>>>>>>                  // Insert an empty item in the list of childnodes (aux procedure for
92564>>>>>>>                  // the hInsertChildNode function.
92564>>>>>>>                  integer liItem liMax
92564>>>>>>>                  get item_count to liMax
92565>>>>>>>                  for_ex liItem from liMax down_to (liInsertItem+1)
92572>>>>>>>                    set value item liItem to (value(self,liItem-1))
92573>>>>>>>                  loop
92574>>>>>>>>
92574>>>>>>>                  set value item liInsertItem to 0
92575>>>>>>>                end_procedure
92576>>>>>>>
92576>>>>>>>                function hCreateChildNode returns integer
92578>>>>>>>                  integer lhObject lhClass
92578>>>>>>>                  get phNodeClass to lhClass
92579>>>>>>>                  name lhClass U_cTreeNodeClass
92579>>>>>>>                  object oTreeNode is a cTreeNodeClass NO_IMAGE
92581>>>>>>>                    move self to lhObject
92582>>>>>>>                  end_object
92583>>>>>>>                  function_return lhObject
92584>>>>>>>                end_function
92585>>>>>>>
92585>>>>>>>  //> Create and append a child node. The function returns the object id of the
92585>>>>>>>  //> new child node.
92585>>>>>>>  function hAddChildNode returns integer
92587>>>>>>>    integer liItem lhObject
92587>>>>>>>    get item_count to liItem
92588>>>>>>>    get hCreateChildNode to lhObject
92589>>>>>>>    set phParentNode of lhObject to self
92590>>>>>>>    set value item liItem to lhObject
92591>>>>>>>    function_return lhObject
92592>>>>>>>  end_function
92593>>>>>>>  //> Create and insert a node in the list of child nodes. The function returns the object
92593>>>>>>>  //> id of the new child node.
92593>>>>>>>  function hInsertChildNode integer liItem returns integer
92595>>>>>>>    integer lhObject
92595>>>>>>>    send insert_item liItem
92596>>>>>>>
92596>>>>>>>    get hCreateChildNode to lhObject
92597>>>>>>>
92597>>>>>>>    set phParentNode of lhObject to self
92598>>>>>>>    set value item liItem to lhObject
92599>>>>>>>    function_return lhObject
92600>>>>>>>  end_function
92601>>>>>>>
92601>>>>>>>  //> Delete and destroy all data referenced by this object (except the object itself).
92601>>>>>>>  procedure DoReset
92603>>>>>>>    integer liItem liMax
92603>>>>>>>    get item_count to liMax
92604>>>>>>>    decrement liMax
92605>>>>>>>    for liItem from 0 to liMax
92611>>>>>>>>
92611>>>>>>>      send DoDestroy to (integer(value(self,liItem)))
92612>>>>>>>    loop
92613>>>>>>>>
92613>>>>>>>    send delete_data
92614>>>>>>>  end_procedure
92615>>>>>>>
92615>>>>>>>            procedure DestroyDataObject
92617>>>>>>>              integer lhData
92617>>>>>>>              get phDataObject to lhData
92618>>>>>>>              if lhData begin
92620>>>>>>>                send DoReset to lhData // Prepare the object for destroying
92621>>>>>>>                send request_destroy_object to lhData
92622>>>>>>>                set phDataObject to 0
92623>>>>>>>              end
92623>>>>>>>>
92623>>>>>>>            end_procedure
92624>>>>>>>
92624>>>>>>>            function iParentNodeIndex returns integer
92626>>>>>>>              integer lhSelf lhParentNode liMax liItem
92626>>>>>>>              move self to lhSelf
92627>>>>>>>              get phParentNode to lhParentNode
92628>>>>>>>              get item_count of lhParentNode to liMax
92629>>>>>>>              decrement liMax
92630>>>>>>>              for liItem from 0 to liMax
92636>>>>>>>>
92636>>>>>>>                if (integer(value(lhParentNode,liItem))=lhSelf) function_return liItem
92639>>>>>>>              loop
92640>>>>>>>>
92640>>>>>>>              function_return -1
92641>>>>>>>            end_function
92642>>>>>>>
92642>>>>>>>  //> Function Request_SwitchUp will attempt to switch positions with the
92642>>>>>>>  //> preceeding sibling. If successful, true will be returned.
92642>>>>>>>  function Request_SwitchUp returns integer
92644>>>>>>>
92644>>>>>>>  end_function
92645>>>>>>>
92645>>>>>>>  procedure DoDestroy
92647>>>>>>>    send DoReset
92648>>>>>>>    send DestroyDataObject
92649>>>>>>>    send request_destroy_object // Destroy yourself
92650>>>>>>>  end_procedure
92651>>>>>>>
92651>>>>>>>  procedure DoDestroyItem integer liItem
92653>>>>>>>    send DoDestroy to (integer(value(self,liItem)))
92654>>>>>>>    send delete_item liItem
92655>>>>>>>  end_procedure
92656>>>>>>>
92656>>>>>>>  //> Instantiate a data object for this node (of the cTreeNodeDataClass class)
92656>>>>>>>  function hCreateDataObject returns integer
92658>>>>>>>    integer lhObject lhDataClass
92658>>>>>>>    get phDataObject to lhObject
92659>>>>>>>    ifnot lhObject begin
92661>>>>>>>      get phDataClass to lhDataClass
92662>>>>>>>      name lhDataClass U_cTreeNodeDataClass
92662>>>>>>>      object oTreeNodeDataClass is a cTreeNodeDataClass NO_IMAGE
92664>>>>>>>        move self to lhObject
92665>>>>>>>      end_object
92666>>>>>>>      set phDataObject to lhObject
92667>>>>>>>    end
92667>>>>>>>>
92667>>>>>>>    function_return lhObject
92668>>>>>>>  end_function
92669>>>>>>>
92669>>>>>>>  //> This function may be used as a shortcut to retrieve data
92669>>>>>>>  //> from an array based data object
92669>>>>>>>  function DataObject_Array_Value integer liItem returns string
92671>>>>>>>    integer lhObject
92671>>>>>>>    get phDataObject to lhObject
92672>>>>>>>    if lhObject function_return (value(lhObject,liItem))
92675>>>>>>>    function_return ""
92676>>>>>>>  end_function
92677>>>>>>>  procedure set DataObject_Array_Value integer liItem string lsValue
92679>>>>>>>    integer lhObject
92679>>>>>>>    get phDataObject to lhObject
92680>>>>>>>    ifnot lhObject get hCreateDataObject to lhObject
92683>>>>>>>    set value of lhObject item liItem to lsValue
92684>>>>>>>  end_procedure
92685>>>>>>>
92685>>>>>>>  enumeration_list // Tree traverser order
92685>>>>>>>    define TTO_PARENT_FIRST
92685>>>>>>>    define TTO_CHILDREN_FIRST
92685>>>>>>>  end_enumeration_list
92685>>>>>>>
92685>>>>>>>  //> Send message lhMsg to this node object and all children.
92685>>>>>>>  procedure BroadcastNodeMessage integer liTraverseOrder integer lhMsg integer liLevel
92687>>>>>>>    integer liItem liMax lhChildNode lhSelf
92687>>>>>>>    move self to lhSelf
92688>>>>>>>    if (liTraverseOrder=TTO_PARENT_FIRST) send lhMsg liLevel lhSelf // The lhSelf parameter will be handy if the message is caught via delegation
92691>>>>>>>    get item_count to liMax
92692>>>>>>>    decrement liMax
92693>>>>>>>    for liItem from 0 to liMax
92699>>>>>>>>
92699>>>>>>>      get value item liItem to lhChildNode
92700>>>>>>>      send BroadcastNodeMessage to lhChildNode liTraverseOrder lhMsg (liLevel+1)
92701>>>>>>>    loop
92702>>>>>>>>
92702>>>>>>>    if (liTraverseOrder=TTO_CHILDREN_FIRST) send lhMsg liLevel lhSelf // The lhSelf parameter will be handy if the message is caught via delegation
92705>>>>>>>  end_procedure
92706>>>>>>>
92706>>>>>>>  //> Send message lhMsg to the data object of this node and all of
92706>>>>>>>  //> the children of this node. The message will only be sent
92706>>>>>>>  //> if the nodes do actually have a data object.
92706>>>>>>>  procedure BroadcastDataMessage integer liTraverseOrder integer lhMsg integer liLevel
92708>>>>>>>    integer liItem liMax lhChildNode lhSelf lhDataObject
92708>>>>>>>    get phDataObject to lhDataObject
92709>>>>>>>    move self to lhSelf
92710>>>>>>>    if lhDataObject begin
92712>>>>>>>      if (liTraverseOrder=TTO_PARENT_FIRST) send lhMsg to lhDataObject liLevel lhSelf lhDataObject // The lhSelf and lhDataObject parameters will be handy if the message is via through delegation
92715>>>>>>>    end
92715>>>>>>>>
92715>>>>>>>    get item_count to liMax
92716>>>>>>>    decrement liMax
92717>>>>>>>    for liItem from 0 to liMax
92723>>>>>>>>
92723>>>>>>>      get value item liItem to lhChildNode
92724>>>>>>>      send BroadcastDataMessage to lhChildNode liTraverseOrder lhMsg (liLevel+1)
92725>>>>>>>    loop
92726>>>>>>>>
92726>>>>>>>    if lhDataObject begin
92728>>>>>>>      if (liTraverseOrder=TTO_CHILDREN_FIRST) send lhMsg to lhDataObject liLevel lhSelf lhDataObject // The lhSelf and lhDataObject parameters will be handy if the message is via through delegation
92731>>>>>>>    end
92731>>>>>>>>
92731>>>>>>>  end_procedure
92732>>>>>>>
92732>>>>>>>  function ChildCount returns integer
92734>>>>>>>    function_return (item_count(self))
92735>>>>>>>  end_function
92736>>>>>>>  function ChildNodeObject integer liItem returns integer
92738>>>>>>>    function_return (value(self,liItem))
92739>>>>>>>  end_function
92740>>>>>>>end_class // cTreeNode
92741>>>>>>>
92741>>>>>>>
92741>>>>>>>//
92741>>>>>>>//  --- Typical example of treenode subclassing
92741>>>>>>>//
92741>>>>>>>//  enumeration_list // Popup Menu Data item
92741>>>>>>>//    define PMD_TEXT       // Menu item text
92741>>>>>>>//    define PMD_MESSAGE    // Message to be sent
92741>>>>>>>//    define PMD_OBJECT     // Object to receive the message
92741>>>>>>>//    define PMD_PARAMETER  // Parameters to be passed to object
92741>>>>>>>//  end_enumeration_list
92741>>>>>>>//
92741>>>>>>>//  class cPopupMenuDataObject is a cTreeNodeDataObject
92741>>>>>>>//  end_class // cPopupMenuDataObject
92741>>>>>>>//
92741>>>>>>>//  class cPopupMenuTreeNode is  a cTreeNode
92741>>>>>>>//    procedure construct_object
92741>>>>>>>//      forward send construct_object
92741>>>>>>>//
92741>>>>>>>//      set phNodeClass to U_cPopupMenuTreeNode
92741>>>>>>>//      set phDataClass to U_cPopupMenuDataObject
92741>>>>>>>//    end_procedure
92741>>>>>>>//  end_class // cPopupMenuTreeNode
92741>>>>>>>
92741>>>>>>>//
92741>>>>>>>//  --- Small test sample
92741>>>>>>>//
92741>>>>>>>//  object oTestTree is a cTreeNode
92741>>>>>>>//              procedure MakeThreeChildNodes integer lhNode
92741>>>>>>>//                integer lhChildNode
92741>>>>>>>//                get hAddChildNode of lhNode to lhChildNode
92741>>>>>>>//                get hAddChildNode of lhNode to lhChildNode
92741>>>>>>>//                get hAddChildNode of lhNode to lhChildNode
92741>>>>>>>//              end_procedure
92741>>>>>>>//
92741>>>>>>>//    procedure DoPopulate
92741>>>>>>>//      integer lhChildNode lhGrandChildnode
92741>>>>>>>//
92741>>>>>>>//      get hAddChildNode of self to lhChildNode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//      get hAddChildNode of self to lhChildNode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//      get hAddChildNode of self to lhChildNode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//          get hAddChildNode of lhChildNode to lhGrandChildnode
92741>>>>>>>//    end_procedure
92741>>>>>>>//
92741>>>>>>>//    procedure ShowlnYourself integer liLevel integer lhNode
92741>>>>>>>//      showln (repeat("  ",liLevel)+string(lhNode))
92741>>>>>>>//    end_procedure
92741>>>>>>>//
92741>>>>>>>//    send DoPopulate
92741>>>>>>>//    send BroadcastNodeMessage TTO_PARENT_FIRST MSG_ShowlnYourself 0
92741>>>>>>>//    inkey windowindex
92741>>>>>>>//  end_object
92741>>>>>>>
92741>>>>>use Files.nui    // Utilities for handling file related stuff (No User Interface)
92741>>>>>use Strings.nui  // String manipulation for VDF (No User Interface)
92741>>>>>use WinFolder.nui // WinFolder_ReadFolder message
92741>>>>>
92741>>>>>enumeration_list
92741>>>>>  define FTSU_READ_FOLDER_CB_OBJECT
92741>>>>>  define FTSU_READ_FOLDER_CB_MESSAGE
92741>>>>>end_enumeration_list
92741>>>>>
92741>>>>>desktop_section
92746>>>>>object oFolderTreeSetup is a cArray
92748>>>>>  procedure DoReset
92751>>>>>    set value item FTSU_READ_FOLDER_CB_OBJECT  to 0
92752>>>>>    set value item FTSU_READ_FOLDER_CB_MESSAGE to 0
92753>>>>>  end_procedure
92754>>>>>  send DoReset
92755>>>>>end_object
92756>>>>>end_desktop_section
92761>>>>>
92761>>>>>procedure FolderTreeSetup_Reset global
92763>>>>>  send DoReset of oFolderTreeSetup
92764>>>>>end_procedure
92765>>>>>function FolderTreeSetup_Value global integer liItem returns string
92767>>>>>  function_return (value(oFolderTreeSetup(self),liItem))
92768>>>>>end_function
92769>>>>>procedure set FolderTreeSetup_Value global integer liItem string lsValue
92771>>>>>  set value of (oFolderTreeSetup(self)) item liItem to lsValue
92772>>>>>end_procedure
92773>>>>>
92773>>>>>enumeration_list
92773>>>>>  define FLDS_PARENT_FOLDER        // Path to parent folder
92773>>>>>  define FLDS_FOLDER_NAME          // Folder name
92773>>>>>  define FLDS_FOLDER_NAME_PATH     // Folder name including full path
92773>>>>>
92773>>>>>  // The folder itself
92773>>>>>  define FLDS_FILE_COUNT           // File count
92773>>>>>  define FLDS_FOLDER_SIZE          // Folder size
92773>>>>>  define FLDS_MIN_FILESZ           // Minimum file size
92773>>>>>  define FLDS_MAX_FILESZ           // Maximum file size
92773>>>>>  define FLDS_MIN_TIME             // Time of oldest file
92773>>>>>  define FLDS_MAX_TIME             // Time of newest file
92773>>>>>
92773>>>>>  // The folder including its subfolders
92773>>>>>  define FLDSX_FILE_COUNT          // File count
92773>>>>>  define FLDSX_FOLDER_SIZE         // Folder size
92773>>>>>  define FLDSX_MIN_FILESZ          // Minimum file size
92773>>>>>  define FLDSX_MAX_FILESZ          // Maximum file size
92773>>>>>  define FLDSX_MIN_TIME            // Time of oldest file
92773>>>>>  define FLDSX_MAX_TIME            // Time of newest file
92773>>>>>end_enumeration_list
92773>>>>>
92773>>>>>function FolderTree_DataTreeLabel global integer lhData integer lbExpanded returns string
92775>>>>>  integer liFileCount
92775>>>>>  number lnFolderSize
92775>>>>>  string lsValue
92775>>>>>  get value of lhData item FLDS_FOLDER_NAME to lsValue
92776>>>>>  move (lsValue+" (# in # files)") to lsValue
92777>>>>>  if lbExpanded begin
92779>>>>>    get value of lhData item FLDS_FILE_COUNT  to liFileCount
92780>>>>>    get value of lhData item FLDS_FOLDER_SIZE to lnFolderSize
92781>>>>>  end
92781>>>>>>
92781>>>>>  else begin
92782>>>>>    get value of lhData item FLDSX_FILE_COUNT  to liFileCount
92783>>>>>    get value of lhData item FLDSX_FOLDER_SIZE to lnFolderSize
92784>>>>>  end
92784>>>>>>
92784>>>>>  move (replace("#",lsValue,replace(",",SEQ_FileSizeToString(lnFolderSize),"."))) to lsValue
92785>>>>>  move (replace("#",lsValue,liFileCount)) to lsValue
92786>>>>>  function_return lsValue
92787>>>>>end_function // FolderTree_DataTreeLabel
92788>>>>>
92788>>>>>class cFolderData is a cTreeNodeDataObject
92789>>>>>
92789>>>>>  procedure ReadDataFromFolder string lsFolder
92791>>>>>    integer liRow liMax lhWinFolderEntries lbFirst lhMsg lhObj
92791>>>>>    number  lnFolderSz lnSizeMin lnSizeMax lnTimeMin lnTimeMax lnSize lnTime
92791>>>>>    string lsParentFolder
92791>>>>>
92791>>>>>    set value item FLDS_FOLDER_NAME_PATH to lsFolder
92792>>>>>
92792>>>>>    get SEQ_ExtractPathFromFileName lsFolder to lsParentFolder
92793>>>>>    get SEQ_RemovePathFromFileName  lsFolder to lsFolder
92794>>>>>
92794>>>>>    set value item FLDS_PARENT_FOLDER     to lsParentFolder
92795>>>>>    set value item FLDS_FOLDER_NAME       to lsFolder
92796>>>>>
92796>>>>>    get FolderTreeSetup_Value FTSU_READ_FOLDER_CB_MESSAGE to lhMsg
92797>>>>>    if lhMsg begin
92799>>>>>      get FolderTreeSetup_Value FTSU_READ_FOLDER_CB_OBJECT to lhObj
92800>>>>>      send lhMsg of lhObj lsParentFolder lsFolder
92801>>>>>    end
92801>>>>>>
92801>>>>>
92801>>>>>    move 1 to lbFirst
92802>>>>>    move 0 to lnFolderSz
92803>>>>>    move 0 to lnSizeMin
92804>>>>>    move 0 to lnSizeMax
92805>>>>>    move 0 to lnTimeMin
92806>>>>>    move 0 to lnTimeMax
92807>>>>>    move (oWinFolderEntries(self)) to lhWinFolderEntries
92808>>>>>    get row_count of lhWinFolderEntries to liMax
92809>>>>>    decrement liMax
92810>>>>>    for liRow from 0 to liMax
92816>>>>>>
92816>>>>>      ifnot (pbFolder.i(lhWinFolderEntries,liRow)) begin // Files only
92818>>>>>        get pnFileSz.i of lhWinFolderEntries liRow to lnSize
92819>>>>>        get pnLastWrite.i of lhWinFolderEntries liRow to lnTime
92820>>>>>        if lbFirst begin
92822>>>>>          move lnSize to lnSizeMin
92823>>>>>          move lnSize to lnSizeMax
92824>>>>>          move lnTime to lnTimeMin
92825>>>>>          move lnTime to lnTimeMax
92826>>>>>          move 0 to lbFirst
92827>>>>>        end
92827>>>>>>
92827>>>>>        else begin
92828>>>>>          move (lnSizeMin min lnSize) to lnSizeMin
92829>>>>>          move (lnSizeMax max lnSize) to lnSizeMax
92830>>>>>          move (lnTimeMin min lnTime) to lnTimeMin
92831>>>>>          move (lnTimeMax max lnTime) to lnTimeMax
92832>>>>>        end
92832>>>>>>
92832>>>>>        move (lnFolderSz+lnSize) to lnFolderSz
92833>>>>>      end
92833>>>>>>
92833>>>>>    loop
92834>>>>>>
92834>>>>>
92834>>>>>    set value item FLDS_FILE_COUNT        to (piFileCount(lhWinFolderEntries))
92835>>>>>    set value item FLDS_FOLDER_SIZE       to lnFolderSz
92836>>>>>    set value item FLDS_MIN_FILESZ        to lnSizeMin
92837>>>>>    set value item FLDS_MAX_FILESZ        to lnSizeMax
92838>>>>>    set value item FLDS_MIN_TIME          to lnTimeMin
92839>>>>>    set value item FLDS_MAX_TIME          to lnTimeMax
92840>>>>>
92840>>>>>    // Initial X values:
92840>>>>>    set value item FLDSX_FILE_COUNT        to (piFileCount(lhWinFolderEntries))
92841>>>>>    set value item FLDSX_FOLDER_SIZE       to lnFolderSz
92842>>>>>    set value item FLDSX_MIN_FILESZ        to lnSizeMin
92843>>>>>    set value item FLDSX_MAX_FILESZ        to lnSizeMax
92844>>>>>    set value item FLDSX_MIN_TIME          to lnTimeMin
92845>>>>>    set value item FLDSX_MAX_TIME          to lnTimeMax
92846>>>>>  end_procedure
92847>>>>>
92847>>>>>  function TreeViewLabel returns string
92849>>>>>    function_return (FolderTree_DataTreeLabel(self,1))
92850>>>>>  end_function
92851>>>>>end_class // cFolderData
92852>>>>>
92852>>>>>class cFolderTree is a cTreeNode
92853>>>>>  procedure construct_object
92855>>>>>    forward send construct_object
92857>>>>>    set phNodeClass to U_cFolderTree
92858>>>>>    set phDataClass to U_cFolderData
92859>>>>>    object oTemp is a cArray NO_IMAGE
92861>>>>>    end_object
92862>>>>>  end_procedure
92863>>>>>
92863>>>>>            procedure BuildListOfSubFolders string lsRootFolder
92865>>>>>              integer lhTmp liItm liRow liMax lhWinFolderEntries
92865>>>>>              string lsFolderName
92865>>>>>              move 0 to liItm
92866>>>>>              move (oTemp(self)) to lhTmp
92867>>>>>              send delete_data to lhTmp
92868>>>>>              move (oWinFolderEntries(self)) to lhWinFolderEntries
92869>>>>>              get row_count of lhWinFolderEntries to liMax
92870>>>>>              decrement liMax
92871>>>>>              for liRow from 0 to liMax
92877>>>>>>
92877>>>>>                if (pbFolder.i(lhWinFolderEntries,liRow)) begin
92879>>>>>                  get psFileName.i of lhWinFolderEntries liRow to lsFolderName
92880>>>>>                  get Files_AppendPath lsRootFolder lsFolderName to lsFolderName
92881>>>>>                  set value of lhTmp item liItm to lsFolderName
92882>>>>>                  increment liItm
92883>>>>>                end
92883>>>>>>
92883>>>>>              loop
92884>>>>>>
92884>>>>>            end_procedure
92885>>>>>
92885>>>>>  procedure build_folder_tree string lsRootFolder
92887>>>>>    integer lhSelf lhData lhTmp liItem liMax lhChildNode
92887>>>>>    integer liFileCount liSubFolderFileCount lbFirst
92887>>>>>    number lnSize lnSubFolderSize
92887>>>>>    number lnMinSize lnSubFolderMinSize
92887>>>>>    number lnMaxSize lnSubFolderMaxSize
92887>>>>>    number lnMinTime lnSubFolderMinTime
92887>>>>>    number lnMaxTime lnSubFolderMaxTime
92887>>>>>    move (oTemp(self)) to lhTmp
92888>>>>>
92888>>>>>    send WinFolder_ReadFolder lsRootFolder
92889>>>>>
92889>>>>>    get hCreateDataObject to lhData
92890>>>>>    send ReadDataFromFolder to lhData lsRootFolder
92891>>>>>
92891>>>>>    send BuildListOfSubFolders lsRootFolder
92892>>>>>
92892>>>>>    get item_count of lhTmp to liMax
92893>>>>>    decrement liMax
92894>>>>>    move 0 to lnSubFolderSize
92895>>>>>    move 0 to liSubFolderFileCount
92896>>>>>    move 0 to lnSubFolderMinSize
92897>>>>>    move 0 to lnSubFolderMaxSize
92898>>>>>    move 0 to lnSubFolderMinTime
92899>>>>>    move 0 to lnSubFolderMaxTime
92900>>>>>    move 1 to lbFirst
92901>>>>>    for liItem from 0 to liMax
92907>>>>>>
92907>>>>>      get hAddChildNode to lhChildNode
92908>>>>>      send build_folder_tree to lhChildNode (value(lhTmp,liItem))
92909>>>>>
92909>>>>>      // Calculate subfolder totals
92909>>>>>      get DataObject_Array_Value of lhChildNode FLDSX_FILE_COUNT to liFileCount
92910>>>>>      move (liSubFolderFileCount+liFileCount) to liSubFolderFileCount
92911>>>>>      get DataObject_Array_Value of lhChildNode FLDSX_FOLDER_SIZE to lnSize
92912>>>>>      move (lnSubFolderSize+lnSize) to lnSubFolderSize
92913>>>>>
92913>>>>>      if liFileCount begin
92915>>>>>        get DataObject_Array_Value of lhChildNode  FLDSX_MIN_FILESZ to lnMinSize
92916>>>>>        get DataObject_Array_Value of lhChildNode  FLDSX_MAX_FILESZ to lnMaxSize
92917>>>>>        get DataObject_Array_Value of lhChildNode  FLDSX_MIN_TIME   to lnMinTime
92918>>>>>        get DataObject_Array_Value of lhChildNode  FLDSX_MAX_TIME   to lnMaxTime
92919>>>>>        if lbFirst begin
92921>>>>>          move lnMinSize to lnSubFolderMinSize
92922>>>>>          move lnMaxSize to lnSubFolderMaxSize
92923>>>>>          move lnMinTime to lnSubFolderMinTime
92924>>>>>          move lnMaxTime to lnSubFolderMaxTime
92925>>>>>          move 0 to lbFirst
92926>>>>>        end
92926>>>>>>
92926>>>>>        else begin
92927>>>>>          if (lnMinSize>>>>          if (lnMaxSize>lnSubFolderMaxSize) move lnMaxSize to lnSubFolderMaxSize
92933>>>>>          if (lnMinTime>>>>          if (lnMaxTime>lnSubFolderMaxTime) move lnMaxTime to lnSubFolderMaxTime
92939>>>>>        end
92939>>>>>>
92939>>>>>      end
92939>>>>>>
92939>>>>>    loop
92940>>>>>>
92940>>>>>    send delete_data to lhTmp
92941>>>>>    // Update X values here:
92941>>>>>    if (liMax=>0) begin
92943>>>>>      get DataObject_Array_Value FLDSX_FILE_COUNT to liFileCount
92944>>>>>      if liSubFolderFileCount begin
92946>>>>>        get DataObject_Array_Value FLDSX_MIN_FILESZ to lnMinSize
92947>>>>>        get DataObject_Array_Value FLDSX_MAX_FILESZ to lnMaxSize
92948>>>>>        get DataObject_Array_Value FLDSX_MIN_TIME   to lnMinTime
92949>>>>>        get DataObject_Array_Value FLDSX_MAX_TIME   to lnMaxTime
92950>>>>>
92950>>>>>        if liFileCount begin
92952>>>>>          if (lnSubFolderMinSize>>>>          if (lnSubFolderMaxSize>lnMaxSize) move lnSubFolderMaxSize to lnMaxSize
92958>>>>>          if (lnSubFolderMinTime>>>>          if (lnSubFolderMaxTime>lnMaxTime) move lnSubFolderMaxTime to lnMaxTime
92964>>>>>        end
92964>>>>>>
92964>>>>>        else begin
92965>>>>>          move lnSubFolderMinSize to lnMinSize
92966>>>>>          move lnSubFolderMaxSize to lnMaxSize
92967>>>>>          move lnSubFolderMinTime to lnMinTime
92968>>>>>          move lnSubFolderMaxTime to lnMaxTime
92969>>>>>        end
92969>>>>>>
92969>>>>>
92969>>>>>        set DataObject_Array_Value FLDSX_MIN_FILESZ to lnMinSize
92970>>>>>        set DataObject_Array_Value FLDSX_MAX_FILESZ to lnMaxSize
92971>>>>>        set DataObject_Array_Value FLDSX_MIN_TIME   to lnMinTime
92972>>>>>        set DataObject_Array_Value FLDSX_MAX_TIME   to lnMaxTime
92973>>>>>      end
92973>>>>>>
92973>>>>>      move (liSubFolderFileCount+liFileCount) to liFileCount
92974>>>>>      set DataObject_Array_Value FLDSX_FILE_COUNT to liFileCount
92975>>>>>
92975>>>>>      get DataObject_Array_Value FLDSX_FOLDER_SIZE to lnSize
92976>>>>>      move (lnSubFolderSize+lnSize) to lnSize
92977>>>>>      set DataObject_Array_Value FLDSX_FOLDER_SIZE to lnSize
92978>>>>>    end
92978>>>>>>
92978>>>>>  end_procedure
92979>>>>>end_class // cFolderTree
92980>>>//************************************************************************************
92980>>>
92980>>>use treenode_treeview_class.pkg // cTreeNodeView class
Including file: treenode_treeview_class.pkg    (C:\Apps\VDFQuery\AppSrc\treenode_treeview_class.pkg)
92980>>>>>// use treenode_treeview_class.pkg // cTreeNodeView class
92980>>>>>
92980>>>>>use dfallent
92980>>>>>use dftreevw
92980>>>>>use treenode.nui // Defines the cTreeNode class.
92980>>>>>
92980>>>>>class cTreeNodeView is a TreeView
92981>>>>>  procedure construct_object
92983>>>>>    forward send construct_object
92985>>>>>    property integer phTreeNode
92986>>>>>  end_procedure
92987>>>>>
92987>>>>>            function iImageItems integer lhData returns integer // complex hi: "Image" low: "Selected Image"
92989>>>>>              function_return 0
92990>>>>>            end_function
92991>>>>>            procedure DoAddNode integer lhNode integer lhParentItem
92993>>>>>              integer lhItem lhData lhImage lhSelImage liMax liItem lhChildNode
92993>>>>>              string lsLabel
92993>>>>>              get phDataObject of lhNode to lhData
92994>>>>>              if lhData begin
92996>>>>>                get TreeViewLabel of lhData to lsLabel
92997>>>>>                get iImageItems lhData to lhImage
92998>>>>>                move (low(lhImage)) to lhSelImage
92999>>>>>                move (hi(lhImage)) to lhSelImage
93000>>>>>              end
93000>>>>>>
93000>>>>>              else begin
93001>>>>>                move "" to lsLabel
93002>>>>>                move 0 to lhImage
93003>>>>>                move 0 to lhSelImage
93004>>>>>              end
93004>>>>>>
93004>>>>>              get AddTreeItem lsLabel lhParentItem lhNode lhImage lhSelImage to lhItem
93005>>>>>              get ChildCount of lhNode to liMax
93006>>>>>              decrement liMax
93007>>>>>              for liItem from 0 to liMax
93013>>>>>>
93013>>>>>                get ChildNodeObject of lhNode liItem to lhChildNode
93014>>>>>                send DoAddNode lhChildNode lhItem
93015>>>>>              loop
93016>>>>>>
93016>>>>>            end_procedure
93017>>>>>  function ItemVisibleState integer lhItem returns integer
93019>>>>>    integer lhRoot
93019>>>>>    get RootItem to lhRoot
93020>>>>>    while (lhItem<>lhRoot)
93024>>>>>      get ParentItem lhItem to lhItem
93025>>>>>      if lhItem begin
93027>>>>>        ifnot (ItemExpandedState(self,lhItem)) function_return FALSE
93030>>>>>      end
93030>>>>>>
93030>>>>>      else function_return TRUE
93032>>>>>    end
93033>>>>>>
93033>>>>>    function_return TRUE
93034>>>>>  end_function
93035>>>>>  procedure DoAddTreeItems
93037>>>>>    integer lhNode
93037>>>>>    get phTreeNode to lhNode
93038>>>>>    send DoAddNode lhNode 0
93039>>>>>    send DoExpandItem (RootItem(self))
93040>>>>>  end_procedure
93041>>>>>
93041>>>>>  procedure OnCreateTree
93043>>>>>    send DoAddTreeItems
93044>>>>>    send DoExpandAll
93045>>>>>  end_procedure
93046>>>>>end_class // cTreeNodeView
93047>>>>>
93047>>>>>use aps
93047>>>>>class aps.TreeNodeView is a cTreeNodeView startmac APS.STARTMAC_SNAP
93048>>>>>  procedure construct_object
93050>>>>>    forward send construct_object
93052>>>>>    send define_aps_control_mx
93053>>>>>    set p_auto_size_control_state to false
93054>>>>>  end_procedure
93055>>>>>  import_class_protocol aps_control_mx
93056>>>>>  procedure end_construct_object
93058>>>>>    forward send end_construct_object
93060>>>>>    send end_define_aps_control_mx
93061>>>>>  end_procedure
93062>>>>>end_class // aps.TreeNodeView
93063>>>>>
93063>>>>>class cTreeNodeViewEdit is a cTreeNodeView
93064>>>>>  procedure construct_object
93066>>>>>    forward send construct_object
93068>>>>>    on_key KEY_CTRL+KEY_UP_ARROW   send MoveItemUp
93069>>>>>    on_key KEY_CTRL+KEY_DOWN_ARROW send MoveItemDown
93070>>>>>  end_procedure
93071>>>>>
93071>>>>>            procedure MoveItemUp.h handle lhItem
93073>>>>>              integer lhNode lbSuccess
93073>>>>>              get ItemData lhItem to lhNode
93074>>>>>              get Request_SwitchUp of lhNode to lbSuccess
93075>>>>>              if lbSuccess begin
93077>>>>>              end
93077>>>>>>
93077>>>>>            end_procedure
93078>>>>>            procedure MoveItemDown.h handle lhItem
93080>>>>>          //    send obs "WayOdown" lhItem
93080>>>>>            end_procedure
93081>>>>>
93081>>>>>  procedure MoveItemUp
93083>>>>>    handle lhItem
93083>>>>>    get CurrentTreeItem to lhItem
93084>>>>>    if (lhItem<>0) send MoveItemUp.h lhItem
93087>>>>>  end_procedure
93088>>>>>  procedure MoveItemDown
93090>>>>>    handle lhItem
93090>>>>>    get CurrentTreeItem to lhItem
93091>>>>>    if (lhItem<>0) send MoveItemDown.h lhItem
93094>>>>>  end_procedure
93095>>>>>
93095>>>>>end_class // cTreeNodeViewEdit
93096>>>>>
93096>>>>>class aps.TreeNodeViewEdit is a cTreeNodeViewEdit startmac APS.STARTMAC_SNAP
93097>>>>>  procedure construct_object
93099>>>>>    forward send construct_object
93101>>>>>    send define_aps_control_mx
93102>>>>>    set p_auto_size_control_state to false
93103>>>>>  end_procedure
93104>>>>>  import_class_protocol aps_control_mx
93105>>>>>  procedure end_construct_object
93107>>>>>    forward send end_construct_object
93109>>>>>    send end_define_aps_control_mx
93110>>>>>  end_procedure
93111>>>>>end_class // aps.TreeNodeView
93112>>>>>
93112>>>>>
93112>>>Use Files.utl    // Utilities for handling file related stuff
93112>>>Use Dates.nui    // Date routines (No User Interface)
93112>>>use Strings.nui  // String manipulation for VDF (No User Interface)
93112>>>Use HTML.utl     // HTML functions
Including file: html.utl    (C:\Apps\VDFQuery\AppSrc\html.utl)
93112>>>>>//**********************************************************************
93112>>>>>// Use HTML.utl     // HTML functions
93112>>>>>//
93112>>>>>//
93112>>>>>// Create: Fri  04-09-1998
93112>>>>>// Update: Wed  16-09-1998 - Un-commented setting of pHtmlConversionTable
93112>>>>>//
93112>>>>>//
93112>>>>>//**********************************************************************
93112>>>>>
93112>>>>>Use Strings.nui  // String manipulation for VDF
93112>>>>>Use Files.nui    // Utilities for handling file related stuff
93112>>>>>Use URL.nui      // URL manipulation
Including file: url.nui    (C:\Apps\VDFQuery\AppSrc\url.nui)
93112>>>>>>>// Use URL.nui      // URL manipulation
93112>>>>>>>
93112>>>>>>>//> From the point of view of the URL string manipulation functions an URL
93112>>>>>>>//> is composed of the following items:
93112>>>>>>>//>
93112>>>>>>>//>    * Protocol      "http:"
93112>>>>>>>//>    * User ID       "sture"
93112>>>>>>>//>    * Password      "headset"
93112>>>>>>>//>    * Host          "www.sture.dk"
93112>>>>>>>//>    * Port          80
93112>>>>>>>//>    * Path          "/Images/EDUC2001"
93112>>>>>>>//>    * Type          "type=xml"
93112>>>>>>>//>
93112>>>>>>>//> function URL_ParseURL global string lsURL returns integer
93112>>>>>>>//>
93112>>>>>>>//> To have a URL decomposed into the items above use the URL_ParseURL
93112>>>>>>>//> function. The function returns TRUE if a host could be identidfied
93112>>>>>>>//> as part of the lsURL string and FALSE if not.
93112>>>>>>>//>
93112>>>>>>>//>
93112>>>>>>>//> function URL_Value global integer liSegment returns string
93112>>>>>>>//>
93112>>>>>>>//> After having used the URL_ParseURL to decompose an URL you should use
93112>>>>>>>//> the URL_Value function to obtain the value of each component in the
93112>>>>>>>//> URL. For example, to obtain the 'Path' part of the URL you would write
93112>>>>>>>//>
93112>>>>>>>//>   get URL_Value URL_SEGMENT_PATH to lsPath
93112>>>>>>>//>
93112>>>>>>>//> The URL_SEGMENT_PATH symbol is a constant defined by the URL.nui package.
93112>>>>>>>//> You may pass the following segment identifiers to the function:
93112>>>>>>>//>
93112>>>>>>>//>    URL_SEGMENT_PROTOCOL, URL_SEGMENT_USER, URL_SEGMENT_PASSWORD,
93112>>>>>>>//>    URL_SEGMENT_HOST, URL_SEGMENT_PORT, URL_SEGMENT_PATH and
93112>>>>>>>//>    URL_SEGMENT_TYPE
93112>>>>>>>//>
93112>>>>>>>//> These symbols may also be used as arguments to a the 'set URL_Value'
93112>>>>>>>//> procedure anabling you to set the value of each individual before
93112>>>>>>>//> calling this function:
93112>>>>>>>//>
93112>>>>>>>//> function URL_Compose global returns string
93112>>>>>>>//>
93112>>>>>>>//> This function combines all the segments setup via the 'set URL_Value'
93112>>>>>>>//> procedure (and possebly leftovers from the most recent call to
93112>>>>>>>//> URL_ParseURL) and returns a URL.
93112>>>>>>>//>
93112>>>>>>>//>
93112>>>>>>>//> Note that the URL functions decribed here are merely string manipulations.
93112>>>>>>>//> They do not interact with any internet componenents locally on the machine
93112>>>>>>>//> or on the internet itself.
93112>>>>>>>//>
93112>>>>>>>
93112>>>>>>>Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes (No User Interface)
93112>>>>>>>Use Strings.nui  // String manipulation for VDF
93112>>>>>>>
93112>>>>>>>enumeration_list
93112>>>>>>>  define URL_SEGMENT_PROTOCOL
93112>>>>>>>  define URL_SEGMENT_USER
93112>>>>>>>  define URL_SEGMENT_PASSWORD
93112>>>>>>>  define URL_SEGMENT_HOST
93112>>>>>>>  define URL_SEGMENT_PORT
93112>>>>>>>  define URL_SEGMENT_PATH
93112>>>>>>>  define URL_SEGMENT_TYPE
93112>>>>>>>end_enumeration_list
93112>>>>>>>
93112>>>>>>>
93112>>>>>>>desktop_section
93117>>>>>>>  object oUrlParser is a cArray NO_IMAGE
93119>>>>>>>    function iFindToken string lsToken string lsValue returns integer
93122>>>>>>>      integer liPos liLen liTokenLen
93122>>>>>>>      string lsString
93122>>>>>>>      move (length(lsToken)) to liTokenLen
93123>>>>>>>      move (length(lsValue)) to liLen
93124>>>>>>>      for liPos from 1 to liLen
93130>>>>>>>>
93130>>>>>>>        move (left(lsValue,liPos)) to lsString
93131>>>>>>>        if (right(lsString,liTokenLen)=lsToken) function_return liPos
93134>>>>>>>      loop
93135>>>>>>>>
93135>>>>>>>      function_return 0
93136>>>>>>>    end_function
93137>>>>>>>
93137>>>>>>>    //   ftp://:@:/;type=
93137>>>>>>>
93137>>>>>>>    function sParseUrl string lsUrl returns integer
93140>>>>>>>      integer liPos lbRval
93140>>>>>>>      string lsValue lsValue2 lsHost
93140>>>>>>>      send delete_data
93141>>>>>>>      move DFTRUE to lbRval
93142>>>>>>>      get iFindToken ("/"+"/") lsUrl to liPos // Protokol?
93143>>>>>>>      if liPos begin // Protokol
93145>>>>>>>        move (left(lsUrl,liPos)) to lsValue
93146>>>>>>>        move (replace(lsValue,lsUrl,"")) to lsUrl
93147>>>>>>>        set value item URL_SEGMENT_PROTOCOL to (StringLeftBut(lsValue,2))
93148>>>>>>>      end
93148>>>>>>>>
93148>>>>>>>
93148>>>>>>>      get iFindToken "@" lsUrl to liPos // User ?
93149>>>>>>>      if liPos begin // User
93151>>>>>>>        move (left(lsUrl,liPos)) to lsValue
93152>>>>>>>        move (replace(lsValue,lsUrl,"")) to lsUrl
93153>>>>>>>        get iFindToken ":" lsValue to liPos
93154>>>>>>>        if liPos begin // User and Password
93156>>>>>>>          move (left(lsValue,liPos)) to lsValue2
93157>>>>>>>          set value item URL_SEGMENT_USER to (StringLeftBut(lsValue2,1))
93158>>>>>>>          move (replace(lsValue2,lsValue,"")) to lsValue
93159>>>>>>>          set value item URL_SEGMENT_PASSWORD to (StringLeftBut(lsValue,1))
93160>>>>>>>        end
93160>>>>>>>>
93160>>>>>>>        else begin // User without password
93161>>>>>>>          set value item URL_SEGMENT_USER to (StringLeftBut(lsValue,1))
93162>>>>>>>        end
93162>>>>>>>>
93162>>>>>>>      end
93162>>>>>>>>
93162>>>>>>>
93162>>>>>>>      //   ftp://:@:/;type=
93162>>>>>>>
93162>>>>>>>      get iFindToken ";" lsUrl to liPos // Type ?
93163>>>>>>>      if liPos begin // Type!
93165>>>>>>>        move (left(lsUrl,liPos)) to lsValue
93166>>>>>>>        move (replace(lsValue,lsUrl,"")) to lsUrl
93167>>>>>>>        set value item URL_SEGMENT_TYPE to lsUrl
93168>>>>>>>        move (StringLeftBut(lsValue,1)) to lsValue
93169>>>>>>>        get iFindToken "/" lsValue to liPos // Path ?
93170>>>>>>>        if liPos begin // Path! www.dataaccess.dk:80/magicpath/Images
93172>>>>>>>          move (left(lsValue,liPos-1)) to lsValue2
93173>>>>>>>          set value item URL_SEGMENT_PATH to (replace(lsValue2,lsValue,""))
93174>>>>>>>          move lsValue2 to lsValue
93175>>>>>>>        end
93175>>>>>>>>
93175>>>>>>>        get iFindToken ":" lsValue to liPos // Port ?
93176>>>>>>>        if liPos begin // Port !  Dataaccess.kn:80
93178>>>>>>>          move (left(lsValue,liPos)) to lsHost
93179>>>>>>>          set value item URL_SEGMENT_HOST to (StringLeftBut(lsHost,1))
93180>>>>>>>          set value item URL_SEGMENT_PORT to (replace(lsHost,lsValue,""))
93181>>>>>>>        end
93181>>>>>>>>
93181>>>>>>>        else set value item URL_SEGMENT_HOST to lsValue
93183>>>>>>>      end
93183>>>>>>>>
93183>>>>>>>      else begin
93184>>>>>>>        get iFindToken "/" lsUrl to liPos // Path ?
93185>>>>>>>        if liPos begin
93187>>>>>>>          move lsUrl to lsValue
93188>>>>>>>
93188>>>>>>>          if liPos begin // Path! www.dataaccess.dk:80/magicpath/Images
93190>>>>>>>            move (left(lsValue,liPos-1)) to lsValue2
93191>>>>>>>            set value item URL_SEGMENT_PATH to (replace(lsValue2,lsValue,""))
93192>>>>>>>            move lsValue2 to lsValue
93193>>>>>>>          end
93193>>>>>>>>
93193>>>>>>>          get iFindToken ":" lsValue to liPos // Port ?
93194>>>>>>>          if liPos begin // Port!  Dataaccess.kn:80
93196>>>>>>>            move (left(lsValue,liPos)) to lsHost
93197>>>>>>>            set value item URL_SEGMENT_HOST to (StringLeftBut(lsHost,1))
93198>>>>>>>            set value item URL_SEGMENT_PORT to (replace(lsHost,lsValue,""))
93199>>>>>>>          end
93199>>>>>>>>
93199>>>>>>>          else set value item URL_SEGMENT_HOST to lsValue
93201>>>>>>>        end
93201>>>>>>>>
93201>>>>>>>        else begin
93202>>>>>>>          get iFindToken ":" lsUrl to liPos // Port?
93203>>>>>>>          if liPos begin
93205>>>>>>>            move (left(lsUrl,liPos)) to lsValue
93206>>>>>>>            move (replace(lsValue,lsUrl,"")) to lsUrl
93207>>>>>>>            set value item URL_SEGMENT_HOST to (StringLeftBut(lsValue,1))
93208>>>>>>>            set value item URL_SEGMENT_PORT to lsUrl
93209>>>>>>>          end
93209>>>>>>>>
93209>>>>>>>          else begin
93210>>>>>>>            set value item URL_SEGMENT_HOST to lsUrl
93211>>>>>>>          end
93211>>>>>>>>
93211>>>>>>>        end
93211>>>>>>>>
93211>>>>>>>      end
93211>>>>>>>>
93211>>>>>>>      if (value(self,URL_SEGMENT_HOST)="") move DFFALSE to lbRval
93214>>>>>>>      function_return lbRval
93215>>>>>>>    end_function
93216>>>>>>>  end_object
93217>>>>>>>end_desktop_section
93222>>>>>>>
93222>>>>>>>// Public interface:
93222>>>>>>>
93222>>>>>>>function URL_ParseURL global string lsValue returns integer
93224>>>>>>>  function_return (sParseUrl(oUrlParser(self),lsValue))
93225>>>>>>>end_function
93226>>>>>>>
93226>>>>>>>function URL_Value global integer liSegment returns string
93228>>>>>>>  function_return (value(oUrlParser(self),liSegment))
93229>>>>>>>end_function
93230>>>>>>>
93230>>>>>>>procedure set URL_Value global integer liSegment string lsValue
93232>>>>>>>  set value of (oUrlParser(self)) item liSegment to lsValue
93233>>>>>>>end_procedure
93234>>>>>>>
93234>>>>>>>procedure URL_Reset
93237>>>>>>>  send delete_data to (oUrlParser(self))
93238>>>>>>>end_procedure
93239>>>>>>>
93239>>>>>>>function URL_Compose global returns string
93241>>>>>>>  integer liPort
93241>>>>>>>  string lsUser lsPassword lsHost lsPath lsType lsProtocol
93241>>>>>>>  string lsRval
93241>>>>>>>
93241>>>>>>>  //   ftp://:@:/;type=
93241>>>>>>>
93241>>>>>>>  get URL_Value URL_SEGMENT_PROTOCOL to lsProtocol
93242>>>>>>>  get URL_Value URL_SEGMENT_USER     to lsUser
93243>>>>>>>  get URL_Value URL_SEGMENT_PASSWORD to lsPassword
93244>>>>>>>  get URL_Value URL_SEGMENT_HOST     to lsHost
93245>>>>>>>  get URL_Value URL_SEGMENT_PORT     to liPort
93246>>>>>>>  get URL_Value URL_SEGMENT_PATH     to lsPath
93247>>>>>>>  get URL_Value URL_SEGMENT_TYPE     to lsType
93248>>>>>>>
93248>>>>>>>  if (lsProtocol<>"") move (lsProtocol+"/"+"/") to lsRval
93251>>>>>>>
93251>>>>>>>  if (lsUser<>"") begin
93253>>>>>>>    move (lsRval+lsUser) to lsRval
93254>>>>>>>    if (lsPassword<>"") move (lsRval+":"+lsPassword) to lsRval
93257>>>>>>>    move (lsRval+"@") to lsRval
93258>>>>>>>  end
93258>>>>>>>>
93258>>>>>>>  move (lsRval+lsHost) to lsRval
93259>>>>>>>  if (liPort<>0) move (lsRval+":"+string(liPort)) to lsRval
93262>>>>>>>  if (lsPath<>"") begin
93264>>>>>>>    if (left(lsPath,1)="/") move (lsRval+lsPath) to lsRval
93267>>>>>>>    else move (lsRval+"/"+lsPath) to lsRval
93269>>>>>>>  end
93269>>>>>>>>
93269>>>>>>>  if (lsType<>"") move (lsRval+";"+lsType) to lsRval
93272>>>>>>>  function_return lsRval
93273>>>>>>>end_function
93274>>>>>>>
93274>>>>>>>// The URL_InsertLinks is meant to be used to insert links into a string
93274>>>>>>>// of text as a preparation for writing it to a html page.
93274>>>>>>>//
93274>>>>>>>// If an URL occurs in the text the function will insert link tags
93274>>>>>>>// around the URL in order to make it a clickable.
93274>>>>>>>//
93274>>>>>>>// If you have an 'ugly' link like this:
93274>>>>>>>//
93274>>>>>>>//  ftp://jakob:magic@ftp.kruse-net.dk:8000/magic/data;type=xml
93274>>>>>>>//
93274>>>>>>>// and you want the browser to simply display
93274>>>>>>>//
93274>>>>>>>//         Click [here] to download some magic data
93274>>>>>>>//
93274>>>>>>>// where [] denotes the scope of the link, just pass this text to the
93274>>>>>>>// function:
93274>>>>>>>//
93274>>>>>>>//   Click ftp://jakob:magic@ftp.kruse-net.dk:8000/magic/data;type=xml[here]
93274>>>>>>>//   to download some magic data
93274>>>>>>>//
93274>>>>>>>//
93274>>>>>>>//
93274>>>>>>>//
93274>>>>>>>function URL_InsertLinks global string lsValue returns string
93276>>>>>>>  integer liPos liLen lbInLink lbFin
93276>>>>>>>  string lsRval lsChar lsLeadIn lsLink lsLinkText lsDblSlash
93276>>>>>>>  move (length(lsValue)) to liLen
93277>>>>>>>  move "" to lsRval
93278>>>>>>>  move 1 to liPos
93279>>>>>>>  move ("/"+"/") to lsDblSlash
93280>>>>>>>  repeat
93280>>>>>>>>
93280>>>>>>>    move "" to lsLeadIn
93281>>>>>>>    if (lowercase(mid(lsValue,4,liPos))="www.") begin
93283>>>>>>>      //move "http://www." to lsLeadIn
93283>>>>>>>      move ("http:"+lsDblSlash+"www.") to lsLeadIn
93284>>>>>>>      move (liPos+4) to liPos
93285>>>>>>>    end
93285>>>>>>>>
93285>>>>>>>    if (lowercase(mid(lsValue,4,liPos))="ftp.") begin
93287>>>>>>>      //move "ftp://ftp." to lsLeadIn
93287>>>>>>>      move ("ftp:"+lsDblSlash+"ftp.") to lsLeadIn
93288>>>>>>>      move (liPos+4) to liPos
93289>>>>>>>    end
93289>>>>>>>>
93289>>>>>>>    if (lowercase(mid(lsValue,6,liPos))="ftp:"+lsDblSlash) begin
93291>>>>>>>      move ("ftp:"+lsDblSlash) to lsLeadIn
93292>>>>>>>      move (liPos+6) to liPos
93293>>>>>>>    end
93293>>>>>>>>
93293>>>>>>>    if (lowercase(mid(lsValue,7,liPos))="http:"+lsDblSlash) begin
93295>>>>>>>      move ("http:"+lsDblSlash) to lsLeadIn
93296>>>>>>>      move (liPos+7) to liPos
93297>>>>>>>    end
93297>>>>>>>>
93297>>>>>>>    if (lowercase(mid(lsValue,8,liPos))="https:"+lsDblSlash) begin
93299>>>>>>>      move ("https:"+lsDblSlash) to lsLeadIn
93300>>>>>>>      move (liPos+8) to liPos
93301>>>>>>>    end
93301>>>>>>>>
93301>>>>>>>    if (lsLeadIn<>"") begin
93303>>>>>>>      move lsLeadIn to lsLink
93304>>>>>>>      repeat
93304>>>>>>>>
93304>>>>>>>        move (mid(lsValue,1,liPos)) to lsChar
93305>>>>>>>        move (not(("abcdefghijklmnopqrstuvwxyz:;=?@/.-+%*_01234567890#&~'"+'"') contains lowercase(lsChar))) to lbFin
93306>>>>>>>        ifnot lbFin begin
93308>>>>>>>          move (lsLink+lsChar) to lsLink
93309>>>>>>>          increment liPos
93310>>>>>>>        end
93310>>>>>>>>
93310>>>>>>>      until (lbFin or (liPos>liLen))
93312>>>>>>>      if (".:@;=" contains right(lsLink,1)) begin
93314>>>>>>>        get StringLeftBut lsLink 1 to lsLink
93315>>>>>>>        decrement liPos
93316>>>>>>>      end
93316>>>>>>>>
93316>>>>>>>      move lsLink to lsLinkText
93317>>>>>>>      // Insert:
93317>>>>>>>      if (mid(lsValue,1,liPos)="[") begin
93319>>>>>>>        increment liPos // Beyond the "[" sign
93320>>>>>>>        move "" to lsLinkText
93321>>>>>>>        repeat
93321>>>>>>>>
93321>>>>>>>          move (mid(lsValue,1,liPos)) to lsChar
93322>>>>>>>          move (lsChar="]") to lbFin
93323>>>>>>>          increment liPos
93324>>>>>>>          ifnot lbFin begin
93326>>>>>>>            move (lsLinkText+lsChar) to lsLinkText
93327>>>>>>>          end
93327>>>>>>>>
93327>>>>>>>        until (lbFin or (liPos>liLen))
93329>>>>>>>      end
93329>>>>>>>>
93329>>>>>>>      // End insert
93329>>>>>>>      move (''+lsLinkText+'') to lsLink
93330>>>>>>>      move (lsRval+lsLink) to lsRval
93331>>>>>>>    end
93331>>>>>>>>
93331>>>>>>>    else begin
93332>>>>>>>      move (mid(lsValue,1,liPos)) to lsChar
93333>>>>>>>      move (lsRval+lsChar) to lsRval
93334>>>>>>>      increment liPos
93335>>>>>>>    end
93335>>>>>>>>
93335>>>>>>>  until (liPos>liLen)
93337>>>>>>>  function_return lsRval
93338>>>>>>>end_function
93339>>>>>>>
93339>>>>>>>
93339>>>>>
93339>>>>>integer oGlobalHtmlAttributes#
93339>>>>>object oGlobalHtmlAttributes is an array
93341>>>>>  property integer pHtmlConversionTable public 0
93343>>>>>  property integer pHtmlTrimCrState     public 1           // Exclamation mark
93345>>>>>  property string  pHtmlDocType         public ('<'+character(33)+'DOCTYPE HTML PUBLIC "-/'+'/IETF/'+'/DTD HTML/'+'/EN">')
93347>>>>>  property string  pHtmlMT_Generator    public "Visual DataFlex"
93349>>>>>  property string  pHtmlMT_Formatter    public "Visual DataFlex"
93351>>>>>  move self to oGlobalHtmlAttributes#
93352>>>>>end_object
93353>>>>>
93353>>>>>class cAnsiToHtml_ConversionTable is an array
93354>>>>>  procedure construct_object integer img#
93356>>>>>    forward send construct_object img#
93358>>>>>    property string pCharacterSetName public "Un-named"
93359>>>>>    property string pCharacterSetID   public ""
93360>>>>>  end_procedure
93361>>>>>  function Is_cAnsiToHtml_ConversionTable returns integer
93363>>>>>    function_return 1
93364>>>>>  end_function
93365>>>>>  procedure set CharacterConversion integer char# string html#
93367>>>>>    // By setting the item value to character(char#) we avoid having
93367>>>>>    // to call that function during the character translation:
93367>>>>>    set value item (item_count(self)) to (character(char#))
93368>>>>>    set value item (item_count(self)) to html#
93369>>>>>  end_procedure
93370>>>>>  function ConvertAnsiToHtml string str# returns string
93372>>>>>    integer max# itm#
93372>>>>>    string html# char#
93372>>>>>    get item_count to max#
93373>>>>>    move 0 to itm#
93374>>>>>    while itm# lt max#
93378>>>>>      get value item itm# to char#
93379>>>>>      increment itm#
93380>>>>>      get value item itm# to html#
93381>>>>>      increment itm#
93382>>>>>      move (replaces(char#,str#,html#)) to str#
93383>>>>>    end
93384>>>>>>
93384>>>>>    function_return str#
93385>>>>>  end_function
93386>>>>>end_class
93387>>>>>
93387>>>>>function html_TextToHTML global string lsValue returns string
93389>>>>>  get Text_Trim lsValue to lsValue
93390>>>>>  move (replaces(character(10),lsValue,"
")) to lsValue
93391>>>>>  get RemoveDblBlanks lsValue to lsValue
93392>>>>>  get url_InsertLinks lsValue to lsValue
93393>>>>>  function_return lsValue
93394>>>>>end_function
93395>>>>>
93395>>>>>function html_TextToHTML_LeaveSpaces global string lsValue returns string
93397>>>>>  get Text_Trim lsValue to lsValue
93398>>>>>  move (replaces(character(10),lsValue,"
")) to lsValue
93399>>>>>  get url_InsertLinks lsValue to lsValue
93400>>>>>  function_return lsValue
93401>>>>>end_function
93402>>>>>
93402>>>>>desktop_section
93407>>>>>object oAnsiToHtml_Latin_1 is a cAnsiToHtml_ConversionTable
93409>>>>>  set pCharacterSetName to "Latin 1"
93410>>>>>  set pCharacterSetID   to "iso-8859-1"
93411>>>>>  set CharacterConversion 160 to " "    //
93412>>>>>  set CharacterConversion 161 to "¡"   // 
93413>>>>>  set CharacterConversion 162 to "¢"    // 
93414>>>>>  set CharacterConversion 163 to "£"   // 
93415>>>>>  set CharacterConversion 164 to "¤"  // general currency
93416>>>>>  set CharacterConversion 165 to "¥"     // 
93417>>>>>  set CharacterConversion 166 to "¦"  // |
93418>>>>>  set CharacterConversion 167 to "§"    // 
93419>>>>>  set CharacterConversion 168 to "¨"     // 
93420>>>>>  set CharacterConversion 169 to "©"    // (c)
93421>>>>>  set CharacterConversion 170 to "ª"    //
93422>>>>>  set CharacterConversion 171 to "«"   //
93423>>>>>  set CharacterConversion 172 to "¬"     // 
93424>>>>>  set CharacterConversion 173 to "­"     //
93425>>>>>  set CharacterConversion 174 to "®"     // (r) 
93426>>>>>  set CharacterConversion 175 to "¯"    //
93427>>>>>  set CharacterConversion 176 to "°"     // 
93428>>>>>  set CharacterConversion 177 to "±"  // 
93429>>>>>  set CharacterConversion 178 to "²"    // exp(2)
93430>>>>>  set CharacterConversion 179 to "³"    // exp(3)
93431>>>>>  set CharacterConversion 180 to "´"   //
93432>>>>>  set CharacterConversion 181 to "µ"   //
93433>>>>>  set CharacterConversion 182 to "¶"    //
93434>>>>>  set CharacterConversion 183 to "·"  //
93435>>>>>  set CharacterConversion 184 to "¸"   //
93436>>>>>  set CharacterConversion 185 to "¹"    //
93437>>>>>  set CharacterConversion 186 to "º"    //
93438>>>>>  set CharacterConversion 187 to "»"   //
93439>>>>>  set CharacterConversion 188 to "¼"  // 1/4
93440>>>>>  set CharacterConversion 189 to "½"  // 1/2
93441>>>>>  set CharacterConversion 190 to "¾"  // 3/4
93442>>>>>  set CharacterConversion 191 to "¿"  // 
93443>>>>>  set CharacterConversion 192 to "À"  // 
93444>>>>>  set CharacterConversion 193 to "Á"  // 
93445>>>>>  set CharacterConversion 194 to "Â"   // 
93446>>>>>  set CharacterConversion 195 to "Ã"  // 
93447>>>>>  set CharacterConversion 196 to "Ä"    // 
93448>>>>>  set CharacterConversion 197 to "Å"   // 
93449>>>>>  set CharacterConversion 198 to "&Aelig;"   // 
93450>>>>>  set CharacterConversion 199 to "Ç"  // 
93451>>>>>  set CharacterConversion 200 to "È"  // 
93452>>>>>  set CharacterConversion 201 to "É"  // 
93453>>>>>  set CharacterConversion 202 to "Ê"   // 
93454>>>>>  set CharacterConversion 203 to "Ë"    // 
93455>>>>>  set CharacterConversion 204 to "Ì"  // 
93456>>>>>  set CharacterConversion 205 to "Í"  // 
93457>>>>>  set CharacterConversion 206 to "Î"   // 
93458>>>>>  set CharacterConversion 207 to "Ï"    // 
93459>>>>>  set CharacterConversion 208 to "Ð"     // 
93460>>>>>  set CharacterConversion 209 to "Ñ"  // 
93461>>>>>  set CharacterConversion 210 to "Ò"  // 
93462>>>>>  set CharacterConversion 211 to "Ó"  // 
93463>>>>>  set CharacterConversion 212 to "Ô"   // 
93464>>>>>  set CharacterConversion 213 to "Õ"  // 
93465>>>>>  set CharacterConversion 214 to "Ö"    // 
93466>>>>>  set CharacterConversion 216 to "Ø"  // 
93467>>>>>  set CharacterConversion 217 to "Ù"  // 
93468>>>>>  set CharacterConversion 218 to "Ú"  // 
93469>>>>>  set CharacterConversion 219 to "Û"   // 
93470>>>>>  set CharacterConversion 220 to "Ü"    // 
93471>>>>>  set CharacterConversion 221 to "Ý"  // 
93472>>>>>  set CharacterConversion 222 to "Þ"   // 
93473>>>>>  set CharacterConversion 223 to "ß"   // 
93474>>>>>  set CharacterConversion 224 to "à"  // 
93475>>>>>  set CharacterConversion 225 to "á"  // 
93476>>>>>  set CharacterConversion 226 to "â"   // 
93477>>>>>  set CharacterConversion 227 to "ã"  // 
93478>>>>>  set CharacterConversion 228 to "ä"    // 
93479>>>>>  set CharacterConversion 229 to "å"   // 
93480>>>>>  set CharacterConversion 230 to "æ"   // 
93481>>>>>  set CharacterConversion 231 to "ç"  // 
93482>>>>>  set CharacterConversion 232 to "è"  // 
93483>>>>>  set CharacterConversion 233 to "é"  // 
93484>>>>>  set CharacterConversion 234 to "ê"   // 
93485>>>>>  set CharacterConversion 235 to "ë"    // 
93486>>>>>  set CharacterConversion 236 to "ì"  // 
93487>>>>>  set CharacterConversion 237 to "í"  // 
93488>>>>>  set CharacterConversion 238 to "î"   // 
93489>>>>>  set CharacterConversion 239 to "ï"    // 
93490>>>>>  set CharacterConversion 240 to "ð"     // 
93491>>>>>  set CharacterConversion 241 to "ñ"  // 
93492>>>>>  set CharacterConversion 242 to "ò"  // 
93493>>>>>  set CharacterConversion 243 to "ó"  // 
93494>>>>>  set CharacterConversion 244 to "ô"   // 
93495>>>>>  set CharacterConversion 245 to "õ"  // 
93496>>>>>  set CharacterConversion 246 to "ö"    // 
93497>>>>>  set CharacterConversion 248 to "ø"  // 
93498>>>>>  set CharacterConversion 249 to "ù"  // 
93499>>>>>  set CharacterConversion 250 to "ú"  // 
93500>>>>>  set CharacterConversion 251 to "û"   // 
93501>>>>>  set CharacterConversion 252 to "ü"    // 
93502>>>>>  set CharacterConversion 253 to "ý"  // 
93503>>>>>  set CharacterConversion 254 to "þ"   // 
93504>>>>>  set CharacterConversion 255 to "ÿ"    // 
93505>>>>>end_object // oAnsiToHtml_Latin_1
93506>>>>>end_desktop_section
93511>>>>>
93511>>>>>// Uncomment the following line in order to have the function convert ANSI
93511>>>>>// characters to native html characters.
93511>>>>>//set pHtmlConversionTable of oGlobalHtmlAttributes# to (oAnsiToHtml_Latin_1(self))
93511>>>>>
93511>>>>>// Make the html_AnsiToHtml function cut away superflous trailing cr/lf
93511>>>>>// characters when printing text.
93511>>>>>set pHtmlTrimCrState of oGlobalHtmlAttributes# to true
93512>>>>>
93512>>>>>// If function ConvertChar is not already defined we define it here:
93512>>>>>
93512>>>>>// This function assumes that string parameter contains ANSI characters
93512>>>>>function html_AnsiToHtml global string str# returns string
93514>>>>>  move (replaces("&",str#,"&"))          to str#
93515>>>>>  move (replaces('"',str#,"""))         to str#
93516>>>>>  move (replaces("<",str#,"<"))           to str#
93517>>>>>  move (replaces(">",str#,">"))           to str#
93518>>>>>  if (pHtmlTrimCrState(oGlobalHtmlAttributes#)) ;          move (Text_RemoveTrailingCr(str#)) to str#
93521>>>>>  move (replaces(character(10),str#,"
")) to str#
93522>>>>>  move (replaces(character(13),str#,""))     to str#
93523>>>>>  move (RemoveDblBlanks(str#))               to str#
93524>>>>>  if (pHtmlConversionTable(oGlobalHtmlAttributes#)) ;    get ConvertAnsiToHtml of (pHtmlConversionTable(oGlobalHtmlAttributes#)) str# to str#
93527>>>>>  function_return str#
93528>>>>>end_function
93529>>>>>
93529>>>>>// This function is identical to html_AnsiToHtml except that it
93529>>>>>// assumes the parameter to be OEM characters.
93529>>>>>function html_DfToHtml global string str# returns string
93531>>>>>  function_return (html_AnsiToHtml(ConvertChar(1,str#)))
93532>>>>>end_function
93533>>>>>
93533>>>>>// This is identical to the html_DfToHtml function except that it will
93533>>>>>// never return the empty string. Where html_DfToHtml would return the
93533>>>>>// empty string this function will return a 'non breaking space'. You
93533>>>>>// may want to use this function when writing table data since it will
93533>>>>>// ensure that the cells are appearing even if their content is empty.
93533>>>>>function html_DfToHtmlTable global string str# returns string
93535>>>>>  string rval#
93535>>>>>  move (html_AnsiToHtml(ConvertChar(1,str#))) to rval#
93536>>>>>  if rval# eq "" move " " to rval#
93539>>>>>  function_return rval#
93540>>>>>end_function
93541>>>>>
93541>>>>>External_Function32 HtmlShellExecute "ShellExecuteA" SHELL32.DLL ;  handle hwnd# String lpszOp# String lpszFile# String lpszParams# ;  String lpszDir# integer FsShowCmd# returns integer
93542>>>>>
93542>>>>>// This may be used to start any kind of document. Not just html docs.
93542>>>>>procedure html_StartDoc global string doc#
93544>>>>>  integer grb#
93544>>>>>  handle scrhDC#
93544>>>>>  string dir#
93544>>>>>  move (GetDesktopWindow()) to scrhDC# // Defined in WinUser.pkg
93545>>>>>  // We assume that the document is in a directory along DFPATH or that
93545>>>>>  // the directory path is part of the doc name:
93545>>>>>  get SEQ_ExtractPathFromFileName doc# to dir# // Is a path specified?
93546>>>>>  if dir# eq "" get SEQ_FindFileAlongDFPath doc# to dir#
93549>>>>>  else move "" to dir#
93551>>>>>  //                               Parameters   Directory
93551>>>>>  move (HtmlShellExecute(scrhDC#,"Open",doc#,"",dir#,1)) to grb#
93552>>>>>end_procedure
93553>>>>>
93553>>>>>procedure html_WriteHeader global integer channel# string title#
93555>>>>>  writeln channel channel# (pHtmlDocType(oGlobalHtmlAttributes#))
93558>>>>>  writeln ''
93560>>>>>  writeln ''
93562>>>>>  writeln (' '+html_DfToHtmlTable(title#)+'')
93564>>>>>  //writeln ' '
93564>>>>>  writeln (' ')
93566>>>>>  writeln ''
93568>>>>>end_procedure
93569>>>>>
93569>>>Use GridUtil.utl // Grid and List utilities (not for dbGrid's or Table's)
93569>>>
93569>>>object oFolderSizeTree is a cFolderTree
93571>>>end_object
93572>>>
93572>>>object oFolderSizeArray is a cArray
93574>>>  item_property_list
93574>>>    item_property string   psName.i
93574>>>    // On its own:
93574>>>    item_property integer  piFiles.i
93574>>>    item_property number   pnSize.i
93574>>>    item_property number   pnMinSz.i
93574>>>    item_property number   pnMaxSz.i
93574>>>    item_property number   pnOlder.i
93574>>>    item_property number   pnNewer.i
93574>>>  end_item_property_list
#REM 93626 DEFINE FUNCTION PNNEWER.I INTEGER LIROW RETURNS NUMBER
#REM 93631 DEFINE PROCEDURE SET PNNEWER.I INTEGER LIROW NUMBER VALUE
#REM 93636 DEFINE FUNCTION PNOLDER.I INTEGER LIROW RETURNS NUMBER
#REM 93641 DEFINE PROCEDURE SET PNOLDER.I INTEGER LIROW NUMBER VALUE
#REM 93646 DEFINE FUNCTION PNMAXSZ.I INTEGER LIROW RETURNS NUMBER
#REM 93651 DEFINE PROCEDURE SET PNMAXSZ.I INTEGER LIROW NUMBER VALUE
#REM 93656 DEFINE FUNCTION PNMINSZ.I INTEGER LIROW RETURNS NUMBER
#REM 93661 DEFINE PROCEDURE SET PNMINSZ.I INTEGER LIROW NUMBER VALUE
#REM 93666 DEFINE FUNCTION PNSIZE.I INTEGER LIROW RETURNS NUMBER
#REM 93671 DEFINE PROCEDURE SET PNSIZE.I INTEGER LIROW NUMBER VALUE
#REM 93676 DEFINE FUNCTION PIFILES.I INTEGER LIROW RETURNS INTEGER
#REM 93681 DEFINE PROCEDURE SET PIFILES.I INTEGER LIROW INTEGER VALUE
#REM 93686 DEFINE FUNCTION PSNAME.I INTEGER LIROW RETURNS STRING
#REM 93691 DEFINE PROCEDURE SET PSNAME.I INTEGER LIROW STRING VALUE
93697>>>  procedure AddToArray integer lhData integer lbIncludeSubFolders
93700>>>    integer liRow
93700>>>    get row_count to liRow
93701>>>    set psName.i   liRow to (value(lhData,FLDS_FOLDER_NAME_PATH))
93702>>>
93702>>>    if lbIncludeSubFolders begin
93704>>>      set piFiles.i liRow to (value(lhData,FLDSX_FILE_COUNT))
93705>>>      set pnSize.i  liRow to (value(lhData,FLDSX_FOLDER_SIZE))
93706>>>      set pnMinSz.i liRow to (value(lhData,FLDSX_MIN_FILESZ))
93707>>>      set pnMaxSz.i liRow to (value(lhData,FLDSX_MAX_FILESZ))
93708>>>      set pnOlder.i liRow to (value(lhData,FLDSX_MIN_TIME))
93709>>>      set pnNewer.i liRow to (value(lhData,FLDSX_MAX_TIME))
93710>>>    end
93710>>>>
93710>>>    else begin
93711>>>      set piFiles.i  liRow to (value(lhData,FLDS_FILE_COUNT))
93712>>>      set pnSize.i   liRow to (value(lhData,FLDS_FOLDER_SIZE))
93713>>>      set pnMinSz.i  liRow to (value(lhData,FLDS_MIN_FILESZ))
93714>>>      set pnMaxSz.i  liRow to (value(lhData,FLDS_MAX_FILESZ))
93715>>>      set pnOlder.i  liRow to (value(lhData,FLDS_MIN_TIME))
93716>>>      set pnNewer.i  liRow to (value(lhData,FLDS_MAX_TIME))
93717>>>    end
93717>>>>
93717>>>  end_procedure
93718>>>end_object
93719>>>
93719>>>object oFolderSizeGridPanel is a aps.ModalPanel label "Folder sizes (expanded as in tree view)"
93722>>>  set locate_mode to CENTER_ON_SCREEN
93723>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
93724>>>  on_key kcancel send close_panel
93725>>>  object oGrid is a aps.Grid
93727>>>    set size to 200 0
93728>>>    set peAnchors to (anTop+anLeft+anRight+anBottom)
93729>>>    set peResizeColumn to rcSelectedColumn // Resize mode (rcAll or rcSelectedColumn)
93730>>>    set piResizeColumn to 0                // This is the column to resize
93731>>>    set select_mode to NO_SELECT
93732>>>    send GridPrepare_AddColumn "Folder"             AFT_ASCII40
93733>>>    send GridPrepare_AddColumn "Files"              AFT_NUMERIC6.0
93734>>>    send GridPrepare_AddColumn "Folder size"        AFT_ASCII8
93735>>>    send GridPrepare_AddColumn "Largest file"       AFT_ASCII8
93736>>>    send GridPrepare_AddColumn "Most recent update" AFT_ASCII20
93737>>>    send GridPrepare_Apply self
93738>>>    on_key kEnter send DoExplorer
93739>>>
93739>>>    procedure mouse_click integer liItem integer liGrb
93742>>>      if ((liItem-1)>>    end_procedure
93746>>>
93746>>>    function iSpecialSortValueOnColumn.i integer liColumn returns integer
93749>>>      if (liColumn>0) function_Return 1
93752>>>    end_function
93753>>>
93753>>>    function sSortValue.ii integer liColumn integer liItem returns string
93756>>>      integer liRow liBase lhArray
93756>>>      number lnValue
93756>>>      if (liColumn>0) begin
93758>>>        move (oFolderSizeArray(self)) to lhArray
93759>>>        get Grid_ItemBaseItem self liItem to liBase
93760>>>        get aux_value item liBase to liRow
93761>>>        if (liColumn=1) get piFiles.i of lhArray liRow to lnValue
93764>>>        if (liColumn=2) get pnSize.i  of lhArray liRow to lnValue
93767>>>        if (liColumn=3) get pnMaxSz.i of lhArray liRow to lnValue
93770>>>        if (liColumn=4) get pnNewer.i of lhArray liRow to lnValue
93773>>>        function_return (IntToStrR(lnValue,14))
93774>>>      end
93774>>>>
93774>>>    end_function
93775>>>
93775>>>    procedure sort_data.i integer liColumn
93778>>>      send Grid_SortByColumn self liColumn
93779>>>    end_procedure
93780>>>
93780>>>    procedure sort_data
93783>>>      integer liCurrentColumn
93783>>>      get Grid_CurrentColumn self to liCurrentColumn
93784>>>      send sort_data.i liCurrentColumn
93785>>>    end_procedure
93786>>>    procedure header_mouse_click integer liItem
93789>>>      send sort_data.i liItem
93790>>>      forward send header_mouse_click liItem
93792>>>    end_procedure
93793>>>
93793>>>    procedure fill_list
93796>>>      integer lhArray liMax liRow lbSubFoldersIncluded liBase
93796>>>      integer liFiles
93796>>>      number lnSz lnMinSz lnMaxSz lnMinTime lnMaxTime
93796>>>      move (oFolderSizeArray(self)) to lhArray
93797>>>      set dynamic_update_state to false
93798>>>      send delete_data
93799>>>      get row_count of lhArray to liMax
93800>>>      decrement liMax
93801>>>      for liRow from 0 to liMax
93807>>>>
93807>>>        get item_count to liBase
93808>>>        send add_item MSG_NONE (psName.i(lhArray,liRow))
93809>>>        set aux_value item liBase to liRow
93810>>>        get piFiles.i of lhArray liRow to liFiles
93811>>>        get pnSize.i  of lhArray liRow to lnSz
93812>>>        get pnMinSz.i of lhArray liRow to lnMinSz
93813>>>        get pnMaxSz.i of lhArray liRow to lnMaxSz
93814>>>        get pnOlder.i of lhArray liRow to lnMinTime
93815>>>        get pnNewer.i of lhArray liRow to lnMaxTime
93816>>>        send add_item MSG_NONE liFiles
93817>>>        if liFiles begin
93819>>>          send add_item MSG_NONE (replace(",",SEQ_FileSizeToString(lnSz),"."))
93820>>>          send add_item MSG_NONE (replace(",",SEQ_FileSizeToString(lnMaxSz),"."))
93821>>>          send add_item MSG_NONE (TS_ConvertToString(lnMaxTime))
93822>>>        end
93822>>>>
93822>>>        else begin
93823>>>          send add_item MSG_NONE ""
93824>>>          send add_item MSG_NONE ""
93825>>>          send add_item MSG_NONE ""
93826>>>        end
93826>>>>
93826>>>      loop
93827>>>>
93827>>>      send Grid_SetEntryState self false
93828>>>      set dynamic_update_state to true
93829>>>    end_procedure
93830>>>  end_object
93831>>>  procedure DoExplorer
93834>>>    integer liBase
93834>>>    string lsPath
93834>>>    get Grid_BaseItem oGrid to liBase
93835>>>    get value of oGrid item liBase to lsPath
93836>>>    send html_StartDoc lsPath
93837>>>  end_procedure
93838>>>  procedure DoWriteToFile
93841>>>    send Grid_DoWriteToFile (oGrid(self))
93842>>>  end_procedure
93843>>>  on_key KEY_CTRL+KEY_W send DoWriteToFile
93844>>>  object oBtn1 is a aps.Multi_Button
93846>>>    set size to 14 50
93847>>>    on_item "Explorer" send DoExplorer
93848>>>    set peAnchors to (anBottom+anRight)
93849>>>  end_object
93850>>>  object oBtn2 is a aps.Multi_Button
93852>>>    on_item "Write to file" send DoWriteToFile
93853>>>    set peAnchors to (anBottom+anRight)
93854>>>  end_object
93855>>>  object oBtn3 is a aps.Multi_Button
93857>>>    set size to 14 40
93858>>>    on_item "Close" send close_panel
93859>>>    set peAnchors to (anBottom+anRight)
93860>>>  end_object
93861>>>  send aps_locate_multi_buttons
93862>>>  procedure popup
93865>>>    send fill_list of oGrid
93866>>>    forward send popup
93868>>>  end_procedure
93869>>>end_object // oFolderSizeGridPanel
93870>>>send aps_SetMinimumDialogSize (oFolderSizeGridPanel(self)) // Set minimum size
93871>>>
93871>>>object oFolderSizeTreePanel is a aps.View label "Explore folder size"
93874>>>  set Border_Style to BORDER_THICK   // Make panel resizeable
93875>>>  on_key kcancel send close_panel
93876>>>
93876>>>  object oTree is a aps.TreeNodeView
93878>>>    set peAnchors to (anTop+anLeft+anRight+anBottom)
93879>>>    set size to 200 310
93880>>>    set phTreeNode to (oFolderSizeTree(self))
93881>>>
93881>>>    Object oImageList is a cImageList
93883>>>      Set piMaxImages To 3
93884>>>      Procedure OnCreate // add the images
93887>>>        Integer iImage
93887>>>        Get AddTransparentImage 'closfold.bmp' clFuchsia To iImage
93888>>>        Get AddTransparentImage 'openfold.bmp' clFuchsia To iImage
93889>>>      End_Procedure
93890>>>    End_Object
93891>>>    Set ImageListObject To (oImageList(self))
93892>>>
93892>>>    function iImageItems integer lhData returns integer // complex hi: "Image" low: "Selected Image"
93895>>>      function_return (1*65536+0)
93896>>>    end_function
93897>>>
93897>>>    procedure DoGotoTop
93900>>>      send DoMakeItemVisible (RootItem(self))
93901>>>    end_procedure
93902>>>
93902>>>    procedure DoReset
93905>>>      send DoDeleteItem (RootItem(self))
93906>>>      send DoDeleteItem 0
93907>>>    end_procedure
93908>>>
93908>>>              function hDataObject integer lhItem returns integer
93911>>>                integer lhNode lhData
93911>>>                get ItemData lhItem to lhNode
93912>>>                if lhNode begin
93914>>>                  get phDataObject of lhNode to lhData
93915>>>                end
93915>>>>
93915>>>                else move 0 to lhData
93917>>>                function_return lhData
93918>>>              end_function
93919>>>
93919>>>    procedure OnItemCollapsed handle lhItem
93922>>>      integer lhData
93922>>>      string lsValue
93922>>>      get hDataObject lhItem to lhData
93923>>>      get FolderTree_DataTreeLabel lhData false to lsValue
93924>>>      set ItemLabel lhItem to lsValue
93925>>>    end_procedure
93926>>>    procedure OnItemExpanded handle lhItem
93929>>>      integer lhData
93929>>>      string lsValue
93929>>>      get hDataObject lhItem to lhData
93930>>>      get FolderTree_DataTreeLabel lhData true to lsValue
93931>>>      set ItemLabel lhItem to lsValue
93932>>>    end_procedure
93933>>>    procedure OnItemChanging handle lhItem handle lhOldItem
93936>>>      integer lhData
93936>>>      get hDataObject lhItem to lhData
93937>>>      send ItemInfo_Display lhData
93938>>>    end_procedure
93939>>>
93939>>>    function hCurrentDataObject returns integer
93942>>>      integer lhItem
93942>>>      get CurrentTreeItem to lhItem
93943>>>      if lhItem function_return (hDataObject(self,lhItem))
93946>>>      function_return 0
93947>>>    end_function
93948>>>
93948>>>              procedure ExportDataToArray_Help integer lhItem integer liLevel
93951>>>                integer lbVisible lhData lbExpanded lbExpandable
93951>>>                get ItemVisibleState lhItem to lbVisible
93952>>>                if lbVisible begin
93954>>>                  get hDataObject lhItem to lhData
93955>>>                  if lhData begin
93957>>>                    get ItemChildCount lhItem to lbExpandable
93958>>>                    if lbExpandable move (ItemExpandedState(self,lhItem)) to lbExpanded
93961>>>                    else move 1 to lbExpanded
93963>>>                    send AddToArray of oFolderSizeArray lhData (not(lbExpanded))
93964>>>                  end
93964>>>>
93964>>>                end
93964>>>>
93964>>>              end_procedure
93965>>>    procedure ExportDataToArray
93968>>>      send delete_data of oFolderSizeArray
93969>>>      send DoEnumerateTree MSG_ExportDataToArray_Help (RootItem(self)) 0
93970>>>//      send DoEnumerateTree MSG_ExportDataToArray_Help (CurrentTreeItem(self)) 0
93970>>>    end_procedure
93971>>>  end_object // oTree
93972>>>
93972>>>  object oStatusPanel is a StatusPanel
93974>>>    set allow_cancel_state to FALSE
93975>>>  end_object
93976>>>
93976>>>  procedure OnReadFolder string lsParentFolder string lsFolder
93979>>>    set Message_Text of oStatusPanel to lsParentFolder
93980>>>    set Action_Text  of oStatusPanel to lsFolder
93981>>>  end_procedure
93982>>>
93982>>>  procedure ItemInfo_Display integer lhData
93985>>>    //send DoUpdate of oGroup lhData
93985>>>  end_procedure
93986>>>
93986>>>  property string psFolder public ""
93988>>>
93988>>>            procedure DoReadFolder string lsFolder
93991>>>              set label to ("Explore folder size ("+lsFolder+")")
93992>>>              set psFolder to lsFolder
93993>>>
93993>>>              send FolderTreeSetup_Reset
93994>>>
93994>>>              set FolderTreeSetup_Value FTSU_READ_FOLDER_CB_OBJECT  to self
93995>>>              set FolderTreeSetup_Value FTSU_READ_FOLDER_CB_MESSAGE to MSG_OnReadFolder
93996>>>
93996>>>              set Caption_Text of oStatusPanel to ("Reading "+lsFolder)
93997>>>              send Start_StatusPanel of oStatusPanel
93998>>>
93998>>>              send DoReset of oFolderSizeTree
93999>>>              send DoReset of oTree
94000>>>              send build_folder_tree of oFolderSizeTree lsFolder
94001>>>
94001>>>              send Stop_StatusPanel of oStatusPanel
94002>>>
94002>>>              send OnCreateTree of oTree
94003>>>              send DoGotoTop of oTree
94004>>>              send activate of oTree
94005>>>            end_procedure
94006>>>
94006>>>  procedure DoNewFolder
94009>>>    string lsFolder
94009>>>    get SEQ_SelectDirectory "Select folder" to lsFolder
94010>>>    if (lsFolder<>"") send DoReadFolder lsFolder
94013>>>  end_procedure
94014>>>
94014>>>  procedure DoRefresh
94017>>>    string lsFolder
94017>>>    get psFolder to lsFolder
94018>>>    if (lsFolder<>"") send DoReadFolder lsFolder
94021>>>    else send obs "Folder has not been selected"
94023>>>  end_procedure
94024>>>
94024>>>
94024>>>  procedure DoExpandLevel
94027>>>    integer lhItem lhOrigItem lhData
94027>>>    string lsFolder lsPath lsValue
94027>>>    get psFolder to lsFolder
94028>>>    if (lsFolder<>"") begin
94030>>>      get CurrentTreeItem of oTree to lhItem
94031>>>      move lhItem to lhOrigItem
94032>>>      if lhItem begin
94034>>>        send DoExpandItem of oTree lhItem
94035>>>             // Otherwise the labels wont reflect it:
94035>>>             get hDataObject of oTree lhItem to lhData
94036>>>             get FolderTree_DataTreeLabel lhData TRUE to lsValue
94037>>>             set ItemLabel of oTree lhItem to lsValue
94038>>>        get ChildItem of oTree lhItem to lhItem
94039>>>        while lhItem
94043>>>          send DoCollapseItem of oTree lhItem
94044>>>               // Otherwise the labels wont reflect it:
94044>>>               get hDataObject of oTree lhItem to lhData
94045>>>               get FolderTree_DataTreeLabel lhData FALSE to lsValue
94046>>>               set ItemLabel of oTree lhItem to lsValue
94047>>>          get NextSiblingItem of oTree lhItem to lhItem
94048>>>        end
94049>>>>
94049>>>        send DoMakeItemVisible of oTree lhOrigItem
94050>>>      end
94050>>>>
94050>>>      else send obs "You are not pointing to a folder"
94052>>>    end
94052>>>>
94052>>>    else send obs "Folder has not been selected"
94054>>>  end_procedure
94055>>>
94055>>>  procedure DoExplorer
94058>>>    integer lhData
94058>>>    string lsFolder lsPath
94058>>>    get psFolder to lsFolder
94059>>>    if (lsFolder<>"") begin
94061>>>      get hCurrentDataObject of oTree to lhData
94062>>>      if lhData begin
94064>>>        get value of lhData item FLDS_FOLDER_NAME_PATH to lsPath
94065>>>        send html_StartDoc lsPath
94066>>>      end
94066>>>>
94066>>>      else send obs "You are not pointing to a folder"
94068>>>    end
94068>>>>
94068>>>    else send obs "Folder has not been selected"
94070>>>  end_procedure
94071>>>
94071>>>  procedure DoGrid
94074>>>    string lsFolder
94074>>>    get psFolder to lsFolder
94075>>>    if (lsFolder<>"") begin
94077>>>      send ExportDataToArray of oTree
94078>>>      send popup of oFolderSizeGridPanel
94079>>>    end
94079>>>>
94079>>>    else send obs "Folder has not been selected"
94081>>>  end_procedure
94082>>>
94082>>>  object oBtn1 is a aps.Multi_Button
94084>>>    on_item "Select folder" send DoNewFolder
94085>>>    set peAnchors to (anBottom+anRight)
94086>>>  end_object
94087>>>  object oBtn2 is a aps.Multi_Button
94089>>>    set size to 14 40
94090>>>    on_item "Refresh" send DoRefresh
94091>>>    set peAnchors to (anBottom+anRight)
94092>>>  end_object
94093>>>  object oBtn3 is a aps.Multi_Button
94095>>>    set size to 14 50
94096>>>    on_item "Expand level" send DoExpandLevel
94097>>>    set peAnchors to (anBottom+anRight)
94098>>>  end_object
94099>>>  object oBtn4 is a aps.Multi_Button
94101>>>    set size to 14 40
94102>>>    on_item "Explorer" send DoExplorer
94103>>>    set peAnchors to (anBottom+anRight)
94104>>>  end_object
94105>>>  object oBtn5 is a aps.Multi_Button
94107>>>    on_item "Display in grid" send DoGrid
94108>>>    set peAnchors to (anBottom+anRight)
94109>>>  end_object
94110>>>  object oBtn6 is a aps.Multi_Button
94112>>>    set size to 14 40
94113>>>    on_item "Close" send close_panel
94114>>>    set peAnchors to (anBottom+anRight)
94115>>>  end_object
94116>>>  send aps_locate_multi_buttons
94117>>>
94117>>>end_object // oFolderSizeTreePanel
94118>>>send aps_SetMinimumDialogSize (oFolderSizeTreePanel(self)) // Set minimum size
94119>>>
94119>>>procedure activate_oFolderSizeTreePanel
94122>>>  send popup of oFolderSizeTreePanel
94123>>>end_procedure
94124>>>
94124>>>
94124>
94124>    ///////////////////////////
94124>//  use vdfsort.vw
94124>//  use vdfquery.rv
94124>    ///////////////////////////
94124>
94124>
94124>  //procedure DFMatrix_Activate_Query_Vw
94124>  //  if (DFMatrix_RealData_Check()) send Activate_Query_Vw
94124>  //end_procedure
94124>  End_Object  // Client_Area
94125>
94125>End_Object // Main
94126>
94126>procedure set DFMatrix_App_Label string lsValue
#REM AMBIGUOUS METHODS ON .DESKTOP. ARE .NOT. RECOMMENDED (OBSOLETE TECHNIQUE)
94128>  set label of (Main(self)) to lsValue
94129>end_procedure
94130>send DFMatrix_Update_App_Title
94131>//send DoDfMatrixCommandLine to (Client_Area(Main(self)))
94131>send deactivate to (oSplash(self))
94132>
94132>Start_UI
94133>
94133>
Summary
Memory Available: 1377632256
Total Warnings : 0
Total Errors   : 0
Total Symbols  : 45404
Total Resources: 0
Total Commands : 94132
Total Windows  : 20
Total Pages    : 23
Static Data    : 730485
Message area   : 557120
Total Blocks   : 32426