Shareware Overload/ShartewareOverload.cdr/database/prg_hlp.zip/PRG_HLP.PRG

Text File | 1987-04-07 | 38KB | 1,403 lines

************************************************************************
*                          PRG_HLP.PRG   version 1.2                   *
*                   S. ROBERT DAVIDOFF, D.M.D.                         *
*                         November 1986                                *
************************************************************************
*    This program will allow you to make modifications in your .PRG
*    files and your database files from within your CLIPPER program.
*    It is a debugging tool that I designed to help me write my programs
*     more efficiently. I got tired of "jumping out" of my Clipper programs
*    to edit files and edit databases and make new databases, and use dflow
*    and Documentor to help me debug, and........
*    In order to take maximum use of the program, you should have (AS IN
*    PURCHASE!!!) the following programs:
*
*                        THE NORTON EDITOR   (NE)
*                 NORTON UTILITIES DIRECTORY SORT  (DS.COM)
*                        DFLOW                          (WALLSOFT)
*                        THE DOCUMENTOR   (DOC)    (WALLSOFT)
*
*    You may, of course, substitute another editor for the Norton Editor and
*    you may choose to not use one or more of the other programs that I have
*    incorporated here, BUT to get maximum effect, I would suggest that you
*    purchase and use all of the programs... They were all designed as serious
*    adjuncts to serious programming.
*
*    You can also link in DOT.PRG which comes on the Clipper Autmn disk. DOT
*    is supposed to do some of these things, but I found my program to be more
*    reliable and easier to operate.
*
*    The beauty of this program is that you merely have to hit the F2 key
*  from any "Wait" state in your running clipper program and you can
*  Tinker with all the .prg files and databases without leaving clipper.
*    Make as many changes as you would like and then continue running your
*    clipper program. When your through debugging, simply recompile and your
*    in business! You can also make new databases as well as modifying old
*    ones from inside your Clipper program.
**********************************************************************
*
*               CREDIT WHERE CREDIT IS DUE!!!!
*
**********************************************************************
*    I wish to thank the DATABASED ADVISOR magazine from which some of my
*    better ideas eminate. This program is based on information from
*    DataBased Advisor, particularly J. Ari Kornfeld's article in the
*    December 1986 issue. I have consistently found this magazine to be
*    the best source of usefull information for my programming needs!!!
**********************************************************************
**********************************************************************
*
*                   BEFORE YOU BEGIN....
*
**********************************************************************
*    The calling program has to set the F2 key as follows:
*
*                      SET KEY -1 TO PRG_HLP
*
*  This will activate this program from any "wait" state when the F2 key
*  is pressed.
*
*  The variable "REPEAT", must be initialized by the calling program as
*  a PUBLIC  variable (which is automatically set to .F.). This will prevent
*  a recurrsive call of this program. The parameters passed are the same as
*  the normal Clipper HELP program.
*  The PROCEDURES INDEX_H and REINDEX_ are set up for your specific programs.
*  I have included them here as demonsration modules. You have to set
*    then up for your own programs and you have to change them as you add or
*    subtract databases and/or indexes
*
**********************************************************************
*
*  PLEASE BE AWARE THAT THERE ARE STILL SOME BUGS IN THIS PROGRAM!!!!
*  I will release updates as they come along.
*  You are encouraged to make any modifications that you wish. I would hope
*  that any improvements generated will be thrown back into the public domaine
*  area so that others may use them.....
*  If you like the program or if you have any comments, please leave me a
*  message on the Source.
*
*      Bob Davidoff
*                              SOURCE ID:  NA2066
**********************************************************************
**********************************************************************
parameters call_prg,Line_num,input_var
MHLP_CODE = HELP_CODE
HELP_CODE = "00"
public hselection
set console on
PRIVATE MSEL,N,X
if repeat                && prevents recurrsive calls
   repeat = .F.
   return
else
   repeat = .T.
   save screen to prghlp
   do while .T.
      @ 0,0 clear
        answer = space(1)
