home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database / CLIPR503.W96 / RLBACK.PR_ / RLBACK.PR
Text File  |  1995-06-26  |  40KB  |  1,464 lines
  1. /***
  2. *
  3. *  Rlback.prg
  4. *
  5. *  Copyright (c) 1987-1993, Computer Associates International, Inc.
  6. *  All rights reserved.
  7. *
  8. *  Note: Compile with /m /n
  9. *
  10. */
  11.  
  12.  
  13. ***
  14. *  Function   :  LBL_LOAD()
  15. *  Purpose    :  Reads a label <.LBL> file into the label system
  16. *             :  <.MEM> and <.DBF> files.
  17. *
  18. *  Convention :
  19. *
  20. *     status = LBL_LOAD(lbl_file, dbf_file, mem_file)
  21. *
  22. *  Parameters :
  23. *
  24. *     lbl_file -  string, label file to load.
  25. *     dbf_file -  string, data file for contents description.
  26. *     mem_file -  string, memory file for specs.
  27. *
  28. *  Return     :
  29. *
  30. *     status   -  logical, sucess of load operation.
  31. *
  32. *  Externals  :
  33. *
  34. *     FOPEN(), FCLOSE() FREAD(), FERROR(), CREATE_DBF(), WORD_2_NUM()
  35. *
  36. *  Notes      :   Label file passed with extension.
  37. *             :   <.LBL> not found, init <.DBF> and <.MEM> with defaults.
  38. *             :   File error number placed in file_error.
  39. *
  40. FUNCTION LBL_LOAD
  41.  
  42. PARAMETERS label_file, dbf_file, mem_file
  43.  
  44. PRIVATE i, buff_size, buff, handle, read_count, status, offset,;
  45.    lbl_remark, lbl_height, lbl_width, lbl_margin, lbl_lines, lbl_spaces,;
  46.    lbl_across
  47.  
  48. buff_size = 1034              && size of label file.
  49. buff      = SPACE(buff_size)
  50.  
  51. i          = 0
  52. handle     = 0
  53. read_count = 0                    && read/write and content record counter.
  54. status     = .F.
  55. offset     = 74                   && start of label content descriptions.
  56.  
  57. DECLARE ffield[1]
  58. DECLARE ftype[1]
  59. DECLARE flength[1]
  60. DECLARE fdecimal[1]
  61.  
  62. ffield[1]   = "CONTENTS"
  63. ftype[1]    = "C"
  64. flength[1]  = 60
  65. fdecimal[1] = 0
  66.  
  67. ** Create label line transfer <.DBF>. **
  68. IF CREATE_DBF(dbf_file, 1, ffield, ftype, flength, fdecimal)
  69.  
  70.    ** Open the label file **
  71.    handle = FOPEN(label_file)
  72.  
  73.    ** File does not exist **
  74.    file_error = FERROR()
  75.    IF file_error = 2
  76.  
  77.       ** Initialize default values **
  78.       lbl_remark = SPACE(60)
  79.       lbl_height = 5
  80.          lbl_width  = 35
  81.          lbl_margin = 0
  82.          lbl_lines  = 1
  83.          lbl_spaces = 0
  84.          lbl_across = 1
  85.  
  86.       SAVE ALL LIKE lbl_* TO &mem_file
  87.  
  88.       ** Append default number blank lines to file  **
  89.       USE &dbf_file
  90.       FOR count = 0 to (lbl_height - 1)
  91.          APPEND BLANK
  92.          REPLACE contents WITH SPACE(60)
  93.       NEXT
  94.       CLOSE DATABASES
  95.  
  96.       status = .T.
  97.  
  98.    ELSE
  99.  
  100.       ** OPEN ok? **
  101.       IF file_error = 0
  102.  
  103.          ** Read label file **
  104.          read_count = FREAD(handle, @buff, buff_size)
  105.  
  106.          ** READ ok? **
  107.          IF read_count = 0
  108.             file_error = -3         && file is empty.
  109.          ELSE
  110.             file_error = FERROR()   && check for DOS errors
  111.          ENDIF
  112.  
  113.          IF file_error = 0
  114.  
  115.             ** Load label dimension to mem file **
  116.             lbl_remark = SUBSTR(buff, 2, 60)
  117.             lbl_height = WORD_2_NUM(SUBSTR(buff, 62, 2))
  118.             lbl_width  = WORD_2_NUM(SUBSTR(buff, 64, 2))
  119.             lbl_margin = WORD_2_NUM(SUBSTR(buff, 66, 2))
  120.             lbl_lines  = WORD_2_NUM(SUBSTR(buff, 68, 2))
  121.             lbl_spaces = WORD_2_NUM(SUBSTR(buff, 70, 2))
  122.             lbl_across = WORD_2_NUM(SUBSTR(buff, 72, 2))
  123.  
  124.             SAVE ALL LIKE lbl_* TO &mem_file
  125.  
  126.             ** Load label line content expressions to file **
  127.             USE &dbf_file
  128.             FOR i = 0 to (lbl_height - 1)
  129.                APPEND BLANK
  130.                REPLACE contents WITH SUBSTR(buff, offset, 60)
  131.                offset = offset + 60
  132.             NEXT
  133.             CLOSE DATABASES
  134.  
  135.             ** Close file **
  136.             FCLOSE(handle)
  137.             file_error = FERROR()
  138.          ENDIF
  139.       ENDIF
  140.  
  141.       ** Label file loaded ok? **
  142.       status = (file_error = 0)
  143.  
  144.    ENDIF
  145. ENDIF
  146.  
  147. RETURN (status)
  148. // eofunc LBL_LOAD
  149.  
  150.  
  151.  
  152. ***
  153. *  Function   :  LBL_SAVE()
  154. *  Purpose    :  Writes contents of the label system <.DBF> and
  155. *             :  <.MEM> files to a <.LBL> file.
  156. *
  157. *  Convention :
  158. *
  159. *     status = LBL_SAVE(lbl_file, dbf_file, mem_file)
  160. *
  161. *  Parameters :
  162. *
  163. *     lbl_file -  string, label file to load.
  164. *     dbf_file -  string, data file containing label line contents.
  165. *     mem_file -  string, memory file label dimension.
  166. *
  167. *  Return     :
  168. *
  169. *     status   -  logical, success of save operation.
  170. *
  171. *  Externals  :
  172. *
  173. *     FCREATE(), FCLOSE(), FWRITE(), FERROR(), NUM_2_WORD()
  174. *
  175. *  Notes      :   Label file name passed with extension.
  176. *             :   File error number placed in file_error.
  177. *
  178. FUNCTION LBL_SAVE
  179.  
  180. PARAMETERS label_file, dbf_file, mem_file
  181.  
  182. PRIVATE label_image, label_size, content_size, handle, write_count,;
  183.    status, i, lbl_remark, lbl_height, lbl_width, lbl_margin, lbl_lines,;
  184.    lbl_spaces, lbl_across
  185.  
  186. label_size   = 1034        && size of label file.
  187. label_image  = ""          && holds modified label for write operation.
  188. content_size = 960         && content area of file holds 16 60-byte records.
  189.  
  190. write_count = 0            && bytes written.
  191. handle      = 0
  192. i           = 0            && record counter.
  193. status      = .F.
  194.  
  195. ** Create the label file **
  196. handle = FCREATE(label_file)
  197.  
  198. ** Open ok? **
  199. file_error = FERROR()
  200. status = (file_error = 0)
  201.  
  202. IF status
  203.    ** Restore label dimension values **
  204.    RESTORE ADDITIVE FROM &mem_file
  205.  
  206.    ** Build new file image. **
  207.    label_image = CHR(2) + lbl_remark + CHR(lbl_height) + CHR(0);
  208.                + CHR(lbl_width) + CHR(0) + CHR(lbl_margin);
  209.                + CHR(0) + CHR(lbl_lines) + CHR(0) + CHR(lbl_spaces);
  210.                + CHR(0) + CHR(lbl_across) + CHR(0)
  211.  
  212.    ** Add contents fields to label file image **
  213.    USE &dbf_file
  214.    FOR i = 0 to (lbl_height - 1)
  215.       label_image = label_image + contents
  216.       SKIP
  217.    NEXT
  218.    CLOSE DATABASES
  219.  
  220.    ** Pad if needed **
  221.    IF i < 16
  222.       label_image = label_image + SPACE(content_size - (60 * i))
  223.    ENDIF
  224.  
  225.    ** Label file signature, 1034th byte **
  226.    label_image = label_image + CHR(2)
  227.  
  228.    ** Write new image to label file **
  229.    write_count = FWRITE(handle, label_image, label_size)
  230.  
  231.    ** WRITE error? **
  232.    IF write_count = 0
  233.       file_error = -2
  234.    ELSE
  235.       file_error = FERROR()
  236.    ENDIF
  237.  
  238.    ** Close file **
  239.    IF !FCLOSE(handle)
  240.       file_error = FERROR()         && write error detect may be covered up
  241.    ENDIF                            &&    if done differently.
  242.  
  243.    status = (file_error = 0)
  244.  
  245. ENDIF
  246.  
  247. RETURN (status)
  248. // eofunc LBL_SAVE
  249.  
  250.  
  251.  
  252. ***
  253. *  Function   :  FRM_LOAD()
  254. *  Purpose    :  Reads a report <.FRM> file into the report system
  255. *             :  <.MEM> and <.DBF> files.
  256. *
  257. *  Convention :
  258. *
  259. *     status = FRM_LOAD(report_file, dbf_file, mem_file)
  260. *
  261. *  Parameters :
  262. *
  263. *     report_file  -  string, report file to load.
  264. *     dbf_file     -  string, data file for column expressions.
  265. *     mem_file     -  string, memory file for report dimension.
  266. *
  267. *  Return     :
  268. *
  269. *     status   -  logical, success of load operation.
  270. *
  271. *  Externals  :
  272. *
  273. *     GET_EXPR(), GET_FIELD(), CREATE_DBF(), FOPEN(), FCLOSE(),
  274. *     FSEEK(), FREAD(), FERROR(), WORD_2_NUM()
  275. *
  276. *  Notes      :   Report file name has extension.
  277. *             :   File error number placed in file_error.
  278. *             :   WARNING!!!!!!->   Offsets start at 1.
  279. *             :      Offsets are into a CLIPPER STRING, 1 to 1990
  280. *             :
  281. *             :   WARNING!!!!!!->   The offsets mentioned in these notes
  282. *             :      are actual DOS FILE offsets. NOT like the offsets
  283. *             :      declared in the body of FRM_LOAD() which are CLIPPER
  284. *             :      STRING offsets.
  285. *             :
  286. *             :   Report file length is 7C6h (1990d) bytes.
  287. *             :   Expression length array starts at 04h (4d) and can
  288. *             :      contain upto 55 short (2 byte) numbers.
  289. *             :   Expression offset index array starts at 72h (114d) and
  290. *             :      can contain upto 55 short (2 byte) numbers.
  291. *             :   Expression area starts at offset E0h (224d).
  292. *             :   Expression area length is 5A0h (1440d).
  293. *             :   Expressions in expression area are null terminated.
  294. *             :   Field expression area starts at offset 680h (1664d).
  295. *             :   Field expressions (column definition) are null terminated.
  296. *             :   Field expression area can contain upto 25 12-byte blocks.
  297. *
  298. FUNCTION FRM_LOAD
  299.  
  300. PARAMETERS report_file, dbf_file, mem_file
  301.  
  302. ** Shared by FRM_LOAD() and its ancillary functions **
  303. PRIVATE lengths_buff, offsets_buff, expr_buff, fields_buff,;
  304.    field_width_offset, field_totals_offset, field_decimals_offset,;
  305.    field_content_expr_offset, field_header_expr_offset
  306.  
  307. PRIVATE i,  handle, read_count, status, pointer, fcount, fld_offset,;
  308.    file_buff, params_buff, size_file_buff, size_lengths_buff,;
  309.    size_offsets_buff, size_expr_buff, size_fields_buff, size_params_buff,;
  310.    expr_offset, offsets_offset, lengths_offset, fields_offset,;
  311.    page_hdr_offset, grp_expr_offset, sub_expr_offset, grp_hdr_offset,;
  312.    sub_hdr_offset, page_width_offset, lns_per_page_offset, left_mrgn_offset,;
  313.    right_mgrn_offset, col_count_offset, dbl_space_offset,;
  314.    summary_rpt_offset, pe_offset, plnpg_peap_pebp_offset, plus_byte,;
  315.    frm_pagehdr, frm_grpexpr, frm_subexpr, frm_grphdr, frm_subhdr,;
  316.    frm_pagewidth, frm_linespage, frm_leftmarg, frm_rightmarg,;
  317.    frm_colcount, frm_dblspaced, frm_summary, frm_pe, frm_pebp, frm_peap,;
  318.    frm_plainpage
  319.  
  320. i          = 0
  321. handle     = 0
  322. read_count = 0              && read/write and content record counter.
  323. pointer    = 0             && points to an offset into EXPR_BUFF string.
  324. status     = .F.
  325.  
  326. size_file_buff = 1990           && size of report file.
  327. file_buff = SPACE(size_file_buff)
  328.  
  329. size_lengths_buff = 110
  330. size_offsets_buff = 110
  331. size_expr_buff    = 1440
  332. size_fields_buff  = 300
  333. size_params_buff  = 24
  334.  
  335. lengths_buff = ""
  336. offsets_buff = ""
  337. expr_buff    = ""
  338. fields_buff  = ""
  339. params_buff  = ""
  340.  
  341. ** There are offsets into the FILE_BUFF string **
  342. lengths_offset = 5      && start of expression length array.
  343. offsets_offset = 115    && start of expression position array.
  344. expr_offset    = 225    && start of expression data area.
  345. fields_offset  = 1665   && start of report columns (fields).
  346. params_offset  = 1965   && start of report parameters block.
  347.  
  348. ** These are offsets into the FIELDS_BUFF string to actual values **
  349. ** Values are added to a block offset FLD_OFFSET that is moved in **
  350. **    increments of 12 **
  351. fld_offset            = 0
  352. field_width_offset    = 1
  353. field_totals_offset   = 6
  354. field_decimals_offset = 7
  355.  
  356. ** These are offsets into FIELDS_BUFF which are used to 'point' into **
  357. **    the EXPR_BUFF string which contains the textual data **
  358. field_content_expr_offset = 9
  359. field_header_expr_offset  = 11
  360.  
  361. ** These are actual offsets into the PARAMS_BUFF string which **
  362. **    are used to 'point' into the EXPR_BUFF string **
  363. page_hdr_offset = 1
  364. grp_expr_offset = 3
  365. sub_expr_offset = 5
  366. grp_hdr_offset  = 7
  367. sub_hdr_offset  = 9
  368.  
  369. ** These are actual offsets into the PARAMS_BUFF string to actual values **
  370. page_width_offset      = 11
  371. lns_per_page_offset    = 13
  372. left_mrgn_offset       = 15
  373. right_mgrn_offset      = 17
  374. col_count_offset       = 19
  375. dbl_space_offset       = 21
  376. summary_rpt_offset     = 22
  377. pe_offset              = 23
  378. plnpg_peap_pebp_offset = 24
  379.  
  380.  
  381. ** Default report values **
  382. frm_pagehdr   = SPACE(240)
  383. frm_grpexpr   = SPACE(200)
  384. frm_subexpr   = SPACE(200)
  385. frm_grphdr    = SPACE(50)
  386. frm_subhdr    = SPACE(50)
  387. frm_pagewidth = 80
  388. frm_linespage = 58
  389. frm_leftmarg  = 8
  390. frm_rightmarg = 0
  391. frm_colcount  = 0
  392. frm_dblspaced = "N"
  393. frm_summary   = "N"
  394. frm_pe        = "N"
  395. frm_pebp      = "Y"
  396. frm_peap      = "N"
  397. frm_plainpage = "N"
  398.  
  399.  
  400. ** Initialize transfer dbf creation arrays **
  401. fcount = 5
  402. DECLARE ffield[fcount]
  403. DECLARE ftype[fcount]
  404. DECLARE flength[fcount]
  405. DECLARE fdecimal[fcount]
  406.  
  407. ffield[1]   = "WIDTH"
  408. ftype[1]    = "N"
  409. flength[1]  = 2
  410. fdecimal[1] = 0
  411.  
  412. ffield[2]   = "TOTALS"
  413. ftype[2]    = "C"
  414. flength[2]  = 1
  415. fdecimal[2] = 0
  416.  
  417. ffield[3]   = "DECIMALS"
  418. ftype[3]    = "N"
  419. flength[3]  = 2
  420. fdecimal[3] = 0
  421.  
  422. ffield[4]   = "CONTENTS"
  423. ftype[4]    = "C"
  424. flength[4]  = 254
  425. fdecimal[4] = 0
  426.  
  427. ffield[5]   = "HEADER"
  428. ftype[5]    = "C"
  429. flength[5]  = 260
  430. fdecimal[5] = 0
  431.  
  432. ** CREATE the Report FIELDS reocrd transfer file. **
  433. IF CREATE_DBF(dbf_file, fcount, ffield, ftype, flength, fdecimal)
  434.  
  435.    ** Open the report file **
  436.    handle = FOPEN(report_file)
  437.  
  438.    ** File does not exist **
  439.    file_error = FERROR()
  440.    IF file_error = 2
  441.  
  442.       ** Save default report variables as initialize above **
  443.       SAVE ALL LIKE frm_* TO &mem_file
  444.  
  445.       ** Load at least one FIELDS (column) record **
  446.       USE &dbf_file
  447.       APPEND BLANK
  448.  
  449.       REPLACE width WITH 10
  450.       REPLACE totals WITH "N"
  451.       REPLACE decimals WITH 0
  452.       REPLACE contents WITH SPACE(254)
  453.       REPLACE header WITH SPACE(260)
  454.  
  455.       CLOSE DATABASES
  456.  
  457.       status = .T.
  458.  
  459.    ENDIF
  460.  
  461.    ** OPEN ok? **
  462.    IF file_error = 0
  463.  
  464.       ** Go to START of report file **
  465.       FSEEK(handle, 0)
  466.  
  467.       ** SEEK ok? **
  468.       file_error = FERROR()
  469.       IF file_error = 0
  470.  
  471.          ** Read entire file into process buffer **
  472.          read_count = FREAD(handle, @file_buff, size_file_buff)
  473.  
  474.          ** READ ok? **
  475.          IF read_count = 0
  476.             file_error = -3         && file is empty.
  477.          ELSE
  478.             file_error = FERROR()   && check for DOS errors
  479.          ENDIF
  480.  
  481.          IF file_error = 0
  482.  
  483.             ** Is this a .FRM type file (2 at start and end of file) **
  484.             IF WORD_2_NUM(SUBSTR(file_buff, 1, 2)) = 2 .AND.;
  485.                WORD_2_NUM(SUBSTR(file_buff, size_file_buff - 1, 2)) = 2
  486.  
  487.                file_error = 0
  488.             ELSE
  489.                file_error = -1
  490.             ENDIF
  491.          ENDIF
  492.       ENDIF
  493.  
  494.       ** Close file **
  495.       IF !FCLOSE(handle)
  496.          file_error = FERROR()
  497.       ENDIF
  498.    ENDIF
  499.  
  500.    ** File existed, was opened and read ok and is a .FRM file **
  501.    IF file_error = 0
  502.  
  503.       ** Fill processing buffers **
  504.       lengths_buff = SUBSTR(file_buff, lengths_offset, size_lengths_buff)
  505.       offsets_buff = SUBSTR(file_buff, offsets_offset, size_offsets_buff)
  506.       expr_buff    = SUBSTR(file_buff, expr_offset, size_expr_buff)
  507.       fields_buff  = SUBSTR(file_buff, fields_offset, size_fields_buff)
  508.       params_buff  = SUBSTR(file_buff, params_offset, size_params_buff)
  509.  
  510.       ** Extract Numerics **
  511.       frm_pagewidth = WORD_2_NUM(SUBSTR(params_buff,page_width_offset,2))
  512.       frm_linespage = WORD_2_NUM(SUBSTR(params_buff,lns_per_page_offset,2))
  513.       frm_leftmarg  = WORD_2_NUM(SUBSTR(params_buff,left_mrgn_offset,2))
  514.       frm_rightmarg = WORD_2_NUM(SUBSTR(params_buff,right_mgrn_offset,2))
  515.       frm_colcount  = WORD_2_NUM(SUBSTR(params_buff,col_count_offset,2))
  516.  
  517.       ** Extract characters **
  518.       frm_dblspaced = SUBSTR(params_buff, dbl_space_offset, 1)
  519.       frm_summary   = SUBSTR(params_buff, summary_rpt_offset, 1)
  520.       frm_pe        = SUBSTR(params_buff, pe_offset, 1)
  521.  
  522.       ** Process packed 'plus byte' **
  523.       plus_byte = ASC(SUBSTR(params_buff, plnpg_peap_pebp_offset, 1))
  524.       IF INT( plus_byte / 4 ) = 1
  525.          frm_plainpage = "Y"
  526.          plus_byte = plus_byte - 4
  527.       ENDIF
  528.       IF INT( plus_byte / 2 ) = 1
  529.          frm_peap = "Y"
  530.          plus_byte = plus_byte - 2
  531.       ENDIF
  532.       IF INT( plus_byte / 1 ) = 1
  533.          frm_pebp = "N"
  534.          plus_byte = plus_byte - 1
  535.       ENDIF
  536.  
  537.       ** Extract expression (strings) pointed to by pointers **
  538.  
  539.       ** Page Heading, Report Title **
  540.       pointer = WORD_2_NUM(SUBSTR(params_buff, page_hdr_offset, 2))
  541.       frm_pagehdr = GET_EXPR(pointer)
  542.  
  543.       ** Grouping expression **
  544.       pointer = WORD_2_NUM(SUBSTR(params_buff, grp_expr_offset, 2))
  545.       frm_grpexpr = GET_EXPR(pointer)
  546.  
  547.       ** Sub-grouping expression **
  548.       pointer = WORD_2_NUM(SUBSTR(params_buff, sub_expr_offset, 2))
  549.       frm_subexpr = GET_EXPR(pointer)
  550.  
  551.       ** Group header **
  552.       pointer = WORD_2_NUM(SUBSTR(params_buff, grp_hdr_offset, 2))
  553.       frm_grphdr = GET_EXPR(pointer)
  554.  
  555.       ** Sub-group header **
  556.       pointer = WORD_2_NUM(SUBSTR(params_buff, sub_hdr_offset, 2))
  557.       frm_subhdr = GET_EXPR(pointer)
  558.  
  559.       SAVE ALL LIKE frm_* TO &mem_file
  560.  
  561.       ** EXTRACT FIELDS (columns) **
  562.  
  563.       fld_offset = 12      && dBASE skips first 12 byte fields block.
  564.       USE &dbf_file
  565.       FOR i = 1 to frm_colcount
  566.  
  567.          ** APPEND and REPLACEs happen in GET_FIELD() **
  568.          fld_offset = GET_FIELD(fld_offset)
  569.  
  570.       NEXT
  571.       CLOSE DATABASES
  572.  
  573.       ** If we have gotten this far assume that the file is ok **
  574.       status = (file_error = 0)
  575.  
  576.    ENDIF
  577. ENDIF
  578.  
  579. RETURN (status)
  580. // eofunc FRM_LOAD
  581.  
  582.  
  583.  
  584. ***
  585. *  Function   :  GET_EXPR()
  586. *  Purpose    :  Reads an expression from EXPR_BUFF via the OFFSETS_BUFF.
  587. *
  588. *  Convention :
  589. *
  590. *     string = GET_EXPR(pointer)
  591. *
  592. *  Parameters :
  593. *
  594. *     pointer  -  numeric, 'pointer' to offset contained in OFFSETS_BUFF
  595. *                    string that inturn 'points' to an expression located
  596. *                    in the EXPR_BUFF string.
  597. *
  598. *  Return     :
  599. *
  600. *     string   -  string, retrieved expression, NULL ("") is empty.
  601. *
  602. *  Externals  :
  603. *
  604. *     WORD_2_NUM()
  605. *
  606. *  Notes      :   The expression is empty if......
  607. *             :      1. Passed pointer is equal to 65535.
  608. *             :      2. Character following character pointed to by
  609. *             :         pointer is CHR(0) (NULL).
  610. *             :   Called by the FRM_LOAD(), GET_FIELD()
  611. *             :   File error number placed in file_error.
  612. *
  613. FUNCTION GET_EXPR
  614.  
  615. PARAMETERS pointer
  616.  
  617. PRIVATE expr_offset, expr_length, offset_offset, string
  618.  
  619. expr_offset   = 0
  620. expr_length   = 0
  621. offset_offset = 0
  622.  
  623. string = ""
  624.  
  625. ** Stuff for dBASE compatability. **
  626. IF pointer != 65535
  627.  
  628.    ** Convert DOS FILE offset to CLIPPER string offset **
  629.    pointer = pointer + 1
  630.  
  631.    ** Calculate offset into OFFSETS_BUFF **
  632.    IF pointer > 1
  633.       offset_offset = (pointer * 2) - 1
  634.    ENDIF
  635.  
  636.    expr_offset = WORD_2_NUM(substr(offsets_buff, offset_offset, 2))
  637.    expr_length = WORD_2_NUM(substr(lengths_buff, offset_offset, 2))
  638.  
  639.    ** EXPR_OFFSET points to a NULL, so add one (+1) to get the string **
  640.    ** and subtract one (-1) from EXPR_LENGTH for correct length **
  641.  
  642.    expr_offset = expr_offset + 1
  643.    expr_length = expr_length - 1
  644.  
  645.    ** Extract string **
  646.    string = substr(expr_buff, expr_offset, expr_length)
  647.  
  648.    ** dBASE does this so we must do it too **
  649.    ** Character following character pointed to by pointer is NULL **
  650.    IF CHR(0) = SUBSTR(string, 1, 1) .AND. LEN(SUBSTR(string,1,1)) = 1
  651.       string = ""
  652.    ENDIF
  653. ENDIF
  654.  
  655. RETURN (string)
  656. // eofunc GET_EXPR()
  657.  
  658.  
  659.  
  660. ***
  661. *  Function   :  GET_FIELD()
  662. *  Purpose    :  Get a FIELDS element from FIELDS_BUFF string.
  663. *
  664. *  Convention :
  665. *
  666. *     offset = GET_FIELD(offset)
  667. *
  668. *  Parameters :
  669. *
  670. *     offset   -  numeric, current FIELDS_OFFSET block.
  671. *
  672. *  Return     :
  673. *
  674. *     offset   -  numeric, next FIELDS_OFFSET block.
  675. *
  676. *  Externals  :
  677. *
  678. *     GET_EXPR(), WORD_2_NUM()
  679. *
  680. *  Notes      :   The Header or Contents expressions are empty if......
  681. *             :      1. Passed pointer is equal to 65535.
  682. *             :      2. Character following character pointed to by
  683. *             :         pointer is CHR(0) (NULL).
  684. *             :   Called by the FRM_LOAD()
  685. *             :   File error number placed in file_error.
  686. *
  687. FUNCTION GET_FIELD
  688.  
  689. PARAMETERS offset
  690.  
  691. PRIVATE pointer, number
  692.  
  693. pointer = 0
  694. number  = 0
  695.  
  696. APPEND BLANK
  697.  
  698. ** Column width **
  699. number = WORD_2_NUM(SUBSTR(fields_buff, offset + field_width_offset, 2))
  700. REPLACE width WITH number
  701.  
  702.  
  703. ** Total **
  704. REPLACE totals WITH SUBSTR(fields_buff, offset + field_totals_offset, 1)
  705.  
  706.  
  707. ** Decimals width **
  708. number = WORD_2_NUM(SUBSTR(fields_buff, offset +;
  709.             field_decimals_offset, 2))
  710. REPLACE decimals WITH number
  711.  
  712. ** Offset (relative to FIELDS_OFFSET), 'point' to **
  713. **    expression area via array OFFSETS[]. **
  714.  
  715.  
  716. ** Content expression **
  717. pointer = WORD_2_NUM(SUBSTR(fields_buff, offset +;
  718.                field_content_expr_offset, 2))
  719. REPLACE contents WITH GET_EXPR(pointer)
  720.  
  721.  
  722. ** Header expression **
  723. pointer = WORD_2_NUM(SUBSTR(fields_buff, offset +;
  724.                field_header_expr_offset, 2))
  725. REPLACE header WITH GET_EXPR(pointer)
  726.  
  727. RETURN (offset + 12)
  728. // eofunc GET_FIELD()
  729.  
  730.  
  731.  
  732. ***
  733. *  Function   :  FRM_SAVE()
  734. *  Purpose    :  Writes contents of the report system <.DBF> and
  735. *             :  <.MEM> files to a <.FRM> file.
  736. *
  737. *  Convention :
  738. *
  739. *     status = FRM_SAVE(frm_file, dbf_file, mem_file)
  740. *
  741. *  Parameters :
  742. *
  743. *     frm_file -  string, destination report form.
  744. *     dbf_file -  string, data file for column expressions.
  745. *     mem_file -  string, memory file for report dimension.
  746. *
  747. *  Return     :
  748. *
  749. *     status   -  logical, sucess of save operation.
  750. *
  751. *  Externals  :
  752. *
  753. *     WRITE_EXPR(), WRITE_FIELD(), WRITE_PARAMS(), FCREATE(), FCLOSE(),
  754. *     FERROR(), FWRITE()
  755. *
  756. *  Notes      :   Report file name has extension.
  757. *             :   File error number placed in file_error.
  758. *             :   WARNING!!!!!!->   Offsets start are from 0.
  759. *             :      Offsets are into a DOS FILE, 0 to 1989
  760. *             :
  761. *             :   WARNING!!!!!!->   The offsets mentioned in these notes
  762. *             :      are actual DOS FILE offsets.  These ARE NOT the same
  763. *             :      as those declared in FRM_LOAD().
  764. *             :
  765. *             :   WARNING!!!!!!->   An exception to this is the fields
  766. *             :      (columns) related offsets which are relative to the
  767. *             :      FIELDS_OFFSET offset.
  768. *             :
  769. *             :   Report file length is 7C6h (1990d) bytes.
  770. *             :   Expression length array starts at 04h (4d) and can
  771. *             :      contain upto 55 short (2 byte) numbers.
  772. *             :   Expression offset index array starts at 72h (114d) and
  773. *             :      can contain upto 55 short (2 byte) numbers.
  774. *             :   Expression area starts at offset E0h (224d).
  775. *             :   Expression area length is 5A0h (1440d).
  776. *             :   Expressions in expression area are null terminated.
  777. *             :   Expression lengths include the null terminator.
  778. *             :   Field expression area starts at offset 680h (1664d).
  779. *             :   Field expressions (column definition) are null terminated.
  780. *             :   Field expression area can contain upto 25 12 byte elements
  781. *             :      describing a column layout.
  782. *
  783. FUNCTION FRM_SAVE
  784.  
  785. PARAMETERS report_file, dbf_file, mem_file
  786.  
  787. ** Shared by FRM_SAVE() and its ancillary functions **
  788. PRIVATE handle, expr_offset, offsets_offset, lengths_offset, fields_offset,;
  789.    page_hdr_num, grp_expr_num, sub_expr_num, grp_hdr_num, sub_hdr_num,;
  790.    next_free_offset, last_expr, expr_count
  791.  
  792. PRIVATE report_size, report_image, status, expr_count, i, j, write_count,;
  793.    frm_pagehdr, frm_grpexpr, frm_subexpr, frm_grphdr, frm_subhdr,;
  794.    frm_pagewidth, frm_linespage, frm_leftmarg, frm_rightmarg,;
  795.    frm_colcount, frm_dblspaced, frm_summary, frm_pe, frm_pebp, frm_peap,;
  796.    frm_plainpage
  797.  
  798. report_size  = 1990              && size of report file.
  799. report_image = ""
  800.  
  801. i           = 0
  802. j           = 0
  803. handle      = 0
  804. write_count = 0                       && read/write and content record counter.
  805. status      = .F.
  806.  
  807. expr_num   = 0                   && expression record count.
  808. last_expr  = 0                   && end of last expression in area + 1.
  809. expr_count = -1                  && first expression at offset 0.
  810.  
  811. ** Offsets into the report file **
  812. next_free_offset = 2             && first un-USEd expr area offset.
  813. lengths_offset   = 4             && start of expression length array.
  814. offsets_offset   = 114           && start of expression position array.
  815. expr_offset      = 224           && start of expression data area.
  816. fields_offset    = 1664          && start of report columns (fields).
  817. end_offset       = 1964          && start of last 24 bytes to write.
  818.  
  819. ** Offsets array index numbers to these expressions **
  820. page_hdr_num = 0
  821. grp_expr_num = 0
  822. sub_expr_num = 0
  823. grp_hdr_num  = 0
  824. sub_hdr_num  = 0
  825.  
  826. ** Create the label file **
  827. handle = FCREATE(report_file)
  828.  
  829. ** Open ok? **
  830. file_error = FERROR()
  831. IF file_error = 0
  832.    ** Restore report dimension values **
  833.    RESTORE ADDITIVE FROM &mem_file
  834.  
  835.    ** Write a NULL filled report 'skeleton' **
  836.    report_image = CHR(2) + CHR(0) + replicate(CHR(0), (1990 - 4)) +;
  837.                      CHR(2) + CHR(0)
  838.    write_count = FWRITE(handle, report_image, report_size)
  839.  
  840.    ** Skeleton WRITE ok? **
  841.    IF write_count = 0
  842.       file_error = -2
  843.    ELSE
  844.       file_error = FERROR()
  845.    ENDIF
  846.  
  847.    IF file_error = 0
  848.  
  849.       ** Write Page Heading info **
  850.       page_hdr_num = WRITE_EXPR(frm_pagehdr, .T.)
  851.  
  852.       ** WRITE ok? **
  853.       IF page_hdr_num != -1
  854.  
  855.          ** Write Grouping expression info **
  856.          grp_expr_num = WRITE_EXPR(frm_grpexpr, .T.)
  857.  
  858.          ** WRITE ok? **
  859.          IF grp_expr_num != -1
  860.  
  861.             ** Write Sub-grouping expression info **
  862.             sub_expr_num = WRITE_EXPR(frm_subexpr, .T.)
  863.  
  864.             ** WRITE ok? **
  865.             IF sub_expr_num != -1
  866.  
  867.                ** Write Group Heading info **
  868.                grp_hdr_num = WRITE_EXPR(frm_grphdr, .T.)
  869.  
  870.                ** WRITE ok? **
  871.                IF grp_hdr_num != -1
  872.  
  873.                   ** Write Sub-group Heading info **
  874.                   sub_hdr_num = WRITE_EXPR(frm_subhdr, .F.)
  875.  
  876.                   ** WRITE ok? **
  877.                   status = (sub_hdr_num != -1)
  878.  
  879.                ENDIF
  880.             ENDIF
  881.          ENDIF
  882.       ENDIF
  883.  
  884.       ** Headers, grouping and sub-group info writen ok? **
  885.       IF status
  886.  
  887.          ** Write FIELDS (columns) info **
  888.          USE &dbf_file
  889.          j = lastrec()
  890.          FOR i = 1 to j
  891.  
  892.             IF i == j .AND. LEN( TRIM( contents ) ) == 0
  893.                status := .T.
  894.                frm_colcount--
  895.             ELSE
  896.                status := WRITE_FIELD()
  897.             ENDIF
  898.  
  899.             ** Ok? **
  900.             IF status
  901.                SKIP                    && pass, go next.
  902.             ELSE
  903.                i = j + 1               && error, break out.
  904.             ENDIF
  905.          NEXT
  906.          CLOSE DATABASES
  907.       ENDIF
  908.  
  909.       ** Column info written ok? **
  910.       IF status
  911.          ** Write last 24 bytes of report and update next_free_offset **
  912.          status = WRITE_PARAMS()
  913.       ENDIF
  914.    ENDIF
  915.  
  916.    ** CLOSE ok? **
  917.    IF !FCLOSE(handle)
  918.       file_error = FERROR()
  919.       status = .F.
  920.    ENDIF
  921. ENDIF
  922.  
  923. RETURN (status)
  924. // eofunc FRM_SAVE
  925.  
  926.  
  927.  
  928. ***
  929. *  Function   :  WRITE_EXPR()
  930. *  Purpose    :  Writes an expression to Report expression area.
  931. *
  932. *  Convention :
  933. *
  934. *     expr_num = WRITE_EXPR(string, blank)
  935. *
  936. *  Parameters :
  937. *
  938. *     string   -  string, thing to write to expression area.
  939. *     blank    -  logical, test for dBASE like blank expression handling
  940. *                    and return a 65535 if expression to write is blank.
  941. *
  942. *  Return     :
  943. *
  944. *     expr_num -  numeric, expression count (0 to 55 inclusive) or
  945. *                    65535 (if blank = .T. and EMPTY(string) = .T.) or
  946. *                    -1 (if WRITE/SEEK error).
  947. *
  948. *  Externals  :
  949. *
  950. *     FWRITE(), FSEEK(), FERROR(), NUM_2_WORD()
  951. *
  952. *  Notes      :   Called by the FRM_SAVE()
  953. *             :   Updates lengths_offset, offsets_offset, last_expr,
  954. *             :      expr_count
  955. *             :   Special dBASE test - string is EMPTY() and = CHR(0).
  956. *             :   File error number placed in file_error.
  957. *             :   DISK FULL error, file_error = -2.
  958. *
  959. FUNCTION WRITE_EXPR
  960.  
  961. PARAMETERS string, blank
  962.  
  963. PRIVATE status, write_item, write_len, write_count, return_count
  964.  
  965. status       = .F.
  966. write_item   = ""
  967. write_len    = 0
  968. write_count  = 0
  969. return_count = 0        && expression count/65535 if empty/-1 error.
  970.  
  971. ** For dBASE compatability **
  972. IF blank .AND. LEN(string) = 0
  973.    status = .T.
  974. ELSE
  975.  
  976.    write_item = string + CHR(0)
  977.    write_len = LEN(write_item)
  978.  
  979.    ** Move to the next free area **
  980.    FSEEK(handle, expr_offset + last_expr)
  981.  
  982.    file_error = FERROR()
  983.    IF file_error = 0
  984.  
  985.       ** Write the expression **
  986.       write_count = FWRITE(handle, write_item, write_len)
  987.  
  988.       ** WRITE error? **
  989.       IF write_count = 0
  990.          file_error = -2
  991.       ELSE
  992.          file_error = FERROR()
  993.       ENDIF
  994.  
  995.       IF file_error = 0
  996.          FSEEK(handle, offsets_offset)
  997.  
  998.          file_error = FERROR()
  999.          IF file_error = 0
  1000.  
  1001.             ** Add an offset to the offsets array. **
  1002.             write_count = FWRITE(handle, NUM_2_WORD(last_expr), 2)
  1003.  
  1004.             ** WRITE error? **
  1005.             IF write_count = 0
  1006.                file_error = -2
  1007.             ELSE
  1008.                file_error = FERROR()
  1009.             ENDIF
  1010.  
  1011.             IF file_error = 0
  1012.                FSEEK(handle, lengths_offset)
  1013.  
  1014.                file_error = FERROR()
  1015.                IF file_error = 0
  1016.  
  1017.                   ** Add the expression length to the lengths array **
  1018.                   write_count = FWRITE(handle, NUM_2_WORD(write_len), 2)
  1019.  
  1020.                   ** WRITE error? **
  1021.                   IF write_count = 0
  1022.                      file_error = -2
  1023.                   ELSE
  1024.                      file_error = FERROR()
  1025.                   ENDIF
  1026.  
  1027.                   ** Move offsets to next position **
  1028.                   IF file_error = 0
  1029.                      last_expr = last_expr + write_len
  1030.                      lengths_offset = lengths_offset + 2
  1031.                      offsets_offset = offsets_offset + 2
  1032.  
  1033.                      ** Write was performed ok **
  1034.                      status = .T.
  1035.  
  1036.                   ENDIF
  1037.                ENDIF
  1038.             ENDIF
  1039.          ENDIF
  1040.       ENDIF
  1041.    ENDIF
  1042. ENDIF
  1043.  
  1044. ** If the write ok, bump the expression count. **
  1045. IF status
  1046.    IF blank .and. LEN(string) = 0
  1047.       return_count = 65535                && if the expression was empty.
  1048.    ELSE
  1049.       expr_count = expr_count + 1         && global increment.
  1050.       return_count = expr_count           && local return.
  1051.    ENDIF
  1052. ELSE
  1053.    return_count = -1                      && WRITE/SEEK ops error.
  1054. ENDIF
  1055.  
  1056. RETURN (return_count)
  1057. // eofunc WRITE_EXPR()
  1058.  
  1059.  
  1060.  
  1061. ***
  1062. *  Function   :  WRITE_FIELD()
  1063. *  Purpose    :  Writes a FIELDS element to the FIELDS area.
  1064. *
  1065. *  Convention :
  1066. *
  1067. *     status = WRITE_FIELD()
  1068. *
  1069. *  Parameters :
  1070. *
  1071. *     (none)
  1072. *
  1073. *  Return     :
  1074. *
  1075. *     status   -  logical, success or fail of write operation.
  1076. *
  1077. *  Externals  :
  1078. *
  1079. *     FWRITE(), FSEEK(), FERROR(), WRITE_EXPR(), NUM_2_WORD()
  1080. *
  1081. *  Notes      :   Called by the FRM_SAVE()
  1082. *             :   Updates fields_offset, lengths_offset, offsets_offset,
  1083. *             :      last_expr
  1084. *             :   File error number placed in file_error.
  1085. *
  1086. FUNCTION WRITE_FIELD
  1087.  
  1088. PRIVATE status, write_item, write_len, write_count, cnts_offset, hdr_offset
  1089.  
  1090. status      = .F.
  1091. write_item  = ""
  1092. write_len   = 0
  1093. write_count = 0
  1094. cnts_offset = 65535
  1095. hdr_offset  = 65535
  1096.  
  1097. ** Write Contents **
  1098. cnts_offset = WRITE_EXPR(trim(contents), .F.)
  1099.  
  1100. ** WRITE ok? **
  1101. IF cnts_offset != -1
  1102.  
  1103.    ** Write Header **
  1104.    hdr_offset = WRITE_EXPR(trim(header), .T.)
  1105.  
  1106.    ** WRITE ok? **
  1107.    IF hdr_offset != -1
  1108.  
  1109.       ** Seek to the next free FIELDS area **
  1110.       fields_offset = fields_offset + 12
  1111.       FSEEK(handle, fields_offset)
  1112.  
  1113.       ** SEEK ok? **
  1114.       file_error = FERROR()
  1115.       IF file_error = 0
  1116.  
  1117.          write_item = NUM_2_WORD(width) +;
  1118.                          replicate(CHR(0), 3) +;
  1119.                          totals +;
  1120.                          NUM_2_WORD(decimals) +;
  1121.                          NUM_2_WORD(cnts_offset) +;
  1122.                          NUM_2_WORD(hdr_offset)
  1123.          write_len = LEN(write_item)
  1124.  
  1125.          ** Write the FIELDS info **
  1126.          write_count = FWRITE(handle, write_item, write_len)
  1127.  
  1128.          ** WRITE error? **
  1129.          IF write_count = 0
  1130.             file_error = -2
  1131.          ELSE
  1132.             file_error = FERROR()
  1133.          ENDIF
  1134.  
  1135.          ** WRITE ok? **
  1136.          status = (file_error = 0)
  1137.  
  1138.       ENDIF
  1139.    ENDIF
  1140. ENDIF
  1141.  
  1142. RETURN (status)
  1143. // eofunc WRITE_FIELD()
  1144.  
  1145.  
  1146.  
  1147. ***
  1148. *  Function   :  WRITE_PARAMS()
  1149. *  Purpose    :  Writes the last 24 bytes of the report file plus
  1150. *             :      updates the first un-used offset. (last_offset)
  1151. *
  1152. *  Convention :
  1153. *
  1154. *     status = WRITE_PARAMS()
  1155. *
  1156. *  Parameters :
  1157. *
  1158. *     (none)
  1159. *
  1160. *  Return     :
  1161.  
  1162. *     status   -  logical, success or fail of write operation.
  1163. *
  1164. *  Externals  :
  1165. *
  1166. *     FSEEK(), FWRITE(), FERROR(), NUM_2_WORD()
  1167. *
  1168. *  Notes      :   Called by the FRM_SAVE()
  1169. *             :   File error number placed in file_error.
  1170. *
  1171. FUNCTION WRITE_PARAMS
  1172.  
  1173. PRIVATE status, write_item, write_len, write_count, plus_byte
  1174.  
  1175. status      = .F.
  1176. write_item  = ""
  1177. write_len   = 0
  1178. write_count = 0
  1179. plus_byte   = 0
  1180.  
  1181. ** Calculate plus byte **
  1182. IF frm_plainpage = "Y"
  1183.    plus_byte = plus_byte + 4
  1184. ENDIF
  1185. IF frm_peap = "Y"
  1186.    plus_byte = plus_byte + 2
  1187. ENDIF
  1188. IF frm_pebp = "N"
  1189.    plus_byte = plus_byte + 1
  1190. ENDIF
  1191.  
  1192. ** Prepare miscellaneous data area string for write ops **
  1193. write_item = NUM_2_WORD(page_hdr_num) +;
  1194.                 NUM_2_WORD(grp_expr_num) +;
  1195.                 NUM_2_WORD(sub_expr_num) +;
  1196.                 NUM_2_WORD(grp_hdr_num) +;
  1197.                 NUM_2_WORD(sub_hdr_num) +;
  1198.                 NUM_2_WORD(frm_pagewidth) +;
  1199.                 NUM_2_WORD(frm_linespage) +;
  1200.                 NUM_2_WORD(frm_leftmarg) +;
  1201.                 NUM_2_WORD(frm_rightmarg) +;
  1202.                 NUM_2_WORD(frm_colcount) +;
  1203.                 frm_dblspaced +;
  1204.                 frm_summary +;
  1205.                 frm_pe +;
  1206.                 CHR(plus_byte)
  1207. write_len = LEN(write_item)
  1208.  
  1209. ** Seek to first parameters area **
  1210. FSEEK(handle, end_offset)
  1211.  
  1212. ** SEEK ok? **
  1213. file_error = FERROR()
  1214. IF file_error = 0
  1215.    write_count = FWRITE(handle, write_item, write_len)
  1216.  
  1217.    ** WRITE error? **
  1218.    IF write_count = 0
  1219.       file_error = -2
  1220.    ELSE
  1221.       file_error = FERROR()
  1222.    ENDIF
  1223.  
  1224.    IF file_error = 0
  1225.       FSEEK(handle, next_free_offset)
  1226.  
  1227.       ** SEEK ok? **
  1228.       file_error = FERROR()
  1229.       IF file_error = 0
  1230.  
  1231.          ** Update the next free expression offset **
  1232.          write_count = FWRITE(handle, NUM_2_WORD(last_expr), 2)
  1233.  
  1234.          ** WRITE error? **
  1235.          IF write_count = 0
  1236.             file_error = -2
  1237.          ELSE
  1238.             file_error = FERROR()
  1239.          ENDIF
  1240.  
  1241.          status = (file_error = 0)
  1242.  
  1243.       ENDIF
  1244.    ENDIF
  1245. ENDIF
  1246.  
  1247.  
  1248. RETURN (status)
  1249. // eofunc WRITE_PARAMS()
  1250.  
  1251.  
  1252.  
  1253. ***
  1254. *  Function   :  CREATE_DBF()
  1255. *  Purpose    :  Creates a <.DBF> file.
  1256. *
  1257. *  Convention :
  1258. *
  1259. *    status = CREATE_DBF(file, size, field, ftype, flength, fdecimal)
  1260. *
  1261. *  Parameters :
  1262. *
  1263. *     file     -  string, dbf file name to create.
  1264. *     size     -  numeric, number of fields. (for speed)
  1265. *     field    -  array, field name(s).
  1266. *     ftype    -  array, field type(s).
  1267. *     flength  -  array, field length(s).
  1268. *     fdecimal -  array, field decimal length(s).
  1269. *
  1270. *  Return     :
  1271. *
  1272. *     status   -  logical, success of create operation.
  1273. *
  1274. *  Externals  :
  1275. *
  1276. *     FCREATE(), FCLOSE(), FWRITE(), FERROR(), NUM_2_WORD()
  1277. *
  1278. *  Notes      :   File error number placed in file_error.
  1279. *
  1280. FUNCTION CREATE_DBF
  1281.  
  1282. PARAMETERS file, size, fieldname, ftype, flength, fdecimal
  1283.  
  1284. PRIVATE header_image, field_image, tail_image, block_size, handle,;
  1285.    i, write_count, field_count, data_offset, record_size, status
  1286.  
  1287. ** DBF file creation variables **
  1288. i           = 0                  && array subscript.
  1289. handle      = 0
  1290. block_size  = 32                 && header and field block size.
  1291. data_offset = block_size         && field records start are offset 32d.
  1292. record_size = 0
  1293. write_count = 0                  && bytes writen.
  1294. field_count = 0                  && fields to create.
  1295. status = .T.
  1296.  
  1297. ** NO extension **
  1298. IF AT(".", file) = 0
  1299.    file = TRIM(file) + ".DBF"
  1300. ENDIF
  1301.  
  1302. ** Calculate record_size, field_count and data_offset **
  1303. FOR i = 1 to size
  1304.    record_size = record_size + flength[i]
  1305.    data_offset = data_offset + block_size
  1306. NEXT
  1307.  
  1308. field_count = i - 1
  1309. record_size = record_size + 1       && + one byte of pad.
  1310. data_offset = data_offset + 2       && + 2 for CR and NULL.
  1311.  
  1312. header_image = CHR(3) +;                        && dbf id.      (byte)
  1313.                   replicate(CHR(0), 3) +;       && last update. (byte)
  1314.                   replicate(CHR(0), 4) +;       && last record. (long)
  1315.                   NUM_2_WORD(data_offset) +;    && data offset. (word)
  1316.                   NUM_2_WORD(record_size) +;    && record size. (word)
  1317.                   replicate(CHR(0), 20)         && 20 byte pad.
  1318.  
  1319. field_image = ""                                && filled in later.
  1320. tail_image = CHR(13) + CHR(0) + CHR(26)         && CR, pad, EOF
  1321.  
  1322. ** Create label content dbf file **
  1323. handle = FCREATE(file)
  1324.  
  1325. ** CREATEd ok? **
  1326. file_error = FERROR()
  1327. status = (file_error = 0)
  1328.  
  1329. IF status
  1330.  
  1331.    ** Write dbf header image **
  1332.    write_count = FWRITE(handle, header_image, block_size)
  1333.  
  1334.    ** Header WRITE ok? **
  1335.    IF write_count = 0
  1336.       file_error = -2
  1337.    ELSE
  1338.       file_error = FERROR()
  1339.    ENDIF
  1340.    status = (file_error = 0)
  1341.  
  1342.    IF status
  1343.  
  1344.       ** Make a FIELD header block **
  1345.       FOR i = 1 to field_count
  1346.  
  1347.          ** Build it **
  1348.          field_image = fieldname[i] +;                   && field name + pad
  1349.                          replicate(CHR(0), 11 - LEN(fieldname[i])) +;
  1350.                          ftype[i] +;                 && field type   (byte)
  1351.                          replicate(CHR(0), 4) +;     && 4 byte pad
  1352.                          CHR(flength[i] % 256) +;    && field length (byte)
  1353.                          IF(ftype[i] = "C",;         && for "C" type > 256
  1354.                             CHR(flength[i] / 256),;  && low + high bytes
  1355.                             CHR(fdecimal[i])) +;     && decimals     (byte)
  1356.                          replicate(CHR(0), 14)       && 14 byte pad
  1357.  
  1358.          ** Write it **
  1359.          write_count = FWRITE(handle, field_image, block_size)
  1360.  
  1361.          ** WRITE ok? **
  1362.          IF write_count = 0
  1363.             file_error = -2
  1364.          ELSE
  1365.             file_error = FERROR()
  1366.          ENDIF
  1367.          status = (file_error = 0)
  1368.  
  1369.          IF !status
  1370.             i = field_count + 1        && breakout of FOR loop.
  1371.          ENDIF
  1372.       NEXT
  1373.  
  1374.    ENDIF
  1375.  
  1376.    ** If file created ok so far... **
  1377.    IF status
  1378.       ** Write Tail CR + NULL + EOF (0Dh + 00h + 1Ah) **
  1379.       write_count = FWRITE(handle, tail_image, 3)
  1380.  
  1381.       ** WRITE error? **
  1382.       IF write_count = 0
  1383.          file_error = -2
  1384.       ELSE
  1385.          file_error = FERROR()
  1386.       ENDIF
  1387.  
  1388.       status = (file_error = 0)
  1389.  
  1390.    ENDIF
  1391.  
  1392.    ** Close file **
  1393.    status = FCLOSE(handle)
  1394.    IF !status
  1395.       file_error = FERROR()
  1396.    ENDIF
  1397. ENDIF
  1398.  
  1399. RETURN (status)
  1400. // eofunc CREATE_DBF
  1401.  
  1402.  
  1403.  
  1404. ***
  1405. *  Function   :  WORD_2_NUM()
  1406. *  Purpose    :  Converts a 2 byte string to numeric.
  1407. *
  1408. *  Convention :
  1409. *
  1410. *     num = WORD_2_NUM(hex_string)
  1411. *
  1412. *  Parameters :
  1413. *
  1414. *     string   -  hex_string, 2 hex bytes in LSB, MSB order
  1415. *
  1416. *  Return     :
  1417. *
  1418. *     num      -  numeric, converted number.
  1419. *
  1420. *
  1421.  
  1422. FUNCTION WORD_2_NUM
  1423.  
  1424. PARAMETERS byte_string
  1425.  
  1426. PRIVATE numeric
  1427.  
  1428. numeric = ASC(SUBSTR(byte_string, 1, 1)) +;           && extract LSB
  1429.              ASC(SUBSTR(byte_string, 2, 1)) * 256     && extract MSB
  1430.  
  1431. RETURN (numeric)
  1432. // eofunc WORD_2_NUM()
  1433.  
  1434.  
  1435.  
  1436. ***
  1437. *  Function   :  NUM_2_WORD()
  1438. *  Purpose    :  Converts a numeric to a 2 byte string.
  1439. *
  1440. *  Convention :
  1441. *
  1442. *     byte_string = NUM_2_WORD(numeric)
  1443. *
  1444. *  Parameters :
  1445. *
  1446. *     numeric       -  numeric, number to convert.
  1447. *
  1448. *  Return     :
  1449. *
  1450. *     byte_string   -  string, 2 bytes in LSB, MSB order
  1451. *
  1452. *
  1453. FUNCTION NUM_2_WORD
  1454.  
  1455. PARAMETERS numeric
  1456.  
  1457. PRIVATE byte_string
  1458.  
  1459. byte_string = CHR(numeric % 256) +;         && make LSB
  1460.                 CHR(numeric / 256)          && make MSB
  1461.  
  1462. RETURN (byte_string)
  1463. // eofunc NUM_2_WORD()
  1464.