home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1993 #2 / Image.iso / clipper / cl52bus.zip / 52BRL.EXE / RLBACK.PRG < prev    next >
Text File  |  1993-06-10  |  41KB  |  1,460 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.             ** Write contents of FIELDS record to report file.
  892.             status = WRITE_FIELD()
  893.  
  894.             ** Ok? **
  895.             IF status
  896.                SKIP                    && pass, go next.
  897.             ELSE               
  898.                i = j + 1               && error, break out.
  899.             ENDIF
  900.          NEXT
  901.          CLOSE DATABASES
  902.       ENDIF
  903.  
  904.       ** Column info written ok? **
  905.       IF status
  906.          ** Write last 24 bytes of report and update next_free_offset **
  907.          status = WRITE_PARAMS()
  908.       ENDIF   
  909.    ENDIF
  910.  
  911.    ** CLOSE ok? **
  912.    IF !FCLOSE(handle)
  913.       file_error = FERROR()
  914.       status = .F.
  915.    ENDIF
  916. ENDIF
  917.  
  918. RETURN (status)
  919. // eofunc FRM_SAVE
  920.  
  921.  
  922.  
  923. ***
  924. *  Function   :  WRITE_EXPR()
  925. *  Purpose    :  Writes an expression to Report expression area.
  926. *
  927. *  Convention :
  928. *
  929. *     expr_num = WRITE_EXPR(string, blank)
  930. *
  931. *  Parameters :
  932. *
  933. *     string   -  string, thing to write to expression area.
  934. *     blank    -  logical, test for dBASE like blank expression handling
  935. *                    and return a 65535 if expression to write is blank.
  936. *
  937. *  Return     :
  938. *
  939. *     expr_num -  numeric, expression count (0 to 55 inclusive) or
  940. *                    65535 (if blank = .T. and EMPTY(string) = .T.) or
  941. *                    -1 (if WRITE/SEEK error).
  942. *     
  943. *  Externals  :
  944. *
  945. *     FWRITE(), FSEEK(), FERROR(), NUM_2_WORD()
  946. *
  947. *  Notes      :   Called by the FRM_SAVE()
  948. *             :   Updates lengths_offset, offsets_offset, last_expr,
  949. *             :      expr_count
  950. *             :   Special dBASE test - string is EMPTY() and = CHR(0).
  951. *             :   File error number placed in file_error.
  952. *             :   DISK FULL error, file_error = -2.
  953. *
  954. FUNCTION WRITE_EXPR
  955.  
  956. PARAMETERS string, blank
  957.  
  958. PRIVATE status, write_item, write_len, write_count, return_count
  959.  
  960. status       = .F.
  961. write_item   = ""
  962. write_len    = 0
  963. write_count  = 0
  964. return_count = 0        && expression count/65535 if empty/-1 error.
  965.  
  966. ** For dBASE compatability **
  967. IF blank .AND. LEN(string) = 0
  968.    status = .T.
  969. ELSE
  970.  
  971.    write_item = string + CHR(0)
  972.    write_len = LEN(write_item)  
  973.  
  974.    ** Move to the next free area **
  975.    FSEEK(handle, expr_offset + last_expr)
  976.  
  977.    file_error = FERROR()
  978.    IF file_error = 0
  979.               
  980.       ** Write the expression **      
  981.       write_count = FWRITE(handle, write_item, write_len)            
  982.  
  983.       ** WRITE error? **
  984.       IF write_count = 0
  985.          file_error = -2
  986.       ELSE
  987.          file_error = FERROR()
  988.       ENDIF
  989.  
  990.       IF file_error = 0
  991.          FSEEK(handle, offsets_offset)
  992.  
  993.          file_error = FERROR()
  994.          IF file_error = 0
  995.  
  996.             ** Add an offset to the offsets array. **
  997.             write_count = FWRITE(handle, NUM_2_WORD(last_expr), 2)
  998.  
  999.             ** WRITE error? **
  1000.             IF write_count = 0
  1001.                file_error = -2
  1002.             ELSE
  1003.                file_error = FERROR()
  1004.             ENDIF
  1005.  
  1006.             IF file_error = 0
  1007.                FSEEK(handle, lengths_offset)
  1008.  
  1009.                file_error = FERROR()
  1010.                IF file_error = 0
  1011.  
  1012.                   ** Add the expression length to the lengths array **
  1013.                   write_count = FWRITE(handle, NUM_2_WORD(write_len), 2)
  1014.  
  1015.                   ** WRITE error? **
  1016.                   IF write_count = 0
  1017.                      file_error = -2
  1018.                   ELSE
  1019.                      file_error = FERROR()
  1020.                   ENDIF
  1021.  
  1022.                   ** Move offsets to next position **
  1023.                   IF file_error = 0
  1024.                      last_expr = last_expr + write_len
  1025.                      lengths_offset = lengths_offset + 2
  1026.                      offsets_offset = offsets_offset + 2
  1027.  
  1028.                      ** Write was performed ok **
  1029.                      status = .T.
  1030.  
  1031.                   ENDIF
  1032.                ENDIF
  1033.             ENDIF
  1034.          ENDIF
  1035.       ENDIF
  1036.    ENDIF
  1037. ENDIF
  1038.  
  1039. ** If the write ok, bump the expression count. **
  1040. IF status
  1041.    IF blank .and. LEN(string) = 0
  1042.       return_count = 65535                && if the expression was empty.
  1043.    ELSE
  1044.       expr_count = expr_count + 1         && global increment.
  1045.       return_count = expr_count           && local return.
  1046.    ENDIF
  1047. ELSE
  1048.    return_count = -1                      && WRITE/SEEK ops error.
  1049. ENDIF
  1050.  
  1051. RETURN (return_count)
  1052. // eofunc WRITE_EXPR()
  1053.  
  1054.  
  1055.  
  1056. ***
  1057. *  Function   :  WRITE_FIELD()
  1058. *  Purpose    :  Writes a FIELDS element to the FIELDS area.
  1059. *
  1060. *  Convention :
  1061. *
  1062. *     status = WRITE_FIELD()
  1063. *
  1064. *  Parameters :
  1065. *
  1066. *     (none)
  1067. *
  1068. *  Return     :
  1069. *
  1070. *     status   -  logical, success or fail of write operation.
  1071. *     
  1072. *  Externals  :
  1073. *
  1074. *     FWRITE(), FSEEK(), FERROR(), WRITE_EXPR(), NUM_2_WORD()
  1075. *
  1076. *  Notes      :   Called by the FRM_SAVE()
  1077. *             :   Updates fields_offset, lengths_offset, offsets_offset,
  1078. *             :      last_expr
  1079. *             :   File error number placed in file_error.
  1080. *
  1081. FUNCTION WRITE_FIELD
  1082.  
  1083. PRIVATE status, write_item, write_len, write_count, cnts_offset, hdr_offset
  1084.  
  1085. status      = .F.
  1086. write_item  = ""
  1087. write_len   = 0
  1088. write_count = 0
  1089. cnts_offset = 65535
  1090. hdr_offset  = 65535
  1091.  
  1092. ** Write Contents **
  1093. cnts_offset = WRITE_EXPR(trim(contents), .F.)
  1094.  
  1095. ** WRITE ok? **
  1096. IF cnts_offset != -1
  1097.  
  1098.    ** Write Header **
  1099.    hdr_offset = WRITE_EXPR(trim(header), .T.)
  1100.  
  1101.    ** WRITE ok? **
  1102.    IF hdr_offset != -1
  1103.  
  1104.       ** Seek to the next free FIELDS area **   
  1105.       fields_offset = fields_offset + 12
  1106.       FSEEK(handle, fields_offset)
  1107.       
  1108.       ** SEEK ok? **
  1109.       file_error = FERROR()
  1110.       IF file_error = 0
  1111.  
  1112.          write_item = NUM_2_WORD(width) +;
  1113.                          replicate(CHR(0), 3) +;
  1114.                          totals +;
  1115.                          NUM_2_WORD(decimals) +;
  1116.                          NUM_2_WORD(cnts_offset) +;
  1117.                          NUM_2_WORD(hdr_offset)
  1118.          write_len = LEN(write_item)                
  1119.  
  1120.          ** Write the FIELDS info **
  1121.          write_count = FWRITE(handle, write_item, write_len)
  1122.  
  1123.          ** WRITE error? **
  1124.          IF write_count = 0
  1125.             file_error = -2
  1126.          ELSE
  1127.             file_error = FERROR()
  1128.          ENDIF
  1129.       
  1130.          ** WRITE ok? **
  1131.          status = (file_error = 0)
  1132.  
  1133.       ENDIF
  1134.    ENDIF
  1135. ENDIF
  1136.  
  1137. RETURN (status)
  1138. // eofunc WRITE_FIELD()
  1139.  
  1140.  
  1141.  
  1142. ***
  1143. *  Function   :  WRITE_PARAMS()
  1144. *  Purpose    :  Writes the last 24 bytes of the report file plus
  1145. *             :      updates the first un-used offset. (last_offset)
  1146. *
  1147. *  Convention :
  1148. *
  1149. *     status = WRITE_PARAMS()
  1150. *
  1151. *  Parameters :
  1152. *
  1153. *     (none)
  1154. *
  1155. *  Return     :
  1156.  
  1157. *     status   -  logical, success or fail of write operation.
  1158. *     
  1159. *  Externals  :
  1160. *
  1161. *     FSEEK(), FWRITE(), FERROR(), NUM_2_WORD()
  1162. *
  1163. *  Notes      :   Called by the FRM_SAVE()
  1164. *             :   File error number placed in file_error.
  1165. *
  1166. FUNCTION WRITE_PARAMS
  1167.  
  1168. PRIVATE status, write_item, write_len, write_count, plus_byte
  1169.  
  1170. status      = .F.
  1171. write_item  = ""
  1172. write_len   = 0
  1173. write_count = 0
  1174. plus_byte   = 0
  1175.  
  1176. ** Calculate plus byte **
  1177. IF frm_plainpage = "Y"
  1178.    plus_byte = plus_byte + 4
  1179. ENDIF
  1180. IF frm_peap = "Y"
  1181.    plus_byte = plus_byte + 2
  1182. ENDIF
  1183. IF frm_pebp = "N"
  1184.    plus_byte = plus_byte + 1
  1185. ENDIF
  1186.  
  1187. ** Prepare miscellaneous data area string for write ops **
  1188. write_item = NUM_2_WORD(page_hdr_num) +;
  1189.                 NUM_2_WORD(grp_expr_num) +;
  1190.                 NUM_2_WORD(sub_expr_num) +;
  1191.                 NUM_2_WORD(grp_hdr_num) +;
  1192.                 NUM_2_WORD(sub_hdr_num) +;
  1193.                 NUM_2_WORD(frm_pagewidth) +;
  1194.                 NUM_2_WORD(frm_linespage) +;
  1195.                 NUM_2_WORD(frm_leftmarg) +;
  1196.                 NUM_2_WORD(frm_rightmarg) +;
  1197.                 NUM_2_WORD(frm_colcount) +;
  1198.                 frm_dblspaced +;
  1199.                 frm_summary +;
  1200.                 frm_pe +;
  1201.                 CHR(plus_byte)
  1202. write_len = LEN(write_item)                
  1203.  
  1204. ** Seek to first parameters area **
  1205. FSEEK(handle, end_offset)
  1206.  
  1207. ** SEEK ok? **
  1208. file_error = FERROR()
  1209. IF file_error = 0
  1210.    write_count = FWRITE(handle, write_item, write_len)
  1211.  
  1212.    ** WRITE error? **
  1213.    IF write_count = 0
  1214.       file_error = -2
  1215.    ELSE
  1216.       file_error = FERROR()
  1217.    ENDIF
  1218.  
  1219.    IF file_error = 0
  1220.       FSEEK(handle, next_free_offset)
  1221.  
  1222.       ** SEEK ok? **
  1223.       file_error = FERROR()
  1224.       IF file_error = 0
  1225.  
  1226.          ** Update the next free expression offset **
  1227.          write_count = FWRITE(handle, NUM_2_WORD(last_expr), 2)
  1228.  
  1229.          ** WRITE error? **
  1230.          IF write_count = 0
  1231.             file_error = -2
  1232.          ELSE
  1233.             file_error = FERROR()
  1234.          ENDIF
  1235.  
  1236.          status = (file_error = 0)
  1237.  
  1238.       ENDIF
  1239.    ENDIF
  1240. ENDIF
  1241.  
  1242.       
  1243. RETURN (status)
  1244. // eofunc WRITE_PARAMS()
  1245.  
  1246.  
  1247.  
  1248. ***
  1249. *  Function   :  CREATE_DBF()
  1250. *  Purpose    :  Creates a <.DBF> file.
  1251. *
  1252. *  Convention :
  1253. *
  1254. *    status = CREATE_DBF(file, size, field, ftype, flength, fdecimal)
  1255. *
  1256. *  Parameters :
  1257. *
  1258. *     file     -  string, dbf file name to create.
  1259. *     size     -  numeric, number of fields. (for speed)
  1260. *     field    -  array, field name(s).
  1261. *     ftype    -  array, field type(s).
  1262. *     flength  -  array, field length(s).
  1263. *     fdecimal -  array, field decimal length(s).
  1264. *
  1265. *  Return     :
  1266. *
  1267. *     status   -  logical, success of create operation.
  1268. *     
  1269. *  Externals  :
  1270. *
  1271. *     FCREATE(), FCLOSE(), FWRITE(), FERROR(), NUM_2_WORD()
  1272. *
  1273. *  Notes      :   File error number placed in file_error.
  1274. *
  1275. FUNCTION CREATE_DBF
  1276.  
  1277. PARAMETERS file, size, fieldname, ftype, flength, fdecimal
  1278.  
  1279. PRIVATE header_image, field_image, tail_image, block_size, handle,;
  1280.    i, write_count, field_count, data_offset, record_size, status
  1281.  
  1282. ** DBF file creation variables **
  1283. i           = 0                  && array subscript.
  1284. handle      = 0
  1285. block_size  = 32                 && header and field block size.
  1286. data_offset = block_size         && field records start are offset 32d.
  1287. record_size = 0                  
  1288. write_count = 0                  && bytes writen.
  1289. field_count = 0                  && fields to create.
  1290. status = .T.
  1291.  
  1292. ** NO extension **
  1293. IF AT(".", file) = 0
  1294.    file = TRIM(file) + ".DBF"
  1295. ENDIF
  1296.  
  1297. ** Calculate record_size, field_count and data_offset **
  1298. FOR i = 1 to size
  1299.    record_size = record_size + flength[i]   
  1300.    data_offset = data_offset + block_size
  1301. NEXT
  1302.  
  1303. field_count = i - 1
  1304. record_size = record_size + 1       && + one byte of pad.
  1305. data_offset = data_offset + 2       && + 2 for CR and NULL.
  1306.  
  1307. header_image = CHR(3) +;                        && dbf id.      (byte)
  1308.                   replicate(CHR(0), 3) +;       && last update. (byte)
  1309.                   replicate(CHR(0), 4) +;       && last record. (long)
  1310.                   NUM_2_WORD(data_offset) +;    && data offset. (word)
  1311.                   NUM_2_WORD(record_size) +;    && record size. (word)
  1312.                   replicate(CHR(0), 20)         && 20 byte pad.
  1313.  
  1314. field_image = ""                                && filled in later.
  1315. tail_image = CHR(13) + CHR(0) + CHR(26)         && CR, pad, EOF
  1316.  
  1317. ** Create label content dbf file **   
  1318. handle = FCREATE(file)
  1319.  
  1320. ** CREATEd ok? **
  1321. file_error = FERROR()
  1322. status = (file_error = 0)
  1323.  
  1324. IF status
  1325.  
  1326.    ** Write dbf header image **
  1327.    write_count = FWRITE(handle, header_image, block_size)
  1328.  
  1329.    ** Header WRITE ok? **
  1330.    IF write_count = 0
  1331.       file_error = -2
  1332.    ELSE
  1333.       file_error = FERROR()
  1334.    ENDIF
  1335.    status = (file_error = 0)
  1336.  
  1337.    IF status
  1338.  
  1339.       ** Make a FIELD header block **
  1340.       FOR i = 1 to field_count
  1341.  
  1342.          ** Build it **
  1343.          field_image = fieldname[i] +;                   && field name + pad
  1344.                          replicate(CHR(0), 11 - LEN(fieldname[i])) +;
  1345.                          ftype[i] +;                 && field type   (byte)
  1346.                          replicate(CHR(0), 4) +;     && 4 byte pad
  1347.                          CHR(flength[i] % 256) +;    && field length (byte)
  1348.                          IF(ftype[i] = "C",;         && for "C" type > 256
  1349.                             CHR(flength[i] / 256),;  && low + high bytes
  1350.                             CHR(fdecimal[i])) +;     && decimals     (byte)
  1351.                          replicate(CHR(0), 14)       && 14 byte pad
  1352.  
  1353.          ** Write it **
  1354.          write_count = FWRITE(handle, field_image, block_size)
  1355.  
  1356.          ** WRITE ok? **
  1357.          IF write_count = 0
  1358.             file_error = -2
  1359.          ELSE
  1360.             file_error = FERROR()
  1361.          ENDIF
  1362.          status = (file_error = 0)
  1363.  
  1364.          IF !status
  1365.             i = field_count + 1        && breakout of FOR loop.
  1366.          ENDIF
  1367.       NEXT
  1368.  
  1369.    ENDIF
  1370.  
  1371.    ** If file created ok so far... **
  1372.    IF status
  1373.       ** Write Tail CR + NULL + EOF (0Dh + 00h + 1Ah) **
  1374.       write_count = FWRITE(handle, tail_image, 3)
  1375.  
  1376.       ** WRITE error? **
  1377.       IF write_count = 0
  1378.          file_error = -2
  1379.       ELSE
  1380.          file_error = FERROR()
  1381.       ENDIF
  1382.  
  1383.       status = (file_error = 0)
  1384.  
  1385.    ENDIF
  1386.  
  1387.    ** Close file **
  1388.    status = FCLOSE(handle)
  1389.    IF !status
  1390.       file_error = FERROR()
  1391.    ENDIF
  1392. ENDIF
  1393.  
  1394. RETURN (status)
  1395. // eofunc CREATE_DBF
  1396.  
  1397.  
  1398.  
  1399. ***
  1400. *  Function   :  WORD_2_NUM()
  1401. *  Purpose    :  Converts a 2 byte string to numeric.
  1402. *
  1403. *  Convention :
  1404. *
  1405. *     num = WORD_2_NUM(hex_string)
  1406. *
  1407. *  Parameters :
  1408. *
  1409. *     string   -  hex_string, 2 hex bytes in LSB, MSB order
  1410. *
  1411. *  Return     :
  1412. *
  1413. *     num      -  numeric, converted number.
  1414. *     
  1415. *
  1416.  
  1417. FUNCTION WORD_2_NUM
  1418.  
  1419. PARAMETERS byte_string
  1420.  
  1421. PRIVATE numeric
  1422.  
  1423. numeric = ASC(SUBSTR(byte_string, 1, 1)) +;           && extract LSB
  1424.              ASC(SUBSTR(byte_string, 2, 1)) * 256     && extract MSB
  1425.  
  1426. RETURN (numeric)
  1427. // eofunc WORD_2_NUM()
  1428.  
  1429.  
  1430.  
  1431. ***
  1432. *  Function   :  NUM_2_WORD()
  1433. *  Purpose    :  Converts a numeric to a 2 byte string.
  1434. *
  1435. *  Convention :
  1436. *
  1437. *     byte_string = NUM_2_WORD(numeric)
  1438. *
  1439. *  Parameters :
  1440. *
  1441. *     numeric       -  numeric, number to convert.
  1442. *
  1443. *  Return     :
  1444. *
  1445. *     byte_string   -  string, 2 bytes in LSB, MSB order
  1446. *     
  1447. *
  1448. FUNCTION NUM_2_WORD
  1449.  
  1450. PARAMETERS numeric
  1451.  
  1452. PRIVATE byte_string
  1453.  
  1454. byte_string = CHR(numeric % 256) +;         && make LSB
  1455.                 CHR(numeric / 256)          && make MSB
  1456.  
  1457. RETURN (byte_string)
  1458. // eofunc NUM_2_WORD()
  1459.  
  1460.