**********************************************************************
*   insert the version of clipper that you are using here            *
**********************************************************************
        @ 1,4 say "AUTUMN VERSION"
      SET color to I
      do h_center with 1, call_prg + ".PRG"
      SET color to
      @ 1,60 say "MEMORY: [" + ALLTRIM(STR(memory(0))) + "]"
        msel = select()
        n = msel
        mdbf1 = space(1)
        row = 6
        do while n > 0
        if len(trim(H_dbf())) > 0
            do Hs_select with n
            x = select()
            @ row,60 say "Select "
            @ row,col() say x
            row = row+1
            @ row,65 say H_dbf()
            row = row+1
            @ row,65 say "Record " +alltrim(str(recno()))
            row = row+1
            n = n-1
         else
            do Hs_select with n
            n = n-1
        endif
        enddo
        do Hs_select with msel
        @ 5,59 to row,78
      head1 = "1. NORTON EDITOR           "
        head2 = "2. DFLOW                   "
        head3 = "3. DOCUMENTOR              "
        head4 = "4. WHAT KEY                "
        head5 = "5. NEWLY CHANGED PRG FILES "
        head6 = "6. MODIFY DBF FILES        "
        head7 = "7. EDIT RECORDS IN DBF FILE"
        head8 = "8. CREATE A NEW DBF FILES  "
        head9 = "9. COMPILE PROGRAM         "
        head0 = "0. RETURN TO CLIPPER       "
        Hnum_items = 10
        HX = 7
        HY = 23
        HW = LEN(HEAD1)
        DO H_F1 WITH "HELP"
        @ 22,1 to 22,78 double
      @ 0,0 TO 24,79 DOUBLE
        @ 23,2 say "Use UP and DOWN arrows to highlight choice...Press ENTER to select"
        do h_lightbar with Hnum_items,HX,HY,HW,head1,head2,head3,head4,head5,head6,head7,head8,head9,head0
        choice = str(hselection,1)
      do case
      case answer = "Q"
         clear
        quit
      case choice = "0"                && RETURNS TO CLIPPER
         @ 0,0 clear
         repeat = .F.
         HELP_CODE = MHLP_CODE
         restore screen from prghlp
         return


      case choice = "1"                && LOADS THE NORTON EDITOR
         mfile = "NE.COM"
            if .not. file(mfile)
                do hlp_mes with "YOU MUST HAVE THE NORTON EDITOR <NE.COM>"
                loop
            endif
            mfile = space(15)
         DO CLEARIT WITH 22,1,23,78
         @ 22,1
         accept "Enter name of file to edit..." to mfile
         if len(trim(mfile)) = 0
            mfile = call_prg + ".prg"
            ! \ne + &mfile
         else
            X = AT(".",mfile)
            if X = 0
               mfile = mfile + ".prg"
               ! \ne + &mfile
            else
               ! \ne + &mfile
            endif
         endif
      case choice = "2"              && CALL DFLOW
         mfile = "DFLOW.COM"
            if .not. file(mfile)
                do hlp_mes with "YOU MUST HAVE WALLSOFT'S DFLOW  <DFLOW.COM>"
                loop
            endif
            ! dflow

      case choice = "3"              && CALL THE DOCUMENTOR
            mfile = "DOC.COM"
            if .not. file(mfile)
                do hlp_mes with "YOU MUST HAVE WALLSOFT'S DOCUMENTOR  <DOC.COM>"
                loop
            endif
         ! doc


      case choice = "4"              && CHECK INKEY VALUES
         do whatkey

      case choice = "5"              && MAKES A BAT FILE TO COMPILE NEW PRG'S
         mfile = "DS.COM"
            if .not. file(mfile)
                do hlp_mes with "YOU MUST HAVE NORTON UTILITIES  <DS.COM>"
                loop
            endif
            do H_make

      case choice = "6"              && CHANGE A DBF FILE
         do dbf_chng

      case choice = "7"              && EDIT A DBF FILE
         do srd_edit

      case choice = "8"              && MAKE NEW DBF FILE
         do dbf_make

      case choice = "9"                && COMPILE A SINGLE FILE
         mfile = "CLIPPER.EXE"
            if .not. file(mfile)
                do hlp_mes with "YOU MUST HAVE THE CLIPPER COMPILER  <CLIPPER.EXE>"
                loop
            endif
            mfile = space(15)
         DO CLEARIT WITH 22,1,23,78
         @ 22,1
         accept "Enter name of file to Compile... " to mfile
         @ 0,0 clear
         if len(trim(mfile)) = 0
            mfile = call_prg + "-m"
            ! clipper &mfile
         else
            mfile = mfile + "-m"
            ! clipper &mfile
         endif
         wait
      endcase
   enddo
endif
***********************************************************************
**********************************************************************
*  PROCEDURE TO MODIFY DATABASE STRUCTURE

procedure dbf_chng
msel = select()
n = msel
mdbf1 = space(1)
do while n > 0
   if len(trim(H_dbf())) > 0
      x = str(n,1)
      mdbf&x = H_dbf()
      mrec&x = recno()
      n = n-1
      select n
   else
      mdbf&x = space(1)
      n = n-1
      select n
   endif
enddo
close databases
clear gets
do while .T.
   do while .T.
      @ 0,0 clear
      mname = space(8)
      @ 0,10
      dir *.dbf
      @ 20,35 say "Enter name of DBF file..." get mname picture "@!"
      read
      if len(trim(mname)) = 0
         ?
         do index_H
         n = msel
         do while n > 0
            x = str(n,1)
            if len(trim(mdbf&x)) > 0
               select n
               mdbf = mdbf&x
               use &mdbf
               mrec = mrec&x
               goto mrec
               n = n-1
            else
               n = n-1
            endif
         enddo
         return
      endif
      mname = trim(mname)
      first = mname + ".DBF"
      if .not. file(first)
         ? first + " not found"
         WAIT
         loop
      else
         exit
      endif
   enddo
   use &mname
   copy to teststru structure extended
   use teststru
   copy to testasci SDF
   ! ne testasci.txt
   @ 0,0 clear
   do h_center with 12, "working..."
   second = mname + ".BAK"
   erase &second
   rename &first to &second
   use teststru
   zap
   append from testasci SDF
   create &mname from teststru
   append from &second
   @ 0,0 clear
   nnn = 1
   for nnn = 1 to fcount()
   ? fieldname(nnn)
   next
   close databases
   erase &second
   erase teststru.dbf
   erase testasci.txt
