C!T ROM 2/ctrom_ii_b.zip/ctrom_ii_b/PROGRAM/CLIPPER/SCRNUZ/MAKEREPO.PRG

Text File | 1991-12-13 | 12KB | 393 lines

*----------------------------------------------------------------------------
*
*   Program Name: MAKEREPO.PRG      Copyright: EDON Corporation
*   Date Created: 10/26/90           Language: Clipper S'87
*   Time Created: 17:03:18             Author: Ed Phillips
*    Description:
*----------------------------------------------------------------------------

CLEAR
STORE Space(8) TO dbf1, dbf2, dbf3, dbf4, dbf5
STORE Space(8) TO d1_ndx1, d1_ndx2, d1_ndx3, d1_ndx4, d1_ndx5
STORE Space(8) TO d2_ndx1, d2_ndx2, d2_ndx3, d2_ndx4, d2_ndx5
STORE Space(8) TO d3_ndx1, d3_ndx2, d3_ndx3, d3_ndx4, d3_ndx5
STORE Space(8) TO d4_ndx1, d4_ndx2, d4_ndx3, d4_ndx4, d4_ndx5
STORE Space(8) TO d5_ndx1, d5_ndx2, d5_ndx3, d5_ndx4, d5_ndx5

prg = Space(8)
tit = Space(30)
rpt_prompt = Space(50)
key_expr = Space(50)
key_len = 0
key_pict = Space(20)
ctrl_cond = Space(50)

exit_msg = 'To Exit, Leave Program Name Empty'
prompt1 = 'Enter Data Base File Names'
prompt2 = 'Enter Associated Indexes'
prompt3 = 'Enter Name of Program to Create'
prompt5 = 'Enter Screen Title'
prompt6 = 'Enter Report Prompt'
prompt7 = 'Enter Report Scope-Variable Expression'
prompt8 = 'Enter Controlling DO WHILE loop condition'
prompt9 = 'Enter Key Length'
prompt10 = 'Enter Key Picture (no quotes)'

@ 03,Centr(prompt3,8) SAY prompt3 GET prg PICT '!XXXXXXX'
@ 05,Centr(prompt5,30) SAY prompt5 GET tit
@ 06,Centr(prompt6,0) SAY prompt6
@ 07,15 GET rpt_prompt
@ 08,Centr(prompt7,0) SAY prompt7
@ 09,15 GET key_expr
* @ 10,Centr(prompt9,2) SAY prompt9 GET key_len PICT '##'
@ 11,Centr(prompt10,20) SAY prompt10 GET key_pict
@ 12,Centr(prompt8,0) SAY prompt8
@ 13,15 GET ctrl_cond
@ 24,Centr(exit_msg,0) SAY exit_msg
READ

IF Empty(prg)
   RETURN
ELSE
   prefix = Trim(Subs(prg,1,4))
   prg = Trim(prg)+'.prg'
   tit = Trim(tit)
   rpt_prompt = Trim(rpt_prompt)
   key_expr = Trim(key_expr)
   ctrl_cond = Trim(ctrl_cond)
*   key_lstr = IIF(key_len < 10, Str(key_len,1,0), Str(key_len,2,0))
   key_pict = Trim(key_pict)
ENDIF

@ 6,0 CLEAR
@ 06,Centr(prompt1,0) SAY prompt1

@ 07,16 GET dbf1 PICT '!XXXXXXX'
@ 07,26 GET dbf2 PICT '!XXXXXXX'
@ 07,36 GET dbf3 PICT '!XXXXXXX'
@ 07,46 GET dbf4 PICT '!XXXXXXX'
@ 07,56 GET dbf5 PICT '!XXXXXXX'
READ

@ 09,Centr(prompt2,0) SAY prompt2
@ 10,16 GET d1_ndx1 PICT '!XXXXXXX'
@ 11,16 GET d1_ndx2 PICT '!XXXXXXX'
@ 12,16 GET d1_ndx3 PICT '!XXXXXXX'
@ 13,16 GET d1_ndx4 PICT '!XXXXXXX'
@ 14,16 GET d1_ndx5 PICT '!XXXXXXX'

@ 10,26 GET d2_ndx1 PICT '!XXXXXXX'
@ 11,26 GET d2_ndx2 PICT '!XXXXXXX'
@ 12,26 GET d2_ndx3 PICT '!XXXXXXX'
@ 13,26 GET d2_ndx4 PICT '!XXXXXXX'
@ 14,26 GET d2_ndx5 PICT '!XXXXXXX'

@ 10,36 GET d3_ndx1 PICT '!XXXXXXX'
@ 11,36 GET d3_ndx2 PICT '!XXXXXXX'
@ 12,36 GET d3_ndx3 PICT '!XXXXXXX'
@ 13,36 GET d3_ndx4 PICT '!XXXXXXX'
@ 14,36 GET d3_ndx5 PICT '!XXXXXXX'

