Liren Large Software Subsidy 5

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

/ Liren Large Software Subsidy 5 / 05.iso / a / a102 / 1.ddi / NEWTPORT / TRANSPRT.PRG

Wrap

Text File | 1993-05-20 | 247.7 KB | 7,541 lines

*:***************************************************************************** *: *: Procedure file: C:\FOXPROW\TRANSPRT.PRG *: System: FoxPro 2.5 Transporter *: Author: Microsoft Corp. *: Copyright (c) 1993, *: Last modified: 1/4/93 at 15:57:18 *: *: Procs & Fncts: SETALL *: : ERRORHANDLER *: : STRIPPATH() *: : CLEANUP *: : SETVERSION *: : GETOLDREPORTTYPE() *: : DOUPDATE() *: : CVRT102FRX() *: : CVRTFBPRPT() *: : OPENDBF() *: : STARTTHERM *: : CONVERTER *: : UPDTHERM *: : IMPORT *: : SYNCHTIME *: : CONVERTTYPE() *: : MAKECURSOR *: : GRAPHICTOCHAR *: : CHARTOGRAPHIC *: : UPDATESCREEN *: : CONVERTPROJECT *: : UPDATEREPORT *: : NEWCHARTOGRAPHIC *: : NEWGRAPHICTOCHAR *: : NEWBANDS *: : ALLGRAPHICTOCHAR *: : ALLCHARTOGRAPHIC *: : INITBANDS *: : BLDBREAKEXP *: : BLDBREAKS *: : BLDDETAIL *: : ADDTOTAL *: : LITEXIST() *: : GETLITEXPR() *: : MAKEBAND *: : MAKETEXT *: : MAKEFIELD *: : GETHEADING() *: : LINESFORHEADING() *: : HOWMANYHEADINGS() *: : FLD_HEAD_EXIST() *: : TOTALS_EXIST() *: : CENTER_COL() *: : EVALIMPORTEXPR *: : MAPBUTTON() *: : SCATTERBUTTONS *: : FINDLIKEVPOS *: : FINDLIKEHPOS *: : MAKECHARFIT *: : ALLENVIRONS *: : ALLOTHERS *: : FILLININFO *: : ADJRPTFLOAT *: : ADJRPTSUPPRESS *: : ADJRPTRESET *: : GETCHARSUPPRESS() *: : SUPPRESSBLANKLINES *: : ALLGROUPS *: : RPTCONVERT *: : RPTOBJCONVERT *: : GETBANDINDEX *: : BANDINFO() *: : CLONEBAND *: : RESIZEBAND *: : BANDPOS() *: : EMPTYBAND() *: : GETBANDCODE() *: : CVTREPORTVERTICAL() *: : CVTREPORTHORIZONTAL() *: : CVTRPTLINES() *: : MERGELABELOBJECTS *: : LABELOBJMERGE *: : ADDLABELBLANKS *: : LINESBETWEEN *: : LABELBANDS *: : LABELLINES *: : CALCPOSITIONS *: : CALCWINDOWDIMENSIONS *: : FINDWIDEROBJECTS *: : ADJHPOS *: : SGN() *: : REPOOBJECTS *: : ADJITEMSINBOXES *: : ITEMSINBOXES *: : FINDOTHERSONLINE() *: : ADJINVBTNS *: : ADJPOSTINV *: : FINDALIGNEND() *: : STRETCHLINESTOBORDERS *: : JOINLINES *: : JOINHORIZONTAL *: : JOINVERTICAL *: : MEETBOXCHAR *: : ZAPBOXCHAR *: : ADDJOIN *: : REJOINBOXES *: : JOINLINEWIDTH() *: : GETLASTOBJECTLINE() *: : ADJOBJCODE *: : GETWINDFONT *: : ADJHEIGHTANDWIDTH *: : COLUMNAR() *: : DOSSIZE() *: : ADJBITMAPCTRL *: : ADJCOLOR *: : RGBTOX() *: : ADJPEN *: : ADJFONT *: : CONVERTCOLORPAIR *: : GETCOLOR() *: : WHATSTYLE() *: : ADJTEXT *: : ADJBOX *: : GETLINEWIDTH() *: : HORIZBUTTON() *: : MAXBTNWIDTH() *: : GETOBJWIDTH() *: : GETOBJHEIGHT() *: : GETRIGHTMOST *: : GETLOWEST *: : DOCREATE *: : ADDGRAPHICALLABELGROUPS *: : UPDATELABELDATA *: : PLATFORMDEFAULTS *: : UPDATEVERSION *: : STAMPVAL() *: : SHIFTL() *: : SHIFTR() *: : EMPTYPLATFORM() *: : STRUCTDIALOG() *: : CURPOS() *: : SCXFRXDIALOG() *: : TRANSPRMPT() *: : RDVALID() *: : DEACCLAU() *: : SHOWCLAU() *: : SCRNCTRL() *: : ENABLEPROC() *: : PVALID() *: : ACTTHERM *: : DEACTTHERM *: : CLEANWIND *: : ESCHANDLER *: : ERRSHOW *: : JUSTSTEM() *: : WRITERESULT *: : ISOBJECT() *: : ISREPTOBJECT() *: : ISGRAPHOBJ() *: : HASRECORDS() *: : ASKFONT() *: : IS20SCX() *: : IS20FRX() *: : IS20LBX() *: : GETSNIPFLAG() *: : MATCH() *: : WORDNUM() *: : ADDBS() *: : JUSTFNAME() *: : JUSTPATH() *: : FORCEEXT() *: : CVTLONG() *: : CVTSHORT() *: : CVTBYTE() *: : OBJ2BASEFONT() *: : VERSIONCAP() *: : BLACKBOX() *: : SELECTOBJ *: : INITSEL *: : ADDSEL *: : ISSELECTED() *: : ASSEMBLE() *: : TYPE2NAME() *: : CLEANPICT() *: : TPSELECT *: : TOGGLE() *: : OKVALID() *: : WREADDEAC() *: *: Calls: SETALL (procedure in TRANSPRT.PRG) *: : ERRORHANDLER (procedure in TRANSPRT.PRG) *: : STRIPPATH() (function in TRANSPRT.PRG) *: : CLEANUP (procedure in TRANSPRT.PRG) *: : SETVERSION (procedure in TRANSPRT.PRG) *: : GETOLDREPORTTYPE() (function in TRANSPRT.PRG) *: : DOUPDATE() (function in TRANSPRT.PRG) *: : CVRT102FRX() (function in TRANSPRT.PRG) *: : CVRTFBPRPT (procedure in TRANSPRT.PRG) *: : OPENDBF() (function in TRANSPRT.PRG) *: : STARTTHERM (procedure in TRANSPRT.PRG) *: : CONVERTER (procedure in TRANSPRT.PRG) *: : UPDTHERM (procedure in TRANSPRT.PRG) *: : IMPORT (procedure in TRANSPRT.PRG) *: : SYNCHTIME (procedure in TRANSPRT.PRG) *: : CONVERTTYPE() (function in TRANSPRT.PRG) *: : MAKECURSOR (procedure in TRANSPRT.PRG) *: *: Documented FoxDoc version 3.00a *:***************************************************************************** * * TRANSPORT - FoxPro screen, report and label conversion utility. * *:***************************************************************************** * Copyright (c) 1993 Microsoft Corp. * One Microsoft Way * Redmond, WA 98052 * * Notes: * In this program, for clarity/readability reasons, we use variable * names that are longer than 10 characters. Note, however, that only * the first 10 characters are significant. * * * Revision History: * First written by Matt Pohle, John Beaver and Walt Kennamer for FoxPro 2.5 * PROCEDURE transprt PARAMETER m.g_scrndbf, m.tp_filetype, m.dummy * "g_crndbf" is the name of the file to transport. It will usually be in some sort * of database format (e.g., SCX/PJX/MNX) but might also be a FoxBASE+ or FoxPro 1.02 * report or label file, which is not a database. * * "tp_filetype" specifies what kind of file "g_scrndbf" is. Allowable values are * found in the #DEFINE constants immediately below. Note that the Transporter usually * does not use this value and instead figures out what kind of file it is being * presented with by counting the fields in the database. For FoxBASE+ and FoxPro 1.02 files, * however, the Transporter does use this parameter to convert the report or label * data into 2.0 database format before transporting to Windows. Note that the FoxBASE+ * types are never actually passed in m.tp_filetype. They are inferred in GetOldReportType * and GetOldLabelTypefrom the ID byte in the report/label files. * The "dummy" parameter is not used. At one point in the developement of the Transporter, * another parameter was passed. * * Define Global Constants * * Filetype constants for FoxPro 2.0 and FoxPro 2.5 formats #DEFINE c_20pjxtype 1 #DEFINE c_25scxtype 12 #DEFINE c_20scxtype 2 #DEFINE c_25frxtype 13 #DEFINE c_20frxtype 3 #DEFINE c_25lbxtype 14 #DEFINE c_20lbxtype 4 * FoxPro 1.02 and FoxBASE+ formats. Note that the FoxBASE+ types are never * actually passed in m.tp_filetype. They are inferred in GetOldReportType and * GetOldLabelTypefrom the ID byte in the report/label files. The suffix tells * us how the file was called, by REPORT FORM ... or by MODIFY REPORT ... #DEFINE c_frx102repo 23 #DEFINE c_frx102modi 33 #DEFINE c_fbprptrepo 43 #DEFINE c_fbprptmodi 53 #DEFINE c_lbx102repo 24 #DEFINE c_lbx102modi 34 #DEFINE c_fbplblrepo 44 #DEFINE c_fbplblmodi 54 * Definitions for Objtype fields in screens/reports/labels #DEFINE c_otheader 1 #DEFINE c_otworkar 2 #DEFINE c_otindex 3 #DEFINE c_otrel 4 #DEFINE c_ottext 5 #DEFINE c_otline 6 #DEFINE c_otbox 7 #DEFINE c_otrepfld 8 #DEFINE c_otband 9 #DEFINE c_otgroup 10 #DEFINE c_otlist 11 #DEFINE c_ottxtbut 12 #DEFINE c_otradbut 13 #DEFINE c_otchkbox 14 #DEFINE c_otfield 15 #DEFINE c_otpopup 16 #DEFINE c_otpicture 17 #DEFINE c_otrepvar 18 #DEFINE c_ot20lbxobj 19 #DEFINE c_otinvbut 20 #DEFINE c_otpdset 21 #DEFINE c_otspinner 22 #DEFINE c_otfontdata 23 * Window types #DEFINE c_user 1 #DEFINE c_system 2 #DEFINE c_dialog 3 #DEFINE c_alert 4 * ObjCode definitions #DEFINE c_sgsay 0 #DEFINE c_sgget 1 #DEFINE c_sgedit 2 #DEFINE c_sgfrom 3 #DEFINE c_sgbox 4 #DEFINE c_sgboxd 5 #DEFINE c_sgboxp 6 #DEFINE c_sgboxc 7 #DEFINE c_lnvertical 0 #DEFINE c_lnhorizontal 1 #DEFINE c_ocboxgrp 1 * Attempt to preserve colors of text, lines and boxes when transporting to DOS? #DEFINE c_maptextcolor .T. * Field counts #DEFINE c_20scxfld 57 #DEFINE c_scxfld 79 #DEFINE c_20frxfld 36 #DEFINE c_frxfld 74 #DEFINE c_ot20label 30 #DEFINE c_20lbxfld 17 #DEFINE c_20pjxfld 33 #DEFINE c_pjxfld 31 * Metrics for various objects, report bands, etc. #DEFINE c_pophght 1.231 #DEFINE c_radhght 1.308 #DEFINE c_chkhght 1.308 #DEFINE c_listht 1.000 #DEFINE c_adjfld 0.125 #DEFINE c_adjlist 0.125 #DEFINE c_adjtbtn 0.769 #DEFINE c_adjrbtn 0.308 #DEFINE c_vchkbox 0.154 #DEFINE c_vradbtn 0.154 #DEFINE c_vpopup 0.906 #DEFINE c_vlist 0.500 #DEFINE c_hpopup 1.000 #DEFINE c_adjbox 0.500 #DEFINE c_chkpixel 12 #DEFINE c_pixelsize 96 #DEFINE c_bandheight ((19/96) * 10000) #DEFINE c_bandfudge 4350 #DEFINE c_charrptheight 66 #DEFINE c_charrptwidth 80 #DEFINE c_linesperinch (66/11) #DEFINE c_charsperinch 13.71 * Version codes, put into Objcode fields in the header record #DEFINE c_25scx 63 #DEFINE c_25frx 53 * Major file types #DEFINE c_report 0 #DEFINE c_screen 1 #DEFINE c_label 2 #DEFINE c_project 3 * Error codes #DEFINE c_error1 "Minor" #DEFINE c_error2 "Serious" #DEFINE c_error3 "Fatal" * Font style for Transporter dialogs #DEFINE c_dlgface "MS Sans Serif" #DEFINE c_dlgsize 8.000 #DEFINE c_dlgstyle "BT" #DEFINE c_dlgsty1 "BO" * Return values #DEFINE c_yes 1 #DEFINE c_no 0 #DEFINE c_cancel -1 * Codepage translation #DEFINE c_cptrans .T. && do special CP translation for FoxBASE+ and FoxPro 1.02? #DEFINE c_doscp 437 && default DOS code page #DEFINE c_wincp 1252 && default Windows code page #DEFINE c_maccp 0 #DEFINE c_unixcp 0 * bands[] array indexes #DEFINE c_tobandvpos 1 #DEFINE c_tobandheight 2 #DEFINE c_fmbandvpos 3 #DEFINE c_fmbandheight 4 * Defines used in converting FoxBASE+ reports #DEFINE maxliterals 55 #DEFINE litpoolsize 1452 #DEFINE maxrepflds 24 #DEFINE h_page 1 #DEFINE h_break 3 #DEFINE l_item 4 #DEFINE f_break 5 #DEFINE f_page 7 #DEFINE f_rpt 8 PRIVATE ALL IF SET("TALK") = "ON" SET TALK OFF m.talkset = "ON" ELSE m.talkset = "OFF" ENDIF m.pcount = PARAMETERS() PUSH KEY * * Declare Environment Variables so that they are visible throughout the program * STORE "" TO m.cursor, m.consol, m.bell, m.exact, m.escape, m.onescape, m.safety, ; m.fixed, m.print, m.unqset, m.udfparms, m.exclusive, m.onerror, ; m.trbetween, m.comp, m.device, m.status, m.g_fromplatform, m.choice, ; m.g_fromobjonlyalias, m.g_boxeditemsalias, m.g_tempalias, m.mtopic, m.rbord, m.mcollate STORE 0 TO m.deci, m.memowidth, m.currarea DO setall * Set default typeface for reports m.g_rptfface = "Courier" m.g_rptfstyle = 0 m.g_rpttxtfontstyle = "" m.g_rptfsize = 8 IF _MAC OR _WINDOWS m.g_rptlinesize = (FONTMETRIC(1, m.g_rptfface, m.g_rptfsize, m.g_rpttxtfontstyle) / c_pixelsize) * 10000 m.g_rptcharsize = (FONTMETRIC(6, m.g_rptfface, m.g_rptfsize, m.g_rpttxtfontstyle) / c_pixelsize) * 10000 ENDIF * Font selections for fields/text in the SCX/FRX itself. May be overridden by user. m.g_fontface = "MS Sans Serif" m.g_fontsize = 8 m.g_fontstyle = "B" * Font selections for controls in the SCX/FRX. Not overrideable. m.g_cfontface = "MS Sans Serif" m.g_cfontsize = 8 m.g_foxfont = "Foxfont" m.g_normstyle = 0 m.g_boldstyle = 1 m.g_filetype = " " m.g_fromplatform = " " m.g_toplatform = " " m.g_windheight = 1 m.g_windwidth = 1 m.g_thermwidth = 0 m.g_mercury = 0 m.g_20alias = "" m.g_status = 0 m.g_energize = .F. m.g_norepeat = .F. m.g_allobjects = .T. m.g_newobjects = .T. m.g_snippets = .T. m.g_scrnalias = "" m.g_updenviron = .F. && have we transported the environment records? m.g_tpselcnt = 0 && number of entries in the tparray selection array m.g_boxstrg = ['─','─','│','│','┌','┐','└','┘','─','─','│','│','┌','┐','└','┘'] m.g_returncode = c_cancel m.g_tocodepage = 0 m.g_fromcodepage = 0 * Dimension the array of records to be transported. This is the picklist of new and * updated objects. DIMENSION tparray[1,2] DIMENSION g_lastobjectline[2] g_lastobjectline = 0 m.g_tempindex = "S" + SUBSTR(LOWER(SYS(3)),2,8) + ".cdx" m.onerror = ON("ERROR") ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error3 IF m.pcount < 2 DO ErrorHandler WITH "Invalid number of parameters",LINENO(),c_error3 ENDIF * * Make sure we have a file name we can deal with. Prompt if the file cannot be found. * IF TYPE("m.g_scrndbf") != "C" m.g_scrndbf = "" ENDIF m.g_scrndbf = UPPER(ALLTRIM(m.g_scrndbf)) DO CASE CASE SUBSTR(m.g_scrndbf, RAT(".", m.g_scrndbf)+1, 3) = "SCX" IF !FILE(m.g_scrndbf) m.g_scrndbf = GETFILE("SCX", "Where is "+strippath(m.g_scrndbf)) ENDIF CASE SUBSTR(m.g_scrndbf, RAT(".", m.g_scrndbf)+1, 3) = "FRX" IF !FILE(m.g_scrndbf) m.g_scrndbf = GETFILE("FRX", "Where is "+strippath(m.g_scrndbf)) ENDIF CASE SUBSTR(m.g_scrndbf, RAT(".", m.g_scrndbf)+1, 3) = "LBX" IF !FILE(m.g_scrndbf) m.g_scrndbf = GETFILE("LBX", "Where is "+strippath(m.g_scrndbf)) ENDIF CASE SUBSTR(m.g_scrndbf, RAT(".", m.g_scrndbf)+1, 3) = "PJX" IF !FILE(m.g_scrndbf) m.g_scrndbf = GETFILE("PJX", "Where is "+strippath(m.g_scrndbf)) ENDIF OTHERWISE IF !FILE(m.g_scrndbf) m.g_scrndbf = GETFILE("SCX|FRX|LBX|PJX", "Select the file to transport", "Transport") ENDIF ENDCASE IF !FILE(m.g_scrndbf) OR EMPTY(m.g_scrndbf) DO cleanup RETURN .F. ENDIF DO putwinmsg WITH "FoxPro Transporter: " + LOWER(strippath(m.g_scrndbf)) DO setversion * If we've been passed an old format report or label form, see if it is a FoxPro 1.02 * form, a FoxBASE+ form, or an unknown form. * Convert FoxPro 1.02 or FoxBASE+ DOS reports into 2.5 DOS reports IF INLIST(m.tp_filetype,c_frx102modi,c_frx102repo,c_lbx102modi, c_lbx102repo) IF INLIST(m.tp_filetype,c_frx102modi,c_frx102repo) m.tp_filetype = getoldreporttype() && FoxPro 1.02 or FoxBASE+ report? ELSE m.tp_filetype = getoldlabeltype() && FoxPro 1.02 or FoxBASE+ label? ENDIF m.g_fromcodepage = c_doscp IF doupdate() && prompt to convert to 2.5 format; sets m.g_filetype DO CASE CASE INLIST(m.tp_filetype,c_frx102modi,c_frx102repo) * FoxPro 1.02 report m.g_scrndbf = cvrt102frx(m.g_scrndbf, m.tp_filetype) CASE INLIST(m.tp_filetype,c_fbprptmodi,c_fbprptrepo) * FoxBASE+ report m.g_scrndbf = cvrtfbprpt(m.g_scrndbf, m.tp_filetype) CASE INLIST(m.tp_filetype,c_lbx102modi,c_lbx102repo) * FoxPro 1.02 label m.g_scrndbf = cvrt102lbx(m.g_scrndbf, m.tp_filetype) CASE INLIST(m.tp_filetype,c_fbplblmodi,c_fbplblrepo) * FoxBASE+ label m.g_scrndbf = cvrtfbplbl(m.g_scrndbf, m.tp_filetype) OTHERWISE DO errorhandler WITH "Unknown report format",LINENO(),c_error3 ENDCASE ELSE DO cleanup RETURN c_cancel ENDIF ENDIF * Open the screen/report/label/project file IF !opendbf(m.g_scrndbf) m.g_returncode = c_cancel ENDIF * * We have three basic conversion cases. These are transporting a 2.0 file to a * graphical 2.5 platform (structure change and conversion), converting a 2.0 file * to a character 2.5 platform (structure change) and transporting a 2.5 platform * to another 2.5 platform (character/graphical conversion). This case statement * calls the appropriate dialog routines and makes sure we have done all the * preparation (like creating the cursor we actually work with.) * * The 1.02 and FoxBASE+ reports/labels are handled in basically the same way. * They get their own cases in this construct since we don't want to prompt the * user twice for conversion. Almost all of the actual conversion of these files * has already taken place, in the "cvrt102frx" procedure (and related procedures) * called above. * * Conversion of 2.0 project files is handled in its own case also. * DO CASE CASE INLIST(m.tp_filetype,c_frx102repo,c_fbprptrepo,c_lbx102repo,c_fbplblrepo) ; AND (_WINDOWS OR _MAC) * FoxPro 1.02 or FoxBASE+ report/label opened via REPORT/LABEL FORM. At this point, * we've already converted the old format form into FoxPro 2.5 DOS format. * Finish conversion, but don't transport it to Windows. m.g_fromplatform = "DOS" DO getcodepage m.g_returncode = c_yes DO starttherm WITH "Converting",g_filetype DO putwinmsg WITH "Converting " + LOWER(strippath(m.g_scrndbf)) DO converter DO updtherm WITH 100 CASE INLIST(m.tp_filetype,c_frx102modi,c_fbprptmodi,c_lbx102modi,c_fbplblmodi) ; AND (_WINDOWS OR _MAC) * FoxPro 1.02 or FoxBASE+ report/label opened via MODIFY REPORT/LABEL. At this point, * we've already converted the old format form into FoxPro 2.5 DOS format. * Finish conversion, and then transport it to Windows. m.g_fromplatform = "DOS" DO getcodepage m.g_returncode = c_yes DO putwinmsg WITH "Converting " + LOWER(strippath(m.g_scrndbf)) DO converter DO putwinmsg WITH "Transporting " + LOWER(strippath(m.g_scrndbf)) DO import DO synchtime WITH m.g_toplatform, m.g_fromplatform DO updtherm WITH 100 CASE ((FCOUNT() = c_20scxfld OR FCOUNT() = c_20frxfld OR FCOUNT() = c_20lbxfld); AND (_DOS OR _UNIX)) * Convert it to a DOS report, but don't transport it to Windows DO CASE CASE !doupdate() && displays dialog and sets g_toPlatform m.g_returncode = c_cancel OTHERWISE m.g_fromplatform = "DOS" DO getcodepage m.g_returncode = c_yes DO starttherm WITH "Converting",g_filetype DO converter DO updtherm WITH 100 ENDCASE CASE (FCOUNT() = c_20scxfld OR FCOUNT() = c_20frxfld ; OR FCOUNT() = c_20lbxfld) AND (_WINDOWS OR _MAC) * Convert it to DOS and then transport it to Windows m.choice = converttype(.T.) DO getcodepage DO CASE CASE m.choice = c_yes m.g_returncode = c_yes DO converter DO import DO synchtime WITH m.g_toplatform, m.g_fromplatform DO updtherm WITH 100 CASE m.choice = c_no m.g_returncode = c_no OTHERWISE m.g_returncode = c_cancel ENDCASE CASE FCOUNT() = c_scxfld OR FCOUNT() = c_frxfld m.choice = converttype(.F.) DO CASE CASE m.choice = c_yes m.g_returncode = c_yes DO makecursor DO import IF m.g_returncode <> c_cancel * This might happen if the user picked "Cancel" on the screen that lets * him/her uncheck specific items. SELECT (m.g_scrnalias) DO synchtime WITH m.g_toplatform, m.g_fromplatform DO updtherm WITH 100 ENDIF CASE m.choice = c_no m.g_returncode = c_no OTHERWISE m.g_returncode = c_cancel ENDCASE CASE FCOUNT() = c_20pjxfld * IF versnum() > "2.5" * * Identify fields that contain binary data. These should not be codepage-translated. * * Note that files opened via low level routines (e.g., FoxPro 1.02 reports) will not * * be codepage-translated automatically. Strings in those files that require codepage * * translation will be codepage translated explicitly below. * SET NOCPTRANS TO arranged, object, symbols, devinfo * ENDIF * Converting a 2.0 project to 2.5 format IF !doupdate() && displays dialog and sets g_toPlatform m.g_returncode = c_cancel ELSE m.g_fromplatform = "DOS" DO getcodepage m.g_returncode = c_yes DO putwinmsg WITH "Converting " + LOWER(strippath(m.g_scrndbf)) DO starttherm WITH "Converting",g_filetype DO converter DO updtherm WITH 100 ENDIF CASE FCOUNT() = c_pjxfld * 2.5 project passed to us by mistake--shouldn't ever happen. WAIT WINDOW "The transporter has nothing to do." NOWAIT m.g_returncode = c_cancel OTHERWISE DO errorhandler WITH "Unknown or invalid file format", LINENO(), c_error3 m.g_returncode = c_cancel ENDCASE DO cleanup RETURN m.g_returncode *!***************************************************************************** *! *! Function: OPENDBF *! *! Called by: TRANSPRT.PRG *! *!***************************************************************************** FUNCTION opendbf PARAMETER fname m.g_scrnalias = "S"+SUBSTR(LOWER(SYS(3)),2,8) SELECT 0 USE (m.fname) AGAIN ALIAS (m.g_scrnalias) IF RECCOUNT() = 0 WAIT WINDOW "No records to transport" NOWAIT RETURN .F. ENDIF RETURN .T. * * doupdate - Ask the user if a 2.0 screen/report/label should be updated to 2.5 format. * *!***************************************************************************** *! *! Function: DOUPDATE *! *! Called by: TRANSPRT.PRG *! *! Calls: STRUCTDIALOG() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION doupdate PRIVATE m.result DO CASE CASE INLIST(m.tp_filetype,c_frx102modi, c_frx102repo) m.g_filetype = c_report m.result = structdialog("Convert 1.02 report file to 2.5 format?") CASE INLIST(m.tp_filetype,c_fbprptmodi, c_fbprptrepo) m.g_filetype = c_report m.result = structdialog("Convert FoxBASE+ report file to FoxPro 2.5 format?") CASE INLIST(m.tp_filetype,c_lbx102modi, c_lbx102repo) m.g_filetype = c_label m.result = structdialog("Convert 1.02 label file to 2.5 format?") CASE INLIST(m.tp_filetype,c_fbplblmodi, c_fbplblrepo) m.g_filetype = c_label m.result = structdialog("Convert FoxBASE+ label file to FoxPro 2.5 format?") CASE FCOUNT() = c_20scxfld m.g_filetype = c_screen m.result = structdialog("Convert 2.0 screen file to 2.5 format?") CASE FCOUNT() = c_20frxfld m.g_filetype = c_report m.result = structdialog("Convert 2.0 report file to 2.5 format?") CASE FCOUNT() = c_20lbxfld RETURN .F. CASE FCOUNT() = c_20pjxfld m.g_filetype = c_project m.result = structdialog("Convert 2.0 project file to 2.5 format?") ENDCASE RETURN m.result * * converttype - Display the dialog used when converting between 2.5 platforms * *!***************************************************************************** *! *! Function: CONVERTTYPE *! *! Called by: TRANSPRT.PRG *! *! Calls: CLEANUP (procedure in TRANSPRT.PRG) *! : SCXFRXDIALOG() (function in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *!***************************************************************************** FUNCTION converttype PARAMETER m.twooh PRIVATE m.i, m.pcount, m.nplatforms IF m.twooh && If it's a 2.0 file, there is only one platform to convert from. DIMENSION platforms[1] platforms[1] = "FoxPro for MS-DOS" DO CASE && Remember the type of file we are converting CASE INLIST(m.tp_filetype,c_frx102modi,c_frx102repo,c_fbprptmodi,c_fbprptrepo) m.g_filetype = c_report CASE FCOUNT() = c_20scxfld m.g_filetype = c_screen CASE FCOUNT() = c_20frxfld m.g_filetype = c_report CASE FCOUNT() = c_20lbxfld m.g_filetype = c_label CASE FCOUNT() = c_20pjxfld m.g_filetype = c_project ENDCASE ELSE IF FCOUNT() = c_scxfld && Remember the type of file we are converting m.g_filetype = c_screen ELSE IF UPPER(RIGHT(m.g_scrndbf, 4)) = ".LBX" LOCATE FOR objtype = c_ot20label OR ; ((platform = "WINDOWS" OR platform = "MAC") AND ; objtype = c_otheader AND BOTTOM) IF FOUND() m.g_filetype = c_label ELSE m.g_filetype = c_report ENDIF ELSE m.g_filetype = c_report ENDIF ENDIF * Get a list of the platforms in this file. SELECT DISTINCT platform ; FROM (m.g_scrnalias) ; WHERE !DELETED() ; INTO ARRAY availplatforms m.nplatforms = _TALLY m.g_fromplatform = availplatforms[1] m.pcount = 0 FOR i = 1 TO m.nplatforms && Get a list of available platforms excluding the current one. DO CASE CASE ATC('DOS',availplatforms[m.i]) > 0 AND !_DOS m.pcount = m.pcount + 1 DIMENSION platforms[m.pcount] platforms[m.pcount] = 'FoxPro for MS-DOS' CASE ATC('WINDOWS',availplatforms[m.i]) > 0 AND !_WINDOWS m.pcount = m.pcount + 1 DIMENSION platforms[m.pcount] platforms[m.pcount] = 'FoxPro for Windows' CASE ATC('UNIX',availplatforms[m.i]) > 0 AND !_UNIX m.pcount = m.pcount + 1 DIMENSION platforms[m.pcount] platforms[i] = 'FoxPro for Unix' CASE ATC('MAC',availplatforms[m.i]) > 0 AND !_MAC m.pcount = m.pcount + 1 DIMENSION platforms[m.pcount] platforms[i] = 'FoxPro for Macintosh' ENDCASE ENDFOR RELEASE availplatforms IF m.nplatforms = 0 OR m.pcount = 0 && There isn't anything to convert from. WAIT WINDOW "The transporter has nothing to do." NOWAIT DO cleanup RETURN c_cancel ENDIF ENDIF * Call the dialog routine appropriate to this file type. DO CASE && Ask the user what we should do. CASE m.g_filetype = c_screen RETURN scxfrxdialog("SCX") CASE m.g_filetype = c_report RETURN scxfrxdialog("FRX") CASE m.g_filetype = c_label RETURN scxfrxdialog("LBX") ENDCASE RETURN c_cancel * * setversion - set global variable m.g_toPlatform with the name of the platform * we are running on. * *!***************************************************************************** *! *! Procedure: SETVERSION *! *! Called by: TRANSPRT.PRG *! *! Calls: ERRORHANDLER (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE setversion DO CASE CASE _WINDOWS m.g_toplatform = "WINDOWS" m.g_tocodepage = c_wincp CASE _MAC m.g_toplatform = "MAC" m.g_tocodepage = c_maccp CASE _UNIX m.g_toplatform = "UNIX" m.g_tocodepage = c_unixcp CASE _DOS m.g_toplatform = "DOS" m.g_tocodepage = c_doscp OTHERWISE DO errorhandler WITH "Unknown Version of FoxPro.", LINENO(), c_error3 ENDCASE * * import - Do the import. * *!***************************************************************************** *! *! Procedure: IMPORT *! *! Called by: TRANSPRT.PRG *! *! Calls: EMPTYPLATFORM() (function in TRANSPRT.PRG) *! : GETCHARSUPPRESS() (function in TRANSPRT.PRG) *! : CHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : GRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *!***************************************************************************** PROCEDURE import IF m.g_fromplatform = m.g_toplatform RETURN ELSE * If we are converting everything, remove all records for the target * platform. IF m.g_allobjects AND !emptyplatform(m.g_toplatform) * We need to copy the records we want to a temporary file, clear our cursor * and copy the records back since you can't pack a cursor and SELECT creates * a read only cursor. m.g_tempalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) SELECT * FROM (m.g_scrnalias) ; WHERE !DELETED() AND platform <> m.g_toplatform ; INTO TABLE (m.g_tempalias) SELECT (m.g_scrnalias) ZAP APPEND FROM (m.g_tempalias) SELECT (m.g_tempalias) USE DELETE FILE (m.g_tempalias+".dbf") DELETE FILE (m.g_tempalias+".fpt") SELECT (m.g_scrnalias) ENDIF * Are we converting from graphics to a character * based screen? m.g_tographic = (m.g_toplatform = 'WINDOWS' OR m.g_toplatform = 'MAC') AND ; (m.g_fromplatform = 'DOS' OR m.g_fromplatform = 'UNIX') ENDIF IF g_filetype = c_report m.g_norepeat = getcharsuppress() ENDIF * Pass control to the control routine appropriate for the direction we are converting. DO CASE CASE m.g_tographic DO chartographic CASE !m.g_tographic DO graphictochar ENDCASE RETURN * * GraphicToChar - Converts everything, new objects or changed snippets from a grpahical * platform to a character platform. * *!***************************************************************************** *! *! Procedure: GRAPHICTOCHAR *! *! Called by: IMPORT (procedure in TRANSPRT.PRG) *! *! Calls: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : SELECTOBJ (procedure in TRANSPRT.PRG) *! : STARTTHERM (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! : UPDATESCREEN (procedure in TRANSPRT.PRG) *! : UPDATEREPORT (procedure in TRANSPRT.PRG) *! : NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE graphictochar IF m.g_allobjects * Start the thermometer with the appropriate message. DO starttherm WITH "Transporting",m.g_filetype DO allgraphictochar ELSE * Do a partial conversion, unless we're dealing with a label IF m.g_filetype = c_label && We only do complete label conversion RETURN ENDIF DO selectobj && figure out which ones to transport * Start the thermometer with the appropriate message. DO starttherm WITH "Transporting",m.g_filetype m.g_mercury = 5 DO updtherm WITH m.g_mercury DO putwinmsg WITH "Transporting " + LOWER(strippath(m.g_scrndbf)) SELECT (m.g_scrnalias) IF m.g_snippets IF m.g_filetype = c_screen DO updatescreen ELSE DO updatereport ENDIF ENDIF IF m.g_newobjects DO newgraphictochar ENDIF ENDIF * * CharToGraphic - Converts everything, new objects or changed snippets from a character * platform to a graphical platform. * *!***************************************************************************** *! *! Procedure: CHARTOGRAPHIC *! *! Called by: IMPORT (procedure in TRANSPRT.PRG) *! *! Calls: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : SELECTOBJ (procedure in TRANSPRT.PRG) *! : STARTTHERM (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! : UPDATESCREEN (procedure in TRANSPRT.PRG) *! : UPDATEREPORT (procedure in TRANSPRT.PRG) *! : NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE chartographic IF m.g_allobjects * Start the thermometer with the appropriate message. DO starttherm WITH "Transporting",m.g_filetype DO allchartographic ELSE IF m.g_filetype = c_label && We only do complete label convertsion RETURN ENDIF DO selectobj && figure out which ones to transport * Start the thermometer with the appropriate message. DO starttherm WITH "Transporting",m.g_filetype m.g_mercury = 5 DO updtherm WITH m.g_mercury DO putwinmsg WITH "Transporting " + LOWER(strippath(m.g_scrndbf)) SELECT (m.g_scrnalias) IF m.g_snippets IF m.g_filetype = c_screen DO updatescreen ELSE DO updatereport ENDIF ENDIF IF m.g_newobjects DO newchartographic ENDIF ENDIF * * UpdateScreen - Copy any non-platform specific * *!***************************************************************************** *! *! Procedure: UPDATESCREEN *! *! Called by: GRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : CHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: GETSNIPFLAG() (function in TRANSPRT.PRG) *! : ISOBJECT() (function in TRANSPRT.PRG) *! : MAPBUTTON() (function in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *! Indexes: ID (tag) *! *!***************************************************************************** PROCEDURE updatescreen PRIVATE m.thermstep COUNT TO m.thermstep FOR platform = m.g_toplatform IF m.g_newobjects m.thermstep = 40/m.thermstep ELSE m.thermstep = 80/m.thermstep ENDIF m.g_tempalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) SELECT * FROM (m.g_scrnalias) ; WHERE !DELETED() AND platform = m.g_fromplatform ; AND isselected(uniqueid,objtype,objcode) ; INTO CURSOR (m.g_tempalias) INDEX ON uniqueid TAG id SELECT (m.g_scrnalias) SET RELATION TO uniqueid INTO (m.g_tempalias) ADDITIVE LOCATE FOR .T. SELECT (m.g_scrnalias) * Check for flag to transport only code snippets sniponly = .F. LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() m.sniponly = getsnipflag(setupcode) ENDIF IF !m.sniponly DO updenviron WITH .T. ENDIF * Update everything else SCAN FOR platform = m.g_toplatform AND !DELETED() ; AND (isobject(objtype) OR objtype = c_otheader) IF &g_tempalias..timestamp > timestamp IF !m.sniponly REPLACE name WITH &g_tempalias..name REPLACE expr WITH &g_tempalias..expr REPLACE STYLE WITH &g_tempalias..style IF INLIST(objtype,c_otradbut,c_ottxtbut) * Don't zap the whole set of buttons if there are just some new ones REPLACE PICTURE WITH mapbutton(&g_tempalias..picture,PICTURE) ELSE REPLACE PICTURE WITH &g_tempalias..picture ENDIF IF objtype <> c_otheader OR !m.g_tographic OR EMPTY(order) * Icon file name is stored in Windows header, "order" field REPLACE ORDER WITH &g_tempalias..order ENDIF REPLACE UNIQUE WITH &g_tempalias..unique *REPLACE Environ WITH &g_tempalias..Environ REPLACE boxchar WITH &g_tempalias..boxchar REPLACE fillchar WITH &g_tempalias..fillchar REPLACE TAG WITH &g_tempalias..tag REPLACE tag2 WITH &g_tempalias..tag2 REPLACE ruler WITH &g_tempalias..ruler REPLACE rulerlines WITH &g_tempalias..rulerlines REPLACE grid WITH &g_tempalias..grid REPLACE gridv WITH &g_tempalias..gridv REPLACE gridh WITH &g_tempalias..gridh REPLACE FLOAT WITH &g_tempalias..float REPLACE CLOSE WITH &g_tempalias..close REPLACE MINIMIZE WITH &g_tempalias..minimize REPLACE BORDER WITH &g_tempalias..border REPLACE SHADOW WITH &g_tempalias..shadow REPLACE CENTER WITH &g_tempalias..center REPLACE REFRESH WITH &g_tempalias..refresh REPLACE disabled WITH &g_tempalias..disabled REPLACE scrollbar WITH &g_tempalias..scrollbar REPLACE addalias WITH &g_tempalias..addalias REPLACE TAB WITH &g_tempalias..tab REPLACE initialval WITH &g_tempalias..initialval REPLACE initialnum WITH &g_tempalias..initialnum REPLACE spacing WITH &g_tempalias..spacing * Update width if it looks like a text object got longer in Windows IF !m.g_tographic AND objtype = c_ottext REPLACE width WITH MAX(width,LEN(CHRTRAN(expr,'"'+chr(39),''))) ENDIF ENDIF IF objtype = c_otfield && watch out for SAYs changing to GETs REPLACE objcode WITH &g_tempalias..objcode ENDIF REPLACE lotype WITH &g_tempalias..lotype REPLACE rangelo WITH &g_tempalias..rangelo REPLACE hitype WITH &g_tempalias..hitype REPLACE rangehi WITH &g_tempalias..rangehi REPLACE whentype WITH &g_tempalias..whentype REPLACE WHEN WITH &g_tempalias..when REPLACE validtype WITH &g_tempalias..validtype REPLACE VALID WITH &g_tempalias..valid REPLACE errortype WITH &g_tempalias..errortype REPLACE ERROR WITH &g_tempalias..error REPLACE messtype WITH &g_tempalias..messtype REPLACE MESSAGE WITH &g_tempalias..message REPLACE showtype WITH &g_tempalias..showtype REPLACE SHOW WITH &g_tempalias..show REPLACE activtype WITH &g_tempalias..activtype REPLACE ACTIVATE WITH &g_tempalias..activate REPLACE deacttype WITH &g_tempalias..deacttype REPLACE DEACTIVATE WITH &g_tempalias..deactivate REPLACE proctype WITH &g_tempalias..proctype REPLACE proccode WITH &g_tempalias..proccode REPLACE setuptype WITH &g_tempalias..setuptype REPLACE setupcode WITH &g_tempalias..setupcode REPLACE timestamp WITH &g_tempalias..timestamp REPLACE platform WITH m.g_toplatform ENDIF m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN SELECT (m.g_tempalias) USE SELECT (m.g_scrnalias) RETURN * * UpdateReport - Copy any "non-platform specific" information from one platform to another * *!***************************************************************************** *! *! Procedure: UPDATEREPORT *! *! Called by: GRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : CHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: ADJRPTSUPPRESS (procedure in TRANSPRT.PRG) *! : ADJRPTFLOAT (procedure in TRANSPRT.PRG) *! : ADJRPTRESET (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *! Indexes: ID (tag) *! *!***************************************************************************** PROCEDURE updatereport PRIVATE m.thermstep COUNT TO m.thermstep FOR platform = m.g_toplatform IF m.g_newobjects m.thermstep = 40/m.thermstep ELSE m.thermstep = 80/m.thermstep ENDIF m.g_tempalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) SELECT * FROM (m.g_scrnalias) ; WHERE platform = m.g_fromplatform AND !DELETED(); AND isselected(uniqueid,objtype,objcode) ; INTO CURSOR (m.g_tempalias) INDEX ON uniqueid TAG id SELECT (m.g_scrnalias) SET RELATION TO uniqueid INTO (m.g_tempalias) ADDITIVE LOCATE FOR .T. SELECT (m.g_scrnalias) DO updenviron WITH .T. SCAN FOR platform = m.g_toplatform AND ; (objtype = c_otheader OR objtype = c_otfield OR objtype = c_otpicture OR ; objtype = c_otrepfld OR objtype = c_otband OR objtype = c_otrepvar OR ; objtype = c_ottext OR objtype = c_otline OR objtype = c_otbox) AND !DELETED() IF &g_tempalias..timestamp > timestamp REPLACE name WITH &g_tempalias..name IF objtype = c_otrepvar AND !m.g_tographic REPLACE name WITH UPPER(name) ENDIF REPLACE expr WITH &g_tempalias..expr REPLACE STYLE WITH &g_tempalias..style REPLACE PICTURE WITH &g_tempalias..picture REPLACE ORDER WITH &g_tempalias..order REPLACE UNIQUE WITH &g_tempalias..unique REPLACE ENVIRON WITH &g_tempalias..environ REPLACE boxchar WITH &g_tempalias..boxchar REPLACE fillchar WITH &g_tempalias..fillchar REPLACE TAG WITH &g_tempalias..tag REPLACE tag2 WITH &g_tempalias..tag2 REPLACE mode WITH &g_tempalias..mode REPLACE ruler WITH &g_tempalias..ruler REPLACE rulerlines WITH &g_tempalias..rulerlines REPLACE grid WITH &g_tempalias..grid REPLACE gridv WITH &g_tempalias..gridv REPLACE gridh WITH &g_tempalias..gridh REPLACE FLOAT WITH &g_tempalias..float REPLACE STRETCH WITH &g_tempalias..stretch REPLACE stretchtop WITH &g_tempalias..stretchtop REPLACE TOP WITH &g_tempalias..top REPLACE BOTTOM WITH &g_tempalias..bottom REPLACE suptype WITH &g_tempalias..suptype REPLACE suprest WITH &g_tempalias..suprest REPLACE norepeat WITH &g_tempalias..norepeat REPLACE resetrpt WITH &g_tempalias..resetrpt REPLACE pagebreak WITH &g_tempalias..pagebreak REPLACE colbreak WITH &g_tempalias..colbreak REPLACE resetpage WITH &g_tempalias..resetpage REPLACE GENERAL WITH &g_tempalias..general REPLACE spacing WITH &g_tempalias..spacing REPLACE DOUBLE WITH &g_tempalias..double REPLACE swapheader WITH &g_tempalias..swapheader REPLACE swapfooter WITH &g_tempalias..swapfooter REPLACE ejectbefor WITH &g_tempalias..ejectbefor REPLACE ejectafter WITH &g_tempalias..ejectafter REPLACE PLAIN WITH &g_tempalias..plain REPLACE SUMMARY WITH &g_tempalias..summary REPLACE addalias WITH &g_tempalias..addalias REPLACE offset WITH &g_tempalias..offset REPLACE topmargin WITH &g_tempalias..topmargin REPLACE botmargin WITH &g_tempalias..botmargin REPLACE totaltype WITH &g_tempalias..totaltype REPLACE resettotal WITH &g_tempalias..resettotal REPLACE resoid WITH &g_tempalias..resoid REPLACE curpos WITH &g_tempalias..curpos REPLACE supalways WITH &g_tempalias..supalways REPLACE supovflow WITH &g_tempalias..supovflow REPLACE suprpcol WITH &g_tempalias..suprpcol REPLACE supgroup WITH &g_tempalias..supgroup REPLACE supvalchng WITH &g_tempalias..supvalchng REPLACE supexpr WITH &g_tempalias..supexpr REPLACE timestamp WITH &g_tempalias..timestamp REPLACE platform WITH m.g_toplatform * Update width if it looks like a text object got longer in Windows IF !m.g_tographic AND objtype = c_ottext REPLACE width WITH MAX(width,LEN(CHRTRAN(expr,'"'+chr(39),''))) ENDIF DO adjrptsuppress DO adjrptfloat IF objtype = c_otrepvar OR (objtype = c_otrepfld AND totaltype > 0) DO adjrptreset ENDIF ENDIF m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN SELECT (m.g_tempalias) USE SELECT (m.g_scrnalias) RETURN *!***************************************************************************** *! *! Procedure: UPDENVIRON *! *!***************************************************************************** PROCEDURE updenviron PARAMETER m.mustexist * Update environment records if the user selected environment records for transport * and if any of them have been updated. IF EnvSelect() AND IsNewerEnv(m.mustexist) * Drop the old environment and put the new one in DELETE FOR IsEnviron(objtype) and platform = m.g_toplatform SCAN FOR platform = m.g_fromplatform AND IsEnviron(Objtype) SCATTER MEMVAR MEMO APPEND BLANK GATHER MEMVAR MEMO REPLACE platform WITH m.g_toplatform IF !g_tographic * DOS requires the alias name to be in upper case, while Windows doesn't REPLACE TAG WITH UPPER(TAG) REPLACE tag2 WITH UPPER(tag2) ENDIF ENDSCAN m.g_updenviron = .T. ENDIF * * CONVERTPROJECT - Convert project file from 2.0 to 2.5 format * *!***************************************************************************** *! *! Procedure: CONVERTPROJECT *! *! Called by: CONVERTER (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE convertproject PRIVATE m.i SELECT (m.g_scrnalias) ZAP SELECT (m.g_20alias) SCAN FOR !DELETED() SCATTER MEMVAR MEMO m.wasarranged = arranged RELEASE m.arranged && to avoid type mismatch at GATHER time SELECT (m.g_scrnalias) APPEND BLANK GATHER MEMVAR MEMO DO CASE CASE type == "H" IF !EMPTY(devinfo) * Adjust developer info to support wider state code REPLACE devinfo WITH STUFF(devinfo,162,0,CHR(0)+CHR(0)+CHR(0)) REPLACE devinfo WITH STUFF(devinfo,176,0,REPLICATE(CHR(0),46)) ENDIF CASE type == "s" && must be lowercase S * Adjust for the new method of storing cross-platform arrangement info * (ScrnRow = -999 for centered screens) REPLACE arranged WITH ; PADR("DOS",8); +IIF(m.wasarranged,"T","F"); +IIF(m.scrnrow=-999,"T","F"); +PADL(LTRIM(STR(m.scrnrow,4)),8) ; +PADL(LTRIM(STR(m.scrncol,4)),8) ; +PADR("WINDOWS",8); +IIF(m.wasarranged,"T","F"); +IIF(m.scrnrow=-999,"T","F"); +PADL(LTRIM(STR(m.scrnrow,4)),8) ; +PADL(LTRIM(STR(m.scrncol,4)),8) ENDCASE * Adjust the symbol table IF !EMPTY(symbols) FOR i = 1 TO INT((LEN(symbols)-4)/14) * Format of a 2.0 symbol table is * 4 bytes of header information * n occurrences of this structure: * TEXT symName[11] * TEXT symType * TEXT flags[2] * Format of a 2.5 symbol table is the same, except symName is now 13 bytes long REPLACE symbols WITH STUFF(symbols,(m.i-1)*16+15,0,CHR(0)+CHR(0)) REPLACE ckval WITH VAL(sys(2007,symbols)) ENDFOR ENDIF * Blank out the timestamp REPLACE timestamp WITH 0 ENDSCAN * * NewCharToGraphic - Take any new objects from the character platform and copy them * to the graphical platform. * *!***************************************************************************** *! *! Procedure: NEWCHARTOGRAPHIC *! *! Called by: CHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: GETWINDFONT (procedure in TRANSPRT.PRG) *! : NEWBANDS (procedure in TRANSPRT.PRG) *! : BANDINFO() (function in TRANSPRT.PRG) *! : ISOBJECT() (function in TRANSPRT.PRG) *! : PLATFORMDEFAULTS (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! : RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : FINDLIKEVPOS (procedure in TRANSPRT.PRG) *! : FINDLIKEHPOS (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *!***************************************************************************** PROCEDURE newchartographic PRIVATE m.thermstep, m.bandcount SELECT (m.g_scrnalias) SET ORDER TO * Get the default font for the window in the "to" platform IF m.g_tographic DO getwindfont ENDIF * Update the environment if it is new DO updenviron WITH .F. * Remember the window default font SELECT (m.g_scrnalias) LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() m.wfontface = fontface m.wfontsize = fontsize m.wfontstyle = fontstyle ELSE m.wfontface = m.g_fontface m.wfontsize = m.g_fontsize m.wfontstyle = m.g_fontstyle ENDIF m.g_tempalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) SELECT * FROM (m.g_scrnalias) ; WHERE !DELETED() AND platform = m.g_fromplatform AND ; isselected(uniqueid,objtype,objcode) AND ; uniqueid NOT IN (SELECT uniqueid FROM (m.g_scrnalias) ; WHERE platform = m.g_toplatform) ; INTO CURSOR (m.g_tempalias) IF m.g_snippets m.thermstep = 35/_TALLY ELSE m.thermstep = 70/_TALLY ENDIF IF m.g_filetype = c_report DO newbands * We need to know where bands start and where they end in * both platforms. SELECT (m.g_scrnalias) COUNT TO m.bandcount FOR platform = m.g_toplatform AND objtype = c_otband DIMENSION bands[m.bandCount,4] m.bandcount = bandinfo() SELECT (m.g_tempalias) ENDIF m.rightmost = 0 m.bottommost = 0 SCAN IF isobject(objtype) SCATTER MEMVAR MEMO SELECT (m.g_scrnalias) APPEND BLANK GATHER MEMVAR MEMO REPLACE platform WITH m.g_toplatform DO platformdefaults WITH 0 DO fillininfo DO CASE CASE INLIST(objtype,c_otbox, c_otline) DO adjbox WITH c_adjbox ENDCASE IF m.g_filetype = c_report DO rptobjconvert WITH m.bandcount ELSE REPLACE vpos WITH findlikevpos(vpos) REPLACE hpos WITH findlikehpos(hpos) m.rightmost = MAX(m.rightmost, hpos + width ; * FONTMETRIC(6,fontface,fontsize,whatstyle(fontstyle)) ; / FONTMETRIC(6,m.wfontface,m.wfontsize,whatstyle(m.wfontstyle))) m.bottommost = MAX(m.bottommost, vpos + height ; * FONTMETRIC(1,fontface,fontsize,whatstyle(fontstyle)) ; / FONTMETRIC(1,m.wfontface,m.wfontsize,whatstyle(m.wfontstyle))) ENDIF ENDIF SELECT (m.g_tempalias) m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN SELECT (m.g_tempalias) USE SELECT (m.g_scrnalias) * Update screen width/height if necessary to hold the new objects IF m.g_filetype = c_screen LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() * If the screen/report isn't big enough to hold the widest/tallest object, * resize it. IF width < m.rightmost REPLACE width WITH m.rightmost + IIF(m.g_filetype = c_screen,2,2000) ENDIF IF height < m.bottommost AND m.g_filetype = c_screen REPLACE height WITH m.bottommost + IIF(m.g_filetype = c_screen,1,2000) ENDIF ENDIF ENDIF RETURN * * NewGraphicToChar - Take any new objects from the graphic platform and copy them * to the character platform. * *!***************************************************************************** *! *! Procedure: NEWGRAPHICTOCHAR *! *! Called by: GRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Calls: NEWBANDS (procedure in TRANSPRT.PRG) *! : BANDINFO() (function in TRANSPRT.PRG) *! : ISOBJECT() (function in TRANSPRT.PRG) *! : PLATFORMDEFAULTS (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! : ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! : RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : FINDLIKEVPOS (procedure in TRANSPRT.PRG) *! : FINDLIKEHPOS (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! : MAKECHARFIT (procedure in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *!***************************************************************************** PROCEDURE newgraphictochar PRIVATE m.thermstep, m.bandcount SELECT (m.g_scrnalias) SET ORDER TO * Update the environment if it is new DO updenviron WITH .F. m.g_tempalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) * * Get a cursor containing the records in the "to" platform that do not have * counterparts in the "from" platform. Exclude Windows report column headers * and column footers (objtype = 9, objcode = 2 or 6) since they have no DOS analogs. * Exclude boxes that are filled black. They are probably used for shadow effects. * SELECT * FROM (m.g_scrnalias) ; WHERE !DELETED() AND platform = m.g_fromplatform AND ; !(objtype = c_otband AND INLIST(objcode,2,6)) AND ; isselected(uniqueid,objtype,objcode) AND ; !blackbox(objtype,fillred,fillblue,fillgreen,fillpat) AND ; uniqueid NOT IN (SELECT uniqueid FROM (m.g_scrnalias) ; WHERE platform = m.g_toplatform) ; INTO CURSOR (m.g_tempalias) IF m.g_snippets m.thermstep = 35/_TALLY ELSE m.thermstep = 70/_TALLY ENDIF IF m.g_filetype = c_report DO newbands * We need to know where bands start and where they end in * both platforms. SELECT (m.g_scrnalias) COUNT TO m.bandcount FOR platform = m.g_toplatform AND objtype = c_otband DIMENSION bands[m.bandCount,4] m.bandcount = bandinfo() SELECT (m.g_tempalias) ENDIF LOCATE FOR .T. DO WHILE !EOF() IF isobject(objtype) AND objtype <> c_otpicture SCATTER MEMVAR MEMO SELECT (m.g_scrnalias) APPEND BLANK GATHER MEMVAR MEMO REPLACE platform WITH m.g_toplatform DO platformdefaults WITH 0 DO fillininfo IF m.g_filetype = c_screen DO adjheightandwidth ELSE DO rptobjconvert WITH m.bandcount ENDIF REPLACE vpos WITH findlikevpos(vpos) REPLACE hpos WITH findlikehpos(hpos) ENDIF SELECT (m.g_tempalias) SKIP m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDDO SELECT (m.g_tempalias) USE SELECT (m.g_scrnalias) DO makecharfit RETURN * * NewBands - Add any new band records. * *!***************************************************************************** *! *! Procedure: NEWBANDS *! *! Called by: NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Calls: RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : BANDPOS() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE newbands PRIVATE m.prevband, m.bandstart, m.bandheight * We need to have the groups in order to do report objects, so we do them seperately. SCAN FOR objtype = c_otband SCATTER MEMVAR MEMO SELECT (m.g_scrnalias) LOCATE FOR platform = m.g_fromplatform AND uniqueid = m.uniqueid SKIP -1 m.prevband = uniqueid LOCATE FOR platform = m.g_toplatform AND uniqueid = m.prevband INSERT BLANK GATHER MEMVAR MEMO REPLACE platform WITH m.g_toplatform DO rptobjconvert WITH 0 m.bandheight = HEIGHT + IIF(m.g_tographic, c_bandheight+(c_bandfudge/c_pixelsize), 0) m.bandstart = bandpos(m.uniqueid, m.g_toplatform) * Move all the lower bands down by the size of the one we just inserted. REPLACE ALL vpos WITH vpos + m.bandheight ; FOR platform = m.g_toplatform AND ; (objtype = c_otline OR objtype = c_otbox OR ; objtype = c_ottext OR objtype = c_otrepfld) AND ; vpos >= m.bandstart SELECT (m.g_tempalias) ENDSCAN * * AllGraphicToChar - Convert from a graphic platform to a character platform assuming * that no records exist for the target platform. * *!***************************************************************************** *! *! Procedure: ALLGRAPHICTOCHAR *! *! Called by: GRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Calls: ALLENVIRONS (procedure in TRANSPRT.PRG) *! : ALLOTHERS (procedure in TRANSPRT.PRG) *! : ALLGROUPS (procedure in TRANSPRT.PRG) *! : RPTCONVERT (procedure in TRANSPRT.PRG) *! : MERGELABELOBJECTS (procedure in TRANSPRT.PRG) *! : LINESBETWEEN (procedure in TRANSPRT.PRG) *! : MAKECHARFIT (procedure in TRANSPRT.PRG) *! : SUPPRESSBLANKLINES (procedure in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *!***************************************************************************** PROCEDURE allgraphictochar PRIVATE m.objindex DO allenvirons * * Create a cursor with all the objects we have left to add. * m.g_fromobjonlyalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) SELECT *, RECNO() AS recnum FROM (m.g_scrnalias) ; WHERE !DELETED() AND platform = m.g_fromplatform AND ; objtype <> c_otrel AND objtype <> c_otworkar AND objtype <> c_otindex AND ; objtype <> c_otheader AND objtype <> c_otgroup AND ; objtype <> c_otpicture AND ; !blackbox(objtype,fillred,fillblue,fillgreen,fillpat) AND ; !(m.g_filetype = c_label AND objtype = c_ot20label) AND ; !(objtype = c_ot20lbxobj AND EMPTY(expr)) AND; oktransport(comment) ; INTO CURSOR (m.g_fromobjonlyalias) m.objindex = _TALLY DO allothers WITH 80 DO allgroups WITH 10 DO CASE CASE m.g_filetype = c_label ** Trim any records the character platforms won't deal with. DELETE FOR platform = m.g_toplatform AND ; ((objtype = c_otband AND objcode != 4) OR ; objtype = c_otrepvar OR objtype = c_otpicture OR ; objtype = c_otline OR objtype = c_otbox) DO rptconvert DO mergelabelobjects DO linesbetween CASE m.g_filetype = c_report ** Trim any records the character platforms won't deal with. DELETE FOR platform = m.g_toplatform AND (objtype = c_otpicture) DO rptconvert DO makecharfit DO suppressblanklines CASE m.g_filetype = c_screen DO makecharfit ENDCASE SELECT (m.g_fromobjonlyalias) USE SELECT (m.g_scrnalias) RETURN * * AllCharToGraphic - Convert from a character platform to a graphic platform assuming * that no records exist for the target platform. * *!***************************************************************************** *! *! Procedure: ALLCHARTOGRAPHIC *! *! Called by: CHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: ALLENVIRONS (procedure in TRANSPRT.PRG) *! : ALLOTHERS (procedure in TRANSPRT.PRG) *! : ALLGROUPS (procedure in TRANSPRT.PRG) *! : CALCWINDOWDIMENSION(procedure in TRANSPRT.PRG) *! : ADJITEMSINBOXES (procedure in TRANSPRT.PRG) *! : ADJINVBTNS (procedure in TRANSPRT.PRG) *! : JOINLINES (procedure in TRANSPRT.PRG) *! : RPTCONVERT (procedure in TRANSPRT.PRG) *! : SUPPRESSBLANKLINES (procedure in TRANSPRT.PRG) *! : ADDGRAPHICALLABELGR(procedure in TRANSPRT.PRG) *! : LABELBANDS (procedure in TRANSPRT.PRG) *! : LABELLINES (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! : WHATSTYLE() (function in TRANSPRT.PRG) *! : STRETCHLINESTOBORDE(procedure in TRANSPRT.PRG) *! *! Uses: M.G_SCRNALIAS *! *!***************************************************************************** PROCEDURE allchartographic PRIVATE m.objindex * Make equivalent screen/report records for the new platform. DO allenvirons m.g_fromobjonlyalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) SELECT *, RECNO() AS recnum FROM (m.g_scrnalias) ; WHERE !DELETED() AND platform = m.g_fromplatform AND objtype <> c_otrel AND ; objtype <> c_otworkar AND objtype <> c_otindex AND ; objtype <> c_otheader AND objtype <> c_otgroup AND ; !(m.g_filetype = c_label AND objtype = c_ot20label) AND ; !(objtype = c_ot20lbxobj AND EMPTY(expr)) AND; oktransport(comment) ; INTO CURSOR (m.g_fromobjonlyalias) m.objindex = _TALLY IF _TALLY = 0 SELECT (m.g_fromobjonlyalias) USE SELECT (m.g_scrnalias) RETURN ENDIF DIMENSION objectpos[m.objindex, 9] DO allothers WITH 25 DO allgroups WITH 5 * Attempt to adjust the position of objects to reflect the position * in the previous platform. DO CASE CASE m.g_filetype = c_screen DO calcwindowdimensions DO adjitemsinboxes DO adjinvbtns SET ORDER TO IF m.g_toplatform = "WINDOWS" OR m.g_toplatform = "MAC" DO joinlines ENDIF CASE m.g_filetype = c_report DO rptconvert DO joinlines DO suppressblanklines CASE m.g_filetype = c_label IF m.g_fromplatform = "DOS" OR m.g_fromplatform = "UNIX" DO addgraphicallabelgroups ENDIF DO labelbands DO labellines ENDCASE m.g_mercury = m.g_mercury + 5 DO updtherm WITH m.g_mercury IF m.g_filetype = c_screen IF m.g_allobjects LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader AND STYLE != 0 IF FOUND() IF m.g_windheight - g_lastobjectline[1] - 3 = 0 m.adjustment = .5 ELSE m.adjustment = m.g_windheight - g_lastobjectline[1] - 3 ENDIF IF m.adjustment < 0 m.adjustment = m.adjustment + 1.5 ENDIF IF m.adjustment > 0 REPLACE HEIGHT WITH g_lastobjectline[2] + ; m.adjustment * (FONTMETRIC(1) / ; FONTMETRIC(1,fontface, fontsize, whatstyle(fontstyle))) ELSE REPLACE HEIGHT WITH g_lastobjectline[2] + 1 ENDIF ENDIF DO stretchlinestoborders ENDIF ENDIF m.g_mercury = m.g_mercury + 5 DO updtherm WITH m.g_mercury SELECT (m.g_fromobjonlyalias) USE SELECT (m.g_scrnalias) * * cvrt102FRX - Converts a DOS 1.02 report to DOS 2.5 format * *!***************************************************************************** *! *! Function: CVRT102FRX *! *! Called by: TRANSPRT.PRG *! *! Calls: DOCREATE (procedure in TRANSPRT.PRG) *! : FORCEEXT() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION cvrt102frx * Converts FoxPro 1.02 DOS report to FoxPro 2.5 DOS report PARAMETER m.fname102, m.ftype PRIVATE m.bakname, m.in_area m.in_area = SELECT() SELECT 0 * Create a database structure matching the tab delimited format * of a 1.02 report file. CREATE CURSOR old ( ; objtype N(10,0), ; content N(10,0), ; fldcontent C(254), ; frmcontent C(254), ; vertpos N(10,0), ; horzpos N(10,0), ; HEIGHT N(10,0), ; WIDTH N(10,0), ; FONT N(10,0), ; fontsize N(10,0), ; STYLE N(10,0), ; penred N(10,0), ; pengreen N(10,0), ; penblue N(10,0), ; fillred N(10,0), ; fillgreen N(10,0), ; fillblue N(10,0), ; PICTURE C(254), ; rangeup N(10,0), ; rangelow N(10,0), ; VALID N(10,0), ; initc N(10,0), ; calcexp N(10,0) ; ) * Replace quote marks with \" so that APPEND won't strip them out. They are our only * way of distinguishing quoted text from, say, field names. m.fpin = fopen(m.fname102,2) && open for read access m.outname = forceext(m.fname102,"TMP") m.fpout = fcreate(m.outname) IF m.fpin > 0 AND m.fpout > 0 DO WHILE !FEOF(m.fpin) m.buf = fgets(m.fpin) m.buf = STRTRAN(m.buf,'"','\+') =fputs(m.fpout,m.buf) ENDDO =fclose(m.fpin) =fclose(m.fpout) APPEND FROM (m.outname) TYPE DELIMITED WITH TAB * Drop the temporary output file IF FILE(m.outname) DELETE FILE (m.outname) ENDIF * Replace quote markers with quotes in the character fields REPLACE ALL fldcontent WITH STRTRAN(fldcontent,'\+','"'), ; frmcontent WITH STRTRAN(frmcontent,'\+','"'), ; picture WITH STRTRAN(picture, '\+','"') ; FOR objtype = 17 * Strip quotes from other object types, such as quoted strings. REPLACE ALL fldcontent WITH STRTRAN(fldcontent,'\+',''), ; frmcontent WITH STRTRAN(frmcontent,'\+',''), ; picture WITH STRTRAN(picture, '\+','') ; FOR objtype <> 17 ELSE APPEND FROM (m.fname102) TYPE DELIMITED WITH TAB ENDIF * Create an empty 2.5 report file DO docreate WITH "new", c_report SELECT old SCAN DO CASE CASE objtype = 1 && report record SELECT new APPEND BLANK SELECT old REPLACE new.platform WITH "DOS" REPLACE new.objtype WITH 1 REPLACE new.objcode WITH c_25frx REPLACE new.topmargin WITH old.vertpos REPLACE new.botmargin WITH old.horzpos REPLACE new.height WITH old.height REPLACE new.width WITH old.width REPLACE new.offset WITH old.fontsize IF (old.initc > 0) REPLACE new.environ WITH .T. ENDIF IF (old.calcexp = 1 OR old.calcexp = 3) REPLACE new.ejectbefor WITH .T. ENDIF IF (old.calcexp = 2 OR old.calcexp = 3) REPLACE new.ejectafter WITH .T. ENDIF CASE objtype = 5 && text record SELECT new APPEND BLANK SELECT old REPLACE new.platform WITH "DOS" REPLACE new.objtype WITH 5 REPLACE new.vpos WITH old.vertpos REPLACE new.hpos WITH old.horzpos REPLACE new.height WITH 1 REPLACE new.width WITH old.width IF (old.rangelow > 0) REPLACE new.float WITH .T. ENDIF REPLACE new.expr WITH '"' + CPTRANS(m.g_tocodepage,m.g_fromcodepage,ALLTRIM(old.fldcontent)) + '"' CASE objtype = 7 && box record SELECT new APPEND BLANK SELECT old REPLACE new.platform WITH "DOS" REPLACE new.objtype WITH 7 REPLACE new.vpos WITH old.vertpos REPLACE new.hpos WITH old.horzpos REPLACE new.height WITH old.height REPLACE new.width WITH old.width REPLACE new.objcode WITH old.content + 4 IF (old.rangelow > 0) REPLACE new.float WITH .T. ENDIF IF (old.fontsize > 0) REPLACE new.boxchar WITH CHR(old.fontsize / 256) ENDIF CASE objtype = 17 && field record SELECT new APPEND BLANK SELECT old REPLACE new.platform WITH "DOS" REPLACE new.objtype WITH 8 REPLACE new.vpos WITH old.vertpos REPLACE new.hpos WITH old.horzpos REPLACE new.height WITH 1 REPLACE new.width WITH old.width REPLACE new.expr WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,TRIM(old.fldcontent)) IF !EMPTY(old.picture) REPLACE new.picture WITH '"' + CPTRANS(m.g_tocodepage,m.g_fromcodepage,ALLTRIM(old.picture)) + '"' ENDIF REPLACE new.totaltype WITH old.valid REPLACE new.resettotal WITH old.initc IF (old.rangeup > 0) REPLACE new.norepeat WITH .T. ENDIF IF (old.rangelow > 1) WRAP = MAX(old.rangelow - 3, 0) ELSE WRAP = old.rangelow ENDIF IF (WRAP > 0) REPLACE new.stretch WITH .T. ENDIF IF (old.rangelow = 3 OR old.rangelow = 4) REPLACE new.float WITH .T. ENDIF REPLACE new.fillchar WITH ALLTRIM(old.frmcontent) CASE objtype = 18 && band record SELECT new APPEND BLANK SELECT old REPLACE new.platform WITH "DOS" REPLACE new.objtype WITH 9 REPLACE new.objcode WITH old.content REPLACE new.expr WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,old.fldcontent) REPLACE new.height WITH old.height IF (old.vertpos > 0) REPLACE new.pagebreak WITH .T. ENDIF IF (old.fontsize > 0) REPLACE new.swapheader WITH .T. ENDIF IF (old.style > 0) REPLACE new.swapfooter WITH .T. ENDIF ENDCASE ENDSCAN * Discard the temporary cursor SELECT old USE IF m.ftype = c_frx102repo * Back up the original report and copy the new information to the original file name m.bakname = forceext(m.fname102,"TBK") RENAME (m.fname102) TO (m.bakname) ENDIF * Write the new information on top of the original 1.02 report SELECT new COPY TO (m.fname102) USE SELECT (m.in_area) RETURN m.fname102 *!***************************************************************************** *! *! Procedure: CVRTFBPRPT *! *! Called by: TRANSPRT.PRG *! *! Calls: ERRORHANDLER (procedure in TRANSPRT.PRG) *! : CVTSHORT() (function in TRANSPRT.PRG) *! : CVTBYTE() (function in TRANSPRT.PRG) *! : DOCREATE (procedure in TRANSPRT.PRG) *! : EVALIMPORTEXPR (procedure in TRANSPRT.PRG) *! : INITBANDS (procedure in TRANSPRT.PRG) *! : BLDBREAKS (procedure in TRANSPRT.PRG) *! : BLDDETAIL (procedure in TRANSPRT.PRG) *! : FORCEEXT() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE cvrtfbprpt * Convert a FoxBASE+ report to FoxPro 2.5 DOS format PARAMETER m.fnamefbp, m.ftype PRIVATE m.bakname, m.in_area, m.i, m.idbyte, m.objname, m.obj, m.rp_pool, ; m.rp_ltadr, m.rp_ltlen, m.rp_ssexno, m.rp_sbexno, m.rp_doublesp, ; m.rp_flds_width, m.rp_flds_exprno, m.rp_width, m.rp_flds_headno, ; m.rp_plain, m.band_rows, m.current_row, m.group_num, m.head_row m.in_area = SELECT() SELECT 0 m.objname = "" m.obj = 0 m.rp_pool = 0 m.rp_ltadr = 0 m.rp_ltlen = 0 m.rp_ssexno = 0 m.rp_sbexno = 0 m.rp_doublesp = 0 m.rp_flds_width = 0 m.rp_flds_exprno= 0 m.rp_width = 0 m.rp_flds_headno= 0 m.rp_plain = 0 m.band_rows = 0 m.current_row = 0 m.group_num = 0 m.head_row = 0 * Create a set of parallel arrays to contain the report information we need to bring * across to FoxPro 2.5 DOS. DIMENSION rp_ltlen(maxliterals) DIMENSION rp_ltadr(maxliterals) DIMENSION rp_flds_width(maxrepflds) DIMENSION rp_flds_type(maxrepflds) DIMENSION rp_flds_totals(maxrepflds) DIMENSION rp_flds_dp(maxrepflds) DIMENSION rp_flds_exprno(maxrepflds) DIMENSION rp_flds_headno(maxrepflds) DIMENSION band_rows(10) band_rows = 0 m.obj = FOPEN(m.g_scrndbf) IF (m.obj < 1) DO errorhandler WITH "Could not open FoxBASE+ report form",LINENO(),c_error3 ENDIF m.idbyte = cvtshort(FREAD(m.obj,2),0) poolsize = cvtshort(FREAD(m.obj,2),0) FOR i = 1 TO maxliterals rp_ltlen(i) = cvtshort(FREAD(m.obj,2),0) ENDFOR FOR i = 1 TO maxliterals rp_ltadr(i) = cvtshort(FREAD(m.obj,2),0) ENDFOR rp_pool = FREAD(m.obj,litpoolsize) FOR i = 1 TO maxrepflds rp_flds_width(i) = cvtshort(FREAD(m.obj,2),0) =FREAD(m.obj,2) rp_flds_type(i) = FREAD(m.obj,1) rp_flds_totals(i) = FREAD(m.obj,1) rp_flds_dp(i) = cvtshort(FREAD(m.obj,2),0) rp_flds_exprno(i) = cvtshort(FREAD(m.obj,2),0) rp_flds_headno(i) = cvtshort(FREAD(m.obj,2),0) ENDFOR rp_pghdno = cvtshort(FREAD(m.obj,2),0) rp_sbexno = cvtshort(FREAD(m.obj,2),0) rp_ssexno = cvtshort(FREAD(m.obj,2),0) rp_sbhdno = cvtshort(FREAD(m.obj,2),0) rp_sshdno = cvtshort(FREAD(m.obj,2),0) rp_width = cvtshort(FREAD(m.obj,2),0) rp_length = cvtshort(FREAD(m.obj,2),0) rp_lmarg = cvtshort(FREAD(m.obj,2),0) rp_rmarg = cvtshort(FREAD(m.obj,2),0) rp_fldcnt = cvtshort(FREAD(m.obj,2),0) rp_doublesp = FREAD(m.obj,1) rp_summary = FREAD(m.obj, 1) rp_subeject = FREAD(m.obj,1) rp_other = cvtbyte(FREAD(m.obj,1),0) rp_pageno = cvtshort(FREAD(m.obj,2),0) =FCLOSE(m.obj) IF (rp_pageno != 2) =FCLOSE(m.obj) ENDIF * Create an empty 2.5 report file DO docreate WITH "new", c_report * Fill it in DO evalimportexpr DO initbands DO bldbreaks IF rp_fldcnt > 0 DO blddetail ENDIF * Add the header data SELECT new GOTO TOP REPLACE objtype WITH 1, objcode WITH c_25frx IF m.ftype = c_fbprptrepo * Back up the original report and copy the new information to the original file name m.bakname = forceext(m.fnamefbp,"TBK") RENAME (m.fnamefbp) TO (m.bakname) ENDIF * Write the new information to a file with an FRX extension but the * same base name as the original FoxBASE+ report SELECT new COPY TO (m.fnamefbp) USE SELECT (m.in_area) RETURN m.fnamefbp *!******************************************************************** *! *! Convert FoxPro 1.0 label to 2.0 format *! *!******************************************************************** PROCEDURE cvrt102lbx PARAMETERS m.fname102, m.ftype PRIVATE m.i, m.short, m.contlen, m.obj, m.remarks, m.height, m.lmargin, m.width, ; m.numacross, m.spacesbet, m.linesbet, m.bakname, m.in_area m.in_area = SELECT() m.lblname = m.fname102 m.obj = FOPEN(m.lblname) =FREAD(m.obj,1) && Skip revision m.remarks = FREAD(m.obj,60) m.height = cvtshort(FREAD(m.obj,2),0) m.lmargin = cvtshort(FREAD(m.obj,2),0) m.width = cvtshort(FREAD(m.obj,2),0) m.numacross = cvtshort(FREAD(m.obj,2),0) m.spacesbet = cvtshort(FREAD(m.obj,2),0) m.linesbet = cvtshort(FREAD(m.obj,2),0) * Read in label contents -- each line ends in a CR m.contlen = cvtshort(FREAD(m.obj,2),0) m.work = FREAD(m.obj, m.contlen) =FCLOSE(m.obj) DIMENSION lbllines[m.height] m.start = 1 m.i = 1 FOR m.curlen = 1 TO m.contlen IF (SUBSTR(m.work, m.curlen, 1) = CHR(13)) lbllines[m.i] = SUBSTR(m.work, m.start, m.curlen-m.start) m.start = m.curlen+1 m.i = m.i + 1 ENDIF ENDFOR DO WHILE (m.i <= m.height) lbllines[m.i] = '' m.i = m.i + 1 ENDDO * Create an empty 2.0 label CREATE CURSOR new (objtype N(2), objcode N(2), ; name m, expr m, STYLE m, HEIGHT N(3), WIDTH N(3), lmargin N(3), ; numacross N(3), spacesbet N(3), linesbet N(3), ENVIRON l, ; ORDER m, UNIQUE l, TAG m, tag2 m, addalias l) * Add the header data SELECT new APPEND BLANK REPLACE new.objtype WITH 30 REPLACE new.name WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,m.remarks) REPLACE new.height WITH m.height REPLACE new.width WITH m.width REPLACE new.lmargin WITH m.lmargin REPLACE new.numacross WITH m.numacross REPLACE new.spacesbet WITH m.spacesbet REPLACE new.linesbet WITH m.linesbet * Add the label contents FOR m.i = 1 TO m.height APPEND BLANK REPLACE new.objtype WITH 19 REPLACE new.expr WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,lbllines[m.i]) ENDFOR IF m.ftype = c_lbx102repo * Back up the original label and copy the new information to the original file name m.bakname = forceext(m.fname102,"TBK") RENAME (m.fname102) TO (m.bakname) ENDIF * Write the new information on top of the original 1.02 label SELECT new COPY TO (m.fname102) USE SELECT (m.in_area) RETURN m.fname102 RETURN *!******************************************************************** *! *! Convert FoxBase+ label to 2.0 format *! *!******************************************************************** PROCEDURE cvrtfbplbl PARAMETERS m.fnamefbp, m.ftype PRIVATE m.width, m.height, m.lmargin, m.spacesbet, m.linesbet, m.numacross, m.obj, ; m.i, m.lblname, m.in_area, m.dummy m.in_area = SELECT() m.lblname = m.fnamefbp m.width = 0 m.height = 0 m.lmargin = 0 m.spacesbet = 0 m.linesbet = 0 m.numacross = 0 m.obj = FOPEN(m.lblname) =FREAD(m.obj,1) && Skip revision m.remarks = FREAD(m.obj,60) m.height = cvtshort(FREAD(m.obj,2),0) m.width = cvtshort(FREAD(m.obj,2),0) m.lmargin = cvtshort(FREAD(m.obj,2),0) m.linesbet = cvtshort(FREAD(m.obj,2),0) m.spacesbet = cvtshort(FREAD(m.obj,2),0) m.numacross = cvtshort(FREAD(m.obj,2),0) ******************************************************* * Read the label contents -- strip spaces and add a CR ******************************************************* DIMENSION lbllines[m.height] lbllines = '""' m.lastline = 0 FOR m.i = 1 TO m.height m.olen = 60 m.work = FREAD(m.obj,m.olen) DO WHILE ((m.olen > 0) AND (SUBSTR(m.work, m.olen, 1) = ' ')) m.olen = m.olen - 1 ENDDO =STUFF(m.work, m.olen, 1, '\n') lbllines[m.i] = SUBSTR(m.work, 1, m.olen+1) IF EMPTY(lbllines[m.i]) lbllines[m.i] = '""' ELSE m.lastline = m.i ENDIF ENDFOR =FCLOSE(m.obj) CREATE CURSOR new (objtype N(2), objcode N(2), ; name m, expr m, STYLE m, HEIGHT N(3), WIDTH N(3), lmargin N(3), ; numacross N(3), spacesbet N(3), linesbet N(3), ENVIRON l, ; ORDER m, UNIQUE l, TAG m, tag2 m, addalias l) * Add the header data SELECT new APPEND BLANK REPLACE new.objtype WITH 30 REPLACE new.name WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,m.remarks) REPLACE new.height WITH m.height REPLACE new.width WITH m.width REPLACE new.lmargin WITH m.lmargin REPLACE new.numacross WITH m.numacross REPLACE new.spacesbet WITH m.spacesbet REPLACE new.linesbet WITH m.linesbet FOR m.i = 1 TO m.lastline APPEND BLANK REPLACE new.objtype WITH 19 REPLACE new.expr WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,lbllines[m.i]) ENDFOR IF m.ftype = c_fbprptrepo * Back up the original report and copy the new information to the original file name m.bakname = forceext(m.fnamefbp,"TBK") RENAME (m.fnamefbp) TO (m.bakname) ENDIF * Write the new information to a file with an LBX extension but the * same base name as the original FoxBASE+ label. SELECT new COPY TO (m.fnamefbp) USE SELECT (m.in_area) RETURN m.fnamefbp *!***************************************************************************** *! *! Procedure: INITBANDS *! *! Called by: cvrtfbpRPT (procedure in TRANSPRT.PRG) *! *! Calls: GETLITEXPR() (function in TRANSPRT.PRG) *! : LINESFORHEADING() (function in TRANSPRT.PRG) *! : FLD_HEAD_EXIST() (function in TRANSPRT.PRG) *! : HOWMANYHEADINGS() (function in TRANSPRT.PRG) *! : MAKEBAND (procedure in TRANSPRT.PRG) *! : TOTALS_EXIST() (function in TRANSPRT.PRG) *! : MAKETEXT (procedure in TRANSPRT.PRG) *! : MAKEFIELD (procedure in TRANSPRT.PRG) *! : GETHEADING() (function in TRANSPRT.PRG) *! : CENTER_COL() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE initbands APPEND BLANK REPLACE new->platform WITH "DOS" REPLACE new->WIDTH WITH m.rp_width REPLACE new->HEIGHT WITH m.rp_length REPLACE new->offset WITH m.rp_lmarg REPLACE new->ejectbefor WITH .T. m.rp_plain = 0 m.group_num = 0 IF ("Y" = m.rp_summary) REPLACE new->SUMMARY WITH .T. ENDIF IF (INLIST(m.rp_other,1,3,5,7)) REPLACE new->ejectbefor WITH .F. ENDIF IF (INLIST(m.rp_other,3,6,7)) REPLACE new->ejectafter WITH .T. ENDIF IF (INLIST(m.rp_other,4,5,6,7)) REPLACE new->PLAIN WITH .T. m.rp_plain = 1 ENDIF m.rp_totals = 0 m.current_row = 0 * header band m.bandsize = 1 IF (m.rp_plain = 0) m.bandsize = m.bandsize + 2 ENDIF m.string = "" IF (getlitexpr(m.rp_pghdno, @m.string) <> 0) m.size = linesforheading(m.string) m.bandsize = m.bandsize + m.size ENDIF IF (fld_head_exist() = 1) m.size = howmanyheadings() m.bandsize = m.bandsize + m.size + 3 ELSE m.bandsize = m.bandsize + 3 ENDIF DO makeband WITH h_page, m.bandsize, "", .F. * group bands m.bandstring = "" IF (getlitexpr(m.rp_sbexno, @m.bandstring) <> 0) IF ("Y" = m.rp_subeject) m.newpage = .T. ELSE m.newpage = .F. ENDIF DO makeband WITH h_break, 2, m.bandstring, m.newpage m.rp_totals = m.rp_totals + 1 IF (getlitexpr(m.rp_ssexno, @m.bandstring) <> 0) DO makeband WITH h_break, 2, m.bandstring, .F. m.rp_totals = m.rp_totals + 1 ENDIF ENDIF group_num = rp_totals m.numlines = 1 IF ("Y" = m.rp_doublesp) m.numlines = 2 ENDIF * detail band DO makeband WITH l_item, m.numlines, "", .F. * break footer bands IF (totals_exist() = 1) m.bandsize = 2 ELSE m.bandsize = 1 ENDIF m.groupnum = m.rp_totals FOR i = 1 TO m.rp_totals DO makeband WITH f_break, m.bandsize, "", .F. ENDFOR * page footer band DO makeband WITH f_page, 1, "", .F. * report footer band DO makeband WITH f_rpt, m.bandsize, "", .F. IF (rp_plain = 0) DO maketext WITH 9, 1, "PAGE NO. ", band_rows(h_page)+1, 0 DO makefield WITH 5, 1, "_PAGENO", band_rows(h_page)+1, 9, "C", .F., .F., 0, 0 DO makefield WITH 8, 1, "DATE()", band_rows(h_page)+2, 0, "D", .F., .F., 0, 0 m.head_row = 3 ELSE m.head_row = 0 ENDIF IF (getlitexpr(m.rp_pghdno,@m.string) <> 0) m.string = m.string + ";" m.heading = "" DO WHILE .T. IF (getheading(@m.heading, @m.string) > 0) DO maketext WITH LEN(m.heading), 1, m.heading, m.head_row, center_col(LEN(m.heading)) m.head_row = m.head_row + 1 ELSE EXIT ENDIF ENDDO ENDIF m.head_row = m.head_row + 1 RETURN *!***************************************************************************** *! *! Procedure: BLDBREAKEXP *! *! Called by: BLDBREAKS (procedure in TRANSPRT.PRG) *! *! Calls: GETLITEXPR() (function in TRANSPRT.PRG) *! : MAKETEXT (procedure in TRANSPRT.PRG) *! : MAKEFIELD (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE bldbreakexp PARAMETER m.exprno, m.headno, m.row, m.stars PRIVATE m.string m.string = "" =getlitexpr(m.headno, @m.string) m.string = m.stars + m.string strlen = LEN(m.string) DO maketext WITH m.strlen, 1, m.string, m.row, 0 =getlitexpr(m.exprno, @m.string) DO makefield WITH rp_ltlen(m.exprno+1), 1, m.string, m.row, m.strlen + 1, "C", .F., .F., 0, 0 RETURN *!***************************************************************************** *! *! Procedure: BLDBREAKS *! *! Called by: cvrtfbpRPT (procedure in TRANSPRT.PRG) *! *! Calls: LITEXIST() (function in TRANSPRT.PRG) *! : BLDBREAKEXP (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE bldbreaks IF (litexist(rp_sbexno) = 1) DO bldbreakexp WITH rp_sbexno, rp_sbhdno, band_rows(h_break) + 1, "** " IF (litexist(rp_ssexno) = 1) DO bldbreakexp WITH rp_ssexno, rp_sshdno, band_rows(h_break) + 3, "*" ENDIF ENDIF RETURN *!***************************************************************************** *! *! Procedure: BLDDETAIL *! *! Called by: cvrtfbpRPT (procedure in TRANSPRT.PRG) *! *! Calls: GETLITEXPR() (function in TRANSPRT.PRG) *! : MAKEFIELD (procedure in TRANSPRT.PRG) *! : ADDTOTAL (procedure in TRANSPRT.PRG) *! : GETHEADING() (function in TRANSPRT.PRG) *! : MAKETEXT (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE blddetail PRIVATE m.i, m.pg_row, m.istotal, m.fcol, m.row, m.string, m.col, m.heading m.pg_row = 0 m.istotal = 0 m.fcol = 0 m.row = band_rows(l_item) m.string = "" FOR m.i = 1 TO rp_fldcnt IF (getlitexpr(rp_flds_exprno(m.i), @m.string) <> 0) m.row = band_rows(l_item) IF (m.fcol + rp_flds_width(m.i) > m.rp_width - 1) rp_flds_width(m.i) = rp_flds_width(m.i) - (m.fcol + rp_flds_width(m.i) - m.rp_width) IF (rp_flds_width(m.i) < 0) EXIT ENDIF ENDIF DO makefield WITH rp_flds_width(m.i), 1, m.string, m.row, m.fcol, rp_flds_type(m.i), .T., .T., 0, 0 IF ("Y" = rp_flds_totals(m.i)) DO makefield WITH rp_flds_width(m.i), 1, m.string, band_rows(f_rpt) + 1, m.fcol, "N", .F., .F., 2, 0 IF (m.group_num > 0) IF (m.group_num > 1) DO addtotal WITH m.istotal, band_rows(f_break), m.fcol, rp_flds_width(m.i), m.string, "* Subsubtotal *", 4 DO addtotal WITH m.istotal, band_rows(f_break) + 2, m.fcol, rp_flds_width(m.i), m.string, "** Subtotal **", 3 ELSE DO addtotal WITH m.istotal, band_rows(f_break), m.fcol, rp_flds_width(m.i), m.string, "** Subtotal **", 3 ENDIF ENDIF m.istotal = 1 ENDIF ENDIF IF (getlitexpr(rp_flds_headno(m.i), @m.string) <> 0) m.string = m.string + ";" m.heading = "" m.hrow = m.head_row DO WHILE .T. IF (getheading(@m.heading, @m.string) > 0) IF (rp_flds_type(m.i) = "N") m.col = (m.fcol + rp_flds_width(m.i)) - LEN(m.heading) ELSE m.col = m.fcol ENDIF DO maketext WITH LEN(m.heading), 1, m.heading, m.hrow, m.col m.hrow = m.hrow + 1 ELSE EXIT ENDIF ENDDO ENDIF m.fcol = m.fcol + rp_flds_width(m.i) + 1 ENDFOR IF (m.istotal = 1) DO maketext WITH 13, 1, "*** Total ***", band_rows(f_rpt), 0 ENDIF RETURN *!***************************************************************************** *! *! Procedure: ADDTOTAL *! *! Called by: BLDDETAIL (procedure in TRANSPRT.PRG) *! *! Calls: MAKETEXT (procedure in TRANSPRT.PRG) *! : MAKEFIELD (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE addtotal PARAMETER m.isfirst, m.row, m.col, m.wt, m.workstr, m.totalstr, m.reset IF (m.isfirst = 0) DO maketext WITH LEN(m.totalstr), 1, m.totalstr, m.row, 0 ENDIF DO makefield WITH m.wt, 1, m.workstr, m.row+1, m.col, "N", .F., .F., 2, m.reset RETURN *!***************************************************************************** *! *! Function: LITEXIST *! *! Called by: BLDBREAKS (procedure in TRANSPRT.PRG) *! : GETLITEXPR() (function in TRANSPRT.PRG) *! : FLD_HEAD_EXIST() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION litexist PARAMETER m.idx PRIVATE m.flag m.flag = 0 IF m.idx != 65535 IF "" <> SUBSTR(rp_pool, rp_ltadr(m.idx+1)+1, 1) m.flag = 1 ENDIF ENDIF RETURN m.flag *!***************************************************************************** *! *! Function: GETLITEXPR *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! : BLDBREAKEXP (procedure in TRANSPRT.PRG) *! : BLDDETAIL (procedure in TRANSPRT.PRG) *! : HOWMANYHEADINGS() (function in TRANSPRT.PRG) *! : EVALIMPORTEXPR (procedure in TRANSPRT.PRG) *! *! Calls: LITEXIST() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getlitexpr PARAMETER m.idx, m.string m.flag = 0 IF (litexist(m.idx) = 1) m.string = SUBSTR(m.rp_pool, rp_ltadr(m.idx+1)+1, rp_ltlen(m.idx+1) - 1) m.flag = 1 ELSE m.string = "" ENDIF RETURN m.flag *!***************************************************************************** *! *! Procedure: MAKEBAND *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE makeband PARAMETER m.type, m.size, m.string, m.newpage APPEND BLANK REPLACE new->platform WITH "DOS" REPLACE new->objtype WITH 9 REPLACE new->objcode WITH m.type REPLACE new->expr WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,m.string) REPLACE new->HEIGHT WITH m.size REPLACE new->pagebreak WITH m.newpage IF (band_rows(m.type) = 0) band_rows(m.type) = m.current_row ENDIF m.current_row = m.current_row + m.size RETURN *!***************************************************************************** *! *! Procedure: MAKETEXT *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! : BLDBREAKEXP (procedure in TRANSPRT.PRG) *! : BLDDETAIL (procedure in TRANSPRT.PRG) *! : ADDTOTAL (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE maketext PARAMETER wt, ht, string, ROW, COL IF m.wt > 0 APPEND BLANK REPLACE new->platform WITH "DOS" REPLACE new->expr WITH '"' + CPTRANS(m.g_tocodepage,m.g_fromcodepage,m.string) + '"' REPLACE new->objtype WITH 5 REPLACE new->HEIGHT WITH ht REPLACE new->WIDTH WITH wt REPLACE new->vpos WITH ROW REPLACE new->hpos WITH COL ENDIF RETURN *!***************************************************************************** *! *! Procedure: MAKEFIELD *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! : BLDBREAKEXP (procedure in TRANSPRT.PRG) *! : BLDDETAIL (procedure in TRANSPRT.PRG) *! : ADDTOTAL (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE makefield PARAMETER m.wt, m.ht, m.string, m.row, m.col, m.fldchar, m.strch, m.flt, m.total, m.reset APPEND BLANK REPLACE new->platform WITH "DOS" REPLACE new->objtype WITH 8 REPLACE new->expr WITH CPTRANS(m.g_tocodepage,m.g_fromcodepage,m.string) REPLACE new->HEIGHT WITH m.ht REPLACE new->WIDTH WITH m.wt REPLACE new->vpos WITH m.row REPLACE new->hpos WITH m.col REPLACE new->fillchar WITH m.fldchar REPLACE new->STRETCH WITH m.strch REPLACE new->FLOAT WITH m.flt REPLACE new->totaltype WITH m.total REPLACE new->resettotal WITH m.reset RETURN *!***************************************************************************** *! *! Function: GETHEADING *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! : BLDDETAIL (procedure in TRANSPRT.PRG) *! : LINESFORHEADING() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getheading PARAMETER m.heading, m.string PRIVATE m.flag, m.x, m.heading m.flag = 0 m.x = AT(';',m.string) m.heading = SUBSTR(m.string, 1, m.x-1) m.string = SUBSTR(m.string, m.x+1) IF (LEN(m.string) > 0) && more left m.flag = 1 ENDIF IF (LEN(m.heading) > 0) m.flag = 1 ENDIF RETURN m.flag *!***************************************************************************** *! *! Function: LINESFORHEADING *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! : HOWMANYHEADINGS() (function in TRANSPRT.PRG) *! *! Calls: GETHEADING() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION linesforheading PARAMETER m.string PRIVATE m.retval, m.string2, m.heading m.string2 = m.string + ";" m.heading = "" m.retval = 0 DO WHILE .T. IF (getheading(@m.heading, @m.string2) > 0) m.retval = m.retval + 1 ELSE EXIT ENDIF ENDDO RETURN m.retval *!***************************************************************************** *! *! Function: HOWMANYHEADINGS *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! *! Calls: GETLITEXPR() (function in TRANSPRT.PRG) *! : LINESFORHEADING() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION howmanyheadings PRIVATE m.retval, m.i, m.newval m.retval = 0 FOR m.i = 1 TO m.rp_fldcnt IF (getlitexpr(rp_flds_headno, @m.string) <> 0) m.newval = linesforheading(m.string) m.retval = MAX(m.newval, m.retval) ENDIF ENDFOR RETURN m.retval *!***************************************************************************** *! *! Function: FLD_HEAD_EXIST *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! *! Calls: LITEXIST() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION fld_head_exist PRIVATE m.flag, m.i m.flag = 0 FOR m.i = 1 TO m.rp_fldcnt IF (litexist(rp_flds_headno(m.i)) = 1) m.flag = 1 EXIT ENDIF ENDFOR RETURN m.flag *!***************************************************************************** *! *! Function: TOTALS_EXIST *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION totals_exist PRIVATE m.flag, m.i m.flag = 0 FOR m.i = 1 TO m.rp_fldcnt IF ("Y" = rp_flds_totals(m.i)) m.flag = 1 EXIT ENDIF ENDFOR RETURN m.flag *!***************************************************************************** *! *! Function: CENTER_COL *! *! Called by: INITBANDS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION center_col PARAMETER m.length RETURN (MAX(0, ((m.rp_width - m.rp_lmarg - m.rp_rmarg) - m.length)/2)) *!***************************************************************************** *! *! Procedure: EVALIMPORTEXPR *! *! Called by: cvrtfbpRPT (procedure in TRANSPRT.PRG) *! *! Calls: GETLITEXPR() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE evalimportexpr PRIVATE string m.string = "" FOR i = 1 TO rp_fldcnt IF (getlitexpr(rp_flds_exprno(i), @string) <> 0) rp_flds_type(i) = TYPE(m.string) IF ("U" = rp_flds_type(i)) rp_flds_type = "C" ENDIF ENDIF ENDFOR RETURN *!***************************************************************************** *! *! Function: GETOLDREPORTTYPE *! *! Called by: TRANSPRT.PRG *! *! Calls: CVTSHORT() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getoldreporttype * Open the main file and see what kind of file it is. At this point, all we know * is that it is either a FoxPro 1.02 report or a FoxBASE+ report. PRIVATE m.fp, m.reptotals, m.retcode m.retcode = m.tp_filetype m.fp = FOPEN(m.g_scrndbf) IF fp > 0 m.reptotals = cvtshort(FREAD(m.fp,2),0) DO CASE CASE (m.reptotals == 2) && FoxBASE+ report DO CASE CASE m.tp_filetype = c_frx102modi m.retcode= c_fbprptmodi CASE m.tp_filetype = c_frx102repo m.retcode = c_fbprptrepo OTHERWISE m.retcode = c_fbprptrepo ENDCASE OTHERWISE m.retcode = m.tp_filetype ENDCASE =FCLOSE(m.fp) ENDIF RETURN m.retcode *!***************************************************************************** *! *! Function: GETOLDLABELTYPE *! *! Called by: TRANSPRT.PRG *! *! Calls: CVTSHORT() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getoldlabeltype * Open the main file and see what kind of file it is. At this point, all we know * is that it is either a FoxPro 1.02 report or a FoxBASE+ label. PRIVATE m.fp, m.reptotals, m.retcode m.retcode = m.tp_filetype m.fp = FOPEN(m.g_scrndbf) IF fp > 0 m.reptotals = cvtbyte(FREAD(m.fp,1),0) m.dummy = FREAD(m.fp,1) && skip this one DO CASE CASE (m.reptotals == 2) && FoxBASE+ label DO CASE CASE m.tp_filetype = c_lbx102modi m.retcode= c_fbplblmodi CASE m.tp_filetype = c_lbx102repo m.retcode = c_fbplblrepo OTHERWISE m.retcode = c_fbplblrepo ENDCASE OTHERWISE m.retcode = m.tp_filetype ENDCASE =FCLOSE(m.fp) ENDIF RETURN m.retcode * * MAPBUTTON - Compare two sets of buttons * *!***************************************************************************** *! *! Function: MAPBUTTON *! *! Called by: UPDATESCREEN (procedure in TRANSPRT.PRG) *! *! Calls: SCATTERBUTTONS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION mapbutton PARAMETER frombtn, tobtn PRIVATE m.endpos, m.outstrg, m.topos, m.i. m.pictclau m.pictclau = LEFT(m.tobtn,AT(' ',m.tobtn)-1) DO CASE CASE !m.g_tographic * Strip out the BMP extensions, if present m.frombtn = STRTRAN(m.frombtn,".BMP","") m.frombtn = STRTRAN(m.frombtn,".bmp","") CASE ".BMP" $ UPPER(m.tobtn) * Add back in the bitmap extensions, if the to platform already has some. The * strategy is to mark all existing bitmap extensions, then add one to each of the * atoms in the picture clause. DO CASE CASE RIGHT(m.tobtn,1) = '"' OR RIGHT(m.tobtn,1) = "'" m.tobtn = STUFF(m.tobtn,LEN(m.tobtn),0,';') OTHERWISE m.tobtn = m.tobtn + ';' ENDCASE * 'brlfq' is just a marker for where a semicolon needs to go. Mark all the existing * BMP extensions. m.tobtn = STRTRAN(m.tobtn,".BMP;",".BMPbrlfq") m.tobtn = STRTRAN(m.tobtn,".bmp;",".BMPbrlfq") * Add a new BMP extension where there wasn't one before. m.tobtn = STRTRAN(m.tobtn,";",".BMPbrlfq") * Put the semicolons back m.tobtn = STRTRAN(m.tobtn,"brlfq",";") * Remove trailing semicolons DO WHILE RIGHT(m.tobtn,2) = ';"' OR RIGHT(m.tobtn,2) = ";'" m.tobtn = STUFF(m.tobtn,LEN(m.tobtn)-1,1,"") ENDDO * Now make sure there is a 'B' in the picture clause IF !("B" $ m.pictclau) AND ("@" $ m.pictclau) m.tobtn = STUFF(m.tobtn,AT("@",m.tobtn)+2,0,"B") m.pictclau = m.pictclau + "B" ENDIF ENDCASE DO CASE CASE m.frombtn == m.tobtn RETURN m.frombtn CASE OCCURS(';',m.frombtn) = OCCURS(';',m.tobtn) IF m.g_tographic AND ("B" $ m.pictclau) * Return the newly modified "to" string in this case. RETURN m.tobtn ELSE RETURN m.frombtn ENDIF CASE OCCURS(';',m.frombtn) > OCCURS(';',m.tobtn) * Are these bitmap buttons? IF ("B" $ m.pictclau) * Just add a blank one to the end m.endpos = RAT('"',m.tobtn) IF endpos > 1 RETURN STUFF(m.tobtn,m.endpos,0,';NEW.BMP') ELSE RETURN m.tobtn + ';' ENDIF ELSE * Not bitmaps. RETURN m.frombtn ENDIF OTHERWISE RETURN m.frombtn * An alternative strategy is to try to preserve as many as possible of the * destination buttons, especially since they might contain bitmaps, etc. * Populate two arrays with the button prompts. Then scan through the * 'from' array seeing if we can match it up against something in the 'to' * array. If so, emit the 'to' array picture. Otherwise, emit the 'from' * one. DIMENSION fromarray[1], toarray[1] DO scatterbuttons WITH m.frombtn, fromarray DO scatterbuttons WITH m.tobtn, toarray outstrg = "" FOR m.i = 1 TO ALEN(fromarray) m.topos = ASCAN(toarray,fromarray[i]) IF m.topos > 0 m.outstrg = m.outstrg + IIF(EMPTY(m.outstrg),'',';') + toarray[m.topos] ELSE m.outstrg = m.outstrg + IIF(EMPTY(m.outstrg),'',';') + fromarray[m.i] ENDIF ENDFOR m.outstrg = LEFT(m.frombtn,AT(' ',m.frombtn)) + m.outstrg + '"' RETURN m.outstrg ENDCASE *!***************************************************************************** *! *! Procedure: SCATTERBUTTONS *! *! Called by: MAPBUTTON() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE scatterbuttons PARAMETERS btnlist, destarray PRIVATE m.i, m.fromstrg, m.num, m.theword m.fromstrg = SUBSTR(m.btnlist,AT(' ',m.btnlist)+1) m.fromstrg = CHRTRAN(m.fromstrg,CHR(34)+CHR(39),"") m.num = OCCURS(';',m.fromstrg) DIMENSION destarray[m.num+1] FOR m.i = 1 TO m.num + 1 DO CASE CASE m.i = 1 && first button m.theword = LEFT(m.fromstrg,AT(';',m.fromstrg)-1) CASE m.i = m.num + 1 && last button m.theword = SUBSTR(m.fromstrg,AT(';',m.fromstrg,m.num)+1) OTHERWISE m.theword = SUBSTR(m.fromstrg,AT(';',m.fromstrg,m.i-1)+1, ; AT(';',m.fromstrg,m.i) - AT(';',m.fromstrg,m.i-1)) ENDCASE destarray[m.i] = UPPER(ALLTRIM(m.theword)) ENDFOR * * FindLikeVpos - Tries to find an object in the from platform with a vpos that matches the vpos * of a new object we are adding. If it finds one, we return that objects Vpos in the to * platform. This gives us a reasonable chance of coming close to where the user will want * an object that is being added to a pre-converted screen. * *!***************************************************************************** *! *! Procedure: FINDLIKEVPOS *! *! Called by: NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Calls: ISOBJECT() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE findlikevpos PARAMETER m.oldvpos PRIVATE m.objid, m.saverec, m.retval m.saverec = RECNO() m.retval = m.oldvpos LOCATE FOR platform = m.g_fromplatform AND vpos = m.oldvpos AND isobject(objtype) IF FOUND() m.objid = uniqueid LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() m.retval = vpos ENDIF ENDIF GOTO RECORD (m.saverec) RETURN m.retval * * FindLikeHpos - Tries to find an object in the from platform with an hpos that matches the hpos * of a new object we are adding. If it finds one, we return that objects Hpos in the to * platform. This gives us a reasonable chance of coming close to where the user will want * an object that is being added to a pre-converted screen. * *!***************************************************************************** *! *! Procedure: FINDLIKEHPOS *! *! Called by: NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Calls: ISOBJECT() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE findlikehpos PARAMETER m.oldhpos PRIVATE m.objid, m.saverec, m.retval m.saverec = RECNO() m.retval = m.oldhpos LOCATE FOR platform = m.g_fromplatform AND hpos = m.oldhpos AND isobject(objtype) IF FOUND() m.objid = uniqueid LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() m.retval = hpos ENDIF ENDIF GOTO RECORD (m.saverec) RETURN m.retval * * MakeCharFit - Makes sure that a report or screen is large enough to hold all of its objects. * *!***************************************************************************** *! *! Procedure: MAKECHARFIT *! *! Called by: NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Calls: GETRIGHTMOST (procedure in TRANSPRT.PRG) *! : GETLOWEST (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE makecharfit PRIVATE m.right, m.bottom m.right = CEILING(getrightmost(m.g_toplatform))+2 m.bottom = CEILING(getlowest(m.g_toplatform))+2 LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() IF WIDTH < m.right REPLACE WIDTH WITH m.right ENDIF IF HEIGHT < m.bottom AND m.g_filetype = c_screen REPLACE HEIGHT WITH m.bottom ENDIF ENDIF * * allenvirons - Process all the screen and environment records first. * *!***************************************************************************** *! *! Procedure: ALLENVIRONS *! *! Called by: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: ADJCOLOR (procedure in TRANSPRT.PRG) *! : ADJOBJCODE (procedure in TRANSPRT.PRG) *! : ADJFONT (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE allenvirons PRIVATE m.recno SCAN FOR platform = m.g_fromplatform AND !DELETED() AND ; (objtype = c_otheader OR objtype = c_otrel OR objtype = c_otworkar OR objtype = c_otindex OR ; (m.g_filetype = c_label AND objtype = c_ot20label)) m.recno = RECNO() SCATTER MEMVAR MEMO APPEND BLANK GATHER MEMVAR MEMO REPLACE platform WITH m.g_toplatform IF IsEnviron(objtype) AND !g_tographic * DOS requires the alias name to be in upper case, while Windows doesn't REPLACE TAG WITH UPPER(TAG) REPLACE tag2 WITH UPPER(tag2) ENDIF IF objtype = c_otheader OR (m.g_filetype = c_label AND objtype = c_ot20label) m.g_windheight = HEIGHT m.g_windwidth = WIDTH DO CASE CASE m.g_filetype = c_screen DO adjcolor CASE m.g_filetype = c_report IF m.g_toplatform = "WINDOWS" OR m.g_toplatform = "MAC" REPLACE vpos WITH 1 REPLACE WIDTH WITH -1.0 REPLACE ruler WITH 1 REPLACE rulerlines WITH 1 REPLACE gridv WITH 9 REPLACE gridh WITH 9 REPLACE penred WITH 60 REPLACE pengreen WITH 80 REPLACE penblue WITH 0 ELSE REPLACE HEIGHT WITH c_charrptheight REPLACE WIDTH WITH c_charrptwidth ENDIF CASE m.g_filetype = c_label IF m.g_toplatform = "WINDOWS" OR m.g_toplatform = "MAC" REPLACE objtype WITH c_otheader REPLACE ruler WITH 1 REPLACE rulerlines WITH 1 REPLACE grid WITH .T. REPLACE gridv WITH 12 REPLACE gridh WITH 12 REPLACE penred WITH -1 REPLACE pengreen WITH 65535 REPLACE stretchtop WITH .F. REPLACE TOP WITH .F. REPLACE BOTTOM WITH .T. REPLACE curpos WITH .F. ELSE REPLACE objtype WITH c_ot20label *REPLACE vpos WITH (vpos * c_charsperinch)/10000 REPLACE hpos WITH (hpos * c_charsperinch)/10000 REPLACE HEIGHT WITH (HEIGHT * c_linesperinch)/10000 REPLACE WIDTH WITH (WIDTH * c_charsperinch)/10000 IF WIDTH < 0 REPLACE WIDTH WITH c_charrptwidth ENDIF ENDIF ENDCASE DO adjobjcode DO adjfont ENDIF GOTO RECORD m.recno ENDSCAN m.g_mercury = m.g_mercury + 5 DO updtherm WITH m.g_mercury * * allothers - Process all other records. * *!***************************************************************************** *! *! Procedure: ALLOTHERS *! *! Called by: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: CALCPOSITIONS (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE allothers PARAMETER m.thermpart PRIVATE m.recno, m.numothers, m.thermstep, m.i m.thermstep = m.thermpart / m.objindex SELECT (m.g_fromobjonlyalias) SET RELATION TO recnum INTO m.g_scrnalias ADDITIVE LOCATE FOR .T. m.i = 1 SCAN FOR !DELETED() m.recno = RECNO() SCATTER MEMVAR MEMO IF m.g_tographic DO calcpositions WITH m.i m.i = m.i + 1 ENDIF SELECT (m.g_scrnalias) APPEND BLANK GATHER MEMVAR MEMO REPLACE platform WITH m.g_toplatform DO fillininfo SELECT (m.g_fromobjonlyalias) GOTO RECORD m.recno m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN * * FillInInfo - Fill in information for the fields in SCX/FRX database. * *!***************************************************************************** *! *! Procedure: FILLININFO *! *! Called by: NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : ALLOTHERS (procedure in TRANSPRT.PRG) *! *! Calls: ADJRPTSUPPRESS (procedure in TRANSPRT.PRG) *! : ADJRPTFLOAT (procedure in TRANSPRT.PRG) *! : ADJRPTRESET (procedure in TRANSPRT.PRG) *! : OBJ2BASEFONT() (function in TRANSPRT.PRG) *! : WHATSTYLE() (function in TRANSPRT.PRG) *! : ADJPEN (procedure in TRANSPRT.PRG) *! : ADJCOLOR (procedure in TRANSPRT.PRG) *! : ADJFONT (procedure in TRANSPRT.PRG) *! : ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE fillininfo IF m.g_filetype = c_report DO adjrptsuppress DO adjrptfloat ENDIF DO CASE CASE m.g_tographic DO CASE CASE objtype = c_otpopup * Popups are a special case since the arrow control counts against the width * under Windows. REPLACE WIDTH WITH WIDTH + 2 CASE INLIST(objtype,c_otrepvar,c_otrepfld) DO adjrptreset IF fillchar = "N" REPLACE offset WITH 1 && Change alignment for numerics. ENDIF ENDCASE CASE !m.g_tographic DO CASE CASE objtype = c_ottext REPLACE HEIGHT WITH MAX(height,1), width WITH MAX(width,1) CASE objtype = c_otspinner * Map spinners to regular fields REPLACE objtype WITH c_otfield, ; HEIGHT WITH 1, ; fillchar WITH "N" CASE objtype = c_otline * Map Windows lines to DOS boxes REPLACE objtype WITH c_otbox REPLACE HEIGHT WITH MAX(HEIGHT,1), WIDTH WITH MAX(WIDTH,1) IF pensize >= 6 REPLACE boxchar WITH "█" ENDIF CASE INLIST(objtype,c_otradbut,c_ottxtbut) * Remove the BMP extension from bitmap buttons REPLACE PICTURE WITH STRTRAN(PICTURE,".BMP","") REPLACE PICTURE WITH STRTRAN(PICTURE,".bmp","") CASE objtype = c_otfield AND ; (objcode = 2 OR (INLIST(objcode,0,1) AND WIDTH > 25)) * Adjust widths of edit fields and very long GET/SAY fields to account * for font differences between the object and the base font. REPLACE WIDTH WITH MAX(obj2basefont(WIDTH,g_fontface,g_fontsize,g_fontstyle,; fontface,fontsize,whatstyle(fontstyle)),1) CASE objtype = c_otbox AND (objcode = 4) IF pensize >= 6 REPLACE boxchar WITH "█" ENDIF CASE INLIST(objtype,c_otrepvar,c_otrepfld) DO adjrptreset IF objtype = c_otrepvar * DOS report variable names have to be in upper case REPLACE name WITH UPPER(name) ENDIF ENDCASE ENDCASE IF objtype <> c_otbox AND objtype <> c_otline DO adjpen ENDIF DO adjcolor DO adjfont IF m.g_filetype = c_screen DO adjheightandwidth ENDIF * * adjrptfloat - Convert float/stretch/relative postion types between * character and graphical positions * *!***************************************************************************** *! *! Procedure: ADJRPTFLOAT *! *! Called by: UPDATEREPORT (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjrptfloat IF m.g_tographic DO CASE CASE FLOAT AND (objtype = c_otbox AND HEIGHT > 1) * Box or a vertical line--float as band stretches translates to Top--stretch w/ band. * Use the height > 1 test because DOS boxes haven't been translated into Windows * lines yet. REPLACE stretchtop WITH .T. REPLACE TOP WITH .F. REPLACE BOTTOM WITH .F. CASE FLOAT AND STRETCH REPLACE stretchtop WITH .T. REPLACE TOP WITH .F. REPLACE BOTTOM WITH .F. CASE FLOAT REPLACE BOTTOM WITH .T. REPLACE TOP WITH .F. REPLACE stretchtop WITH .F. ENDCASE ELSE DO CASE CASE objtype = c_otrepfld AND (stretchtop OR STRETCH) REPLACE FLOAT WITH .T. REPLACE STRETCH WITH .T. CASE BOTTOM REPLACE FLOAT WITH .T. REPLACE STRETCH WITH .F. CASE TOP REPLACE FLOAT WITH .F. REPLACE STRETCH WITH .F. CASE stretchtop OR STRETCH REPLACE FLOAT WITH .T. REPLACE STRETCH WITH .F. ENDCASE ENDIF * * adjrptSuppress - Convert Suppression types between 2.5 platforms. * *!***************************************************************************** *! *! Procedure: ADJRPTSUPPRESS *! *! Called by: UPDATEREPORT (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjrptsuppress * Handle suppression of repeated values. * * In DOS 2.0, the value of the detail record "norepeat" determines whether repeated values * are suppressed, if this is a field object, or whether group headings are repeated, * if this is a group header. The main screen header record "norepeat" field determines * whether blank lines are suppressed in the detail band. * * In 2.5, the norepeat field is used just for suppression of blank lines. * We are positioned on a detail record now. * IF m.g_tographic IF objtype = c_otband * The meaning for DOS is reversed from Windows REPLACE norepeat WITH !norepeat ELSE IF norepeat && suppress repeated values REPLACE supvalchng WITH .T. REPLACE supovflow WITH .F. DO CASE CASE resetrpt = 0 REPLACE suprpcol WITH 0 REPLACE supgroup WITH 0 CASE resetrpt = 1 REPLACE suprpcol WITH 3 REPLACE supgroup WITH 0 OTHERWISE REPLACE suprpcol WITH 0 REPLACE supgroup WITH resetrpt+3 ENDCASE ELSE && no suppression of repeated values REPLACE supalways WITH .T. REPLACE supvalchng WITH .F. REPLACE supovflow WITH .F. REPLACE suprpcol WITH 3 REPLACE supgroup WITH 0 ENDIF ENDIF ELSE IF supvalchng AND !supalways REPLACE norepeat WITH .T. IF supgroup > 0 REPLACE resetrpt WITH supgroup - 3 ELSE IF suprpcol = 3 REPLACE resetrpt WITH 1 ELSE REPLACE resetrpt WITH 0 ENDIF ENDIF ELSE REPLACE norepeat WITH .F. ENDIF ENDIF * * adjrptreset - Convert the reset values between 2.0 and 2.5. * *!***************************************************************************** *! *! Procedure: ADJRPTRESET *! *! Called by: UPDATEREPORT (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjrptreset IF m.g_tographic DO CASE CASE resettotal = 0 REPLACE resettotal WITH 1 CASE resettotal = 1 REPLACE resettotal WITH 2 OTHERWISE REPLACE resettotal WITH resettotal+3 ENDCASE ELSE DO CASE CASE resettotal = 1 REPLACE resettotal WITH 0 CASE resettotal = 2 OR resettotal = 3 REPLACE resettotal WITH 1 OTHERWISE REPLACE resettotal WITH resettotal-3 ENDCASE ENDIF * * GetCharSuppress - Gets the global setting of blank line Suppression for a report. (This is * only valid for character mode reports). * *!***************************************************************************** *! *! Function: GETCHARSUPPRESS *! *! Called by: IMPORT (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getcharsuppress LOCATE FOR platform = m.g_fromplatform AND objtype = c_otheader IF FOUND() RETURN norepeat ELSE RETURN .F. ENDIF * * SuppressBlankLines - Looks through the from platform to see if any * object is marked to Suppress blank lines. If one is, we * make the entire "to" report (which is assumed to be character) * Suppress blank lines. * *!***************************************************************************** *! *! Procedure: SUPPRESSBLANKLINES *! *! Called by: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: GETBANDCODE() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE suppressblanklines PRIVATE m.supcount DO CASE CASE m.g_toplatform = "DOS" OR m.g_toplatform = "UNIX" COUNT TO m.supcount FOR platform = m.g_fromplatform AND objtype = c_otrepfld IF m.supcount > 0 LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() REPLACE norepeat WITH .T. ENDIF ENDIF CASE m.g_toplatform = "WINDOWS" OR m.g_toplatform = "MAC" * DOS suppression of blank lines only applies to detail lines. Only mark graphical * objects in the detail band as suppressed. SCAN FOR platform = m.g_toplatform AND objtype <> c_otband AND objtype <> c_otheader myexpr = expr IF objtype = 8 WAIT CLEAR ENDIF bcode = getbandcode(vpos) IF bcode = 4 && detail band REPLACE norepeat WITH m.g_norepeat ELSE REPLACE norepeat WITH .F. ENDIF ENDSCAN ENDCASE * * allGroups - Process all Group records. * *!***************************************************************************** *! *! Procedure: ALLGROUPS *! *! Called by: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: UPDTHERM (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE allgroups PARAMETER m.thermpart PRIVATE m.recno, m.numothers, m.thermstep m.thermstep = m.thermpart / m.objindex SELECT (m.g_scrnalias) SCAN FOR platform = m.g_fromplatform AND objtype = c_otgroup m.recno = RECNO() SCATTER MEMVAR MEMO APPEND BLANK GATHER MEMVAR MEMO REPLACE platform WITH m.g_toplatform GOTO RECORD m.recno m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN * * RptConvert - Converts entire reports between platforms. * *!***************************************************************************** *! *! Procedure: RPTCONVERT *! *! Called by: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: ISREPTOBJECT() (function in TRANSPRT.PRG) *! : RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! : BANDINFO() (function in TRANSPRT.PRG) *! : CLONEBAND (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE rptconvert PRIVATE m.thermstep COUNT TO m.thermstep FOR platform = m.g_toplatform AND ; (isreptobject(objtype) OR objtype = c_otband) IF m.g_toplatform = "DOS" OR m.g_toplatform = "UNIX" m.thermstep = 25 / m.thermstep ELSE m.thermstep = 50 / m.thermstep ENDIF * We need to do bands before any other object. SCAN FOR platform = m.g_toplatform AND objtype = c_otband DO rptobjconvert WITH 0 m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN * We need to know where bands start and where they end in * both platforms. COUNT TO m.bandcount FOR platform = m.g_toplatform AND objtype = c_otband GOTO TOP DIMENSION bands[m.bandCount,4] m.bandcount = bandinfo() * Make sure that the band headers and footers match on Windows IF m.g_tographic DO cloneband ENDIF SCAN FOR platform = m.g_toplatform AND ; (objtype = c_otrepfld OR objtype = c_ottext OR ; objtype = c_otbox OR objtype = c_otline) DO rptobjconvert WITH m.bandcount m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN * * RptObjConvert - Converts the size and postion of a given record in a report/label * *!***************************************************************************** *! *! Procedure: RPTOBJCONVERT *! *! Called by: NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : NEWBANDS (procedure in TRANSPRT.PRG) *! : RPTCONVERT (procedure in TRANSPRT.PRG) *! *! Calls: EMPTYBAND() (function in TRANSPRT.PRG) *! : CVTREPORTVERTICAL()(function in TRANSPRT.PRG) *! : ADJBOX (procedure in TRANSPRT.PRG) *! : ADJCOLOR (procedure in TRANSPRT.PRG) *! : ADJFONT (procedure in TRANSPRT.PRG) *! : GETBANDINDEX (procedure in TRANSPRT.PRG) *! : CVTREPORTHORIZONTAL(function in TRANSPRT.PRG) *! : CVTRPTLINES() (function in TRANSPRT.PRG) *! : ADJTEXT (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE rptobjconvert PARAMETER m.bandcount PRIVATE m.bandindex, m.endindex, m.posinband, m.saverec, m.objid, m.origvpos, m.lineheight IF objtype = c_otband * Map height and width of band to proper values IF m.g_tographic AND emptyband(uniqueid) REPLACE HEIGHT WITH 0 ELSE m.lineheight = cvtreportvertical(HEIGHT) IF !m.g_tographic AND BETWEEN(m.lineheight,1.00,1.10) AND objcode = 4 * This is a heuristic rule to make quick reports and other reports with * a single-line detail band transport to DOS correctly. Sometimes the bands * will be just a little larger than one line in Windows. REPLACE HEIGHT WITH 1 ELSE REPLACE HEIGHT WITH CEILING(m.lineheight) ENDIF ENDIF IF m.g_tographic * Map DOS offset field to Windows "if lines less than". These fields control * when the data grouping decides to start a new page. This data is stored in "width". REPLACE WIDTH WITH 10000 * offset / c_linesperinch ELSE REPLACE HEIGHT WITH MAX(1, HEIGHT) REPLACE offset WITH ROUND(WIDTH/10000, 0) * c_linesperinch ENDIF ELSE * Converting a regular object such as a field or line. m.origvpos = vpos m.origheight = HEIGHT IF (m.g_toplatform = "WINDOWS" OR m.g_toplatform = "MAC") AND objtype = c_otbox DO adjbox WITH 0 DO adjcolor DO adjfont ENDIF * Find which band in the "from" platform this object came from * Use a vpos expressed in "from" units for this function. m.bandindex = getbandindex(m.origvpos, m.bandcount) * Since keeping objects in the proper bands is our highest * priority, we calculate the new Vpos by determining how many * lines into its band an object lies and adding this * value (converted) to that band's Vpos in the from platform. m.posinband = MAX(cvtreportvertical((vpos - bands[m.bandIndex, c_fmbandvpos])),0) REPLACE vpos WITH bands[m.bandIndex, c_tobandvpos] + m.posinband * Since vertical lines and boxes can stretch across bands, we need to * watch their ending positions. IF (objtype = c_otbox AND cvtreportvertical(HEIGHT) > 1) ; OR (objtype = c_otline AND WIDTH < HEIGHT) m.endindex = getbandindex(IIF(m.g_tographic,m.origvpos+m.origheight-1,; m.origvpos + m.origheight), m.bandcount) IF m.endindex <> m.bandindex *m.endinband = IIF(m.g_tographic, m.origvpos+m.origheight-.25, m.origvpos+m.origheight) ; * - bands[m.endIndex, c_fmbandvpos] m.endinband = m.origvpos+m.origheight - bands[m.endIndex, c_fmbandvpos] IF m.g_tographic * Allow for the fact that box characters in DOS appear in the middle of * the line, but always stick out into the "end" band a little bit. m.endinband = MAX(m.endinband - 0.5,0.25) ENDIF m.endinband = cvtreportvertical(m.endinband) REPLACE HEIGHT WITH bands[m.endIndex, c_tobandvpos] + m.endinband - vpos ELSE REPLACE HEIGHT WITH cvtreportvertical(HEIGHT) ENDIF ELSE REPLACE HEIGHT WITH cvtreportvertical(HEIGHT) ENDIF REPLACE hpos WITH cvtreporthorizontal(hpos) REPLACE WIDTH WITH cvtreporthorizontal(WIDTH) IF m.g_toplatform = "WINDOWS" OR m.g_toplatform = "MAC" IF objtype = c_otline AND WIDTH > HEIGHT * Handle horizontal lines separately. They are very sensitive to line * height. REPLACE HEIGHT WITH cvtrptlines(HEIGHT) ENDIF ELSE IF objtype = c_otbox AND ROUND(HEIGHT,0) <> 1 DO adjbox WITH 0 ENDIF REPLACE vpos WITH ROUND(vpos,0) REPLACE hpos WITH ROUND(hpos,0) REPLACE HEIGHT WITH ROUND(HEIGHT,0) REPLACE WIDTH WITH ROUND(WIDTH,0) * Make sure that this object will not extend past the end of the last * band, which leads to "invalid report" errors on DOS. IF m.bandindex = m.bandcount AND ; (vpos + HEIGHT ; > bands[m.bandIndex,c_tobandvpos] ; + bands[m.bandIndex,c_tobandheight]) * Can we move the object up so that it fits? IF HEIGHT <= bands[m.bandIndex, c_tobandheight] * It will fit if we scootch it up a little. REPLACE vpos WITH vpos -; (bands[m.bandIndex,c_tobandheight] - HEIGHT) ELSE * No room for it at all. Crop the height. Make as much fit as possible. REPLACE vpos WITH bands[m.bandIndex,c_tobandvpos] REPLACE HEIGHT WITH bands[m.bandIndex,c_tobandheight] ENDIF ENDIF DO CASE CASE objtype = c_ottext REPLACE HEIGHT WITH 1 DO adjtext WITH WIDTH REPLACE WIDTH WITH LEN(expr)-2 CASE objtype = c_otrepfld AND HEIGHT < 1 REPLACE HEIGHT WITH 1 ENDCASE IF ROUND(hpos,0) = -1 REPLACE hpos WITH 0 ENDIF ENDIF * Guarantee that we are in the right band. IF vpos > bands[m.bandIndex,c_tobandvpos] ; + bands[m.bandIndex,c_tobandheight] - 1 REPLACE vpos WITH bands[m.bandIndex,c_tobandvpos] ; + bands[m.bandIndex,c_tobandheight] - 1 ENDIF IF vpos < 0 REPLACE vpos WITH 0 ENDIF ENDIF IF HEIGHT <= 0 REPLACE HEIGHT WITH 1 ENDIF RETURN * * GetBandIndex - Given a Vpos (from platform), this function returns the * index in the Band array of the band which this Vpos lies in. * *!***************************************************************************** *! *! Procedure: GETBANDINDEX *! *! Called by: RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE getbandindex PARAMETER m.vpos, m.bandcount PRIVATE m.loop FOR m.loop = 1 TO m.bandcount IF m.vpos >= bands[m.loop,c_fmbandvpos] ; AND m.vpos < bands[m.loop,c_fmbandvpos]+bands[m.loop,c_fmbandheight] RETURN m.loop ENDIF ENDFOR RETURN m.bandcount && drop them into the bottom band as a default * * BandInfo - Fills a predefined array named Band as follows. * bands[1] = Start Position in To platform. * bands[2] = Height in To platform. * bands[3] = Start Position in From platform. * bands[4] = Height in From platform. * *!***************************************************************************** *! *! Function: BANDINFO *! *! Called by: NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : RPTCONVERT (procedure in TRANSPRT.PRG) *! *! Calls: RESIZEBAND (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION bandinfo PRIVATE m.saverec, m.bandcount, m.loop, ; m.pagefooter, m.pageheader, m.colheader, m.colfooter, ; m.toposition, m.fromposition, m.objcode, m.expr m.toposition = 0 m.fromposition = 0 m.bandcount = 0 m.colheader = 0 m.colfooter = 0 m.pageheader = 0 m.pagefooter = 0 SCAN FOR platform = m.g_toplatform AND objtype = c_otband m.bandcount = m.bandcount + 1 DO CASE CASE objcode = 1 m.pageheader = m.bandcount CASE objcode = 2 m.colheader = m.bandcount CASE objcode = 6 m.colfooter = m.bandcount CASE objcode = 7 m.pagefooter = m.bandcount ENDCASE * The To fields are already converted at this point bands[m.bandCount,c_tobandvpos] = m.toposition IF m.g_tographic bands[m.bandCount,c_tobandheight] ; = HEIGHT + c_bandheight + (c_bandfudge/c_pixelsize) ELSE bands[m.bandCount,c_tobandheight] = HEIGHT ENDIF m.objcode = objcode m.expr = expr m.saverec = RECNO() IF !EMPTY(expr) LOCATE FOR platform = m.g_fromplatform AND ; objtype = c_otband AND objcode = m.objcode AND expr = m.expr ELSE * The expression is empty, which means this is probably a group footer. There could * be many of them, all empty. We have to find the right one. GOTO TOP * Figure out which occurrence this one is. COUNT TO m.seq FOR platform = m.g_toplatform AND ; objtype = c_otband AND objcode = m.objcode AND EMPTY(expr) ; AND RECNO() <= m.saverec GOTO TOP * Now find the corresponding band in the "from" platform LOCATE FOR platform = m.g_fromplatform AND ; objtype = c_otband AND objcode = m.objcode AND EMPTY(expr) m.i = 1 DO WHILE FOUND() AND m.i < m.seq m.i = m.i + 1 CONTINUE ENDDO ENDIF IF FOUND() bands[m.bandCount,c_fmbandvpos] = m.fromposition IF m.g_tographic && so coming from DOS bands[m.bandCount,c_fmbandheight] = HEIGHT ELSE bands[m.bandCount,c_fmbandheight] = HEIGHT + c_bandheight ENDIF m.fromposition = m.fromposition + bands[m.bandCount,c_fmbandheight] IF !g_tographic * Resize 'to' band if necessary to account for boxes that narrowly * surround text on a graphic platform. Sometimes the box can be * tightly against the text such that the graphical band appears to * be only two rows high. We need three rows to display the box in * a character platform bands[m.bandCount,c_tobandheight] = ; resizeband(bands[m.bandCount,c_tobandheight], ; bands[m.bandCount,c_fmbandvpos ], ; bands[m.bandCount,c_fmbandheight]) ENDIF ELSE bands[m.bandCount,c_fmbandvpos] = 9999999 bands[m.bandCount,c_fmbandheight] = 9999999 ENDIF m.toposition = m.toposition + bands[m.bandCount,c_tobandheight] GOTO RECORD (m.saverec) IF !g_tographic * Stuff the newly recomputed height into the DOS record REPLACE HEIGHT WITH bands[m.bandCount,c_tobandheight] ENDIF ENDSCAN * We don't want to have any column headers/footers in the character * products so we need to combine them with the page headers/footers. IF m.colfooter > 0 AND m.pagefooter > 0 bands[m.pageFooter,c_tobandvpos] = bands[m.colFooter,c_tobandvpos] bands[m.pageFooter,c_tobandheight]; = bands[m.pageFooter,c_tobandheight] ; + bands[m.colFooter,c_tobandheight] bands[m.pageFooter,c_fmbandvpos] = bands[m.colFooter,c_fmbandvpos] bands[m.pageFooter,c_fmbandheight] ; = bands[m.pageFooter,c_fmbandheight] ; + bands[m.colFooter,c_fmbandheight] LOCATE FOR platform = m.g_toplatform ; AND objtype = c_otband AND objcode = 6 IF FOUND() DELETE ENDIF LOCATE FOR platform = m.g_toplatform ; AND objtype = c_otband AND objcode = 7 IF FOUND() REPLACE HEIGHT WITH HEIGHT + bands[m.colFooter,c_tobandheight] ENDIF =ADEL(bands,m.colfooter) m.bandcount = m.bandcount - 1 ENDIF IF m.colheader > 0 AND m.pageheader > 0 bands[m.pageHeader,c_tobandheight]; = bands[m.pageHeader,c_tobandheight] ; + bands[m.colHeader,c_tobandheight] bands[m.pageHeader,c_fmbandheight] ; = bands[m.pageHeader,c_fmbandheight] ; + bands[m.colHeader,c_fmbandheight] LOCATE FOR platform = m.g_toplatform AND objtype = c_otband AND objcode = 2 IF FOUND() DELETE ENDIF LOCATE FOR platform = m.g_toplatform AND objtype = c_otband AND objcode = 1 IF FOUND() REPLACE HEIGHT WITH HEIGHT + bands[m.colHeader,c_tobandheight] ENDIF =ADEL(bands,m.colheader) m.bandcount = m.bandcount - 1 ENDIF RETURN m.bandcount *!***************************************************************************** *! *! Procedure: CLONEBAND *! *! Called by: RPTCONVERT (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE cloneband * Copy the band header record data into the respective footer bands. Data in band header * and footer records must match on Windows. The main data that needs to match is the * group expression and things like how many spaces to require after a heading * before doing a page break. PRIVATE m.in_area, m.in_rec, m.pivot, m.ouniqid, m.ovpos, m.ohpos, m.owidth, m.oheight,; m.oobjcode, m.headband IF m.g_tographic m.in_area = SELECT() m.in_rec = RECNO() * First find the detail band. It acts as a pivot. GOTO TOP LOCATE FOR platform = m.g_toplatform ; AND objtype = c_otband ; AND objcode = 4 && detail band has code = 4 IF !FOUND() * Return and make the best of it RETURN ENDIF m.pivot = RECNO() * Scan for each of the header bands SCAN FOR platform = m.g_toplatform ; AND objtype = c_otband ; AND objcode < 4 AND objcode > 0 SCATTER MEMVAR MEMO m.headband = RECNO() * Go to the matching footer band record GOTO (m.pivot + (m.pivot - RECNO())) * Store the values we don't want to copy from the header m.ouniqid = uniqueid m.ovpos = vpos m.ohpos = hpos m.oheight = HEIGHT m.oobjcode = objcode * Stuff header data into this footer band GATHER MEMVAR MEMO * Restore the data we didn't want to copy from the header REPLACE vpos WITH m.ovpos, hpos WITH m.ohpos, ; HEIGHT WITH m.oheight, objcode WITH m.oobjcode, ; uniqueid WITH m.ouniqid GOTO (m.headband) ENDSCAN SELECT (m.in_area) GOTO (MIN(m.in_rec,RECCOUNT())) ENDIF RETURN * * RESIZEBAND - Resize the character mode report band to accommodate * boxes, etc. * *!***************************************************************************** *! *! Procedure: RESIZEBAND *! *! Called by: BANDINFO() (function in TRANSPRT.PRG) *! *! Calls: CVTREPORTVERTICAL()(function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE resizeband PARAMETER tobandheight, fmbandvpos, fmbandheight PRIVATE in_rec, minbandheight m.in_rec = RECNO() m.minbandheight = m.tobandheight IF !g_tographic * Search for boxes that lie entirely within this band. SCAN FOR platform = m.g_fromplatform ; AND objtype = c_otbox AND vpos >= m.fmbandvpos ; AND vpos + HEIGHT <= m.fmbandvpos + m.fmbandheight * The box needs to be expanded m.minbandheight = MAX(m.minbandheight,cvtreportvertical(HEIGHT)+1) * If there is a box in the band, always make it at least three rows m.minbandheight = MAX(m.minbandheight,3) ENDSCAN ENDIF GOTO RECORD (m.in_rec) RETURN CEILING(m.minbandheight) * * BandHeight - Given a band ID and platform, this function reurns the band's * starting position in that platform. * *!***************************************************************************** *! *! Function: BANDPOS *! *! Called by: NEWBANDS (procedure in TRANSPRT.PRG) *! : EMPTYBAND() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION bandpos PARAMETER m.objid, m.platform PRIVATE m.saverec, m.bandstart m.saverec = RECNO() m.bandstart = 0 SCAN FOR platform = m.platform AND objtype = c_otband IF uniqueid <> m.objid IF m.platform = "DOS" OR m.platform = "UNIX" m.bandstart = m.bandstart + HEIGHT ELSE m.bandstart = m.bandstart + HEIGHT + c_bandheight + (c_bandfudge/c_pixelsize) ENDIF ELSE LOCATE FOR .F. ENDIF ENDSCAN GOTO RECORD (m.saverec) RETURN m.bandstart * * EmptyBand - Given a band ID, this funtion determines if the band is empty. * *!***************************************************************************** *! *! Function: EMPTYBAND *! *! Called by: RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! *! Calls: BANDPOS() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION emptyband PARAMETER m.id PRIVATE m.saverec, m.bandstart, m.bandheight, m.retval IF m.g_toplatform = "DOS" OR m.g_toplatform = "UNIX" RETURN .F. ENDIF m.saverec = RECNO() m.retval = .F. LOCATE FOR platform = m.g_fromplatform AND uniqueid = m.id IF FOUND() m.bandheight = HEIGHT m.bandstart = bandpos(m.id, m.g_fromplatform) * Look for objects in this band LOCATE FOR platform = m.g_fromplatform AND ; (objtype = c_otline OR objtype = c_otbox OR ; objtype = c_ottext OR objtype = c_otrepfld) AND ; vpos >= m.bandstart AND vpos < m.bandstart + m.bandheight IF !FOUND() AND m.g_tographic * Look for a DOS box or line that ends in the band GOTO TOP LOCATE FOR platform = m.g_fromplatform AND ; INLIST(objtype,c_otbox, c_otline) AND ; vpos + HEIGHT - 1 >= m.bandstart AND vpos + HEIGHT - 1 < m.bandstart + m.bandheight ENDIF m.retval = !FOUND() ENDIF GOTO RECORD (m.saverec) RETURN m.retval * * GETBANDCODE - returns band objcode given a vpos * *!***************************************************************************** *! *! Function: GETBANDCODE *! *! Called by: SUPPRESSBLANKLINES (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getbandcode PARAMETER m.thisvpos PRIVATE m.in_num, m.retcode retcode = -1 m.in_num = RECNO() m.startvpos = 0 IF INLIST(objtype,c_otheader, c_otband, c_otrel, c_otworkar, c_otindex) RETURN -1 ENDIF SET FILTER TO platform = m.g_toplatform AND (objtype = c_otband) GOTO TOP DO WHILE m.startvpos <= m.thisvpos AND !EOF() IF m.startvpos + HEIGHT +c_bandheight > m.thisvpos retcode = objcode EXIT ELSE m.startvpos = m.startvpos + HEIGHT + c_bandheight SKIP ENDIF ENDDO SET FILTER TO GOTO m.in_num RETURN retcode * * CvtReportVertical - Convert report vertical dimensions between 10000ths of an inch and characters * depending on the to platform. (This function is for vertical dimensions only). * *!***************************************************************************** *! *! Function: CVTREPORTVERTICAL *! *! Called by: RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : RESIZEBAND (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION cvtreportvertical PARAMETER m.units DO CASE CASE !m.g_tographic RETURN m.units/10000 * c_linesperinch CASE g_tographic RETURN (m.units * m.g_rptlinesize) + (5000/c_pixelsize) OTHERWISE RETURN m.units ENDCASE * * CvtReportWidth - Convert report horizontal dimensions between 10000ths of an inch * and chanracters depending on the to platform. * *!***************************************************************************** *! *! Function: CVTREPORTHORIZONTAL *! *! Called by: RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION cvtreporthorizontal PARAMETER m.units DO CASE CASE !m.g_tographic RETURN m.units/10000 * c_charsperinch CASE m.g_tographic RETURN m.units * m.g_rptcharsize OTHERWISE RETURN m.units ENDCASE *!***************************************************************************** *! *! Function: CVTRPTLINES *! *! Called by: RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION cvtrptlines * Adjust the height of horizontal lines PARAMETER m.height DO CASE CASE g_tographic DO CASE CASE BETWEEN(m.height,0,200) RETURN 104 CASE BETWEEN(m.height,200,600) RETURN 520 CASE BETWEEN(m.height,600,850) RETURN 850 OTHERWISE RETURN m.height ENDCASE OTHERWISE RETURN m.height ENDCASE * * MergeLabelObjects - Combines report objects which lie on the same line * when going from a graphical platform to a character platform. * *!***************************************************************************** *! *! Procedure: MERGELABELOBJECTS *! *! Called by: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *! Calls: LABELOBJMERGE (procedure in TRANSPRT.PRG) *! *! Indexes: TEMP (tag) *! *!***************************************************************************** PROCEDURE mergelabelobjects INDEX ON platform+STR(vpos,3)+STR(hpos,3) TAG temp SCAN FOR platform = m.g_toplatform AND !DELETED() AND ; (objtype = c_otrepfld OR objtype = c_ottext OR objtype = c_otbox OR objtype = c_otline) DO labelobjmerge WITH RECNO() ENDSCAN DELETE TAG temp RETURN * * LabelObjMerge - Given a record which is a report object, this function tries to find a label * object on the same line and combine them. If no label object exists on the line, the * record is turned into one. * *!***************************************************************************** *! *! Procedure: LABELOBJMERGE *! *! Called by: MERGELABELOBJECTS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE labelobjmerge PARAMETER m.recno PRIVATE m.saverec, m.vpos, m.hpos, m.width, m.height, m.expr, m.type, m.picture m.saverec = RECNO() GOTO RECORD (m.recno) m.vpos = vpos m.width = WIDTH m.expr = expr m.type = fillchar m.picture = PICTURE DELETE LOCATE FOR platform = m.g_toplatform AND !DELETED() AND ; objtype = c_ot20lbxobj AND vpos = m.vpos IF FOUND() REPLACE expr WITH expr + "," + m.expr ELSE GOTO RECORD (m.recno) RECALL REPLACE objtype WITH c_ot20lbxobj ENDIF GOTO RECORD (m.saverec) * * AddLabelBlanks - Adds sufficient blank lines to make the converted lines * *!***************************************************************************** *! *! Procedure: ADDLABELBLANKS *! *! Uses: M.G_SCRNALIAS *! *!***************************************************************************** PROCEDURE addlabelblanks PRIVATE m.linecount, m.last, m.scanloop SELECT vpos FROM m.g_scrnalias ; WHERE !DELETED() AND platform = m.g_toplatform AND objtype = c_ot20lbxobj ; ORDER BY vpos ; INTO ARRAY lines m.linecount = _TALLY m.last = 0 FOR m.scanloop = 1 TO lines[m.linecount] IF ASCAN(lines, m.scanloop) = 0 APPEND BLANK REPLACE platform WITH m.g_toplatform REPLACE objtype WITH c_ot20lbxobj REPLACE vpos WITH m.lines ENDIF ENDFOR RETURN * * LinesBetween - Removes all the whitespace from the bottom of the detail * band and puts it in lines between. * *!***************************************************************************** *! *! Procedure: LINESBETWEEN *! *! Called by: ALLGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE linesbetween PRIVATE m.linecount, m.blanklines COUNT TO m.linecount FOR platform = m.g_toplatform AND objtype = c_ot20lbxobj LOCATE FOR platform = m.g_toplatform AND objtype = c_otband AND objcode = 4 IF FOUND() AND m.linecount < HEIGHT m.blanklines = HEIGHT - m.linecount REPLACE HEIGHT WITH m.linecount LOCATE FOR platform = m.g_toplatform AND objtype = c_ot20label IF FOUND() REPLACE penblue WITH m.blanklines ENDIF ENDIF * * labelBands - Adds the group records needed by a graphical label * *!***************************************************************************** *! *! Procedure: LABELBANDS *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE labelbands PRIVATE m.lbxheight, m.lbxwidth, m.lbxlinesbet LOCATE FOR platform = m.g_fromplatform AND objtype = c_otband AND objcode = 4 IF FOUND() m.lbxheight = HEIGHT ENDIF LOCATE FOR platform = m.g_fromplatform AND objtype = c_ot20label IF FOUND() DO CASE CASE name = '3 1/2" x 15/16" x 1' AND penblue = 1 AND ; WIDTH = 35 AND m.lbxheight = 5 AND vpos = 1 AND hpos = 0 AND HEIGHT = 0 m.lbxheight = (15/16) * 10000 m.lbxwidth = -1 m.lbxlinesbet = m.lbxheight / 5 CASE name = '3 1/2" x 15/16" x 2' AND penblue = 1 AND ; WIDTH = 35 AND m.lbxheight = 5 AND vpos = 2 AND hpos = 0 AND HEIGHT = 2 m.lbxheight = (15/16) * 10000 m.lbxwidth = (3 + (1/2)) * 10000 m.lbxlinesbet = m.lbxheight / 5 CASE name = '3 1/2" x 15/16" x 3' AND penblue = 1 AND ; WIDTH = 35 AND m.lbxheight = 5 AND vpos = 3 AND hpos = 0 AND HEIGHT = 2 m.lbxheight = (15/16) * 10000 m.lbxwidth = (3 + (1/2)) * 10000 m.lbxlinesbet = m.lbxheight / 5 CASE name = '3 2/10" x 11/12" x 3 (Cheshire)' AND penblue = 1 AND ; WIDTH = 32 AND m.lbxheight = 5 AND vpos = 3 AND hpos = 0 AND HEIGHT = 2 m.lbxheight = (11/12) * 10000 m.lbxwidth = (3 + (2/10)) * 10000 m.lbxlinesbet = m.lbxheight / 5 CASE name = '3" x 5 Rolodex' AND penblue = 4 AND ; WIDTH = 50 AND m.lbxheight = 14 AND vpos = 1 AND hpos = 0 AND HEIGHT = 0 m.lbxheight = 5 * 10000 m.lbxwidth = -1 m.lbxlinesbet = 4 * (m.lbxheight / 14) CASE name = '4" x 1 7/16" x 1' AND penblue = 1 AND ; WIDTH = 40 AND m.lbxheight = 8 AND vpos = 1 AND hpos = 0 AND HEIGHT = 0 m.lbxheight = (1 + (7/16)) * 10000 m.lbxwidth = -1 m.lbxlinesbet = m.lbxheight / 8 CASE name = '4" x 2 1/4 Rolodex' AND penblue = 1 AND ; WIDTH = 40 AND m.lbxheight = 10 AND vpos = 1 AND hpos = 0 AND HEIGHT = 0 m.lbxheight = (2 + (1/4)) * 10000 m.lbxwidth = -1 m.lbxlinesbet = m.lbxheight / 10 CASE name = '6 1/2" x 3 5/8 Envelope' AND penblue = 8 AND ; WIDTH = 65 AND m.lbxheight = 14 AND vpos = 1 AND hpos = 0 AND HEIGHT = 0 m.lbxheight = (3 + (5/8)) * 10000 m.lbxwidth = -1 m.lbxlinesbet = 8 * (m.lbxheight / 14) CASE name = '9 7/8" x 7 1/8 Envelope' AND penblue = 8 AND ; WIDTH = 78 AND m.lbxheight = 17 AND vpos = 1 AND hpos = 0 AND HEIGHT = 0 m.lbxheight = (7 + (1/8)) * 10000 m.lbxwidth = -1 m.lbxlinesbet = 8 * (m.lbxheight / 17) OTHERWISE m.lbxheight = m.lbxheight * m.g_rptlinesize m.lbxwidth = IIF(vpos > 1, WIDTH * m.g_rptcharsize, -1) m.lbxlinesbet = penblue * m.g_rptlinesize ENDCASE ELSE RETURN ENDIF LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() REPLACE vpos WITH IIF(vpos > 1, vpos * m.g_rptlinesize, 1) REPLACE WIDTH WITH m.lbxwidth REPLACE hpos WITH hpos * m.g_rptcharsize && Left margin REPLACE HEIGHT WITH HEIGHT * m.g_rptcharsize && Spaces Between Columns ENDIF LOCATE FOR platform = m.g_toplatform AND objtype = c_otband AND objcode = 4 IF FOUND() REPLACE HEIGHT WITH m.lbxheight + m.lbxlinesbet ENDIF * * labelLines - Converts the character style label objects to graphical report objects * *!***************************************************************************** *! *! Procedure: LABELLINES *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: ADJFONT (procedure in TRANSPRT.PRG) *! : ADJCOLOR (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE labellines PRIVATE m.bandstart, m.linecount, m.thermstep, m.lbxwidth, ; m.saverec, m.nextexpr, m.loop COUNT TO m.thermstep FOR platform = m.g_toplatform AND objtype = c_ot20lbxobj m.thermstep = 45 / m.thermstep m.bandstart = 4166.667 LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF WIDTH != -1 m.lbxwidth = WIDTH ELSE LOCATE FOR platform = m.g_fromplatform AND objtype = c_ot20label m.lbxwidth = WIDTH * m.g_rptcharsize ENDIF m.linecount = 0 SCAN FOR platform = m.g_toplatform AND objtype = c_ot20lbxobj AND !DELETED() REPLACE expr WITH ALLTRIM(expr) REPLACE objtype WITH c_otrepfld REPLACE objcode WITH 0 REPLACE vpos WITH m.bandstart + (m.linecount * m.g_rptlinesize) REPLACE hpos WITH 0 REPLACE HEIGHT WITH m.g_rptlinesize REPLACE WIDTH WITH m.lbxwidth REPLACE fillchar WITH "C" REPLACE FLOAT WITH .F. REPLACE STRETCH WITH .F. REPLACE spacing WITH 12 REPLACE offset WITH 0 REPLACE totaltype WITH 0 REPLACE TOP WITH .T. REPLACE resettotal WITH 1 REPLACE supalways WITH .T. REPLACE supovflow WITH .F. REPLACE suprpcol WITH 3 REPLACE supgroup WITH 0 REPLACE supvalchng WITH .F. DO adjfont DO adjcolor m.loop = (RIGHT(expr,1) = ";") DO WHILE m.loop m.saverec = RECNO() SKIP DO WHILE platform = m.g_toplatform AND objtype = c_ot20lbxobj AND DELETED() SKIP ENDDO IF platform = m.g_toplatform AND objtype = c_ot20lbxobj DELETE m.nextexpr = expr GOTO RECORD (m.saverec) REPLACE expr WITH expr + m.nextexpr REPLACE HEIGHT WITH HEIGHT + m.g_rptlinesize m.loop = (RIGHT(expr,1) = ";") ELSE GOTO RECORD (m.saverec) m.loop = .F. ENDIF ENDDO m.linecount = m.linecount + 1 m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDSCAN * * calcpositions - Calculate each objects position as a percentage across * and down the window. * *!***************************************************************************** *! *! Procedure: CALCPOSITIONS *! *! Called by: ALLOTHERS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE calcpositions PARAMETER m.index PRIVATE m.record, m.vert, m.horiz, m.width, m.numothers, m.thermstep, m.i * * Search for the original platform records and establish the horizontal * and vertical positioning percentages. * objectpos[m.index, 1] = hpos / m.g_windwidth objectpos[m.index, 2] = vpos / m.g_windheight objectpos[m.index, 3] = uniqueid objectpos[m.index, 4] = objtype objectpos[m.index, 5] = .F. && right aligned with object above or below? objectpos[m.index, 6] = hpos objectpos[m.index, 7] = WIDTH objectpos[m.index, 8] = spacing objectpos[m.index, 9] = PICTURE IF objtype = c_ottext m.record = RECNO() m.vert1 = vpos m.horiz = hpos m.endpos = hpos + WIDTH LOCATE FOR objtype = c_ottext AND hpos != m.horiz AND ; m.vert1 - 1 = vpos AND hpos + WIDTH = m.endpos IF FOUND() objectpos[m.index,5] = .T. DO WHILE FOUND() IF objectpos[m.index, 7] < WIDTH objectpos[m.index, 7] = WIDTH ENDIF m.vert = vpos LOCATE FOR objtype = c_ottext AND hpos != m.horiz AND ; m.vert - 1 = vpos AND hpos + WIDTH = m.endpos ENDDO ENDIF LOCATE FOR objtype = c_ottext AND hpos != m.horiz AND ; m.vert1 + 1 = vpos AND hpos + WIDTH = m.endpos IF FOUND() objectpos[m.index,5] = .T. DO WHILE FOUND() IF objectpos[m.index, 7] < WIDTH objectpos[m.index, 7] = WIDTH ENDIF m.vert = vpos LOCATE FOR objtype = c_ottext AND hpos != m.horiz AND ; m.vert + 1 = vpos AND hpos + WIDTH = m.endpos ENDDO ENDIF GOTO RECORD m.record IF objectpos[m.index, 5] objectpos[m.index, 6] = hpos + WIDTH - 1 objectpos[m.index, 1] = (hpos + WIDTH) / m.g_windwidth ENDIF ENDIF * * calcwindowdimensions - Calculate the needed Height and Width for the new window * *!***************************************************************************** *! *! Procedure: CALCWINDOWDIMENSIONS *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: FINDWIDEROBJECTS (procedure in TRANSPRT.PRG) *! : HORIZBUTTON() (function in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! : REPOOBJECTS (procedure in TRANSPRT.PRG) *! *! Indexes: UNIQUEID (tag) *! *!***************************************************************************** PROCEDURE calcwindowdimensions PRIVATE m.i, m.curline, m.largestobj, m.lineheight, m.adjwindowwidth, m.thermstep INDEX ON uniqueid + platform TAG uniqueid OF (m.g_tempindex) ADDITIVE SELECT (m.g_fromobjonlyalias) SET RELATION OFF INTO (m.g_scrnalias) SET RELATION TO uniqueid+m.g_toplatform INTO (m.g_scrnalias) ADDITIVE SELECT (m.g_scrnalias) m.adjwindwidth = 0 DO findwiderobjects WITH m.adjwindwidth =ASORT(objectpos,2) STORE 0 TO m.curline, m.largestobj, m.lineheight, m.adjheight m.thermstep = 10 / m.objindex FOR m.i = 1 TO m.objindex IF objectpos[m.i,2] != m.curline m.adjheight = m.adjheight + m.lineheight STORE 0 TO m.lineheight, m.largestobj m.curline = objectpos[m.i,2] ENDIF IF m.largestobj != 3 DO CASE CASE objectpos[m.i, 4] = c_ottxtbut AND m.largestobj < 3 IF !horizbutton(objectpos[m.i, 9]) m.numitems = OCCURS(';',objectpos[m.i, 9]) + 1 m.lineheight = c_adjtbtn * m.numitems ELSE m.lineheight = c_adjtbtn ENDIF m.largestobj = 3 CASE (objectpos[m.i, 4] = c_otradbut AND m.largestobj < 2) ; OR (objectpos[m.i, 4] = c_otchkbox AND m.largestobj < 2) IF objectpos[m.i, 4] = c_otradbut AND !horizbutton(objectpos[m.i, 9]) m.numitems = OCCURS(';',objectpos[m.i, 9]) + 1 m.lineheight = c_adjrbtn * m.numitems ELSE m.lineheight = c_adjrbtn ENDIF m.largestobj = 2 CASE (objectpos[m.i, 4] = c_otlist AND m.largestobj < 1) ; OR (objectpos[m.i, 4] = c_otfield AND m.largestobj < 1) m.lineheight = c_adjlist m.largestobj = 1 ENDCASE ENDIF m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDFOR m.adjheight = m.adjheight + m.lineheight LOCATE FOR platform = m.g_toplatform AND objtype = 1 IF FOUND() REPLACE WIDTH WITH WIDTH + m.adjwindwidth DO repoobjects WITH HEIGHT + m.adjheight ENDIF RETURN * * findWiderObjects - Find objects which have changed in size * *!***************************************************************************** *! *! Procedure: FINDWIDEROBJECTS *! *! Called by: CALCWINDOWDIMENSION(procedure in TRANSPRT.PRG) *! *! Calls: HORIZBUTTON() (function in TRANSPRT.PRG) *! : SGN() (function in TRANSPRT.PRG) *! : ADJHPOS (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE findwiderobjects PARAMETER m.adjwindowwidth PRIVATE m.curcol, m.adjcol, m.i, m.rightalignflag, m.numitems, ; m.olduniqueid, m.oldwidth, m.buttonflag, m.newwidth, m.adjust, m.thermstep m.thermstep = 10 / m.objindex =ASORT(objectpos,6) && sort on hpos STORE 0 TO m.curcol, m.adjcol m.rightalignflag = .F. FOR m.i = 1 TO m.objindex * Start at the leftmost object IF objectpos[m.i,6] != m.curcol m.adjcol = 0 m.rightalignflag = .F. m.curcol = objectpos[m.i,6] ENDIF DO CASE CASE objectpos[m.i, 4] = c_ottxtbut OR objectpos[m.i, 4] = c_otradbut * Count the objects in push buttons and radio buttons m.numitems = OCCURS(';',objectpos[m.i, 9]) + 1 m.olduniqueid = objectpos[m.i, 3] IF horizbutton(objectpos[m.i, 9]) m.oldwidth = (objectpos[m.i, 7] * m.numitems) + ; (objectpos[m.i, 8] * (m.numitems - 1)) m.buttonflag = .T. ELSE m.buttonflag = .F. m.oldwidth = objectpos[m.i, 7] ENDIF OTHERWISE m.buttonflag = .F. m.oldwidth = objectpos[m.i, 7] m.olduniqueid = objectpos[m.i, 3] ENDCASE LOCATE FOR uniqueid = m.olduniqueid AND platform = m.g_toplatform IF FOUND() IF m.buttonflag m.newwidth = (WIDTH * m.numitems) + ; (spacing * (m.numitems - 1)) ELSE m.newwidth = WIDTH ENDIF IF m.oldwidth != m.newwidth AND ; !(objtype = c_ottext ; AND ASC(SUBSTR(expr,2,1))>=179 ; AND ASC(SUBSTR(expr,2,1))<=218) m.adjust = m.newwidth - m.oldwidth IF ABS(m.adjust) > ABS(m.adjcol) OR sgn(m.adjust) <> sgn(m.adjcol) IF (!objectpos[m.i,5] OR !m.rightalignflag) AND m.adjust > 0 * Move everything over DO adjhpos WITH m.adjust - m.adjcol, ; IIF(objectpos[m.i,5], objectpos[m.i, 6], ; objectpos[m.i, 6] + objectpos[m.i, 7] - 1) * Expand the window m.adjwindowwidth = m.adjwindowwidth + m.adjust - m.adjcol * AdjCol contains the cumulative adjustment m.adjcol = m.adjust IF objectpos[m.i, 5] m.rightalignflag = .T. REPLACE hpos WITH hpos + m.adjust - m.adjcol ENDIF ENDIF ENDIF ENDIF ENDIF m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDFOR * * adjHpos - Adjust the horizontal position of objects across as other objects * become bigger or smaller. * *!***************************************************************************** *! *! Procedure: ADJHPOS *! *! Called by: FINDWIDEROBJECTS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjhpos PARAMETER m.adjustment, m.position SELECT (m.g_fromobjonlyalias) SCAN FOR platform = m.g_fromplatform AND hpos >= m.position REPLACE &g_scrnalias..hpos WITH &g_scrnalias..hpos + m.adjustment ENDSCAN * Stretch lines that begin before the wider object and end after it starts. SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox AND HEIGHT = 1 AND ; hpos < m.position AND hpos + WIDTH - 1 >= m.position REPLACE &g_scrnalias..width WITH &g_scrnalias..width + m.adjustment ENDSCAN SELECT (m.g_scrnalias) *!***************************************************************************** *! *! Function: SGN *! *! Called by: FINDWIDEROBJECTS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION sgn PARAMETER num DO CASE CASE num = 0 RETURN 0 CASE num > 0 RETURN 1 CASE num < 0 RETURN -1 ENDCASE * * repoObjects - Reposition objects to the relative positions on the new window. * This procedure assumes that the array objectpos is sorted on rows ([m.i, 2]). * *!***************************************************************************** *! *! Procedure: REPOOBJECTS *! *! Called by: CALCWINDOWDIMENSION(procedure in TRANSPRT.PRG) *! *! Calls: GETLASTOBJECTLINE()(function in TRANSPRT.PRG) *! : HORIZBUTTON() (function in TRANSPRT.PRG) *! : ADJBOX (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE repoobjects PARAMETER m.windheight PRIVATE m.windwidth, m.thermstep, m.rightalign, m.saverec, ; m.adjust, m.buttonadjust, m.numrb m.saverec = RECNO() m.windwidth = WIDTH m.thermstep = 10 / m.objindex STORE 0 TO m.adjust, m.buttonadjust, m.numrb FOR m.i = 1 TO m.objindex IF objectpos[m.i,2] != m.curline IF m.numrb > 0 m.adjust = m.adjust + c_vradbtn m.numrb = m.numrb - 1 ENDIF m.adjust = m.adjust + m.buttonadjust STORE 0 TO m.buttonadjust m.curline = objectpos[m.i,2] ENDIF LOCATE FOR platform = m.g_toplatform AND uniqueid = objectpos[m.i,3] IF FOUND() g_lastobjectline[1] = getlastobjectline(g_lastobjectline[1], ; m.windheight * objectpos[m.i, 2] + m.adjust) REPLACE vpos WITH m.windheight * objectpos[m.i, 2] + m.adjust IF objectpos[m.i,5] m.rightalign = (m.windwidth * objectpos[m.i,1]) - WIDTH REPLACE hpos WITH IIF(m.rightalign < 0, 0, m.rightalign) ENDIF DO CASE CASE objectpos[m.i,4] = c_otfield REPLACE hpos WITH hpos + c_adjfld CASE objectpos[m.i,4] = c_otlist REPLACE vpos WITH vpos + c_vlist REPLACE HEIGHT WITH HEIGHT - c_listht CASE objectpos[m.i,4] = c_ottxtbut IF horizbutton(objectpos[m.i, 9]) m.buttonadjust = c_adjtbtn ENDIF CASE objectpos[m.i,4] = c_otradbut IF m.buttonadjust < c_adjrbtn m.buttonadjust = c_adjrbtn ENDIF REPLACE vpos WITH vpos - c_vradbtn CASE objectpos[m.i,4] = c_otchkbox REPLACE vpos WITH vpos - c_vchkbox CASE objectpos[m.i,4] = c_otpopup REPLACE vpos WITH MAX(vpos + c_vpopup,0) REPLACE hpos WITH MAX(hpos + c_hpopup,0) CASE objectpos[m.i,4] = c_otbox DO adjbox WITH m.adjust ENDCASE ENDIF m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDFOR GOTO RECORD m.saverec * * adjItemsInBoxes - Adjust the location of objects within boxes * *!***************************************************************************** *! *! Procedure: ADJITEMSINBOXES *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: ITEMSINBOXES (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjitemsinboxes PRIVATE m.subflag, m.emptybox, m.newlastline DIMENSION boxdimension[4,2] && 1 - Topmost && 2 - Leftmost && 3 - Bottommost && 4 - Rightmost SELECT (m.g_fromobjonlyalias) SCAN FOR objtype = c_otbox AND HEIGHT != 1 AND WIDTH != 1 STORE 999 TO boxdimension[1,1], boxdimension[2,1] STORE 0 TO boxdimension[3,1], boxdimension[4,1], boxdimension[4,2] STORE .F. TO m.subflag, m.emptybox, m.shrinkbox DO itemsinboxes WITH vpos, hpos, ; vpos + HEIGHT -1, hpos + WIDTH -1, m.emptybox, m.shrinkbox IF vpos + HEIGHT - 1 >= g_lastobjectline[1] m.newlastline = vpos + HEIGHT -1 m.flag = .T. m.shrinkbox = .F. ELSE m.flag = .F. ENDIF boxdimension[1,1] = boxdimension[1,1] - vpos -.5 boxdimension[2,1] = boxdimension[2,1] - hpos -.5 boxdimension[3,1] = vpos + HEIGHT - 1 - boxdimension[3,1] - IIF(m.shrinkbox, .5 + c_vpopup, .5) boxdimension[4,1] = hpos + WIDTH - boxdimension[4,1] - 1.5 SELECT (m.g_scrnalias) m.thisid = uniqueid LOCATE FOR uniqueid = m.thisid AND platform = m.g_toplatform IF FOUND() AND NOT m.emptybox REPLACE vpos WITH boxdimension[1,2] - boxdimension[1,1] REPLACE hpos WITH boxdimension[2,2] - boxdimension[2,1] REPLACE HEIGHT WITH boxdimension[3,2] - vpos + boxdimension[3,1] REPLACE WIDTH WITH boxdimension[4,2] - hpos + boxdimension[4,1] IF m.flag AND vpos + HEIGHT >= g_lastobjectline[2] g_lastobjectline[1] = m.newlastline g_lastobjectline[2] = vpos + HEIGHT ENDIF ENDIF SELECT (m.g_fromobjonlyalias) ENDSCAN SELECT (m.g_scrnalias) * * itemsInBoxes - Adjust objects which are within a box * *!***************************************************************************** *! *! Procedure: ITEMSINBOXES *! *! Called by: ADJITEMSINBOXES (procedure in TRANSPRT.PRG) *! *! Calls: FINDOTHERSONLINE() (function in TRANSPRT.PRG) *! : WHATSTYLE() (function in TRANSPRT.PRG) *! : HORIZBUTTON() (function in TRANSPRT.PRG) *! : GETOBJWIDTH() (function in TRANSPRT.PRG) *! *! Uses: M.G_FROMOBJONLYALIA *! *!***************************************************************************** PROCEDURE itemsinboxes PARAMETER m.top, m.left, m.bottom, m.right, m.emptybox, m.shrinkbox PRIVATE m.rec, m.wasapopup, m.oldbottom, m.newbottom, m.twidth m.rec = RECNO() m.g_boxeditemsalias = "S" + SUBSTR(LOWER(SYS(3)),2,8) SELECT vpos, hpos, HEIGHT, WIDTH, uniqueid, spacing, objtype, PICTURE, platform ; FROM (m.g_fromobjonlyalias) ; WHERE (vpos > m.top AND vpos < m.bottom) ; AND (hpos > m.left AND hpos < m.right) AND ; objtype <> c_otbox AND !(LEN(expr)=3 ; AND ASC(SUBSTR(CPTCOND(c_doscp,c_wincp,expr),2,1)) >= 179 ; AND ASC(SUBSTR(CPTCOND(c_doscp,c_wincp,expr),2,1)) <= 218); INTO CURSOR (m.g_boxeditemsalias) STORE 0 TO m.oldbottom, m.newbottom IF _TALLY > 0 SET RELATION TO uniqueid+m.g_toplatform INTO (m.g_scrnalias) ADDITIVE LOCATE FOR .T. m.wasapopup = .F. DO WHILE NOT EOF() IF vpos < boxdimension[1,1] OR (m.wasapopup AND vpos = boxdimension[1,1]) boxdimension[1,1] = vpos boxdimension[1,2] = &g_scrnalias..vpos IF objtype = c_otpopup m.wasapopup = .T. ELSE m.wasapopup = .F. ENDIF ENDIF IF hpos < boxdimension[2,1] boxdimension[2,1]= hpos boxdimension[2,2] = &g_scrnalias..hpos ENDIF DO CASE CASE objtype = c_ottext OR objtype = c_otchkbox ; OR (objtype = c_otfield AND HEIGHT = 1) IF vpos > m.oldbottom m.shrinkbox = .F. IF !findothersonline(vpos, @m.newbottom, @m.oldbottom, objtype) m.oldbottom = vpos + HEIGHT m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height ENDIF ENDIF * Check TXTWIDTH for text strings IF m.g_tographic AND objtype = c_ottext m.twidth = TXTWIDTH(&g_scrnalias..expr,g_fontface,g_fontsize,whatstyle(g_boldstyle)) ELSE m.twidth = &g_scrnalias..width ENDIF IF &g_scrnalias..hpos + m.twidth > boxdimension[4,2] boxdimension[4,1] = hpos + WIDTH - 1 boxdimension[4,2] = &g_scrnalias..hpos + m.twidth ENDIF CASE objtype = c_otradbut OR objtype = c_ottxtbut OR objtype = c_otinvbut m.numitems = OCCURS(';',PICTURE) + 1 IF horizbutton(PICTURE) IF vpos > m.oldbottom m.shrinkbox = .F. IF findothersonline(vpos, @m.newbottom, @m.oldbottom, ; objtype) IF objtype = c_ottxtbut REPLACE &g_scrnalias..vpos WITH &g_scrnalias..vpos - 0.312 ENDIF ENDIF m.oldbottom = vpos + HEIGHT - 1 m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height ENDIF IF (hpos -1 + (WIDTH +spacing) * m.numitems - spacing) >= ; boxdimension[4,1] boxdimension[4,1] = hpos - 1 + ; getobjwidth(objtype, ; PICTURE, ; WIDTH, ; spacing, ; m.g_toplatform) boxdimension[4,2] = &g_scrnalias..hpos + ; getobjwidth(&g_scrnalias..objtype, ; &g_scrnalias..picture, ; &g_scrnalias..width, ; &g_scrnalias..spacing, ; m.g_toplatform) ENDIF ELSE m.shrinkbox = .F. IF (vpos -1 + m.numitems + (spacing * (m.numitems -1))) >= ; m.oldbottom m.oldbottom = vpos -1 + m.numitems + ; (spacing * (m.numitems -1)) - 1 m.newbottom = &g_scrnalias..vpos + m.numitems + ; (&g_scrnalias..spacing * (m.numitems -1)) ENDIF IF hpos -1 + WIDTH >= boxdimension[4,1] boxdimension[4,1] = hpos -1 + WIDTH boxdimension[4,2] = &g_scrnalias..hpos + ; &g_scrnalias..width ENDIF ENDIF CASE objtype = c_otpopup IF vpos + HEIGHT - 2 > m.oldbottom IF !findothersonline(vpos + 1, @m.newbottom, @m.oldbottom, objtype) m.oldbottom = vpos + HEIGHT - 2 m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height ENDIF m.shrinkbox = IIF(m.bottom -1 = vpos + HEIGHT -1, .T., .F.) ENDIF IF hpos + WIDTH - 1 > boxdimension[4,1]) boxdimension[4,1] = hpos + WIDTH - 1 boxdimension[4,2] = &g_scrnalias..hpos + &g_scrnalias..width ENDIF CASE objtype = c_otfield OR ; objtype = c_otlist OR objtype = c_otbox IF vpos + HEIGHT - 1 > m.oldbottom m.shrinkbox = .F. IF !findothersonline(vpos, @m.newbottom, @m.oldbottom, objtype) m.oldbottom = vpos + HEIGHT - 1 m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height ENDIF ENDIF IF hpos + WIDTH - 1 > boxdimension[4,1]) boxdimension[4,1] = hpos + WIDTH - 1 boxdimension[4,2] = &g_scrnalias..hpos + &g_scrnalias..width ENDIF ENDCASE SKIP ENDDO m.emptybox = .F. boxdimension[3,1] = m.oldbottom boxdimension[3,2] = m.newbottom ELSE m.emptybox = .T. ENDIF USE SELECT (m.g_fromobjonlyalias) GOTO RECORD m.rec * * findOthersOnLine - Find any other objects in the box and on the line with a text button * *!***************************************************************************** *! *! Function: FINDOTHERSONLINE *! *! Called by: ITEMSINBOXES (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION findothersonline PARAMETER m.lineno, m.newbottom, m.oldbottom, m.curtype PRIVATE m.saverec, m.prevtype, m.flag m.prevtype = 0 m.flag = .F. m.saverec = RECNO() LOCATE FOR (objtype != c_otpopup AND vpos = m.lineno) OR ; (m.curtype != c_otpopup AND objtype = c_otpopup AND m.lineno = vpos + 1) IF !FOUND() GOTO RECORD (m.saverec) RETURN m.flag ENDIF DO WHILE FOUND() DO CASE CASE objtype = c_ottxtbut IF m.curtype != objtype m.flag = .T. m.oldbottom = vpos + HEIGHT -1 m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height GOTO RECORD (m.saverec) RETURN m.flag ENDIF CASE objtype = c_otpopup m.flag = .T. m.oldbottom = vpos + HEIGHT - 2 m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height m.prevtype = c_otpopup CASE (objtype = c_otfield OR objtype = c_otlist OR objtype = c_otline) AND ; (m.prevtype != c_otpopup) m.flag = .T. m.oldbottom = vpos + HEIGHT - 1 m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height m.prevtype = objtype OTHERWISE m.flag = .T. m.oldbottom = vpos m.newbottom = &g_scrnalias..vpos + &g_scrnalias..height ENDCASE CONTINUE ENDDO GOTO RECORD (m.saverec) RETURN m.flag * * StretchLinesToBorders - This procedure makes sure that any lines which stretched to the * edge of the from platform window will stretch to the edge of the to platform window. * *!***************************************************************************** *! *! Procedure: ADJINVBTNS *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: HORIZBUTTON() (function in TRANSPRT.PRG) *! : ADJPOSTINV (procedure in TRANSPRT.PRG) *! : UPDTHERM (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjinvbtns PRIVATE m.saverec, m.loop, m.horizontal, m.btnid, m.objid, m.flag, m.thermstep, m.leftmost, ; m.label, m.btnvpos, m.btnhpos, m.btnwidth, m.btnheight, m.btnspacing, m.btncount, ; m.ybtn, m.vbtn, m.xbtn, m.hbtn, m.defwidth, m.defwidthindex, m.defheight, m.defheightindex, ; m.topmargin, m.bottommargin, m.leftmargin, m.rightmargin, m.adjustment, m.totadjust, m.newhpos m.saverec = RECNO() m.totadjust = 0 m.leftmost = 0 COUNT TO m.thermstep FOR platform = m.g_fromplatform AND objtype = c_otinvbut m.thermstep = 5/m.thermstep SCAN FOR platform = m.g_fromplatform AND objtype = c_otinvbut m.horizontal = horizbutton(PICTURE) m.btnvpos = vpos m.btnhpos = hpos m.btnheight = HEIGHT m.btnwidth = WIDTH m.btnspacing = spacing m.btncount = OCCURS(";", PICTURE) + 1 m.btnid = uniqueid STORE 0 TO m.defwidth, m.defwidthindex, m.defheight, m.defheightindex * This array is used to keep track of the rectangle which bounds the objects which * lie on top of each invisible button in the set. * * sizes[x,1] = Minimum row on the FROM platform. * sizes[x,2] = Minimum colum on the FROM platform. * sizes[x,3] = Maximum row on the FROM platform. * sizes[x,4] = Maximum colum on the FROM platform. * sizes[x,5] = Minimum row on the TO platform. * sizes[x,6] = Minimum colum on the TO platform. * sizes[x,7] = Maximum row on the TO platform. * sizes[x,8] = Maximum colum on the TO platform. * sizes[x,9] = Comma delimeted list of uniqueid's for objects positioned on * the button face. DIMENSION sizes[m.btnCount,9] FOR m.loop = 1 TO m.btncount m.ybtn = IIF(m.horizontal, m.btnvpos, m.btnvpos + ((m.loop-1) * m.btnheight) + ((m.loop-1) * m.btnspacing)) m.vbtn = m.ybtn + m.btnheight m.xbtn = IIF(m.horizontal, m.btnhpos + ((m.loop-1) * m.btnwidth) + ((m.loop-1) * m.btnspacing), m.btnhpos) m.hbtn = m.xbtn + m.btnwidth STORE 0 TO sizes[m.loop,3], sizes[m.loop,4], sizes[m.loop,7], sizes[m.loop,8] STORE 99999999 TO sizes[m.loop,1], sizes[m.loop,2], sizes[m.loop,5], sizes[m.loop,6] sizes[m.loop,9] = "" SCAN FOR platform = m.g_fromplatform AND (objtype = c_ottext OR objtype = c_otfield OR ; objtype = c_otbox OR objtype = c_otline) AND ; vpos >= m.ybtn AND vpos+HEIGHT <= m.vbtn AND hpos >= m.xbtn AND hpos+WIDTH <= m.hbtn m.objid = uniqueid sizes[m.loop,1] = MIN(sizes[m.loop,1], vpos) sizes[m.loop,2] = MIN(sizes[m.loop,2], hpos) sizes[m.loop,3] = MAX(sizes[m.loop,3], vpos+HEIGHT) sizes[m.loop,4] = MAX(sizes[m.loop,4], hpos+WIDTH) sizes[m.loop,9] = sizes[m.loop,9] + ; IIF(LEN(sizes[m.loop,9]) = 0, uniqueid, ","+uniqueid) LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() sizes[m.loop,5] = MIN(sizes[m.loop,5], IIF(objtype = c_otbox OR objtype = c_otline, ; vpos-c_adjbox, vpos)) sizes[m.loop,6] = MIN(sizes[m.loop,6], IIF(objtype = c_otbox OR objtype = c_otline, ; hpos-c_adjbox, hpos)) sizes[m.loop,7] = MAX(sizes[m.loop,7], IIF(objtype = c_otbox OR objtype = c_otline, ; vpos+HEIGHT+c_adjbox, vpos+HEIGHT)) sizes[m.loop,8] = MAX(sizes[m.loop,8], IIF(objtype = c_otbox OR objtype = c_otline, ; hpos+WIDTH+c_adjbox, hpos+WIDTH)) ENDIF LOCATE FOR platform = m.g_fromplatform AND uniqueid = m.objid ENDSCAN * The tallest button region will define where the button set gets * placed so we want to remember which region that was. IF (sizes[m.loop,7] - sizes[m.loop,5]) > m.defheight m.defheight = sizes[m.loop,7] - sizes[m.loop,5] m.defheightindex = m.loop m.topmargin = sizes[m.loop,1] - m.ybtn m.bottommargin = m.vbtn - sizes[m.loop,3] ENDIF * The widest button region will define where the button set gets * placed so we want to remember which region that was. IF (sizes[m.loop,8] - sizes[m.loop,6]) > m.defwidth m.defwidth = sizes[m.loop,8] - sizes[m.loop,6] m.defwidthindex = m.loop m.leftmargin = sizes[m.loop,2] - m.xbtn m.rightmargin = m.hbtn - sizes[m.loop,4] ENDIF ENDFOR IF m.defheightindex != 0 AND m.defwidthindex != 0 LOCATE FOR platform = m.g_toplatform AND uniqueid = m.btnid IF FOUND() IF m.horizontal REPLACE vpos WITH sizes[m.defHeightIndex,5] - m.topmargin ELSE REPLACE hpos WITH sizes[m.defWidthIndex,6] - m.leftmargin ENDIF REPLACE HEIGHT WITH (sizes[m.defHeightIndex,7] - sizes[m.defHeightIndex,5]) + m.topmargin + m.bottommargin REPLACE WIDTH WITH (sizes[m.defWidthIndex,8] - sizes[m.defWidthIndex,6]) + m.leftmargin + m.rightmargin ENDIF IF m.horizontal AND WIDTH > m.btnwidth m.adjustment = WIDTH - m.btnwidth IF spacing > 1 IF m.adjustment <= spacing-1 REPLACE spacing WITH spacing - m.adjustment ELSE m.adjustment = m.adjustment - (spacing-1) REPLACE spacing WITH 1 m.leftmost = MAX(m.leftmost, hpos + (m.btncount*WIDTH) + ((m.btncount-1)*spacing)) m.totadjust = MAX(m.totadjust, m.btncount * m.adjustment) DO adjpostinv WITH vpos, vpos+HEIGHT, ; m.btnhpos + (m.btncount*m.btnwidth) + ((m.btncount-1)*m.btnspacing), ; m.btncount * m.adjustment FOR m.loop = 2 TO m.btncount DO WHILE LEN(sizes[m.loop,9]) > 0 IF AT(",", sizes[m.loop,9]) != 0 m.label = LEFT(sizes[m.loop,9], AT(",", sizes[m.loop,9])-1) sizes[m.loop,9] = SUBSTR(sizes[m.loop,9], AT(",", sizes[m.loop,9])+1) ELSE m.label = sizes[m.loop,9] sizes[m.loop,9] = "" ENDIF LOCATE FOR platform = m.g_fromplatform AND uniqueid = m.label IF FOUND() m.newhpos = hpos + (m.adjustment * (m.loop-1)) LOCATE FOR platform = m.g_toplatform AND uniqueid = m.label IF FOUND() REPLACE hpos WITH IIF(objtype = c_otbox OR objtype = c_otline, ; m.newhpos+c_adjbox, m.newhpos) ENDIF ENDIF ENDDO ENDFOR ENDIF ENDIF ENDIF ENDIF LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() IF m.totadjust > 0 REPLACE WIDTH WITH WIDTH + m.totadjust ENDIF IF WIDTH < m.leftmost REPLACE WIDTH WITH m.leftmost + 1 ENDIF ENDIF m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury LOCATE FOR platform = m.g_fromplatform AND uniqueid = m.btnid ENDSCAN IF m.saverec <= RECCOUNT() GOTO RECORD (m.saverec) ELSE LOCATE FOR .F. ENDIF * * adjPostInv - This procedure moves objects which lie to the right of a set of horizontal * invisible buttons so that they won't overlap. * *!***************************************************************************** *! *! Procedure: ADJPOSTINV *! *! Called by: ADJINVBTNS (procedure in TRANSPRT.PRG) *! *! Calls: FINDALIGNEND() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjpostinv PARAMETER m.ystart, m.yend, m.xstart, m.adjustment PRIVATE m.saverec, m.saveid m.saverec = RECNO() m.ystart = findalignend(m.ystart, m.xstart, -1) m.yend = findalignend(m.yend, m.xstart, 1) SCAN FOR platform = m.g_fromplatform AND hpos >= m.xstart AND vpos >= m.ystart AND vpos <= m.yend AND ; (objtype = c_ottext OR objtype = c_otline OR objtype = c_otbox OR objtype = c_list OR ; objtype = c_otradbut OR objtype = c_otchkbox OR objtype = c_otfield OR objtype = c_popup OR ; objtype = c_otinvbut) m.saveid = uniqueid LOCATE FOR platform = m.g_toplatform AND uniqueid = m.saveid IF FOUND() REPLACE hpos WITH hpos + m.adjustment ENDIF LOCATE FOR platform = m.g_fromplatform AND uniqueid = m.saveid ENDSCAN IF m.saverec <= RECCOUNT() GOTO RECORD m.saverec ELSE LOCATE FOR .F. ENDIF * * FindAlignEnd - Given a position to start with and a direction, this routine looks for the * last line where right aligned objects extend to from the starting position. * *!***************************************************************************** *! *! Function: FINDALIGNEND *! *! Called by: ADJPOSTINV (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION findalignend PARAMETER m.ystart, m.xstart, m.increment PRIVATE m.saverec, m.ytemp, m.xtemp, m.result m.result = m.ystart SCAN FOR platform = m.g_fromplatform AND hpos >= m.xstart AND vpos = m.ystart m.saverec = RECNO() m.ytemp = vpos + m.increment m.xtemp = hpos LOCATE FOR platform = m.g_fromplatform AND vpos = m.ytemp AND hpos = m.xtemp AND ; (objtype = c_ottext OR objtype = c_otline OR objtype = c_otbox OR objtype = c_list OR ; objtype = c_otradbut OR objtype = c_otchkbox OR objtype = c_otfield OR objtype = c_popup OR ; objtype = c_otinvbut) DO WHILE FOUND() m.result = IIF(m.increment < 0, MIN(m.result, m.ytemp), MAX(m.result, m.ytemp)) m.ytemp = m.ytemp + m.increment LOCATE FOR platform = m.g_fromplatform AND vpos = m.ytemp AND hpos = m.xtemp AND ; (objtype = c_ottext OR objtype = c_otline OR objtype = c_otbox OR objtype = c_list OR ; objtype = c_otradbut OR objtype = c_otchkbox OR objtype = c_otfield OR objtype = c_popup OR ; objtype = c_otinvbut) ENDDO GOTO RECORD m.saverec ENDSCAN RETURN m.result * * StretchLinesToBorders - This procedure makes sure that any lines which stretched to the * edge of the from platform window will stretch to the edge of the to platform window. * *!***************************************************************************** *! *! Procedure: STRETCHLINESTOBORDERS *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE stretchlinestoborders PRIVATE m.saverec, m.objid, m.objrec, m.objwidth, m.fromheight, m.fromwidth IF m.g_filetype = c_report OR m.g_filetype = c_label RETURN ENDIF m.saverec = RECNO() LOCATE FOR platform = m.g_fromplatform AND objtype = c_otheader IF FOUND() IF BORDER = 0 OR STYLE = 0 m.fromheight = HEIGHT m.fromwidth = WIDTH ELSE m.fromheight = HEIGHT - 2 m.fromwidth = WIDTH - 2 ENDIF SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox AND ; ((WIDTH = 1 AND vpos+HEIGHT = m.fromheight) OR (HEIGHT = 1 AND hpos+WIDTH = m.fromwidth)) m.objrec = RECNO() m.objid = uniqueid m.objwidth = WIDTH LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() m.toheight = HEIGHT m.towidth = WIDTH LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() IF m.objwidth = 1 REPLACE HEIGHT WITH m.toheight-vpos ELSE REPLACE WIDTH WITH m.towidth-hpos ENDIF ENDIF ENDIF GOTO RECORD m.objrec ENDSCAN ENDIF IF m.saverec > RECCOUNT() LOCATE FOR .F. ELSE GOTO RECORD m.saverec ENDIF RETURN * * JoinLines -This procedure examines each line to see where it meets other lines in the * from platform and constructs an array of these positons. This array can then * be used to make the lines/boxes meet in the from platform. * *!***************************************************************************** *! *! Procedure: JOINLINES *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: UPDTHERM (procedure in TRANSPRT.PRG) *! : JOINHORIZONTAL (procedure in TRANSPRT.PRG) *! : JOINVERTICAL (procedure in TRANSPRT.PRG) *! : MEETBOXCHAR (procedure in TRANSPRT.PRG) *! : ZAPBOXCHAR (procedure in TRANSPRT.PRG) *! : REJOINBOXES (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE joinlines PRIVATE m.saverec, m.joincount, m.linerec, m.lineid, m.i, m.thermstep, ; m.objvpos, m.objhpos, m.objright, m.objbottom, m.objid, m.objrec, m.objcode, ; m.fromvpos, m.fromhpos, m.fromheight, m.fromwidth, m.fromend, m.fromcode, ; m.tovpos, m.tohpos, m.toheight, m.towidth, ; m.joinvpos, m.joinhpos, m.vlevel, m.hlevel DIMENSION joins[1,5] && Joins[X,2] - toVpos && Joins[X,3] - toHpos && Joins[X,4] - Vpos match level && Joins[X,5] - Hpos match level m.joincount = 0 m.saverec = RECNO() COUNT TO m.thermstep FOR platform = m.g_fromplatform AND objtype = c_otbox AND (WIDTH=1 OR HEIGHT=1) IF m.thermstep <> 0 m.thermstep = 10 / m.thermstep ELSE m.g_mercury = m.g_mercury + 10 DO updtherm WITH m.g_mercury ENDIF SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox AND (WIDTH=1 OR HEIGHT=1) m.fromvpos = vpos m.fromhpos = hpos m.fromheight = HEIGHT m.fromwidth = WIDTH m.fromcode = objcode m.lineid = uniqueid m.linerec = RECNO() LOCATE FOR platform = m.g_toplatform AND uniqueid = m.lineid IF FOUND() m.tovpos = vpos m.tohpos = hpos m.toheight = HEIGHT m.towidth = WIDTH SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox AND uniqueid <> m.lineid IF m.fromheight = 1 AND HEIGHT <> 1 AND (m.fromvpos >= vpos AND m.fromvpos <= vpos+HEIGHT-1) m.fromend = m.fromhpos + m.fromwidth - 1 ** Horizontal line which starts on a vertical line/box side. IF m.fromhpos = hpos OR m.fromhpos = hpos+WIDTH-1 DO joinhorizontal WITH m.fromvpos, m.fromhpos, m.fromhpos, m.tovpos, m.toheight, m.fromcode ENDIF ** Horizontal line which ends on a vertical line/box side. IF m.fromend = hpos OR m.fromend = hpos+WIDTH-1 DO joinhorizontal WITH m.fromvpos, m.fromend, m.fromend, m.tovpos, m.toheight, m.fromcode ENDIF ** Horizontal line which starts one to the right of a vertical line/box side IF m.fromhpos-1 = hpos OR m.fromhpos = hpos+WIDTH DO joinhorizontal WITH m.fromvpos, m.fromhpos-1, m.fromhpos, m.tovpos, m.toheight, m.fromcode ENDIF ** Horizontal line which ends one left of a vertical line/box side IF m.fromend+1 = hpos OR m.fromend = hpos+WIDTH-2 DO joinhorizontal WITH m.fromvpos, m.fromend+1, m.fromend, m.tovpos, m.toheight, m.fromcode ENDIF ENDIF IF m.fromwidth = 1 AND WIDTH <> 1 AND (m.fromhpos >= hpos AND m.fromhpos <= hpos+WIDTH-1) m.fromend = m.fromvpos + m.fromheight - 1 ** Vertical line which starts on a horizontical line/box side. IF m.fromvpos = vpos OR m.fromvpos = vpos+HEIGHT-1 DO joinvertical WITH m.fromvpos, m.fromvpos, m.fromhpos, m.tohpos, m.fromcode ENDIF ** Vertical line which ends on a horizontical line/box side. IF m.fromend = vpos OR m.fromend = vpos+HEIGHT-1 DO joinvertical WITH m.fromend, m.fromend, m.fromhpos, m.tohpos, m.fromcode ENDIF ** Vertical line which starts one below a horizontal line/box side IF m.fromvpos-1 = vpos OR m.fromvpos = vpos+HEIGHT DO joinvertical WITH m.fromvpos-1, m.fromvpos, m.fromhpos, m.tohpos, m.fromcode ENDIF ** Vertical line which ends one above a horizontal line/box side IF m.fromend+1 = vpos OR m.fromend = vpos+HEIGHT-2 DO joinvertical WITH m.fromend+1, m.fromend, m.fromhpos, m.tohpos, m.fromcode ENDIF ENDIF ENDSCAN ENDIF m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury GOTO RECORD m.linerec ENDSCAN DO meetboxchar DO zapboxchar m.thermstep = 10/m.joincount FOR m.i = 1 TO m.joincount DO rejoinboxes WITH VAL(LEFT(joins[m.i, 1], 3)), VAL(RIGHT(joins[m.i, 1], 3)), joins[m.i, 2], joins[m.i, 3] m.g_mercury = m.g_mercury + m.thermstep DO updtherm WITH m.g_mercury ENDFOR IF m.saverec > RECCOUNT() LOCATE FOR .F. ELSE GOTO RECORD m.saverec ENDIF RETURN * * joinHorizontal - This procedure adds a join for a horizontal line which has been determined to * intersect something vertical. * *!***************************************************************************** *! *! Procedure: JOINHORIZONTAL *! *! Called by: JOINLINES (procedure in TRANSPRT.PRG) *! *! Calls: GETLINEWIDTH() (function in TRANSPRT.PRG) *! : ADDJOIN (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE joinhorizontal PARAMETER m.fromvpos, m.oldhpos1, m.oldhpos2, m.tovpos, m.tothickness, m.fromcode PRIVATE m.objvpos, m.objhpos, m.objright, m.objbottom, m.objcode, m.objid, m.objrec m.objvpos = vpos m.objhpos = hpos m.objright = hpos + WIDTH - 1 m.objbottom = vpos + HEIGHT - 1 m.objcode = objcode m.objid = uniqueid m.objrec = RECNO() LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() DO CASE CASE m.fromvpos = m.objvpos OR m.fromvpos = m.objbottom IF objtype = c_otline m.joinvpos = m.tovpos - c_adjbox + (m.tothickness/2) STORE 2 TO m.vlevel, m.hlevel ELSE IF m.fromvpos = m.objvpos m.joinvpos = vpos - c_adjbox + (getlinewidth(m.objcode, .T.)/2) ELSE m.joinvpos = vpos+HEIGHT - c_adjbox - (getlinewidth(m.objcode, .T.)/2) ENDIF STORE 4 TO m.vlevel, m.hlevel ENDIF OTHERWISE m.joinvpos = m.tovpos - c_adjbox + (getlinewidth(m.fromcode, .T.)/2) m.vlevel = 0 m.hlevel = IIF(objtype = c_otline, 1, 3) ENDCASE IF m.oldhpos1 = m.objhpos OR objtype = c_otline m.joinhpos = hpos - c_adjbox + (getlinewidth(m.objcode, .F.)/2) ELSE m.joinhpos = hpos+WIDTH - c_adjbox - (getlinewidth(m.objcode, .F.)/2) ENDIF DO addjoin WITH m.fromvpos, m.oldhpos1, m.joinvpos, m.joinhpos, m.vlevel, m.hlevel IF m.oldhpos1 <> m.oldhpos2 DO addjoin WITH m.fromvpos, m.oldhpos2, m.joinvpos, m.joinhpos, m.vlevel, m.hlevel ENDIF ENDIF GOTO RECORD m.objrec RETURN * * joinVertical - This procedure adds a join for a vertical line which has been determined to * intersect something horizontal. * *!***************************************************************************** *! *! Procedure: JOINVERTICAL *! *! Called by: JOINLINES (procedure in TRANSPRT.PRG) *! *! Calls: GETLINEWIDTH() (function in TRANSPRT.PRG) *! : ADDJOIN (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE joinvertical PARAMETER m.oldvpos1, m.oldvpos2, m.fromhpos, m.tohpos, m.fromcode PRIVATE m.objvpos, m.objhpos, m.objright, m.objbottom, m.objcode, m.objid, m.objrec m.objvpos = vpos m.objhpos = hpos m.objright = hpos + WIDTH - 1 m.objbottom = vpos + HEIGHT - 1 m.objcode = objcode m.objid = uniqueid m.objrec = RECNO() LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() DO CASE CASE m.fromhpos = m.objhpos OR m.fromhpos = m.objright IF objtype = c_otline m.joinhpos = IIF(m.fromhpos = m.objhpos, hpos, hpos+WIDTH-1) STORE 2 TO m.vlevel, m.hlevel ELSE IF m.fromhpos = m.objhpos m.joinhpos = hpos - c_adjbox + (getlinewidth(m.objcode, .F.)/2) ELSE m.joinhpos = hpos+WIDTH - c_adjbox - (getlinewidth(m.objcode, .F.)/2) ENDIF STORE 4 TO m.vlevel, m.hlevel ENDIF OTHERWISE m.joinhpos = m.tohpos - c_adjbox + (getlinewidth(m.fromcode, .F.)/2) m.vlevel = IIF(objtype = c_otline, 1, 3) m.hlevel = 0 ENDCASE IF m.oldvpos1 = m.objvpos OR objtype = c_otline m.joinvpos = vpos - c_adjbox + (getlinewidth(m.objcode, .T.)/2) ELSE m.joinvpos = vpos+HEIGHT - c_adjbox - (getlinewidth(m.objcode, .T.)/2) ENDIF DO addjoin WITH m.oldvpos1, m.fromhpos, m.joinvpos, m.joinhpos, m.vlevel, m.hlevel IF m.oldvpos1 <> m.oldvpos2 DO addjoin WITH m.oldvpos2, m.fromhpos, m.joinvpos, m.joinhpos, m.vlevel, m.hlevel ENDIF ENDIF GOTO RECORD m.objrec * * MeetBoxChar - This procedure looks at suspected box join characters and adds a join position for each * line which ends one short of it. * *!***************************************************************************** *! *! Procedure: MEETBOXCHAR *! *! Called by: JOINLINES (procedure in TRANSPRT.PRG) *! *! Calls: ADDJOIN (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE meetboxchar PRIVATE m.saverec, m.fromvpos, m.fromhpos, m.tovpos, m.tohpos, m.joinrec, m.joinid m.saverec = RECNO() SCAN FOR platform = m.g_fromplatform AND objtype = c_ottext AND LEN(expr)=3 AND ; ASC(SUBSTR(CPTCOND(c_doscp,c_wincp,expr),2,1)) >= 179 ; AND ASC(SUBSTR(CPTCOND(c_doscp,c_wincp,expr),2,1)) <= 218 m.fromvpos = vpos m.fromhpos = hpos m.joinid = uniqueid m.joinrec = RECNO() LOCATE FOR platform = m.g_toplatform AND uniqueid = m.joinid IF FOUND() m.tovpos = vpos m.tohpos = hpos SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox AND (WIDTH = 1 OR HEIGHT = 1) IF WIDTH = 1 AND hpos = m.fromhpos DO CASE CASE vpos = m.fromvpos + 1 DO addjoin WITH vpos, hpos, m.tovpos, m.tohpos, 2, 2 CASE vpos+HEIGHT = m.fromvpos DO addjoin WITH vpos+HEIGHT-1, hpos, m.tovpos, m.tohpos, 2, 2 ENDCASE ENDIF IF HEIGHT = 1 AND vpos = m.fromvpos DO CASE CASE hpos = m.fromhpos + 1 DO addjoin WITH vpos, hpos, m.tovpos, m.tohpos, 2, 2 CASE hpos+WIDTH = m.fromhpos DO addjoin WITH vpos, hpos+WIDTH-1, m.tovpos, m.tohpos, 2, 2 ENDCASE ENDIF ENDSCAN ENDIF GOTO RECORD m.joinrec ENDSCAN IF m.saverec > RECCOUNT() LOCATE FOR .F. ELSE GOTO RECORD m.saverec ENDIF RETURN * * zapBoxChar - This procedure looks for any text record which is probably a box join * character and replaces it with a transparent space. * *!***************************************************************************** *! *! Procedure: ZAPBOXCHAR *! *! Called by: JOINLINES (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE zapboxchar PRIVATE m.recno, m.fromvpos, m.fromhpos m.recno = RECNO() * See if we can find any single text box/line joining characters in a group. SCAN FOR platform = m.g_toplatform AND objtype = c_ottext ; AND boxjoin(objtype,recno(),platform) REPLACE expr WITH '" "' REPLACE mode WITH 1 ENDSCAN IF m.recno > RECCOUNT() GOTO RECCOUNT() SKIP ELSE GOTO RECORD m.recno ENDIF * * AddJoin - This routine adds the position for a join character, or modifies a previous join * at the same from position if it has a lower priority. * *!***************************************************************************** *! *! Procedure: ADDJOIN *! *! Called by: JOINHORIZONTAL (procedure in TRANSPRT.PRG) *! : JOINVERTICAL (procedure in TRANSPRT.PRG) *! : MEETBOXCHAR (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE addjoin PARAMETER m.fromvpos, m.fromhpos, m.tovpos, m.tohpos, m.vmatch, m.hmatch PRIVATE m.row, m.key m.key = STR(m.fromvpos, 3)+STR(m.fromhpos, 3) m.row = ASCAN(joins, m.key) IF m.row = 0 m.joincount = m.joincount + 1 DIMENSION joins[m.joinCount, 5] joins[m.joinCount, 1] = m.key joins[m.joinCount, 2] = m.tovpos joins[m.JoinCount, 3] = m.tohpos joins[m.JoinCount, 4] = m.vmatch joins[m.JoinCount, 5] = m.hmatch ELSE m.row = ASUBSCRIPT(joins, m.row, 1) IF m.vmatch > joins[m.row, 4] joins[m.row, 2] = m.tovpos joins[m.row, 4] = m.vmatch ENDIF IF m.hmatch > joins[m.JoinCount, 5] joins[m.row, 3] = m.tohpos joins[m.row, 5] = m.hmatch ENDIF ENDIF RETURN * * RejoinBoxes - This routine stretches lines so that they meet the join characters * they did in the from platform. * *!***************************************************************************** *! *! Procedure: REJOINBOXES *! *! Called by: JOINLINES (procedure in TRANSPRT.PRG) *! *! Calls: JOINLINEWIDTH() (function in TRANSPRT.PRG) *! : GETLINEWIDTH() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE rejoinboxes PARAMETER m.fromvpos, m.fromhpos, m.tovpos, m.tohpos PRIVATE m.objectcode, m.objend, m.saverecno, m.objid, m.joinwidth, m.objrec m.saverecno = RECNO() SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox IF WIDTH = 1 OR HEIGHT = 1 m.objid = uniqueid m.objectcode = objcode m.objrec = RECNO() DO CASE ** A Vertical line which starts at a join character CASE m.fromvpos = vpos AND m.fromhpos = hpos AND WIDTH = 1 LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() m.objend = vpos + HEIGHT m.joinwidth = joinlinewidth(m.fromvpos, m.fromhpos, .T., m.objid) REPLACE vpos WITH m.tovpos + c_adjbox - (m.joinwidth/2) REPLACE HEIGHT WITH m.objend - vpos REPLACE hpos WITH m.tohpos + c_adjbox - (getlinewidth(m.objectcode, .F.)/2) ENDIF ** A Horizontal line which starts at a join character CASE m.fromvpos = vpos AND m.fromhpos = hpos AND HEIGHT = 1 LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() m.objend = hpos + WIDTH m.joinwidth = joinlinewidth(m.fromvpos, m.fromhpos, .F., m.objid) REPLACE hpos WITH m.tohpos + c_adjbox - (m.joinwidth/2) REPLACE WIDTH WITH m.objend - hpos REPLACE vpos WITH m.tovpos + c_adjbox - (getlinewidth(m.objectcode, .T.)/2) ENDIF ** A Vertical line which ends at a join character CASE m.fromvpos = (vpos+HEIGHT-1) AND m.fromhpos = hpos AND WIDTH = 1 LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() m.joinwidth = joinlinewidth(m.fromvpos, m.fromhpos, .T., m.objid) REPLACE HEIGHT WITH (m.tovpos + c_adjbox + (m.joinwidth/2)) - vpos REPLACE hpos WITH m.tohpos + c_adjbox - (getlinewidth(m.objectcode, .F.)/2) ENDIF ** A Horizontal line which ends at a join character CASE m.fromhpos = (hpos+WIDTH-1) AND m.fromvpos = vpos AND HEIGHT = 1 LOCATE FOR platform = m.g_toplatform AND uniqueid = m.objid IF FOUND() m.joinwidth = joinlinewidth(m.fromvpos, m.fromhpos, .F., m.objid) REPLACE WIDTH WITH (m.tohpos + c_adjbox + (m.joinwidth/2)) - hpos REPLACE vpos WITH m.tovpos + c_adjbox - (getlinewidth(m.objectcode, .T.)/2) ENDIF ENDCASE GOTO RECORD m.objrec ENDIF ENDSCAN IF m.saverecno > RECCOUNT() LOCATE FOR .F. ELSE GOTO RECORD m.saverecno ENDIF RETURN * * JoinLineWidth - Looks for the thickest line or box which goes through a given point and * Returns either its horizontal or vertical Width. * *!***************************************************************************** *! *! Function: JOINLINEWIDTH *! *! Called by: REJOINBOXES (procedure in TRANSPRT.PRG) *! *! Calls: GETLINEWIDTH() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION joinlinewidth PARAMETERS m.joinvpos, m.joinhpos, m.horizontal, m.skipid PRIVATE m.i, m.saverecno, m.thickness m.saverecno = RECNO() m.thickness = 0 SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox AND uniqueid <> m.skipid DO CASE CASE m.horizontal AND WIDTH <> 1 AND ; (ABS(m.joinvpos - vpos) <= 1 OR ABS(m.joinvpos - (vpos+HEIGHT-1)) <= 1) AND ; (m.joinhpos >= hpos AND m.joinhpos <= (hpos+WIDTH-1)) m.thickness = MAX(getlinewidth(objcode, .T.), m.thickness) CASE !m.horizontal AND HEIGHT <> 1 AND ; (ABS(m.joinhpos - hpos) <= 1 OR ABS(m.joinhpos - (hpos+WIDTH-1)) <= 1) AND ; (m.joinvpos >= vpos AND m.joinvpos <= (vpos+WIDTH-1)) m.thickness = MAX(getlinewidth(objcode, .F.), m.thickness) ENDCASE ENDSCAN IF m.thickness = 0 SCAN FOR platform = m.g_fromplatform AND objtype = c_otbox AND uniqueid <> m.skipid IF (HEIGHT = 1 OR WIDTH = 1) AND ; (ABS(m.joinvpos - vpos) <= 1 OR ABS(m.joinvpos - (vpos+HEIGHT-1)) <= 1) AND ; (ABS(m.joinhpos - hpos) <= 1 OR ABS(m.joinhpos - (hpos+WIDTH-1)) <= 1) m.thickness = MAX(getlinewidth(objcode, m.horizontal), m.thickness) ENDIF ENDSCAN ENDIF GOTO RECORD m.saverecno RETURN m.thickness * * getLastObjectLine - Determine if this object is the lowest object. * *!***************************************************************************** *! *! Function: GETLASTOBJECTLINE *! *! Called by: REPOOBJECTS (procedure in TRANSPRT.PRG) *! *! Calls: HORIZBUTTON() (function in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getlastobjectline PARAMETER m.currentlastline, m.newposition PRIVATE m.numitems, m.max DO CASE CASE objtype = c_ottext OR objtype = c_otchkbox IF vpos > m.currentlastline g_lastobjectline[2] = m.newposition + HEIGHT RETURN vpos + HEIGHT ELSE RETURN m.currentlastline ENDIF CASE objtype = c_otradbut OR objtype = c_ottxtbut OR objtype = c_otinvbut IF horizbutton(PICTURE) IF vpos + HEIGHT >= m.currentlastline g_lastobjectline[2] = m.newposition + HEIGHT RETURN vpos ELSE RETURN m.currentlastline ENDIF ELSE m.numitems = OCCURS(';',PICTURE) m.max = vpos + m.numitems + (m.numitems * spacing) IF m.max >= m.currentlastline AND (objtype = c_ottxtbut OR objtype = c_otinvbut) OR ; m.max > m.currentlastline AND objtype = c_otradbut g_lastobjectline[2] = m.newposition + (HEIGHT * (m.numitems + 1)) + ; (spacing * m.numitems) RETURN m.max + 1 ELSE RETURN m.currentlastline ENDIF ENDIF CASE objtype = c_otpopup IF vpos + 2 > m.currentlastline g_lastobjectline[2] = m.newposition + 2 RETURN vpos +1 ELSE RETURN m.currentlastline ENDIF CASE objtype = c_otfield IF vpos + HEIGHT -1 > m.currentlastline g_lastobjectline[2] = m.newposition + HEIGHT RETURN vpos + HEIGHT -1 ELSE RETURN m.currentlastline ENDIF CASE objtype = c_otlist OR ; objtype = c_otbox OR objtype = c_otline IF vpos + HEIGHT - 1 > m.currentlastline g_lastobjectline[2] = m.newposition + HEIGHT RETURN vpos + HEIGHT - 1 ELSE RETURN m.currentlastline ENDIF OTHERWISE RETURN m.currentlastline ENDCASE * * adjobjcode - Adjust object code field for Objtype = 1. * *!***************************************************************************** *! *! Procedure: ADJOBJCODE *! *! Called by: ALLENVIRONS (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjobjcode * Stuff the right version code into the object code field for the header record DO CASE CASE objtype = c_otheader OR (m.g_filetype=c_label AND objtype = c_ot20label) REPLACE objcode WITH IIF(m.g_filetype=c_screen,c_25scx,c_25frx) CASE objtype = c_otgroup REPLACE objcode WITH 0 ENDCASE *!***************************************************************************** *! *! Procedure: GETWINDFONT *! *! Called by: NEWCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! *! Calls: WHATSTYLE() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE getwindfont * Get the default font for this window, if one has been defined IF m.g_tographic * Get font information from header GOTO TOP LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() AND !EMPTY(fontface) m.g_fontface = fontface m.g_fontsize = fontsize m.g_fontstyle = whatstyle(fontstyle) ENDIF ENDIF * * adjHeightAndWidth - Adjust the Height and width of objects. * *!***************************************************************************** *! *! Procedure: ADJHEIGHTANDWIDTH *! *! Called by: NEWGRAPHICTOCHAR (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! *! Calls: WHATSTYLE() (function in TRANSPRT.PRG) *! : DOSSIZE() (function in TRANSPRT.PRG) *! : COLUMNAR() (function in TRANSPRT.PRG) *! : ADJTEXT (procedure in TRANSPRT.PRG) *! : ADJBITMAPCTRL (procedure in TRANSPRT.PRG) *! : MAXBTNWIDTH() (function in TRANSPRT.PRG) *! : ADJBOX (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjheightandwidth PRIVATE m.txtwidthratio, m.boldtxtratio, m.chkboxwidth, m.saverec, ; m.oldwidth, m.newheight, m.newwidth, ; m.wndface, m.wndsize, m.wndstyle, m.alignment IF m.g_tographic m.saverec = RECNO() * Get font information from header LOCATE FOR platform = m.g_toplatform AND objtype = c_otheader IF FOUND() m.wndface = fontface m.wndsize = fontsize m.wndstyle = fontstyle ELSE m.wndface = m.g_fontface m.wndsize = m.g_fontsize m.wndstyle = m.g_fontstyle ENDIF GOTO m.saverec * This is the ratio of character size for the window font to that for the current object font m.txtwidthratio = FONTMETRIC(6, m.wndface, m.wndsize, whatstyle(m.wndstyle)) / ; FONTMETRIC(6,fontface,fontsize,whatstyle(fontstyle)) m.boldtxtratio = FONTMETRIC(6, m.wndface, m.wndsize, whatstyle(m.wndstyle)) / ; FONTMETRIC(6,m.g_fontface,m.g_fontsize,whatstyle(m.g_boldstyle)) m.chkboxwidth = c_chkpixel / FONTMETRIC(6,m.g_fontface,m.g_fontsize,whatstyle(m.g_boldstyle)) m.chkboxwidth = m.chkboxwidth + (m.chkboxwidth / 2) ELSE m.saverec = RECNO() LOCATE FOR platform = m.g_fromplatform AND objtype = c_otheader IF FOUND() m.wndface = fontface m.wndsize = fontsize m.wndstyle = fontstyle ELSE m.wndface = "MS Sans Serif" m.wndsize = 8 m.wndstyle = "B" ENDIF GOTO m.saverec ENDIF DO CASE CASE objtype = c_ottext IF m.g_tographic m.oldwidth = WIDTH REPLACE WIDTH WITH TXTWIDTH(SUBSTR(expr, 2,LEN(expr)-2), fontface, ; fontsize, whatstyle(fontstyle)) && * m.txtwidthratio ELSE m.oldwidth = ROUND(dossize(WIDTH, fontsize, m.wndsize), 0) m.newheight = 1 m.newwidth = LEN(expr)-2 m.alignment = columnar(vpos, hpos, WIDTH, objtype) DO CASE CASE m.alignment = 2 REPLACE hpos WITH hpos + WIDTH - m.newwidth CASE m.alignment = 0 REPLACE vpos WITH vpos + ((HEIGHT - m.newheight) / 2) REPLACE hpos WITH hpos + ((WIDTH - m.newwidth) / 2) ENDCASE REPLACE HEIGHT WITH MAX(m.newheight,1) REPLACE WIDTH WITH MAX(m.newwidth,1) DO adjtext WITH m.oldwidth ENDIF CASE objtype = c_otchkbox IF m.g_tographic m.oldwidth = WIDTH REPLACE WIDTH WITH (TXTWIDTH(SUBSTR(PICTURE, 6,LEN(PICTURE)-6) + SPACE(1), fontface, ; fontsize, whatstyle(fontstyle)) * m.boldtxtratio) + m.chkboxwidth REPLACE HEIGHT WITH c_chkhght ELSE DO adjbitmapctrl REPLACE HEIGHT WITH 1 REPLACE WIDTH WITH maxbtnwidth(PICTURE, "", "", "")+4 ENDIF CASE objtype = c_otradbut IF m.g_tographic m.oldwidth = WIDTH DO adjbitmapctrl REPLACE HEIGHT WITH c_radhght ELSE REPLACE HEIGHT WITH 1 REPLACE spacing WITH ROUND(dossize(spacing, fontsize, m.wndsize), 0) REPLACE WIDTH WITH MAX(maxbtnwidth(PICTURE, "", "", "")+4, dossize(WIDTH, fontsize, m.wndsize)) ENDIF CASE objtype = c_otpopup IF m.g_tographic REPLACE HEIGHT WITH c_pophght ELSE m.newheight = 3 REPLACE vpos WITH MAX(vpos + ((HEIGHT - m.newheight) / 2),0) REPLACE HEIGHT WITH m.newheight REPLACE WIDTH WITH dossize(WIDTH, fontsize, m.wndsize) ENDIF CASE objtype = c_ottxtbut IF m.g_tographic REPLACE HEIGHT WITH HEIGHT + c_adjtbtn ELSE DO adjbitmapctrl REPLACE HEIGHT WITH 1 REPLACE spacing WITH ROUND(dossize(spacing, fontsize, m.wndsize), 0) REPLACE WIDTH WITH MAX(maxbtnwidth(PICTURE, "", "", "")+2, dossize(WIDTH, fontsize, m.wndsize)) ENDIF CASE objtype = c_otfield IF m.g_tographic REPLACE HEIGHT WITH HEIGHT + c_adjfld ELSE IF INLIST(objcode,0,1) REPLACE height WITH 1 ELSE REPLACE HEIGHT WITH MAX(dossize(HEIGHT, fontsize, m.wndsize),1) ENDIF REPLACE WIDTH WITH MAX(dossize(WIDTH, fontsize, m.wndsize),1) ENDIF CASE objtype = c_otline OR objtype = c_otbox IF !m.g_tographic DO adjbox ENDIF ENDCASE IF !g_tographic REPLACE vpos WITH MAX(vpos,0) REPLACE hpos WITH MAX(hpos,0) ENDIF * * Columnar - This function takes and object and checks to see if it * is right or left aligned with other objects in a column. * Return values are: * 0 - Not aligned * 1 - Left aligned * 2 - Right aligned * *!***************************************************************************** *! *! Function: COLUMNAR *! *! Called by: ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION columnar PARAMETER m.vpos, m.hpos, m.type, m.otype PRIVATE m.saverec m.saverec = RECNO() LOCATE FOR platform = m.g_fromplatform AND objtype = m.type AND ; hpos = m.hpos AND ABS(vpos - m.vpos) < m.vpos * 2 IF FOUND() GOTO RECORD (m.saverec) RETURN 1 ENDIF LOCATE FOR platform = m.g_fromplatform AND objtype = m.type AND ; hpos + WIDTH = m.hpos + m.width AND ; ABS(vpos - m.vpos) < m.vpos * 2 IF FOUND() GOTO RECORD (m.saverec) RETURN 2 ENDIF GOTO RECORD (m.saverec) RETURN 0 * * DOSSize - This function attempts to normalize a dimension of an object to the font used for the * window it lies in. Unfortunately, we can't use FONTMETRIC since this needs to run on a character * platform. We use the ratio of point sizes. * *!***************************************************************************** *! *! Function: DOSSIZE *! *! Called by: ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION dossize PARAMETER m.size, m.objsize, m.scrnsize RETURN m.size * (m.objsize / m.scrnsize) * * AdjBitmapCtrl - Take the Picture clause for a control, see if it is a bitmap and * turn it into something that a character platform can handle. * *!***************************************************************************** *! *! Procedure: ADJBITMAPCTRL *! *! Called by: ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *! Calls: STRIPPATH() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjbitmapctrl PRIVATE m.function, m.oldpicture, m.newpicture, m.temp m.function = ALLTRIM(SUBSTR(PICTURE, 1, AT(" ", PICTURE))) IF AT("B", m.function) <> 0 m.function = CHRTRAN(m.function, "B", "") m.oldpicture = ALLTRIM(SUBSTR(PICTURE, AT(" ", PICTURE))) m.newpicture = "" DO WHILE LEN(m.oldpicture) > 0 IF AT(";", m.oldpicture) = 0 m.temp = LEFT(m.oldpicture, LEN(m.oldpicture)-1) m.oldpicture = "" ELSE m.temp = LEFT(m.oldpicture, AT(";", m.oldpicture)-1) m.oldpicture = SUBSTR(m.oldpicture, AT(";", m.oldpicture)+1) ENDIF IF LEN(m.newpicture) = 0 m.newpicture = ALLTRIM(strippath(m.temp)) ELSE m.newpicture = m.newpicture + ";" + ALLTRIM(strippath(m.temp)) ENDIF ENDDO REPLACE PICTURE WITH m.function + " " + m.newpicture + '"' ENDIF RETURN * * AdjColor - Adjust color fields in the database. * *!***************************************************************************** *! *! Procedure: ADJCOLOR *! *! Called by: ALLENVIRONS (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! : RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : LABELLINES (procedure in TRANSPRT.PRG) *! *! Calls: CONVERTCOLORPAIR (procedure in TRANSPRT.PRG) *! : RGBTOX() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjcolor IF m.g_tographic IF m.g_filetype = c_report OR m.g_filetype = c_label OR EMPTY(colorpair) IF m.g_filetype = c_screen REPLACE colorpair WITH "" REPLACE penred WITH -1 REPLACE pengreen WITH -1 REPLACE penblue WITH -1 REPLACE fillred WITH -1 REPLACE fillgreen WITH -1 REPLACE fillblue WITH -1 ELSE REPLACE penred WITH 0 REPLACE pengreen WITH 0 REPLACE penblue WITH 0 IF objtype = c_otline REPLACE fillred WITH 0 REPLACE fillgreen WITH 0 REPLACE fillblue WITH 0 ELSE REPLACE fillred WITH 255 REPLACE fillgreen WITH 255 REPLACE fillblue WITH 255 ENDIF ENDIF ELSE DO convertcolorpair ENDIF ELSE IF m.g_filetype = c_screen DO CASE CASE objtype = c_otheader DO CASE CASE STYLE = c_user IF SCHEME + scheme2 = 0 REPLACE SCHEME WITH 1 REPLACE scheme2 WITH 2 ENDIF CASE STYLE = c_system REPLACE SCHEME WITH 8 REPLACE scheme2 WITH 9 CASE STYLE = c_dialog REPLACE SCHEME WITH 5 REPLACE scheme2 WITH 6 CASE STYLE = c_alert REPLACE SCHEME WITH 7 REPLACE SCHEME WITH 12 ENDCASE CASE c_maptextcolor AND INLIST(objtype,c_otbox, c_otline,c_ottext) IF penred <> -1 OR fillred <> -1 REPLACE colorpair WITH rgbtox(penred, penblue, pengreen) + "/" + ; rgbtox(fillred, fillblue, fillgreen) * Don't let it map to black on black IF colorpair = "N/N" OR TRIM(colorpair) == "/" REPLACE colorpair WITH "" ENDIF ENDIF OTHERWISE REPLACE scheme WITH 0 && default color scheme for everything else ENDCASE ENDIF ENDIF * * RGBToX - Convert an RGB triplet to a traditional xBase color letter * *!***************************************************************************** *! *! Function: RGBTOX *! *! Called by: ADJCOLOR (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION rgbtox PARAMETERS m.red, m.blue, m.green PRIVATE m.color * * If it is automatic, we skip it. * IF m.red < 0 OR m.blue < 0 OR m.green < 0 RETURN "" ENDIF * * We use a special triplet for Light Gray which makes it a special case. * IF m.red = 192 AND m.blue = 192 AND m.green = 192 RETURN "W" ENDIF * * This division makes sure that we give a letter for any possible triplet * m.red = ROUND(m.red / 127, 0) m.blue = ROUND(m.blue / 127, 0) m.green = ROUND(m.green / 127, 0) * * Save some time by getting a number we can make a single comparison against * m.color = (m.red * 100) + (m.blue * 10) + m.green DO CASE CASE m.color = 222 && White RETURN "W+" CASE m.color = 0 && Black RETURN "N" CASE m.color = 111 && Dark Gray RETURN "N+" CASE m.color = 200 && Light Red RETURN "R+" CASE m.color = 100 && Dark Red RETURN "R" CASE m.color = 220 && Yellow RETURN "GR+" CASE m.color = 110 && Brown RETURN "GR" CASE m.color = 2 && Light green RETURN "G+" CASE m.color = 1 && Dark Green RETURN "G" CASE m.color = 22 && Light Magenta RETURN "BG+" CASE m.color = 11 && Dark Magenta RETURN "BG" CASE m.color = 20 && Light Blue RETURN "B+" CASE m.color = 10 && Dark Blue RETURN "B" CASE m.color = 202 && Light Purple RETURN "RB+" CASE m.color = 101 && Dark Purple RETURN "RB" ENDCASE RETURN "" && It shouldn't be possible to reach this point. * * \ - Adjust pen attributes. * *!***************************************************************************** *! *! Procedure: ADJPEN *! *! Called by: FILLININFO (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjpen IF m.g_tographic DO CASE CASE objtype = c_ottext REPLACE pensize WITH 1 REPLACE penpat WITH 0 REPLACE fillpat WITH 0 OTHERWISE REPLACE pensize WITH 0 REPLACE penpat WITH 0 REPLACE fillpat WITH 0 ENDCASE ENDIF * * adjfont - Adjust font fields in the SCX or FRX database. * *!***************************************************************************** *! *! Procedure: ADJFONT *! *! Called by: ALLENVIRONS (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! : RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : LABELLINES (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjfont PRIVATE m.i IF m.g_tographic DO CASE CASE objtype = c_ottxtbut OR ; objtype = c_otradbut OR ; objtype = c_otchkbox OR ; objtype = c_otheader OR ; objtype = c_otinvbut OR ; objtype = c_otspinner OR ; objtype = c_otbox OR ; objtype = c_otline REPLACE fontface WITH m.g_cfontface REPLACE fontsize WITH m.g_cfontsize REPLACE fontstyle WITH m.g_boldstyle CASE objtype = c_otpopup REPLACE fontface WITH m.g_cfontface REPLACE fontsize WITH m.g_cfontsize REPLACE fontstyle WITH m.g_normstyle CASE objtype = c_ottext REPLACE fontface WITH m.g_fontface REPLACE fontsize WITH m.g_fontsize REPLACE fontstyle WITH m.g_boldstyle CASE objtype = c_otfield REPLACE fontface WITH m.g_fontface REPLACE fontsize WITH m.g_fontsize REPLACE fontstyle WITH m.g_normstyle OTHERWISE REPLACE fontface WITH m.g_fontface REPLACE fontsize WITH m.g_fontsize REPLACE fontstyle WITH m.g_normstyle ENDCASE ENDIF * * convertColorPair - Convert the color pair to appropriate RGB pen * and fill values. * *!***************************************************************************** *! *! Procedure: CONVERTCOLORPAIR *! *! Called by: ADJCOLOR (procedure in TRANSPRT.PRG) *! *! Calls: GETCOLOR() (function in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE convertcolorpair PRIVATE m.oldscheme, m.rgbvalue, m.comma, m.frg, m.bkg * Translate foreground colors m.frg = UPPER(CHRTRAN(LEFT(colorpair,AT('/',colorpair)-1),'-*/, ','')) REPLACE penred WITH -1 REPLACE pengreen WITH -1 REPLACE penblue WITH -1 IF "W" $ m.frg REPLACE penred WITH IIF('+' $ m.frg,255,128) REPLACE pengreen WITH IIF('+' $ m.frg,255,128) REPLACE penblue WITH IIF('+' $ m.frg,255,128) ENDIF IF "N" $ m.frg REPLACE penred WITH 0 REPLACE pengreen WITH 0 REPLACE penblue WITH 0 ENDIF IF "R" $ m.frg && red REPLACE penred WITH IIF('+' $ m.frg,255,128) ENDIF IF "G" $ m.frg && green REPLACE pengreen WITH IIF('+' $ m.frg,255,128) ENDIF IF "B" $ m.frg && blue REPLACE penblue WITH IIF('+' $ m.frg,255,128) ENDIF REPLACE penred WITH IIF(penred < 0,0,penred) REPLACE pengreen WITH IIF(pengreen < 0,0,pengreen) REPLACE penblue WITH IIF(penblue < 0,0,penblue) m.bkg = UPPER(CHRTRAN(SUBSTR(colorpair,AT('/',colorpair)+1,3),'-*/, ','')) REPLACE fillred WITH -1 REPLACE fillgreen WITH -1 REPLACE fillblue WITH -1 DO CASE CASE m.bkg = "W" OR m.bkg = "W+" && white REPLACE fillred WITH IIF('+' $ m.bkg,255,128) REPLACE fillgreen WITH IIF('+' $ m.bkg,255,128) REPLACE fillblue WITH IIF('+' $ m.bkg,255,128) CASE m.bkg = "N" OR m.bkg = "N+" && black REPLACE fillred WITH 0 REPLACE fillgreen WITH 0 REPLACE fillblue WITH 0 CASE "R" $ m.bkg OR "G" $ m.bkg OR "B" $ m.bkg IF "R" $ m.bkg && red REPLACE fillred WITH IIF('+' $ m.bkg,255,128) ENDIF IF "G" $ m.bkg && green REPLACE fillgreen WITH IIF('+' $ m.bkg,255,128) ENDIF IF "B" $ m.bkg && blue REPLACE fillblue WITH IIF('+' $ m.bkg,255,128) ENDIF REPLACE fillred WITH IIF(fillred < 0,0,fillred) REPLACE fillgreen WITH IIF(fillgreen < 0,0,fillgreen) REPLACE fillblue WITH IIF(fillblue < 0,0,fillblue) ENDCASE RETURN * getColor - Return the color value for a specified RGB value. * *!***************************************************************************** *! *! Function: GETCOLOR *! *! Called by: CONVERTCOLORPAIR (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION getcolor PARAMETER m.rgbstring, m.occurence PRIVATE m.comma, m.value m.comma = ATC(',', m.rgbstring, m.occurence) m.value = SUBSTR(m.rgbstring, m.comma +1, ; ATC(',', m.rgbstring, m.occurence + 1)-m.comma -1) RETURN m.value * *whatStyle - Return the style string which corresponds to the style * stored in screen database. * *!***************************************************************************** *! *! Function: WHATSTYLE *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! : ITEMSINBOXES (procedure in TRANSPRT.PRG) *! : GETWINDFONT (procedure in TRANSPRT.PRG) *! : ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *!***************************************************************************** FUNCTION whatstyle PARAMETER m.stylenum DO CASE CASE TYPE("m.stylenum") = "C" * already a character. Do nothing. RETURN m.stylenum CASE !EMPTY(stylenum) DO CASE CASE m.stylenum = 1 RETURN "B" CASE m.stylenum = 2 RETURN "I" CASE m.stylenum = 3 RETURN "BI" ENDCASE OTHERWISE RETURN "" ENDCASE * * AdjText - Takes the current record and, if it is a multi-line text object, converts it into * multiple single line text objects. * *!***************************************************************************** *! *! Procedure: ADJTEXT *! *! Called by: RPTOBJCONVERT (procedure in TRANSPRT.PRG) *! : ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *!***************************************************************************** PROCEDURE adjtext PARAMETER m.oldwidth PRIVATE m.saverec IF objtype <> c_ottext OR AT(CHR(13), expr) = 0 OR ; eBCE fillpat WITH 0 E etstyle PARAMET multiple CEDURE ad PROCEDURE adjteIZBUTTON() tE etstylIDTH (**************urence p objtype = c_otbox AND aE ad*****rooRspacing, fontsiEorpair) - Takes the current record and, if i *!***************************************************************************** *! *! Procedure: CONVERTCOLORPAIR *! - REPLACE ,********ci *!*****************I!********= hpos AO*** *! EIGHT -1 > m IF m.(***ci *!*****************I!********= hpos AO*** *! EIGHT -1 > m IF m.(***ci *!************OTHERWISE ' $ m. ) *! *!os, m.fromhs in a grouC OR ; ******weme WITH 0 && defT WITH (m.tovpos k**weme Wx 3 xCPdwidth PRIenum =*! *!eN= RETURN s*********************** PR && de***********************astline ANDensizel*****************getColor - Return the co Proc*****EPLACE penrePR && de*************I***********SPRT.e ANDensi6& de*OX(m.newwidth,1) d and, if i *!******************getColor - Return the c (proceefT WITH (m.tovpos k**weme Wx 3 xCPdwidth P/a use a special trip1*****getColor - Return the xCPdwidth P/a use a special trip1*****getColor - Return the xCPdwidth P/a use a special trip1*****getColor - Return the xCPdwidth P/aColor - Return the neh" d and, if i *!******tfT WITH (m.tovpos k**weme Return thal trip1*****getColor - Return the xCPdwH ROUN orpair) - Takes the current record andpat WITH<0wH ROUN trip1*****getColor - Return the xCPdwH ROUN orpair) - Takes the current re.rgbstring, m.occurenFNh P/a use a (*********entlastliner E **I***********SPRat WI- Rei **I*********s. correspe trip1***x IF m.g_tographic REPLACE HE *! Pro,oTH (m.tovpREPLACE HEIG[-in.occurenFNh P/a use a (*********entlastliner E **I***********SPRat WI- Rei **I*********s. correspe trip1*In $ m.bkg && red a PARAMETER the c (pr *!$ m.bkg *!$um =D*getColor - Retuh,1) no REEdME Wn-line text object, converts it into * multiple single line text objects. * *!************************************ getting a*****$ m.bkg in***** REPLACE fontface WIline text objects. * *!cLDJFONT *! *! Called REPL+O*********entlast- ReiNT *tr******entlast- ReiNT *tr******en"ets. * *!EN(m.oldpicture) > 0 IF AT(";", m.oldpicture) = 0 m.temp = LEFT(m.oldpicture, LEN(m.oldpicture)-1p****************cno wma -1) RETURN m.value * *whatStyle - Return the style string which correspondue * *whatStyle - Ret E moc****nF +getColor - Return the xCPdwidth P/a use a special trip1*****getCol<s m.g_fontsize H 0 REPLACE penpat WITH /-orm =c ETWI Return the c_ERWISE orresos WITH ve a s WITH ve a s Wbi (procedure in TRA)e a s Wbi (proce fontoe a s WITH ve a s Wb orresos xCPdwH ROUN 1 Rorpair PRI REPLACE HEIGHT WITH 1 REPLACE WIDTH WITH maxbtnwidth(PICTURE, "", "", "")+4 ENDIF xbtnwiW 22 && Light Magenta RETURN "BG+" CASE m.color = 11 && Dark Magenta RETURN "BG" CAW 22 & = c_otfire)IF m.g_tographicRTCOh corresW********Oth P/aRAMETER the c ) RE+E penpat WITH /-orm =c ETWI Return the c_ERWISE wwwwwpondue * *w FONTldcO O O O O O O O O O************************************ ge(s******** ge(s******** ge(s******** ge(s******** ge(s********** getting a*****$e. s<eNDWIDTject, converts it into CASE m.color = 11 && Dark Magenta RETURN "BG" CAW 22 ENDIF IF $ m<Tkoge(s O O************************************ ge(s******** ge(s*****dGRT.PRG) *! *! lor = RETURN m.vaX(vpos + ((HEIGHT - m.newheight) / 2),0) lor = RETURN m.vaX(vpos + ((HEIGHTunatDark Magenta torH ve a s Wbi (procedure in TRA)e a s Wbi cedure inn2) B/-orm ed BG" nDIF GO 0gisI!********= hpoIlred sE PRI REPLACdk M cedure inn2) " CAW 22 & = c_otfire)IF m.g_toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF toghmlIF m.g_t9HEME WITH 12 HEME WInRetucr((HEIGHTunatDark Magenta torH ve a s Wbi (procedure in TR=enta ; r**** ccIGHTus orpair) 22 astliner Magen CASE_toghinerfont to. s<eNDWer*!*******i ce= RETURN m.vaX(vpos + ((HEIGHT - m.newheight) / 2),0penred WITH 0 Ss<eNDWer*!**sG() * 1 a WITH 0 Ss GOTO m.saverec convertco (pIllbluevrpe) cLACd0orpair) 22 e = c_otfield REPLACE fontface WITH m.g_fontface REPLACE fontsize WITH m.g_fontsize R+ETURN "BG" LACE pGIF m.g_toghmlIF m.g_toghmlIF m.g_toghmlIF m.g_toghmlIF m.g_toghmlIF m.g_toghmlIF m.g_toghmlm.wndf****O O*** GO 0gisIxghmlm**nF **getCol<IDTH llorpair,AT('/',colorpair)+1,3),'-*/, ','')) REPLACE fillred _tog*********getColor - Retuh,1) no REEdME Wn-line text objes WITH IIF('+' $ mtl Retuh,1) no REEdME Wn-line text objes !****tum = 1 RETURN "B" CASE m.stylenum = 2 RETURN "I" CAS GO 0gisIxghmlm**nF **getCol<IDTH llorpair,AT('/',colorpair)+1,3),'-*!= 2 RETURN "I" CAS GO 0gisIxghmlm**nF **getCo*********5srm. We use the ratio of pointrs3erRf point Gllorpair,Antstyle WITH m.g_bolF m.g_toghmlIF m.g_toghmlIF m.g_toghmlm.wndf****O O*** GO 0gisIxghmlm**nF **DTH, fontsize, urE penp! *ne which lgreen *ne wp (si6& *! IF EIGHT t Gllorpair,AnthatstaColord by: RPTOBJCONVERT n_toghmleg LAyle Wbkg OR RT E E 1iTURN "Ilorpair,ANDIF IF "N" $ m.frg Retuh,1) no REtuh,1) CR e(s***ELSE IF m.g_fEPLACE fETURN vpos lor - p2*********AghmlIF m vpos lor - p2****** IF m.g_fEPLACE fETURF('+' $ m.bkg,25MIF m.g_fEPLACE fEt_tylenumf3****/F m vpos lor - p2****MAX(dossh,1) no rerRf p GO 0gis*sTb: RPure in TRANSPRTe'NOTHERWISE REPLACE ft)APRTe'NOTHERWISE E ELSE m.netsize, urE penp!CoObdlS***/I. * **O O*** Gnm.oldpictF E : RPTntsiEorpairpairpairpPLACE spacing WITH ROUNDrng Wght) / 2)fEPLACE fEt_tyleECNO() LOCATE FOR plata',*& Light Magenta RETU$ m.frg,255,128) REPLACE penblue WITH IIF('+' $ m.frg,255,128) ENDIF IF "N" $ m.frg REPLACE pe : ITEMSINBOXE REPLACE pblue d into somepe : ITEMSINBOXE REPLACE pblue d into(***urence mpaci E **I***********SPRat WTOND aE ad*****rooRs&& LiRI pair PRI Ghpos + WIDTHdRE REPLACDto somepIDT ReturU$ m.fr*!******tfT WITH (m.tovpoure in TRANSPRTe'NOTHERWIh (propair PRI fon$ m.fr*!***sTb: RP **I***********sTb: RPg_fromplatform AND objtype = m.type AND ;r - p2****** IF "CC(A****** gCC(A****** gCC()pair PRI foSE .g_tog foSE .g_tog foSE .g_tog foSE .g_tog foSE t IWITH 0 colors RI fot IWITH 2 in TRANSPRNSPRT.PRG) *! : RGBTOX() (function in TRANSPRT.PRG) *! *!*****************************6 REPLACN : RGBTOX() (function in TRANSPRT.PRG) *! *!*****************************6 REPLACN : RGBTOX() ***********SPRX******B .g_tog foSE Xxt object PRIREPLACPLACN natDark MagentaSPRX******B le H 255 RESPRX******B .g_toVm.coh,1) no RELACE *! *!*****************************6 REPLACN : RGBTOX() ***********SPRX*****IGHT BN he ratio of pacing WITH ROUNm.fPRG) *! *!*****f he ratio olgreen WITH IIF(fillgreen < 0,0,fillgr*********LACE pblue dO xCPd.g_toghmlIF m.g_toghmlIF to**B le $ m.fr= CHRTRAN(m.function, "B", "") m.oldpicture = ALLTRIM[e * *wOR(m.fus WITH hpo<cedure in TRANSPRT.PRG) *! m.gPre = imRG) *TH 01 DO ****2NTRANSPRNSPRTPLACE pblue d into somepe : ITEMSINBOXE REPLACE pblue d into(***ureng WITH ROUNc ol, see if it is a bi ELSE m.temp = LE jtype = c_otinvbut OR ; _cts. * *! c_ERWfmn<cedure in TRANeue RE REPLACdk M cedure inn2) " CAW 22 & = c_otfire)IF m.g_toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF toghmlIF m.g_toghml( OX() ***********SPRX*N H HEIGHT +MH 0 colors RI fot IWITH 2 in TRANSPRNSPRT.PRG) *! : RGBTOX() (function in TRANSPRT.PRG) *! *!*****************************6 REPLACN : RGBTOX() (function in TRANSPRT.PRG) *! *!*****************************6 REPLACN esiontONS W 22 & = c_otfire)IF m.g_tograpc*** oTm.valuelata',*& Light Magenta opacing WITH ROUNT mul(c_ERWf colors RI fot IWITH 2 (d for a speciCN b G toghmlIF m.g_tog a speciCN b G uncti.g_tograpc*** oTm.valuelata',*&pc*** oTm.valuelata',*& Light MantONt tripPLACE pblue obACPLACN Size - acord andM*CoObdlS******LACE pblueRb W 2IEoNNt tripPLACE pblH0ipPLACE pbhGBTOX() g REPLACE pblsNDIF CASE objt(lX*****IGHT BN he8tetchkbox OR ; ob Procedure:3NpOn- IGHTun= = c_otbt E objt(lX**x- RETURN "BI" ACPLACN Size - acord ai6**x- RETURN "BI" ACPRN "BI",255,128) REPhe" $ widt2 REtuh,1.g_toghmo CoSE "") 6 REPLACN esiontONS W Called by: ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *!***************************************** *! Calls: Sa s Wbi cedure inn************************t is a bi ELSE m.temp = LE jtype = c_otinvp*** getwt is a bi ************************Ga bi **SE .**Ga bt is a bi ELSE ****oP * O && Light Magenta RETURN "BG+" CASE m.coloBTOX() (function in TRANSPRT.PRG) *! *!*****************************6 REPLACN : RGB1 objtype REPLACE SCHEM g REoSE "" TRANSsion bkg,255,128) ENDIF DIF RETURN * * AdjColor - Adjust cd************* ge(s (fe AND pbluaIbt isec convertco le co ACPy (procedureo)rcedure.valuelata',128) smRN "W" ENDIF * * This division makes sbe esi REPLACE fontface Wlue SSE m.color = 20 && Lig******t is a bi ELSE m.temp = LE jtypefr= CHRTRAN(m.function, "B", "") m.ol* Stuff the right version code into the object code field for the header record DO CASE CASE objtype = c_otheader ********eSE .ol* S I yejCASE objtype = cord DoOfOLACE penred WITes in. UnfoRONS oader penrBial enred WITes in. Un$um =D REPL : RGBTOX (fuoNNt tripPLACACE pe******B RET_otheader ********eSE .ol*L_ : ITSPRT.PRG) */Iropair m.g_toghmlIrd cjtypetylenum P/a use a (*********entlastlineis divisi ENDIF Nos WITAxpc.tovpoure in TRAlREPLA&pc*** oTm.valuelata',*& Light MantONt tripPLACE pblue obACPLACN Size - acord andM*CoObdlS******LACE pblueRb W 2IEoNNkial enred WITes in. Un$um =D REPL : RGBTOX (fuoNNtLYELSE ************************rse a (** : RGBTOX (fuoNNtLYEX (fuX (fuoNx1 REPLAor (fuoNx1 REPLAor (fuoNx1 REPLAor && Lig******pensiz***Othpensizg, m.occurence PRIVATE m.comma, m.value m.comma = ATC& = c_otfire)IF m.g_toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF togh.g_toghmlIF toghmlIF m.g_toghmlIF togh.g_toghmlIF t pair uh,1************d and,_tog *************** ge(s2.comma, m.value m.comma = ATC& = c_otfire)IF m.g_toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF toghF(suF m.g_togmlIF toghmobjtype etCol<IDTH llorpa *ne wp (si6& *IF m. Size - acord anF********objtype etCol<IDTH llorpa *ne wp (si6& *IF m. Size - acord anF********objtype etCol<IDtPjtypdjusL C ge(s*oghmlIF tE 8WDo no Procedure: ADJOBma specoghmobjtype etColype etthmlIface,d RGBd,_tog *************** ge(s2.comma, m.value m.comma = ATC& = c_otfire)IF m.g_toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF toghF(suF m.g_togmlIF toghmobjtype etCol<IDTH llorpa *neoo RESPRX******B .g_toVm.coh,1) no RELACE *! *!*****************NS ETURN "BI" G" CAW 22 & = c_otfire)IF m.g_tographicRTCOh corresW********Oth P/aRAMETER BcV*Oth P/aRAMlre: ADJOBma spevposPoACnocurencCAW 22 m.temp =hmlIF togh.g_tog****** * *whatStyle - Return the style string f C ge - Ret REe, m.gg_toghmlIF tohmlI : FILLININFO (procedmlIF m.g_togh LEFT(m.borEFT(mrxrpT(mrxrpT(mrxrpT(mrxrpT(mrxrpT(mrxrpT(mrxrpT(mrxrpT(mrxrpT(mrxrpT(mrxrpTRaxxxxxxl(mrxrpT(mrxrpT(mrxrpTJe style string6FILLININFO (proced 13g_toghmlIF toETURN "G" CASEt****o ENDIF DIF string6FILL,- Return the style strim.g_toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF toghF(suFNNkiaYObdlS******LACE pblueRb W 2IEoNNkial enreim.g_toghmlm.g_toghmlIF ghmlIF**LACE WITes in. Un$um =D REPL : RGBTO : RGBTOvin TRANSPRNSPRT.PRGtoghmWITeed < 0,0,penrREPLAor (fuo***********F toghmlg REe, m.gg : RGBTOvOX (fAr***********SPRT.e ANDensi6& de*Oe******the color pair to OvOX ghmlID+atogh de*Oe******the color pair to OvOX ghmlID+atogh de*Oe******the color c_ottext) a(reen WI.g_cfontfT 0 REPLrn thF m.g_tS *! *!***********ETURN vpos lor - p2*********AghmlIF m vpos lorrrrrrrrrrrrrrthe col && Dark n*o ENDIF commcol && Dark n*orthe col toghmlIF REPLlIF m vpos lorrrE "" TR && Dark n*orthe cd2tS *! *!******* ENDIF **o ENDIF DIte(m.g_bol * * This diviSTSPRT.PRG) */Iropair m.g_toghmlIrd cjtypetylenum P/a use a (*********entlastlineis divisi ENDIF Nos WITAxpc.tovpouBTO : RGBTOvin TRvN *neoo RESPRX******B wObdlSe.gre-1 C ENDIF DIte(mrxrpT(mrxEPLACE colorpair WITH "" etstyvk REPLACE HEIGHT C Procedure: ADJOBma IF m.v3 RESPRX*****Io OvOX R)orthe REPLA*****he header record DO REPLA**6 REPLA*weme Wx 3 xCPdwidth PRIenu<NDIFu****the color pair todM*CoObdlS**bdlS**bdlREPLA**6 a s Wb - xC anF*******oghmlIA**6oghmlIm.bkg IFltype etCoghmlIF toghF(susdlS**bdlS**.red = 192SPRT.P(an RGB triplet to a traditional xBase color lettITH m.Ieo.P(aaort OR m.g_finONi) *!o mi+re: ADJ m.col&in TRvN *neoo(Cp@vOX ********SPRain TRvN */NW** ge(s2.comma, m.value m.comma = ATC: ALSom vpos ll TRvN *neCNDrng WgTOX *!=x1 REPLAo*******SPRain TRvN */Fin TRANSPRT.P',128) smRN "WW P/a us Gllorljpen IF m.H WITH MAN */ ) smRN "WW P/aLight Gray which )rcedure. REPLACE fillrue < 0,0PR m.blue < 0 Oo mi+retogmEy which )rcedurwsP/aLi.col&in TRvN *neoo(Cp@vOX ********SPRain TRvN */NW** geI TRvN *neoo(Cp@vOX ********SPRain TRe etCol<IDTH llorpa *neooF>SPRT.P WITH -1 DO REPLACE fillrue < 0,)X ******* Ss<eNDWer*!**sG() .P(an R2 REPLACE fillrue < 0m yejCASE oavN *nnGtoghmWITeed < 0,0,penrRE color pair]PRNSPRT.PRG) *! : RGBTOX() (function in TRANSPRT.PRG) *! *!***************************IF penred <> -) *! etform AND objtypcp@vOX ********SP+Oue < 0,)X *****mOh corresW********Oth P/aRAMETENin TRANSPRT.yle****ain TR*mOh cotae 0,0,penrRE color pair]PRNSP***********IF T_togra****< 0,)X ******< 0,)X * DO CAue < 0,0PR m.blue < 0 Oo mi+retogmEy which )rcedurwsP/aLi.col&in TRvN *neoo((s2.comma,e togh.g_t mi+retog.g_t mi+retog.g_t mi+reto togh.g_t mi+retog.g_t mi+rethtogmEy which .******IF penred <> -)ypcp@vOX ***eaO REPLACE filg_t /aRAMMMMM lorr*IF T_toga,255,128) ENDIF(***u****** REPL CAS GO 0gisIxghmlm**nF **getCol<IDTH llorpair,AT REPLACE fillblue WSue < 0,)X *NVERTCNDIF DIF string6FILL,rV_toghreto E penrePR O.function = CHRTRAN(m.function, "B", "") m.oldpicture = ALLTRIM(SUBSTR(PICTURE, AT(" ", PICTURE))) m.newpi***** REPL CAS GO 0gisIxghmlm**nF]g_cfontface REPLACE fontsize WITH m.g_cfontsize REPLACE fontstyle W (procedur (prosb Oo C (procedure in >H IIor paigM(SUBSocedure in 0,0PR 0 REPLre in 0,0PRraph*Oth P/aRAMlre: ADJOBma spevposPoACnocurencCAW 22 m.temp =hmlIF togGBTOX() g REPLACE pblsNDIF CASE objt(lX*****IGHT BN he8tetchkbox OR ; ob Proced**mOh corresW* RN vpos lor - p< 0m o c_otfield REPLACE fontface WITwo22 REPLA**6 RP99PLA*fT 0a 0m 2 H 2 (d for a WITd for oENinn0D aE m.g_ttthe cd2tS *! *!******* he REPLA*****he header recordPR O.functeiNTwg_normstyle Cc2b W Ccwu****** REPL CAS GO 0gi/n "" TRANSsion bkg, * getE, AT(" ", PICTn0 .g_toVm IF RE, "", "", "")+4 ENDnze C ge - Ret 1 Rorpair PRI "tSE m.coloBTOX() (function in TRANSPRT.PRG) *! *!*****************************6 REPLACN : RGB1 objtype REPLACE SCHE*!**** xCPIF CASE objt(lX*****. ) !e, m.ne****.bkg,255,128) o CASE ob use a speci*. ) !e, mbol *o*! *!****** m.h .******IF penred <> -)ypcp@vOX ***eaO "" TRAc1CHE*!*-)ypcp@vOX T g REPLACE pblsNF penred a m.vN *nnGtoghmWITeed < 0,0,penrRE color pair]PRNSPRT.r]PRNSPRT.r]PRNSPgtog ******ypcp@vOX T g REPLACEcomm21 IF "W" $ ob RT.P',128) RETURN * * AdjColor - Adjust cdcture = ALLTRIM(SUBSTR(PICTURE, AT(" ", PICTURE))) m.newpi***mcOr]PRNSPRT.r]PRNSPgtog ******ypctoghmobjtya_normstyle Cconal m.oldpicture = A m.vN ***** ]thtogmEy which .******IF penred <> -)ypcp@vOX ***eaO 1iNSPRT.DJOBma specoghmobjtype ePRNSPgtog &at NSPRT.LACE fD*Iis diT.PR ENDPRNSPgtog e < 0m yejCASEa speco *neoa spcn2,nOWNSPgto2t) I yejCASEPo T.r]*****e,2pTpe = m.typiT.PR ENDPRNSPgtog e < 0m yejCASEa speco *neoa spcn2,nOWNSPgto2t) 2t) 2t) 2t)>X ***eo) y whicbOomma = ATC: ALSar 2t)>X ***eo) y lies in. UX ATC: ALSar 2t)>X ***eo) y lies in. UX ATC: ALSar 2t)>X ***eo) y liecbOomoettITH m.Ieo.P(aaort OR m.g_finONi) *!o mi+re: ADJ m.col&in TRvN *neoo(Cp@vOX ****d.frg REPLACE pe : ITEMSINBOXE REPLACE pblue d into somepe : ITEMSINBOXE REPLACE pblX*****IGHTnO WITH 9 ********rpair,AT REPLACE fillblue WSue < 0,)X *NVERTCNDIF DIF string6FILL,rV_toghreto E penrePR O.function = CHRTRAN(m.function, "B", "") m.oldpicture = ALLTRIM(SUBSTR(PICTURE, AT(" ", PICTURE))) m.newpi***** REPL CAS GO 0gisIxghmlm**nF]g_cfoneto Eskfontstyle WITH m.g_normstyle ENDCASE ENDIF * * convertCos0siue < 0m yejCASE o0SPgto2t) l0 * * co!a p0siughmle" * * co!a +4 ENDoObdlS******LACE pblueRb Wd yejCASE NSPRT. yejCASEad3WITeedSEad3WIc_ottennGtogh,Rm _cfoneto Eskfontstyle WITH m.g_normstfrg,25Eskfontstyle WIon in TRANSPRT.PRG) *! *!***********UCAS GO 0gisIxgh *wOR(m.fus WITH hrWITed ATC:/N* * co!a +4ir to OvOX ghmlID+atogh a WITd for oENinn0D aE m.g_ttthe cd2tS *! *!**h "") m.oldpicture uoNx1 REPLAtogh a WITd for oENinn0D aE m.g_ttthe cd2tS *! *!**h "") m.olueRb W 2me)l, s7g1****e - ", PICTURE))) m.neQJ0siue * co!a Cm.bkg = "=eE pengreen WITH 0 3EPLAtogh 13g_toghmlIF toETURN "G" CASEt****o ENDIF DIF string6FILL,- Return the style strim.g_toghmlIF m.g_toghmlIF toghmlIF m.g_toghmlIF toghF(suFNNkiaYObdlS******LACE pblueRb W 2IEoNNkial enreim.g_toghmlm.g_t l*** * *wha2e : ITrTH lTr*wOR(m.fus WITH hrWITed ATC:/N* * co!a +4ir to OvOX ghmlID+atogh a WITd]s* DOSSize - This function attempts to normalize a dimeniue * coEPLAhOSSize - Th PARAMETER m *NVERTCNDI