enddo
**********************************************************************
*   PROCEDURE TO CREAT A NEW DBF FILE

procedure dbf_make
msel = select()
clear gets
do while .T.
   do while .T.
      @ 0,0 clear
      mname = space(8)
      @ 0,10
      dir *.dbf
      @ 20,35 say "Enter name of DBF file..." get mname picture "@!"
      read
      if len(trim(mname)) = 0
         select msel
         return
      endif
      mname = trim(mname)
      first = mname + ".DBF"
      if file(first)
         ? first + " already exists"
         WAIT
         loop
      else
         exit
      endif
   enddo
   create TEST1
   list
   *       select (0)
   use TEST1
   copy to teststru structure extended
   use teststru
   copy to testasci SDF
   ! ne testasci.txt
   @ 0,0 clear
   do h_center with 12, "working..."
   use teststru
   zap
   append from testasci SDF
   create &mname from teststru
   @ 0,0 clear
   nnn = 1
   for nnn = 1 to fcount()
   ? fieldname(nnn)
   IF nnn = 22
      inkey(0)
      @ 0,0 clear
   endif
   next
   inkey(0)
   @ 0,0 clear
   answer = space(1)
   @ 10,20 say "Do you want to add index files now?   " get answer Picture "!"
   read
   if answer = "Y"
      use &mname
      do while .T.
         store space(8) to mindex
         store space(10) to mfield
         @ 10,20 say "Enter field to index on:"
         @ 10,50 get mfield Picture "@!"
         @ 11,20 say "Enter index name:"
         @ 11,50 get mindex Picture "@!"
         read
         if len(trim(mindex)) = 0 .or. len(trim(mfield)) = 0
            exit
         else
            index on &mfield to &mindex
         endif
      enddo
   endif
   close databases
   erase test1.dbf
   erase teststru.dbf
   erase testasci.txt
enddo
**********************************************************************
*   EDIT DBF RECORDS AND CHECK MEMORY VARIABLES

