Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/DMSUDF.ZIP/DMSUDF.PRG

Text File | 1987-07-28 | 9.7 KB | 325 lines

**||DMS.PRG updated on- Tuesday, July 28, 1987 at- 1:36 am
**||(c)1987, D M Sampson Consulting

function approx
parameter record,fldno
ndxfld = field(fldno)
seek record
if .not. found()
     goto 1
     replace &ndxfld with record
     skip
     if  eof()
         go top
     endif
     store recno() to currec
     goto 1
     do case
     case type('&ndxfld') = 'C'
          replace &ndxfld with space(len(&ndxfld))

     case type('&ndxfld') = 'N'
          replace &ndxfld with 0

     case type('&ndxfld') = 'D'
          replace &ndxfld with ctod('  /  /  ')

     otherwise
          ?? chr(07)+chr(07)
          @ 23,00
          @ 23,00 say 'Run Time Error:  Function Approx() can only use'
          @ 24,00
          @ 24,00 say '                 field types C,N,D'
          close databases
          quit
     endcase
     goto currec
endif
return recno()




function filehere
parameter _chr1,_chr2,_chr3,_fname
store .t. to ok
if .not. file(_fname)
     ?? chr(07)+chr(07)
     save screen to _temp
     @ 09,10 clear to 16,68
     @ 09,10 to 16,68 double
     @ 11,20 say 'YOU ARE MISSING YOUR '+upper(fname)+' FILE'
     center(12,trim(substr(_chr1,1,50)))
     center(13,trim(substr(_chr2,1,50)))
     center(14,trim(substr(_chr3,1,50)))
     set console off
     wait
     set console on
     restore screen from _temp
     store .f. to ok
endif
return ok


function prntoff
set print off
set device to screen
set console on
return .t.


function prnton
set print on
set device to print
set console off
return .t.



** File Name..: ARRAYS.PRG
** Author.....: David M Sampson
** Date.......: February 19, 1987
** Notice.....: (c) 1987 David M Sampson, All Rights Reserved.
** Notes......: This file contains the functions for 2, 3 and 4
**              Dimensional arrays to be used with Clipper arrays.
**
** This Function Controls the Element Pointer for a 2 Dimensional Array
** The array would be Declared in this manner: Declare array[xe * ye]
**     where xe and ye carry the total number of elements for the
**     x and y axis.
**
**     EXAMPLE: store 3  to x,xe    && first level
**              store 30 to y,ye    && lowest level
**              declare arrayname[xe * ye]
**              ? arrayname[r2(2,25,xe)] displays the value of the
**                                       25th position in the 2nd element
function r2
parameter x,y,ye
return (((x-1) * ye) + y)

** This Function Controls the element pointer for a 3 dimensional array
** This array would be declared in a similar manner as the 2 dimensional
** array, in this manner: Declare arrayname[xe * ye * ze]
** where xe, ye, and ze carry the total number of positions for the
** x, y and z elements respectively.
**
**     EXAMPLE: store 4  to x,xe
**              store 10 to y,ye
**              store 8  to z,ze
**              declare arrayname[xe * ye * ze]
**              ? arrayname[r3(3,9,6,ye,ze)] displays the value in the
**                                           6th position of the
**                                           9th Y element of the
**                                           3rd X element.

function r3
parameter x,y,z,ye,ze
return (((x-1) * ye * ze) + ((y-1) * ze) + z)


function r4
parameter w,x,y,z,xe,ye,ze
return (((w-1) * xe * ye * ze) + ((x-1) * ye * ze) + ((y-1) * ze) + z)


** RETURNS COLUMN NUMBER TO RIGHT JUSTIFY MESSAGE AT COLUMN NUMBER '_COL'
function rjust
parameter _row,_col,_mess
@ _row,_col-len(mess) say mess
return .t.


** RETURNS COLUMN NUMBER TO CENTER MESSAGE IN 'COL' COLUMNS
function center
parameter _row,mess
@ _row,(80-len(mess))/2 say mess
return .t.




**  THIS IS THE BASIC, GENERIC VERSION.
**  PLEASE DO NOT MODIFY THIS FOR A SPECIFIC APPLICATION.
**  COPY THIS AND MAKE MODIFICATIONS TO THE COPY ONLY.
**
**
** Function Name...: LOOKUP()
** Author..........: David M. Sampson
** Initial Date....: 01/28/87
** Notice..........: (no copyright)
** Last Update.....: (see first line above)
** Comments........:
**
**  This function moves to the work area indicated by the parameter 'area'
**  performs a search (the .dbf file must be indexed on 'code') for 'code'
**  then, if found, returns the value of the field 'fldno'
**  if not found it returns an appropriate error message.
**  (Just incase it is not obvious,   THIS WORKS ONLY COMPILED UNDER CLIPPER)
**
**  EXAMPLE:
**          lookup() was originally designed to be used with the clipper
**          VALID parameter with its @ say... get... verb
**          (i.e.@ row,col say <string> get <varC> VALID lookup(<varC>,'G',2))
**          but I could think of applications to use it with the  IF,
**          DO WHILE -OR- THE DO CASE syntax.
**
**          if you want to make sure input is being made accurately,
**          especially when data is changing frequently, you could
**          index a database in the valid entries (Account code in
**          Accounting, State Abbreviations (CA, Calif....) etc...)
**          then attach this function after the VALID command and you
**          will not beable to leave that field without a valid entry.
**          This is even greater when you consider that it works in the
**          middle of an @ say... get... read construct.
**
**          Give me some feed back if you are interested at [phone]
**          -or-  on the Source (DBFSIG, NANSIG)
**
Function lookup
parameter code,area,fldno
public ok
*** THESE 3 LINES MUST BE IN THIS ORDER!!!
***
store alias()            to currarea  && TAG CURRENT AREA TO RETURN TO
select &area                          && MOVE TO LOOKUP FILE WORK AREA
store field(fldno)       to fldname   && PASS FIELD NAME TO RETURN INFO FROM
***
store upper(trim(code))  to code
set exact on
seek code
if found()
   store &fldname to string
   @ row(),col()+2               && THESE TWO LINES ASSUME YOU WANT TO PRINT
   @ row(),col()+2 say string    && THE 'STRING' TO THE RIGHT OF THE INPUT
   @ 15,00 clear
      store .t.             to ok,kontinue
