home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a075 / 1.img / TOOLKIT1.EXE / SST264.PRG < prev    next >
Encoding:
Text File  |  1989-08-16  |  12.4 KB  |  497 lines
  1. *******************
  2.  
  3. PROCEDURE Make_dbf
  4.  
  5.    PARAMETERS p, d, e
  6.  
  7.    tdbf = SPACE(12)
  8.    ret_to = LTRIM(TRIM(STR(SELECT())))
  9.    SELECT 0
  10.    tdbf_row = ROW()
  11.    tdbf_col = COL()
  12.    code_out = .F.
  13.    code_name = SPACE(8)
  14.    old_color = SETCOLOR()
  15.  
  16.    IF PCOUNT() <> 3 .OR. TYPE("p") <> "A"
  17.       DECLARE p[20], d[200], e[20]
  18.       disp_at = 5
  19.       IF !MAKE_DBF1()                 && If FALSE, then abort process!
  20.          @ tdbf_row, tdbf_col SAY ""
  21.          RETURN
  22.       ENDIF
  23.    ELSE
  24.       disp_at = 5
  25.    ENDIF
  26.    write2_it = SPACE(8)
  27.  
  28.    IF code_out
  29.       PUSHSCREEN(2,20,4,60,.T.,.T.)
  30.       @ 3,24 SAY "Generating Code as well!!!"
  31.    ENDIF
  32.  
  33.    DO Make_it WITH p, d, e, disp_at
  34.  
  35.    IF code_out
  36.       POPSCREEN(2,20,4,60)
  37.    ENDIF
  38.  
  39.    IF FILE("Sstback.dbf")
  40.       SET COLOR TO W+/B
  41.       PUSHSCREEN(2, 20, 4, 60, .T., .T.)
  42.       @ 3,23 SAY "    Appending Data!"
  43.       USE (tdbf)
  44.       APPEND FROM Sstback WHILE COUNTING(3,45)
  45.       USE
  46.       ERASE Sstback.dbf
  47.       POPSCREEN(2, 20, 4, 60)
  48.    ENDIF
  49.  
  50.    SETCOLOR(old_color)
  51.    SELECT &ret_to.
  52.    @ tdbf_row, tdbf_col SAY ""
  53.  
  54. ********************
  55.  
  56. FUNCTION Make_dbf1
  57.  
  58.    AFILL(p, "", 1, 20)
  59.    AFILL(e, "", 1, 20)
  60.    AFILL(d, "", 1, 200)
  61.    
  62.    old_color = SETCOLOR()
  63.  
  64.    IF ISCOLOR() .AND. !(IF(TYPE("scrmono")="U", .T., scrmono))
  65.       SET COLOR TO W/B
  66.    ELSE
  67.       SETCOLOR(REVERSE(old_color))
  68.    ENDIF
  69.    PUSHSCREEN(2,20,4,60,.T.,.T.)
  70.    @ 3,25 SAY "Enter DBF Name =>" GET tdbf PICT "!!!!!!!!!!!!" 
  71.    READ
  72.    IF EMPTY(tdbf)
  73.       POPSCREEN(2, 20, 4, 60)
  74.       SETCOLOR(old_color)
  75.       RETURN(.F.)
  76.    ENDIF
  77.  
  78.    CLEAR_AREA(2,20,4,60)
  79.    tdbf = IF(EMPTY(AT(".", LTRIM(TRIM(tdbf)))), LTRIM(TRIM(tdbf)) + ".DBF", LTRIM(TRIM(tdbf)))
  80.    
  81.    IF FILE(tdbf)
  82.       IF FILESIZE(tdbf) > 2*DISKSPACE() .OR. EMPTY(tdbf)
  83.          @ 3,24 SAY "Not enough room on disk.  Any Key to Continue..."
  84.          INKEY(0)
  85.          POPSCREEN(2,20,4,60)
  86.          RETURN(.F.)
  87.       ELSE
  88.          USE (tdbf)
  89.          @ 3,24 SAY "Making backup. Copy              "
  90.          COPY TO Sstback WHILE COUNTING(3,45)
  91.          CLEAR_AREA(2,20,4,60)
  92.          @ 3,24 SAY "Now Getting Information...."
  93.          DECLARE fdnm[FCOUNT()], fdtp[FCOUNT()], fdwd[FCOUNT()], fddc[FCOUNT()]
  94.          AFIELDS(fdnm, fdtp, fdwd, fddc)
  95.          cnt_2_it = 1
  96.          FOR now_2_it = 1 TO LEN(fdnm)
  97.             d[LEVEL(cnt_2_it, 1)] = fdnm[now_2_it]
  98.             d[LEVEL(cnt_2_it, 2)] = fdtp[now_2_it]
  99.             d[LEVEL(cnt_2_it, 3)] = fdwd[now_2_it]
  100.             d[LEVEL(cnt_2_it, 4)] = fddc[now_2_it]
  101.             cnt_2_it = cnt_2_it + 1
  102.          NEXT
  103.          KEYBOARD REPLICATE( CHR(13), (4 * LEN(fdnm) ) )
  104.       ENDIF
  105.    ENDIF
  106.    p[1] = TRIM(UPPERLOWER(tdbf))
  107.    tdbf = p[1]
  108.    dbfx = 1
  109.    STORE "" TO saying, pictre, valida, namestring
  110.    POPSCREEN(2, 20, 4, 60)
  111.  
  112.    PUSHSCREEN(1,20,4,60,.T.,.T.)
  113.    PUSHSCREEN(5,10,15,70,.T.,.T.)
  114.    SET CONFIRM ON
  115.  
  116.    @ 2,23 SAY "Database working on &tdbf."
  117.    DO WHILE .T.
  118.  
  119.       SET KEY 27 TO Get_out
  120.       SET KEY 18 TO Up_field
  121.       SET KEY  5 TO Up_one
  122.       SET KEY  6 TO Go_down
  123.       SET KEY  1 TO Go_top
  124.  
  125.       continue = .T.
  126.       f_cnt = LTRIM(TRIM(TRANSFORM( dbfx, "999")))
  127.       @  3,23 SAY "Field &f_cnt. : "
  128.       column = COL()
  129.       FOR dbfy = 1 TO 4
  130.          DO Dbfset
  131.          temp_get = d[LEVEL(dbfx,dbfy)]
  132.          RID(3, column, saying + "               ")
  133.          @  3,column SAY saying GET temp_get PICT pictre VALID &valida.
  134.          READ
  135.          IF LASTKEY() = 3
  136.             EXIT
  137.          ENDIF
  138.          IF LASTKEY() <> 27
  139.             d[LEVEL(dbfx,dbfy)] = temp_get
  140.             IF dbfy = 1                                 && The name
  141.                IF EMPTY(temp_get)
  142.                   KEYBOARD CHR(3)
  143.                   dbfy = -1
  144.                   continue = .F.
  145.                ELSE
  146.                   DO Putstring WITH temp_get, dbfx, dbfy
  147.                ENDIF
  148.             ENDIF
  149.          ENDIF
  150.          dbfy = IF(dbfy < 0, 0, dbfy)
  151.       NEXT
  152.       IF LASTKEY() = 3
  153.          IF !continue
  154.             EXIT
  155.          ENDIF
  156.       ENDIF
  157.       dbfx = IF(dbfx < 0, 0, dbfx)
  158.       dbfx = dbfx + 1
  159.    ENDDO
  160.    POPSCREEN(5,10,15,70)
  161.    DO Make_dbf2
  162.    CLEAR_AREA(1,20,4,60)
  163.    @ 2,23 SAY "Enter Row Number for Interactive"
  164.    @ 3,23 SAY "Display of Messages => " GET disp_at PICT "##" VALID (disp_at >= 0 .AND. disp_at <= 24)
  165.    READ
  166.    CLEAR_AREA(1,20,4,60)
  167.    @ 2,24 SAY "Shall I Generate This in Code? "
  168.    code_out = PROMPT()
  169.    IF code_out
  170.       @ 3,24 SAY "Then Enter .PRG name = " GET code_name PICT "!!!!!!!!!!"
  171.       READ
  172.       code_out = !EMPTY(code_name)
  173.       code_name = UPPERLOWER(code_name)
  174.    ENDIF
  175.  
  176.    CLEAR_AREA(1,20,4,60)
  177.    @ 2,31 SAY "Please Push Any Key"
  178.    @ 3,31 SAY "   to Continue. "
  179.    INKEY(0)
  180.    POPSCREEN(1,20,4,60)
  181.    SETCOLOR(old_color)
  182.    RETURN(.T.)
  183.  
  184. ********************
  185.  
  186. PROCEDURE Dbfset
  187.  
  188.    DO CASE
  189.    CASE dbfy = 1
  190.       saying = "    Name =>"
  191.       pictre = "!!!!!!!!!!"
  192.       valida = "GOODNAME(temp_get, dbfx, NO_BLANK(temp_get))"
  193.       IF EMPTY(d[LEVEL(dbfx,dbfy)])
  194.          d[LEVEL(dbfx,dbfy)] = SPACE(10)
  195.       ENDIF
  196.    CASE dbfy = 2
  197.       saying = "    Type =>"
  198.       pictre = "!"
  199.       valida = "temp_get$'NDMCL'"
  200.       IF EMPTY(d[LEVEL(dbfx,dbfy)])
  201.          d[LEVEL(dbfx,dbfy)] = " "
  202.       ENDIF
  203.    CASE dbfy = 3
  204.       saying = "  Length =>"
  205.       pictre = "####"
  206.       DO CASE
  207.       CASE d[LEVEL(dbfx,dbfy-1)] = "N"
  208.          IF EMPTY(d[LEVEL(dbfx,dbfy)])
  209.             d[LEVEL(dbfx,dbfy)] = 0
  210.          ENDIF
  211.          valida = "temp_get > 0 .AND. temp_get <= 19"
  212.       CASE d[LEVEL(dbfx,dbfy-1)] = "D"
  213.          IF EMPTY(d[LEVEL(dbfx,dbfy)])
  214.             d[LEVEL(dbfx,dbfy)] = 8
  215.          ENDIF
  216.          valida = "temp_get = 8"
  217.          KEYBOARD CHR(13) + CHR(13)
  218.       CASE d[LEVEL(dbfx,dbfy-1)] = "M"
  219.          IF EMPTY(d[LEVEL(dbfx,dbfy)])
  220.             d[LEVEL(dbfx,dbfy)] = 10
  221.          ENDIF
  222.          valida = "temp_get = 10"
  223.          KEYBOARD CHR(13) + CHR(13)
  224.       CASE d[LEVEL(dbfx,dbfy-1)] = "L"
  225.          IF EMPTY(d[LEVEL(dbfx,dbfy)])
  226.             d[LEVEL(dbfx,dbfy)] = 1
  227.          ENDIF
  228.          valida = "temp_get = 1"
  229.          KEYBOARD CHR(13) + CHR(13)
  230.       OTHERWISE
  231.          IF EMPTY(d[LEVEL(dbfx,dbfy)])
  232.             d[LEVEL(dbfx,dbfy)] = 0
  233.          ENDIF
  234.          valida = "temp_get > 0"
  235.       ENDCASE
  236.    OTHERWISE
  237.       saying = "Decimals =>"
  238.       pictre = "##"
  239.       IF EMPTY(d[LEVEL(dbfx,dbfy)])
  240.          d[LEVEL(dbfx,dbfy)] = 0
  241.       ENDIF
  242.       DO CASE
  243.       CASE d[LEVEL(dbfx,dbfy-2)] = "N"
  244.          IF d[LEVEL(dbfx,dbfy-1)] <= 2
  245.             valida = "temp_get >= 0 .AND. temp_get <= 1"
  246.          ELSE
  247.             valida = "temp_get >= 0 .AND. temp_get <= d[LEVEL(dbfx,dbfy-1)] - 2"
  248.          ENDIF
  249.       OTHERWISE
  250.          valida = "temp_get = 0"
  251.       ENDCASE
  252.    ENDCASE
  253.  
  254. ********************
  255.  
  256. FUNCTION Level
  257.  
  258.    PARAMETERS l1, l2
  259.  
  260.    RETURN((l1 * 4) - 4 + l2)
  261.  
  262. ********************
  263.  
  264. FUNCTION No_blank
  265.  
  266.    PARAMETERS no1
  267.  
  268.    the_one = LTRIM(TRIM(no1))
  269.    FOR going = 1 TO LEN(the_one)
  270.       IF SUBSTR(the_one, going, 1)$"!@#$%^&*()-=+\|/?><.,`~[]{}:; "
  271.          RETURN(.F.)
  272.       ENDIF
  273.    NEXT
  274.    RETURN(.T.)
  275.  
  276. ********************
  277.  
  278. PROCEDURE Get_out
  279.  
  280.    KEYBOARD CHR(3)
  281.    continue = .F.
  282.  
  283. ********************
  284.  
  285. PROCEDURE Up_field
  286.  
  287.    SET KEY 27 TO
  288.    KEYBOARD CHR(27)
  289.    dbfy = 5
  290.    dbfx = dbfx - 2
  291.  
  292. ********************
  293.  
  294. PROCEDURE Go_down
  295.  
  296.    KEYBOARD CHR(13) + CHR(13) + CHR(13) + CHR(13)
  297.  
  298. ********************
  299.  
  300. PROCEDURE Go_top
  301.  
  302.    KEYBOARD CHR(3)
  303.    dbfx = -1
  304.  
  305. ********************
  306.  
  307. PROCEDURE Up_one
  308.  
  309.    SET KEY 27 TO
  310.    KEYBOARD CHR(27)
  311.    dbfy = dbfy - 2
  312.  
  313. ********************
  314.  
  315. PROCEDURE Putstring
  316.  
  317.    PARAMETERS pstring, pcnt, ycnt
  318.  
  319.    pstring = FILL_OUT(pstring, 10)
  320.    IF LEN(namestring) < (pcnt * 10) - 9
  321.       namestring = namestring + pstring
  322.    ELSE
  323.       one_momen = FILL_OUT(d[LEVEL(dbfx,1)], 10)
  324.       namestring = STRTRAN(namestring, one_momen, pstring)
  325.    ENDIF
  326.    base = dbfx - 1
  327.    IF (INT(base / 4) + 6 > 14)
  328.       IF (15 * ((base % 4) - 1)) < 0
  329.          SCROLL(6,11,14,69,1)
  330.       ENDIF
  331.       base = base - 4
  332.       @ 14, 28 + (15 * (MODULUS(base, 4) - 1)) SAY pstring
  333.    ELSE
  334.       @ 7 + INT(base  / 4) - 1, 28 + (15 * (MODULUS(base, 4) - 1)) SAY pstring
  335.    ENDIF
  336.  
  337. ********************
  338.  
  339. FUNCTION Goodname
  340.  
  341.    PARAMETERS gname, gcnt, stophere
  342.  
  343.    IF !stophere
  344.       RETURN(.F.)
  345.    ENDIF
  346.  
  347.    IF EMPTY(namestring)
  348.       RETURN(.T.)
  349.    ENDIF
  350.  
  351.    gname = FILL_OUT(gname, 10)
  352.  
  353.    IF gname$namestring
  354.       RETURN(TRIM(gname) == TRIM(SUBSTR(namestring, (gcnt * 10) - 9, 10)))
  355.    ELSE
  356.       RETURN(.T.)
  357.    ENDIF
  358.  
  359. ********************
  360.  
  361. PROCEDURE Make_dbf2
  362.  
  363.    SET KEY 27 TO 
  364.    SET KEY 18 TO 
  365.    SET KEY  5 TO 
  366.    SET KEY  6 TO 
  367.    SET KEY  1 TO 
  368.    dbfx = 2
  369.    DO WHILE .T.
  370.       CLEAR_AREA(1,20,4,60)
  371.       temp_ndx = SPACE(12)
  372.       @ 3,25 SAY "      Leave Blank to Exit"
  373.       @ 2,25 SAY "Index Name => " GET temp_ndx PICT "!!!!!!!!!!!!"
  374.       READ
  375.       IF EMPTY(temp_ndx)
  376.          EXIT
  377.       ENDIF
  378.       IF FILE(temp_ndx)
  379.          SET INDEX TO &temp_ndx
  380.          ndx_exp = LOWER(FILL_OUT(INDEXKEY(0), 200))
  381.       ELSE
  382.          temp_ndx = IF(EMPTY(AT(".", TRIM(temp_ndx))), TRIM(temp_ndx) + ".ntx", TRIM(temp_ndx))
  383.          p[dbfx] = temp_ndx
  384.          ndx_exp = SPACE(200)
  385.       ENDIF
  386.       CLEAR_AREA(1,20,4,60)
  387.       @ 2,27 SAY "Enter the Index Expression"
  388.       PUSHSCREEN(5,10,7,70,.T.,.T.)
  389.       @ 6,12 SAY "=> " GET ndx_exp PICT "@S50@!" VALID MUSTFILL(ndx_exp,3,27)
  390.       READ
  391.       e[dbfx - 1] = UPPERLOWER(LTRIM(TRIM(ndx_exp)))
  392.       POPSCREEN(5,10,7,70)
  393.       dbfx = dbfx + 1
  394.    ENDDO
  395.  
  396. ********************
  397.  
  398. PROCEDURE Make_it
  399.  
  400.    PARAMETERS the_names, the_fields, the_indexes, where_at
  401.  
  402.    IF code_out
  403.       SET ALTERNATE TO &code_name..prg
  404.       DO Writ_it_out WITH "  ********************| |  * Remove this line and the asterisk on the next line if adding to a file|  * PROCEDURE &code_name.|  |"
  405.    ENDIF
  406.  
  407.    cur_area = LTRIM(TRIM(STR(SELECT())))
  408.    SELECT 9
  409.    master_file = LTRIM(TRIM(the_names[1]))
  410.    the_mess = "Initializing &master_file. File.. "
  411.    IF !EMPTY(where_at)
  412.       IF !code_out
  413.          @ where_at,0 SAY the_mess
  414.       ENDIF
  415.    ENDIF
  416.  
  417.    where_str = LTRIM(TRIM(STR(where_at)))
  418.    IF code_out
  419.       DO Writ_it_out WITH "  ret_to = LTRIM(TRIM(STR(SELECT())))|  SELECT 0|  @ &where_str., 5 SAY [&the_mess.]|  CREATE Template|  USE Template"
  420.    ENDIF
  421.  
  422.    IF !FILE("Template.dbf")
  423.       CREATE Template
  424.       USE Template
  425.    ELSE
  426.       USE Template
  427.       ZAP
  428.    ENDIF
  429.  
  430.    start = 1
  431.    DO WHILE !EMPTY(the_fields[LEVEL(start, 1)])
  432.  
  433.       IF code_out
  434.          write_fld = the_fields[LEVEL(start, 1)]
  435.          write_typ = the_fields[LEVEL(start, 2)]
  436.          write_len = LTRIM(TRIM(STR(the_fields[LEVEL(start, 3)])))
  437.          write_dec = LTRIM(TRIM(STR(the_fields[LEVEL(start, 4)])))
  438.          DO Writ_it_out WITH "  DO Ap_it WITH [&write_fld.], [&write_typ.], &write_len., &write_dec."
  439.       ENDIF
  440.  
  441.       DO Ap_it WITH the_fields[LEVEL(start, 1)], the_fields[LEVEL(start, 2)], the_fields[LEVEL(start, 3)], the_fields[LEVEL(start, 4)]
  442.       start = start+ 1
  443.    ENDDO
  444.  
  445.    IF code_out
  446.       DO Writ_it_out WITH "  USE|  CREATE &master_file. FROM Template|  ERASE Template.dbf|  USE &master_file.|  RID(&where_str., 5, [&the_mess.])"
  447.    ENDIF
  448.  
  449.    USE
  450.    IF !EMPTY(master_file)
  451.       CREATE &master_file FROM Template
  452.       ERASE Template.dbf
  453.       USE (master_file)
  454.    ENDIF
  455.    IF !EMPTY(where_at)
  456.       RID(where_at, 0, the_mess)
  457.    ENDIF
  458.    indexes = 2
  459.  
  460.    DO WHILE !EMPTY(the_names[indexes])
  461.       ndx_file = the_names[indexes]
  462.       ndx_exp  = the_indexes[indexes - 1]
  463.  
  464.       the_mess = "Creating &ndx_file. File"
  465.  
  466.       IF !EMPTY(where_at)
  467.          IF !code_out
  468.             @ where_at - 1 + indexes, 0 SAY the_mess
  469.          ENDIF
  470.          INDEX ON (ndx_exp) TO (ndx_file)
  471.          IF !code_out
  472.             RID(where_at - 1 + indexes, 0, the_mess)
  473.          ENDIF
  474.       ELSE
  475.          INDEX ON (ndx_exp) TO (ndx_file)
  476.       ENDIF
  477.  
  478.       IF code_out
  479.  
  480.          where_str = LTRIM(TRIM(STR(INT(where_at - 1 + indexes))))
  481.          DO Writ_it_out WITH "  @ &where_str, 5 SAY [&the_mess.]|  INDEX ON &ndx_exp. TO &ndx_file.|  RID(&where_str, 5, [&the_mess.])"
  482.  
  483.       ENDIF
  484.  
  485.       indexes = indexes + 1
  486.  
  487.    ENDDO
  488.  
  489.    IF code_out
  490.       DO Writ_it_out WITH "  USE|  SELECT &" + "ret_to."
  491.       CLOSE ALTERNATE
  492.    ENDIF
  493.  
  494.    SELECT &cur_area.
  495.  
  496. * End of File
  497.