procedure srd_edit
call cursw with "ON"
do while .T.
   @ 0,0 clear
   head1 = "1. EDIT MEMVARS"
    head2 = "2. EDIT RECORDS"
    head3 = "3. EDIT NEW DBF"
    head4 = "0. MAIN MEN    "
    head5 = "XXXX"
    head6 = "XXXX"
    head7 = "XXXX"
    head8 = "XXXX"
    head9 = "XXXX"
    head0 = "XXXX"
    Hnum_items = 4
    HX = 7
    HY = 25
    HW = LEN(HEAD1)
    @ 22,1 to 22,78 double
    @ 0,0 to 24,79 double
    @ 23,2 say "Use UP and DOWN arrows to highlight choice...Press ENTER to select"
    do h_lightbar with Hnum_items,HX,HY,HW,head1,head2,head3,head4,head5,head6,head7,head8,head9,head0
    choice = str(hselection,1)
   do case
   case choice = "0"
      return

   case choice = "1"
      do while .T.
         do clearit with 1,1,23,78
         mvar = space (10)
         @ 10,10 say "Enter the name of the memory variable: " get mvar Picture "@!"
         read
         @ 15,20 say "The memory variable " + mvar + " is: "
         set color to I
            @ 15,col() say &mvar
            set color to
            HMSG1 = "1. DO ANOTHER"
            HMSG2 = "0. MENU      "
            HMSG3 = "XXXX"
            HMSG4 = "XXXX"
            HMSG5 = "XXXX"
            HMSG6 = "XXXX"
            HMSG7 = "XXXX"
            HMSG8 = "XXXX"
            HMSG9 = "XXXX"
            HMSG0 = "XXXX"
            HNUM_ITEMS = 2
            HX = 23
            HY = 1
            HW = LEN(HMSG1)
            HMSTRING = "DM"
            DO CLEARIT WITH X-1,Y,X,78
            @ X-1,1 to x-1,78 double
            DO HH_LIGHT WITH HNUM_ITEMS,HX,HY,HW,HMSG1,HMSG2,HMSG3,HMSG4,HMSG5,HMSG6,HMSG7,HMSG8,HMSG9,HMSG0,HMSTRING
            CHOICE = STR(hselection,1)
         if CHOICE = "0"
            EXIT
            endif
      enddo


   case choice = "2"
        if reccount() = 0
            ? "No records found"
            inkey(6)
            return
        endif
      mfirrec = recno()
        msel = select()
      n = msel
        do while .T.
            mexit = .F.
         mdbf1 = space(1)
         clear gets
         mdelete = .F.
         do while .T.
            @ 0,0 clear
            private x,y,z,n
            n = 1
            row = 1
                if eof()
                    skip-1
                endif
            do while .not. eof()
               @ 1,0 say reccount()
               @ 2,0 say recno()
               for n = 1 to fcount()
                    do case
                    case n < 10
                        x = str(n,1)
                    case n < 100
                        x = str(n,2)
                    case n > 99
                        x = str(n,3)
                    endcase
               mfield = fieldname(n)
               @ row,10 say fieldname(n)
               @ row,45 get &mfield
               row = row+1
               if row > 20
                  read
                  @ 0,0 clear
                  row = 1
               endif
               next
               read
               row = 1
               HMSG1 = "DELETE  "
                    HMSG2 = "EDIT    "
                    HMSG3 = "PREVIOUS"
                    HMSG4 = "NEXT    "
                    HMSG5 = "SELECT  "
                    HMSG6 = "MENU    "
                    HMSG7 = "XXXX"
                    HMSG8 = "XXXX"
                    HMSG9 = "XXXX"
                    HMSG0 = "XXXX"
                    HNUM_ITEMS = 6
                    HX = 23
                    HY = 1
                    HW = LEN(HMSG1)
                    HMSTRING = "DEPNSM"
                    DO CLEARIT WITH X-1,Y,X,78
                    @ X-1,1 to X-1,78 double
                    DO HH_LIGHT WITH HNUM_ITEMS,HX,HY,HW,HMSG1,HMSG2,HMSG3,HMSG4,HMSG5,HMSG6,HMSG7,HMSG8,HMSG9,HMSG0,HMSTRING
                    CHOICE = STR(hselection,1)
               do case
               case choice = "0"
                  mexit = .T.
                        exit
               case upper(choice) = "1"
                  delete
                  mdelete = .T.
                  skip
               case upper(choice) = "4"
                  skip
               case Upper(choice) = "3"
                  skip - 1
               case choice = "5"
                  n = select()
                  @ 0,0 clear
                  @ 8,10 say "present select area is : " + str(n,1)
                  @ 10,10 say "Enter new select area: " get n
                  read
                  do hs_select with n
                        @ 12,10 say "New SELECT area is: "
                  x = select()
                  @ 12,col() say x
                  @ 14,10 say "The DBF file is: "
                  m_dbf = H_dbf()
                  @ 14,col() say m_dbf
                  inkey(8)
               endcase

               @ 0,0 clear
                    if eof() .or. bof()
                        @ 10,10 say "NO MORE RECORDS"
                        INKEY(7)
                        mexit = .T.
                        EXIT
                    endif
            enddo

            if mdelete
               pack
            endif
                do hs_select with msel
                goto mfirrec
                if mexit
                    exit
                endif
         enddo
            if mexit
                exit
            endif
      enddo
   case choice = "3"
      msel = select()
      n = msel
      mdbf1 = space(1)
      do while n > 0
         if len(trim(H_dbf())) > 0
            x = str(n,1)
            mdbf&x = H_dbf()
            mrec&x = recno()
            n = n-1
            select n
         else
            mdbf&x = space(1)
            n = n-1
            select n
         endif
      enddo
      close databases
      clear gets
      mdelete = .F.
      do while .T.
         do while .T.
            @ 0,0 clear
            mname = space(8)
            @ 0,10
            dir *.dbf
            @ 20,35 say "Enter name of DBF file..." get mname picture "@!"
            read
            if upper(trim(mname)) = "Q"
               n = msel
               do while n > 0
                  x = str(n,1)
                  if len(trim(mdbf&x)) > 0
                     select n
                     mdbf = mdbf&x
                     use &mdbf
                     mrec = mrec&x
                     goto mrec
                     n = n-1
                  else
                     n = n-1
                  endif
               enddo
               return
            endif
            if len(trim(mname)) = 0
               DO CLEARIT WITH 10,10,20,70
               ANSWER = SPACE(1)
               @ 14,20 SAY "DO YOU WISH TO REINDEX THE FILES (Y/N)..." GET ANSWER PICTURE "!"
               @ 10,10 TO 20,70 DOUBLE
               READ
               IF ANSWER = "Y"
                  do reindex_
                  ?
                  ? "reindexing..."
               ENDIF
               n = msel
               do while n > 0
                  x = str(n,1)
                  if len(trim(mdbf&x)) > 0
                     select n
                     mdbf = mdbf&x
                     use &mdbf
                     goto mrec&x
                     n = n-1
                  else
                     n = n-1
                  endif
               enddo
               return
            endif
            mname = trim(mname)
            first = mname + ".DBF"
            if .not. file(first)
               ? first + " not found"
               WAIT
               loop
            else
               exit
            endif
         enddo
         @ 0,0 clear
         use &mname
         goto top
         private x,y,z,n
         n = 1
         row = 1
         do while .not. eof()
            @ 1,0 say reccount()
            @ 2,0 say recno()
            for n = 1 to fcount()
            x = iif(n > 10,str(n,1),str(n,2))
            mfield = fieldname(n)
            @ row,10 say fieldname(n)
            @ row,45 get &mfield
            row = row+1
            if row > 20
               read
               @ 0,0 clear
               row = 1
            endif
            next
            read
            row = 1
            answer = space(1)
            HMSG1 = "DELETE  "
                HMSG2 = "EDIT    "
                HMSG3 = "PREVIOUS"
                HMSG4 = "NEXT    "
                HMSG5 = "MENU    "
                HMSG6 = "XXXX"
                HMSG7 = "XXXX"
                HMSG8 = "XXXX"
                HMSG9 = "XXXX"
                HMSG0 = "XXXX"
                HNUM_ITEMS = 5
                HX = 23
                HY = 1
                HW = LEN(HMSG1)
                HMSTRING = "DEPNM"
                DO CLEARIT WITH X-1,Y,X,78
                @ X-1,1 to X-1,78 double
                DO HH_LIGHT WITH HNUM_ITEMS,HX,HY,HW,HMSG1,HMSG2,HMSG3,HMSG4,HMSG5,HMSG6,HMSG7,HMSG8,HMSG9,HMSG0,HMSTRING
                CHOICE = STR(hselection,1)
            do case
            case choice = "0"
               exit
            case upper(choice) = "D"
               delete
               mdelete = .T.
               skip
            case upper(choice) = "N"
               skip
            case Upper(choice) = "P"
               skip - 1
            endcase
            @ 0,0 clear
         enddo
         if mdelete
            pack
         endif
         use
      enddo
   endcase