@ 10,46 GET d4_ndx1 PICT '!XXXXXXX'
@ 11,46 GET d4_ndx2 PICT '!XXXXXXX'
@ 12,46 GET d4_ndx3 PICT '!XXXXXXX'
@ 13,46 GET d4_ndx4 PICT '!XXXXXXX'
@ 14,46 GET d4_ndx5 PICT '!XXXXXXX'

@ 10,56 GET d5_ndx1 PICT '!XXXXXXX'
@ 11,56 GET d5_ndx2 PICT '!XXXXXXX'
@ 12,56 GET d5_ndx3 PICT '!XXXXXXX'
@ 13,56 GET d5_ndx4 PICT '!XXXXXXX'
@ 14,56 GET d5_ndx5 PICT '!XXXXXXX'
READ


   SET PRINTER TO &prg
   SET DEVICE TO PRINT
   Setprc(0,0)
   @ Lc(),0 SAY '* Program: '+ prg
   @ Lc()+1,0 SAY '* Author : Ed Phillips'
   @ Lc()+1,0 SAY '* Date   : '+DTOC(DATE())
   @ Lc()+1,0 SAY '* Copyright (C) '+Str(Year(Date()),4,0)+', EDON Corporation'


   @ Lc()+3,0 SAY 'PRIV tit,phdr,rprompt,key_field'
   @ Lc()+1,0 SAY 'phdr = '+ '"'+ prefix+ '_hdr'+ '"'
   @ Lc()+1,0 SAY 'tit = '+ '"&tit"'
   IF Empty(rpt_prompt)
      @ Lc()+1,0 SAY 'rprompt = "This is a report prompt"'
   ELSE
      @ Lc()+1,0 SAY 'rprompt = '+'"&rpt_prompt"'
   ENDIF
   @ Lc()+1,0 SAY 'ex_flg = .f.'
   @ Lc()+1,0 SAY ''

*------------------------------
* Create Open database commands
*------------------------------

IF ! Empty(dbf1)
   FOR j = 1 TO 5
      ndxstr = ' '
      ndxlevel = 'd'+Str(j,1,0)
      dbfvar = 'dbf'+Str(j,1,0)
      ndxwork = ndxlevel+'_ndx1'

      IF Empty(&dbfvar)
         EXIT
      ENDIF

      IF ! Empty(&ndxwork)
         ndxstr = ' INDEX '+Trim(&ndxwork)
         FOR i = 2 TO 5
            ndxvar = ndxlevel+'_ndx'+Str(i,1,0)
            IF ! Empty(&ndxvar)
               ndxstr = ndxstr+ ', '+Trim(&ndxvar)
            ELSE
               EXIT
            ENDIF
         NEXT   && i
      ENDIF

      IF j > 1
         @ Lc()+1,0 SAY 'SELECT 0'
      ENDIF

      IF Empty(ndxstr)
         @ Lc()+1,0 SAY 'USE '+ Trim(&dbfvar)
      ELSE
         @ Lc()+1,0 SAY 'USE '+ Trim(&dbfvar) + ndxstr
      ENDIF
   NEXT   && j
ELSE
   @ Lc()+1,0 SAY '*** INSERT DATABASES!! ***'
ENDIF   && dbf1


@ Lc()+2,0 SAY 'IF ! ex_flg'

IF ! Empty(dbf1)
   @ Lc()+1,3 SAY 'SELECT '+ dbf1
ELSE
   @ Lc()+1,3 SAY 'SELECT '+'&& INSERT CONTROLLING DATABASE NAME'
ENDIF

@ Lc()+1,0 SAY '   ok = .t.'
@ Lc()+1,0 SAY '   Setcolor(c_norm)'
@ Lc()+1,0 SAY '   CLEAR'
@ Lc()+1,0 SAY '   @ 1,Centr(tit) SAY tit'

IF ! Empty(key_expr)
   @ Lc()+1,3 SAY 'key_field = '+Trim(key_expr)
ELSE
   @ Lc()+1,3 SAY 'key_field = Space(20)'
ENDIF

* handle key_field input
IF ! Empty(key_pict)
   @ Lc()+1,3 SAY '@ 10,Centr(rprompt,Len(key_field)) SAY rprompt GET key_field PICT "&key_pict"'
ELSE
   @ Lc()+1,3 SAY '@ 10,Centr(rprompt,Len(key_field)) SAY rprompt GET key_field'
ENDIF
@ Lc()+1,0 SAY '   READ'

@ Lc()+1,0 SAY '   IF Empty(key_field)'
@ Lc()+1,0 SAY '      ok = .f.'
@ Lc()+1,0 SAY '   ENDIF'