else
   ?? chr(07)
   if len(code)>0
     string = code+' IS NOT VALID'
   else
     string = 'BLANK ENTRY IS NOT VALID'
   endif
   @ row(),col()+2               && THESE TWO LINES ASSUME YOU WANT TO PRINT
   @ row(),col()+2 say string    && THE 'STRING' TO THE RIGHT OF THE INPUT
   @ 15,00,24,79 box chr(201)+chr(205)+;
                     chr(187)+chr(186)+;
                     chr(188)+chr(205)+;
                     chr(200)+chr(186)
   go top
   store 16        to row
   store 02        to col
   store field(1)  to field1
   store field(2)  to field2
   do while .not. eof()
     do while .not. eof() .and. row<24
       @ row,col say upper(&field1)+' : '+substr(&field2,1,10)
       skip
       row = row+1
     enddo
     col = col + 15
     row = 16
   enddo
      store .f.   to ok,kontinue
endif
set exact off
select &currarea                      && SWITCH BACK TO ORIGINAL WORK AREA
return ok



function implode
parameters r1,c1,r2,c2,incr
store r1               to r_pos1
store r2               to r_pos2
store c1               to c_pos1
store c2               to c_pos2
store ((r2-r1)/2)/iif(incr<1,1,incr) to r_inc1,r_inc2
store ((c2-c1)/2)/iif(incr<1,1,incr) to c_inc1,c_inc2
rest screen
save screen
do while (r_pos1<r_pos2) .and. (c_pos1<c_pos2)
     @ r_pos1,c_pos1 to r_pos2,c_pos2 double
     r_pos1 = r_pos1+r_inc1
     r_pos2 = r_pos2-r_inc2
     c_pos1 = c_pos1+c_inc1
     c_pos2 = c_pos2-c_inc2
     rest screen
     save screen
enddo
return .t.



function explode
parameters r1,c1,r2,c2,incr
store ((r2-r1)/2)+r1   to r_pos1,r_pos2
store ((c2-c1)/2)+c1   to c_pos1,c_pos2
store (r_pos1-r1)/iif(incr<1,1,incr) to r_inc1,r_inc2
store (c_pos1-c1)/iif(incr<1,1,incr) to c_inc1,c_inc2
save screen
do while (r_pos1>r1) .and. (c_pos1>c1)
     @ r_pos1,c_pos1 to r_pos2,c_pos2 double
     r_pos1 = r_pos1-r_inc1
     r_pos2 = r_pos2+r_inc2
     c_pos1 = c_pos1-c_inc1
     c_pos2 = c_pos2+c_inc2
     REST screen
     save screen
enddo
@ r1,c1 clear to  r2,c2
@ r1,c1 to        r2,c2 double
return .t.



* Function...: response function
* Author.....: David M Sampson
* Date.......: 1985
* Last Update: (see line one above)
* Notice.....: Copyright 1985,1986,1987 David M Sampson. All rights reserved
* Version....: dBASE III, Version 1.00
* Notes......: module to permit automatic display of user requests.
*              an enhancment of dbases 'wait' command. (get it?)
*
*            : Converted to a function on 03/18/87
*            : parameters are chr1,chr2,time,vald
*            :      chr1 = message to be displayed on line 23
*            :      chr2 = message to be displayed on line 24
*            :      time = delay value for temporary messages
*            :      vald = string of valid keyboard responses
*
function response
parameter chr1,chr2,time,vald
@ 23,00
@ 24,00
set color to &nvrs
@ 23,(80 - len(chr1))/2 say upper(chr1)
@ 24,(80 - len(chr2))/2 say upper(chr2)
if time > 0
    do while time > 0
        time = time - 1
    enddo
else
 set console off
    wait '' to answr
 set console on
endif
set color to &stnd
@ 23,00
@ 24,00
chr1 = ''
chr2 = ''
answr = upper(answr)
return iif(upper(vald) = 'ALL',.t.,(answr$upper(vald)))



Function ndexdisp
parameter _row, _mess
_expr = _mess+str(recno(),4)+' of '+str(lastrec(),4)
@ row,10 say _expr
return ('')

**||End of File-> DMS.PRG