enddo


**********************************************************************
*   you must of course set this procedure up to make your indexes    *
**********************************************************************


procedure index_h
DO WHILE .t.
   @ 23,0 clear
   @ 23,1
   ?? "working..."
**********************************************************************
*   THIS HAS TO BE HARD-CODED BY YOU TO CREAT YOUR INDEX FILES       *
**********************************************************************
   use done.dbf
    index on str(year(date1),4)+str(month(date1),2)+str(day(date1),2) to done1
    index on str(year(date2),4)+str(month(date2),2)+str(day(date2),2) to done2
    index on str(year(date3),4)+str(month(date3),2)+str(day(date3),2) to done3
    use audio
    index on title to a_title
    index on lastname to a_artist
    use
   return
enddo
**********************************************************************

procedure reindex_
do while .t.
   ?? "working..."
   use
**********************************************************************
*    YOU MUST OF COURSE SET THIS PROCEDURE UP TO REINDEX YOUR FILES  *
**********************************************************************
    use done.dbf
    set index to done1, done2, done3
    reindex
    use audio
    set index to  a_title, a_artist
    reindex
   use
   RETURN
ENDDO
**********************************************************************


procedure h_center
Parameters row, string
@ row,(78-len(string))/2 say string
return
**********************************************************************


procedure h_choice
Parameters INSTRUCTION, RANGE
@ 22,1 to 22,78 double
choice = " "
do while .not. choice $ RANGE
   @23,2
   wait INSTRUCTION to choice