@ Lc()+2,0 SAY '   IF ok'
@ Lc()+1,0 SAY "      output = 'QUIT'"
@ Lc()+1,0 SAY "      f_name = Space(20)"
@ Lc()+1,0 SAY '      lines = 43'
@ Lc()+1,0 SAY '      page = 1'

@ Lc()+1,0 SAY '      Get_device("PFQ")'
@ Lc()+1,0 SAY '      BEGIN SEQUENCE'
@ Lc()+1,0 SAY "         IF (output = 'QUIT') .OR. (output = 'FILE' .AND. Empty(f_name))"
@ Lc()+1,0 SAY "            BREAK"
@ Lc()+1,0 SAY '         ELSE'
@ Lc()+1,0 SAY "            IF output = 'PRINTER'"
@ Lc()+1,0 SAY "               prt = EOSprint()"
@ Lc()+1,0 SAY "               IF prt # 'Local Dot Matrix'   &&Epson FX'"
@ Lc()+1,0 SAY "                  mem_defprt = 'HP Laser'"
@ Lc()+1,0 SAY "                  Ljland()"
@ Lc()+1,0 SAY "                  SET MARGIN TO 10"
@ Lc()+1,0 SAY "               ELSE                                             && OTHERWISE..."
@ Lc()+1,0 SAY "                  mem_defprt = 'Epson FX'"
@ Lc()+1,0 SAY "                  Epson17()"
@ Lc()+1,0 SAY "                  send_ff = .t."
@ Lc()+1,0 SAY "               ENDIF"
@ Lc()+1,0 SAY "               Setprc(0,0)"
@ Lc()+1,0 SAY "            ENDIF                                && IF output = 'PRINTER'"
@ Lc()+1,0 SAY "            Saycxl()"

@ Lc()+1,0 SAY '            Rpt_header(1,output,Lc(),.f.)'

IF ! Empty(ctrl_cond)
   @ Lc()+1,0 SAY '            DO WHILE '+ ctrl_cond
ELSE
   @ Lc()+1,0 SAY '            DO WHILE ! Eof()'
ENDIF

@ Lc()+1,0 SAY '               *-------------'
@ Lc()+1,0 SAY '               * Escape route'
@ Lc()+1,0 SAY '               *-------------'
@ Lc()+1,0 SAY '               cxl = Inkey()'
@ Lc()+1,0 SAY '               IF cxl = esc'
@ Lc()+1,0 SAY '                  EXIT'
@ Lc()+1,0 SAY '               ENDIF'

@ Lc()+1,15 SAY prefix+'_det'+'()'
@ Lc()+1,0 SAY '               SKIP'
@ Lc()+1,0 SAY '            ENDDO'
@ Lc()+1,0 SAY "            @ Lc()+2,0 SAY '** End of Report **'"
@ Lc()+1,0 SAY "            IF output = 'PRINTER'"
@ Lc()+1,0 SAY "               IF prt # 'Local Dot Matrix'   &&Epson FX'"
@ Lc()+1,0 SAY "                  mem_defprt = 'HP Laser'"
@ Lc()+1,0 SAY "                  Ljport()"
@ Lc()+1,0 SAY "               ELSE                                             && OTHERWISE..."
@ Lc()+1,0 SAY "                  mem_defprt = 'Epson FX'"
@ Lc()+1,0 SAY "                  Epson10()"
@ Lc()+1,0 SAY "               ENDIF"
@ Lc()+1,0 SAY "            ENDIF                                && IF output = 'PRINTER'"
@ Lc()+1,0 SAY "            SET MARGIN TO"
@ Lc()+1,0 SAY '            Eorpt(send_ff)'

@ Lc()+1,0 SAY "         ENDIF                                && IF (output = 'PRINTER')"
@ Lc()+1,0 SAY "      END                                     && BEGIN SEQUENCE"
@ Lc()+1,0 SAY '   ENDIF                     && IF ok'
@ Lc()+1,0 SAY 'ENDIF                     && ! ex_flg'
@ Lc()+1,0 SAY 'CLOSE DATA'
@ Lc()+1,0 SAY 'RELEASE ALL'
@ Lc()+1,0 SAY 'RETURN'


*------------------------------
* Write Report header procedure
*------------------------------

@ Lc()+3,0 SAY 'PROC '+prefix+'_hdr'
@ Lc()+1,0 SAY 'PARA page, ln'
@ Lc()+1,0 SAY 'PRIV tit1, tit2, tit3'

SET DEVICE TO SCREEN

