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