enddo
return
**********************************************************************
*                   WHATKEY                                          *
**********************************************************************
* PLEASE NOTE THAT THIS PROCEDURE WAS NOT WRITTEN BY ME. iT WAS TAKEN*
* OFF OF THE CLIPPER SIG ON THE SOURCE.                              *
**********************************************************************
PROCEDURE WHATKEY
@ 0,0 CLEAR
toggle = 1                      && 1=Clipper INKEY()   0=PC keyboard
do MBAN with "WHAT KEY"
@ 8,2 SAY 'IBM PC Keyboard Output'
@ 8,42 SAY 'Clipper INKEY() Function Output'
@ 9,2 to 21,35
@ 9,42 to 21,75
@ 0,0 TO 24,79 DOUBLE
@ 11,65 SAY 'Dec   Hex'                 && Fill Clipper box with prompts
@ 13,45 SAY 'Clipper INKEY(): '
@ 15,45 SAY 'Printed character: '
@ 22,42 SAY '<Alt-T> to Toggle to IBM output'
@ 23,42 SAY '<Alt-Q> to Quit'
@ 15,65 SAY ''
key = 0
DO WHILE .NOT.((toggle=1.AND.key=272) .OR. (toggle=0.AND.key=4096)) && <Alt-Q>
   key = 0
   IF toggle = 1                   && Get/display Clipper key output
      trash = INKEY(0)
      key = LASTKEY()
      IF  key>=0
         hex_str = DECTOHEX(key)
      ELSE
         hex_str='    '
      ENDIF
      hex_str = SUBSTR('0000'+hex_str,LEN(hex_str)+1,4)
      @ 13,62 SAY STR(key,6)+'  '+hex_str
      @ 15,65 SAY CHR(key)
   ELSE                            && Get/display PC key output
      key = PCKEY()
      hex_str = DECTOHEX(key)
      hex_str = SUBSTR('0000'+hex_str,LEN(hex_str)+1,4)
      @ 13,21 SAY STR(INT(key/256),6)+'    '+SUBSTR(hex_str,1,2)
      @ 16,21 SAY STR(key%256,6)+'    '+SUBSTR(hex_str,3,2)
      @ 19,25 SAY CHR(key%256)
   ENDIF :toggle=1

   IF (toggle=1.AND.key=276) .OR. (toggle=0.AND.key = 5120) && <Alt-T>
      trash = INKEY(1)                && Let user glimpse Alt-T toggle char output
      toggle = 1 - toggle             && Toggle to other state, 1-to-0 or 0-to-1
      IF toggle = 1
         @ 9,2 to 21,35
         @ 11,65 SAY 'Dec   Hex'         && and paint prompts in PC box
         @ 13,45 SAY 'Clipper INKEY(): '
         @ 15,45 SAY 'Printed character:  '
         @ 22,0
         @ 23,0
         @ 22,42 SAY '<Alt-T> to Toggle to IBM output'
         @ 23,42 SAY '<Alt-Q> to Quit'
         @ 15,65 SAY ''
      ELSE
         @ 9,42,21,75 BOX empty_frame            && Blank the INKEY() box to show PC
         @ 11,24 SAY 'Dec   Hex'         && and paint prompts in INKEY() box
         @ 13,5 SAY 'Auxiliary byte: '
         @ 14,6 SAY '(scan code)'
         @ 16,5 SAY 'Main byte:      '
         @ 17,6 SAY '(ASCII value)'
         @ 19,5 SAY 'Printed character:  '
         @ 22,0
         @ 23,0
         @ 22,2 SAY '<Alt-T> to Toggle to Clipper output'
         @ 23,2 SAY '<Alt-Q> to Quit'
         @ 19,25 SAY ''
      ENDIF :toggle = 1
   ENDIF :toggle.AND.key .OR. toggle.AND.key
ENDDO :toggle.AND.key .OR. toggle.AND.key
@ 22,0 CLEAR
RETURN


FUNCTION DECTOHEX
*
* Syntax: DECTOHEX(<expN>)
* Return: <expC>, a string consisting of as many hexadecimal digits
*          as required to represent in hex the value of the input
*
PRIVATE dec,hex_str,power,no_times
PARAMETERS dec
hex_str = ''
power = 0
DO WHILE INT( dec/(16^(power+1)) ) > 0          && find highest dividable
   power = power + 1                               && power of 16
ENDDO
DO WHILE power >= 0                             && find how many of each
   no_times = INT(dec/(16^power))
   hex_str = hex_str + IF(no_times<10,CHR(48+no_times),CHR(55+no_times))
   dec = dec - no_times * (16^power)
   power = power - 1
ENDDO
RETURN(hex_str)
**********************************************************************


procedure MBAN
Parameter BANNER
clear
@ 2,2 say cdow(date())
@ 2,(78-len(banner))/2 say banner
@ 2,78-len(cdate) say cdate
@ 3,1 to 3,78 double
return
**********************************************************************

procedure Hs_select
parameter sel_num
do case
                        case sel_num = 1
                        select 1
                        case sel_num = 2
                        select 2
                        case sel_num = 3
                        select 3
                        case sel_num = 4
                        select 4
                        case sel_num = 5
                        select 5
                        case sel_num = 6
                        select 6
                        case sel_num= 7
                        select 7
                        case sel_num=8
                        select 8
                        case sel_num=9
                        select 9
                        endcase
return
**********************************************************************
procedure h_lightbar
  parameters Hitems,hx1,hy1,hwidth,hentry1,hentry2,hentry3,hentry4,hentry5,hentry6,hentry7,hentry8,hentry9,hentry10
  answer = space(1)
  store hx1 to hx1m
  store hy1 to hy1m