@ 6,0 CLEAR
STORE Space(130) TO tit1, tit2, tit3, tit4, tit5, tit6
msg = 'Enter Report Page Header'
msg1 = 'Enter Report Column Header'
@ 6,Centr(msg,0) SAY msg
@ 7,0 GET tit1 PICT '@S80'
@ 8,0 GET tit2 PICT '@S80'
@ 9,0 GET tit3 PICT '@S80'
READ

col_hdr = ' '
SET COLOR TO W+/GR+
@ 10,Centr(msg1,0) SAY msg1

*-------------------
* GET Column Headers
*-------------------

col_hdr = Memoedit(col_hdr,11,0,15,80,.T.,"",130)

tit4 = Trim(Memoline(col_hdr,130,1))
tit5 = Trim(Memoline(col_hdr,130,2))
tit6 = Trim(Memoline(col_hdr,130,3))

max_ln = Max(80,Len(tit4))
max_ln = Max(max_ln,Len(tit5))
max_ln = Max(max_ln,Len(tit6))

SET DEVICE TO PRINT

IF ! Empty(tit1)
   IF Upper(Subs(tit1,1,2)) = '@F'               && field flag
      @ Lc()+1,3 SAY 'tit1 = '+Alltrim(tit1)
   ELSE                                          && else, string
      @ Lc()+1,3 SAY 'tit1 = "'+Alltrim(tit1)+'"'
   ENDIF
   IF ! Empty(tit2)
      IF Upper(Subs(tit2,1,2)) = '@F'
         @ Lc()+1,3 SAY 'tit2 = '+Alltrim(tit2)
      ELSE
         @ Lc()+1,3 SAY 'tit2 = "'+Alltrim(tit2)+'"'
      ENDIF
      IF ! Empty(tit3)
         IF Upper(Subs(tit3,1,2)) = '@F'
            tit3 = Subs(tit3,3)
            @ Lc()+1,3 SAY 'tit3 = '+Alltrim(tit3)
         ELSE
            @ Lc()+1,3 SAY 'tit3 = "'+Alltrim(tit3)+'"'
         ENDIF
      ENDIF
   ENDIF
ENDIF

@ Lc()+2,3 SAY '@ Lc(),0 SAY page PICT "@R Page: ###"'
max_str = Str(max_ln,3,0)
IF ! Empty(tit1)
   @ Lc()+1,3 SAY '@ Lc(),Rpt_centr(tit1,&max_str) SAY tit1'
ENDIF
dcol = Str(max_ln-15,3,0)
@ Lc()+1,3 SAY '@ Lc(),&dcol. SAY "As Of: "+Dtoc(Date())'
IF ! Empty(tit2)
   @ Lc()+1,3 SAY '@ Lc(),Rpt_centr(tit2,&max_str) SAY tit2'
ENDIF
IF ! Empty(tit3)
   @ Lc()+1,3 SAY '@ Lc(),Rpt_centr(tit3,&max_str) SAY tit3'
ENDIF

*------------------------
* Create Column Header(s)
*------------------------

IF ! Empty(tit4)
   @ Lc()+1,3 SAY '@ Lc()+2,0 SAY "&tit4"'
   IF ! Empty(tit5)
      @ Lc()+1,3 SAY '@ Lc()+1,0 SAY "&tit5"'
      IF ! Empty(tit6)
         @ Lc()+1,3 SAY '@ Lc()+1,0 SAY "&tit6"'
      ENDIF
   ENDIF
ENDIF

IF ! Empty(tit4)
   SET DECIMALS TO 0
   tempstr =  '*               '
   temp2 = tempstr+'          '
   FOR i = 0 TO max_ln
      col_num = IIF( i > 9, Mod(i, 10), i)
      tempstr = tempstr + Str(col_num,1,0)
   NEXT
   @ Lc()+1,3 SAY tempstr
   tempstr = Subs(tempstr,At('0',tempstr))
   max_ln = Int(Len(tempstr)/10)
   FOR i = 1 TO max_ln
      col_num = IIF( i > 9, Mod(i, 10), i)
      temp2 = temp2 + Str(col_num,1,0)+ Space(9)
   NEXT
   temp2 = Trim(temp2)
   @ Lc()+1,3 SAY temp2
ENDIF
@ Lc()+1,0 SAY 'RETURN'


*-----------------------------
* Write Report Detail Procedure
*-----------------------------

@ Lc()+2,0 SAY 'PROC '+prefix+'_det'
@ Lc()+1,3 SAY 'IF ! Enuf_ln(Lc(),lines,1)'
@ Lc()+1,6 SAY 'Rpt_header(1,output,1,.t.)'
@ Lc()+1,3 SAY 'ENDIF'
@ Lc()+1,0 SAY 'RETURN'

@ Lc()+1,0 SAY '* EOF: '+ prg
SET PRINT TO
SET DEVI TO SCREEN
CLOSE ALL
RETU
* EOF: Makerepo.prg