CALL CURSW WITH "OFF"
  * display menu and process the keys pressed *
  set color to I
  @ hx1m,hy1m to (hx1m+1+hitems),(hy1m+hwidth+1) double
  set color to

  * Enter menu lines to screen *
  for hn=1 to Hitems                                               && FOR-NEXT LOOP
          hnstring = iif(hn = 10,str(hn,2),str(hn,1))
        hmenu_line = iif(hentry&hnstring = "XXXX",space(hwidth),hentry&hnstring)
          @ hx1+hn,hy1+1 say hmenu_line
  next
  hn=hx1+1
  hk=1
  hcontrol= .T.
  do while hcontrol=.T.
       hkstring = iif(hk = 10,str(hk,2),str(hk,1))
   store hentry&hkstring to hmenu_line

    * display current inverse lightbar *
    set color to I
    @ hn,hy1+1 say upper(hmenu_line)

    * wait for key to be pressed *
    hselection = 0
    do while hselection=0
      hselection=inkey()
    enddo

    * redisplay hilite area back to normal *
    if hselection<>13
      set color to
      @ hn,hy1+1 say upper(hmenu_line)
    endif

    do case
      * Q was pressed *
        case hselection = 113 .or. hselection = 81
        answer = "Q"
        exit

        * down arrow was pressed *
      case hselection=24
        hk=hk+1
        hn=hn+1
        if hk>items
          hn=hx1+1
          hk=1
        endif
          loop
      * up arrow was pressed *
      case hselection=5
        hk=hk-1
        hn=hn-1
        if hk<1
          hn=hx1+hitems
          hk=hitems
        endif
          loop

          * Home or page up was pressed *
        case hselection = 1 .or. hselection = 18
        hk=1
        hn=hx1+1
        loop

        * End or page down was pressed *
        case hselection = 6 .or. hselection = 3
        hk = hitems
        hn = hx1+hitems
        loop


        * F1 was pressed *
        case hselection = 28
        do help with A, B, C
        loop


      case hselection = 48               && 0 key pressed
            hk=0
            hcontrol=.F.
        loop

        case hselection = 49               && 1 key pressed
            hk=1
            hcontrol=.F.
        loop

        case hselection = 50               && 2 key pressed
            hk=2
            hcontrol=.F.
        loop

        case hselection = 51               && 3 key pressed
            IF 3 > hitems
                loop
            endif
            hk=3
            hcontrol=.F.
        loop

        case hselection = 52               && 4 key pressed
            IF 4 > hitems
                loop
            endif
            hk=4
            hcontrol=.F.
        loop

        case hselection = 53               && 5 key pressed
            IF 5 > hitems
                loop
            endif
            hk=5
            hcontrol=.F.
        loop

        case hselection = 54               && 6 key pressed
            IF 6 > hitems
                loop
            endif
            hk=6
            hcontrol=.F.
        loop

        case hselection = 55               && 7 key pressed
            IF 7 > hitems
                loop
            endif
            hk=7
            hcontrol=.F.
        loop

        case hselection = 56               && 8 key pressed
            IF 8 > hitems
                loop
            endif
            hk=8
            hcontrol=.F.
        loop

        case hselection = 57               && 9 key pressed
            IF 9 > hitems
                loop
            endif
            hk=9
            hcontrol=.F.
        loop
        * <cr> was pressed *
      case hselection=13
        hcontrol=.F.
        loop
    endcase
  enddo
  if hk >= hitems
        hselection = 0
  else
         hselection=hk
  endif
  * return video attributes to normal *
  set color to
  CALL CURSW WITH "ON"
  return


PROCEDURE HH_LIGHT
  parameters hitems,hx1,hy1,hwidth,hentry1,hentry2,hentry3,hentry4,hentry5,hentry6,hentry7,hentry8,hentry9,hentry10,hlstring
  answer = space(1)
  hwidth = hwidth + 4
  hmlength = hitems * hwidth
  hy1 = (78-hmlength)/2
  set color to
  * Enter menu lines to screen *
  CALL CURSW WITH "OFF"
  hN = 1
  DO WHILE hN <= hitems
          hnstring = iif(hn = 10,str(hn,2),str(hn,1))
        hmenu_line = iif(hentry&hnstring = "XXXX",space(hwidth),hentry&hnstring)
          @ hx1,hy1+(hN*hWIDTH)-hwidth say hmenu_line
        hN = hN + 1
  ENDDO
  hn=1
  hk=1
  hcontrol= .T.
  do while hcontrol
       hkstring = iif(hk = 10,str(hk,2),str(hk,1))
   store hentry&hkstring to hmenu_line

    * display current inverse lightbar *
    set color to I
    @ hX1,hy1+(hN*hwidth)-hwidth say trim(upper(hmenu_line))

    * wait for key to be pressed *
    hselection = 0
    do while hselection=0
      hselection=inkey()
    enddo

    * redisplay hilite area back to normal *
    if hselection<>13
      set color to
      @ hX1,hy1+(hN*hwidth)-hwidth say trim(upper(hmenu_line))
    endif

    do case
      * right arrow was pressed *
      case hselection=4
        hk=hk+1
        hn=hn+1
        if hk>hitems
          hn=1
          hk=1
        endif
          loop
      * left arrow was pressed *
      case hselection=19
        hk=hk-1
        hn=hn-1
        if hk<1
          hn=hitems
          hk=hitems
        endif
          loop

        * Home was pressed *
        case hselection = 1
        hk=1
        hn=1
        loop

        * End was pressed *
        case hselection = 6
        hk = hitems
        hn = hitems
        loop

        * F1 was pressed *
        case hselection = 28
        do help with A, B, C
        loop

      case hselection = 48               && 0 key pressed
            hk=0
            hcontrol=.F.
        loop

        case hselection = 49               && 1 key pressed
            hk=1
            hcontrol=.F.
        loop

        case hselection = 50               && 2 key pressed
            hk=2
            hcontrol=.F.
        loop

        case hselection = 51               && 3 key pressed
            IF 3 > hitems
                loop
            endif
            hk=3
            hcontrol=.F.
        loop

        case hselection = 52               && 4 key pressed
            IF 4 > hitems
                loop
            endif
            hk=4
            hcontrol=.F.
        loop

        case hselection = 53               && 5 key pressed
            IF 5 > hitems
                loop
            endif
            hk=5
            hcontrol=.F.
        loop

        case hselection = 54               && 6 key pressed
            IF 6 > hitems
                loop
            endif
            hk=6
            hcontrol=.F.
        loop

        case hselection = 55               && 7 key pressed
            IF 7 > hitems
                loop
            endif
            hk=7
            hcontrol=.F.
        loop

        case hselection = 56               && 8 key pressed
            IF 8 > hitems
                loop
            endif
            hk=8
            hcontrol=.F.
        loop

        case hselection = 57               && 9 key pressed
            IF 9 > hitems
                loop
            endif
            hk=9
            hcontrol=.F.
        loop
        * <cr> was pressed *
      case hselection=13
        hcontrol=.F.
        loop

        case upper(chr(hselection)) $ hlstring
            hmpos = AT((upper(chr(hselection))),hlstring)
            hk = hmpos
            exit

    endcase
  enddo
  if hk >= hitems
        hselection = 0
  else
         hselection=k
  endif
  * return video attributes to normal *
  set color to
  CALL CURSW WITH "ON"
  return
**********************************************************************

Procedure H_F1                           && help box
    parameter string
    private mlen
    string = "F1- " + string
    mlen = len(trim(string))
    @ 19,(37 - (mlen/2)) to 21,(42 + (mlen/2))
    set color to I
    @ 20,(39-(mlen/2)) say space(mlen+2)
    @ 20,(40-(mlen/2)) say string
    set color to
return
**********************************************************************

FUNCTION H_DBF
* Syntax: DBF()
* Return: The alias of the currently selected database.
* Note..: Supposed to return the name of the currently selected database file.
*
RETURN ALIAS()
**********************************************************************
*              H_MAKE                                                *
**********************************************************************
*This program will set up a BAT file for linking newly changed PRG files
PROCEDURE H_MAKE
@ 0,0 clear
do clearit with 1,1,23,78
mrunfile = space(8)
@ 10, 10 say "Enter the name of the Run File:" get mrunfile Picture "@!"
read
@ 0,0 to 24,79 double
do center with 13, "working..."
set console off
@ 15,20
! ds d-t-
set console on
do clearit with 1,1,23,78
@ 0,0 to 24,79 double
do center with 20, "Creating temporary files..."
set console off
!dir >newtemp.txt
set console on
use
mfile = "linkfile.dbf"
if file(mfile)
    use linkfile.dbf
else
    create mm_lunk
    append blank
    replace field_name with "FILENAME"
    replace field_type with "C"
    replace field_len with 60
    replace field_dec with 0
    create lunk from mm_lunk
    use
    erase mm_lunk.dbf
    rename lunk.dbf to linkfile.dbf
    use linkfile.dbf
endif
zap
append from newtemp SDF
goto top
counter = 1
mfile = space(8)
do while .not. eof()
    if substr(filename,10,3) = "EXE" .and. substr(filename,1,8) = mrunfile
        counter = counter - 1
        exit
    else
        if substr(filename,10,3) = "PRG"
            x = iif(counter > 9, str(counter,2),str(counter,1))
            mfile&x = substr(filename,1,8)
            counter = counter + 1
        endif
    endif
    skip
enddo
if counter > 0
    do center with 20, "Creating batch file........"
    mmfile = "temp_lnk.dbf"
    if file(mmfile)
        use temp_lnk
    else

        create temp_lnk
        append blank
        replace field_name with "FILENAME"
        replace field_type with "C"
        replace field_len with 60
        replace field_dec with 0
        create mm_lnk from temp_lnk
        use
        erase temp_lnk.dbf
        rename mm_lnk.dbf to temp_lnk.dbf
        use temp_lnk
    endif
    zap
    err = "> err"
    for y = 1 to counter
        append blank
        x = iif(y > 9,str(y,2),str(y,1))
        replace filename with "If not errorlevel 1 clipper @" + mfile&x + " >  err" + x
    next
    append blank
    replace filename with "if not errorlevel 1 link @all.lnk"
    append blank
    copy to newfile sdf
    mfile = "new.bat"
    if file(mfile)
        erase new.bat
    endif
    rename newfile.txt to new.bat
    erase newfile.txt
    erase newtemp.txt
    use temp_lnk.dbf
    zap
    use linkfile.dbf
    zap
    use
endif
if counter > 0
    do clearit with 1,1,23,78
    do center with 5, "The file `NEW.BAT' has been created"
    row = 7
    type new.bat
    inkey(0)
    clear
else
    do center with 20, "No new PRG files have been created!..."
    @ 20,5 say "Enter any key to return to menu..."
    inkey(0)
    clear
endif
return

*********************************EOF********************************