select dd
append blank
replace dd->invnom with tinvnom
replace dd->fkdn with bb->dateprof-tdata
replace dd->norma with aa->norma
replace dd->idzappp with tidzap
replace dd->idzapsp with bb->idzap
sitog:=sitog+(dd->fkdn-dd->norma)
select bb
endif
enddo
lin:="+-----------------------------------------------------------------------------+"
? lin
lin:="¦ Инв.¦ Наименование ¦ Дата ¦ Вид предвор. ¦ Дата ¦ вид след. ¦Просроч.¦"
? lin
lin:="¦номер¦ типа станка ¦ ¦ профилактики ¦ ¦ профилактики ¦ дней ¦"
? lin
lin:="¦-----+--------------+--------+--------------+--------+--------------+--------¦"
? lin
select dd
set relat to dd->invnom into cc additive
go top
do while .not. eof()
tinvnom:=dd->invnom
idpop:=dd->idzappp
lin:="¦ "+dd->invnom+" ¦ "
select bb
go top
do while .not. eof()
if(tinvnom=bb->invnom).and.(idpop=bb->idzap)
lin:=lin+aa->namest+" ¦"+dtoc(bb->dateprof)+"¦ "+bb->vidprof
endif
skip
enddo
select dd
idpop:=dd->idzapsp
select bb
go top
do while .not. eof()
if(tinvnom=bb->invnom).and.(idpop=bb->idzap)
lin:=lin+" ¦"+dtoc(bb->dateprof)+"¦ "+bb->vidprof+"¦ "
endif
skip
enddo
select dd
lin:=lin+str(dd->fkdn-dd->norma,4)+" ¦"
? lin
skip
enddo
lin:="+-----------------------------------------------------------------------------+"
? lin
set color to w+/b
lin:=" Всего просроченно дней -"+str(sitog,5)
? lin
set printer off
sound()
inkey(0)
return nil
6) п.п. подачи звукового сигнала для сигнализации успешного выполнения
поставленной задачи:
func sound
tone(300,1)
tone(100,1)
tone(300,1)
tone(100,1)
return nil
7) п.п. сохранения зкрана:
FUNC s_scr(t,l,b,r)
IF t = NIL
t := 0
ENDIF
IF l = NIL
l := 0
ENDIF
IF b = NIL
b := MAXROW()
ENDIF
IF r = NIL
r := MAXCOL()
AADD( wind[1], t )
AADD( wind[2], l )
AADD( wind[3], b )
AADD( wind[4], r )
AADD( wind[5], SAVESCREEN(t,l,b,r) )
AADD( pos[1], ROW() )
AADD( pos[2], COL() )
AADD( colr, SETCOLOR() )
AADD( curs, SETCURSOR() )
RETURN .T.
8) п.п. восстановления зкрана:
FUNC r_scr()
LOCAL ln
ln := LEN(wind[1])
IF ln == 0
@ 24,0 SAY ' Ошибка - стек для восстановления параметров пуст '
INKEY(0)
@ 24,0
ENDIF
RESTSCREEN(wind[1,ln], wind[2,ln], wind[3,ln], wind[4,ln], wind[5,ln] )
ASIZE(wind[1],ln-1)
ASIZE(wind[2],ln-1)
ASIZE(wind[3],ln-1)
ASIZE(wind[4],ln-1)
ASIZE(wind[5],ln-1)
SETPOS( pos[1,ln], pos[2,ln] )
ASIZE(pos[1],ln-1)
ASIZE(pos[2],ln-1)
SETCOLOR(colr[ln])
ASIZE(colr,ln-1)
SETCURSOR(curs[ln])
ASIZE(curs,ln-1)
RETURN .T.
9) п.п. определения - нажата ли клавиша типового метода, если да - то возвращает блок кода с соответствующим методом, если нет - то возвращает NIL. Параметр функции - INKEY-код нажатой клавиши.
FUNC basemet(cod)
LOCAL ret , ei , i
LOCAL crsm:={ ;
{K_DOWN , {|o| o:down() } } ;
, {K_UP , {|o| o:up() } } ;
, {K_PGDN , {|o| o:pagedown() } } ;
, {K_PGUP , {|o| o:pageup() } } ;
, {K_CTRL_PGDN , {|o| o:gobottom() } } ;
, {K_CTRL_PGUP , {|o| o:gotop() } } ;
, {K_RIGHT , {|o| o:right() } } ;
, {K_LEFT , {|o| o:left() } } ;
, {K_CTRL_RIGHT , {|o| o:panright() } } ;
, {K_CTRL_LEFT , {|o| o:panleft() } } ;
, {K_END , {|o| o:end() } } ;
, {K_HOME , {|o| o:home() } } ;
, {K_CTRL_END , {|o| o:panend() } } ;
, {K_CTRL_HOME , {|o| o:panhome() } } }
i := ASCAN( crsm, {|ei| cod = ei[1] } )
IF i <> 0
ret := crsm[i,2]
ELSE
ret := NIL
ENDIF
RETURN ret
10) п.п. переключения режима вставка/замена и вида курсора:
PROCEDURE Repl_Ins()
IF READINSERT()
READINSERT(.F.)
SETCURSOR(SC_INSERT)
ELSE
READINSERT(.T.)
SETCURSOR(SC_NORMAL)
ENDIF
RETURN
11) п.п. перевода в верхний регистр латиницы и кириллицы:
FUNC UpperC(prm)
LOCAL n , i , smb , cs
n := LEN( prm )
FOR i = 1 TO n
smb := SUBSTR( prm , i , 1 )
cs := ASC( smb )
DO CASE
CASE cs >= 97 .AND. cs <= 122
cs := cs - 32
prm := STUFF( prm , i , 1 , CHR( cs ) )
CASE cs >= 160 .AND. cs <= 175
cs := cs - 32
prm := STUFF( prm , i , 1 , CHR( cs ) )
CASE cs >= 224 .AND. cs <= 239
cs := cs - 80
prm := STUFF( prm , i , 1 , CHR( cs ) )
ENDCASE
NEXT
RETURN prm
12) п.п. выхода из задачи с сохранением всей информации - реакция на клавишу F10:
PROCEDURE fquit()
LOCAL reply
reply := ALERT("Сохранить все внесенные изменения и продолжить;" ;
+ "работу с Базой данных - т.е. сделать промежуточный SAVE или;" ;
+ " Завершить работу с базой данных с сохранением всех изменений ;";
, {" Сохранить и продолжить " , " Завершить работу " } )
IF ( reply = 1 ) .OR. ( reply = 0 )
DBCOMMITALL()
ELSE
QUIT
ENDIF
RETURN
13) п.п. вывода сообщения на экран с заданными координатами и цветом:
PROCEDURE msgs(x,y,m,color)
LOCAL ml,c
IF m = NIL
RETURN
ENDIF
ml=LEN(m)
IF ml=0 && .OR. ml > 80
RETURN
ENDIF
IF x=NIL // Центр по X
x := (80-ml)/2
ENDIF
IF y=NIL // Центр по Y
y := 24/2 - 1
ENDIF
IF color <> NIL
c := SETCOLOR(color)
@ y,x SAY m
SETCOLOR(c)
ELSE
@ y,x SAY m
ENDIF
RETURN
14) п.п. создания TBrowse-объекта для просмотра-редактирования
файла aa.dbf в окне t,l,b,r :
FUNCTION aaCr(t,l,b,r)
LOCAL brws,coln,cblk,chdr
brws := TBrowseDb(t,l,b,r)
cblk := {|| " " + aa->idst }
chdr := "Идент. типа станка"
coln := TBColumnNew(chdr,cblk)
coln:width := 19
brws:AddColumn(coln)
cblk := {|| " " + aa->namest}
chdr := " Наименование типа станка"
coln := TBColumnNew(chdr,cblk)
coln:width := 35
brws:AddColumn(coln)
cblk := {|| STR( aa->norma,7) }
chdr := " Норма,дней"
coln := TBColumnNew(chdr,cblk)
coln:width := 12
brws:AddColumn(coln)
brws:colsep := CHR(186)
brws:headsep := CHR(205)
brws:colorspec := "w+/b,gr+/rb"
RETURN brws
15) п.п. просмотра файла aa.dbf с обработкой нажимаемых клавиш и вызовом соответствующих методов или пользовательских функций:
FUNCTION aaEd(brws)
LOCAL ret_fl,sel,otb , w
LOCAL cc,rr,nrc:=0,i
LOCAL ret:=NIL
LOCAL t := brws:nTop , l := brws:nLeft , b := brws:nBottom , r := brws:nRight
LOCAL t_ := 5 , l_ := 6 , b_ := 15 , r_ := 74
s_scr()
s_r_s()
SETCOLOR( "N/W" )
CLS
SETCOLOR( "gr+/b,w+/gr")
hlp("AAED")
SELECT aa
SET ORDER TO 2
@ t-2 , l-1 CLEAR TO b+2 , r+1
@ b+1, l TO b+1, r
ret_fl := .F.
DO WHILE .NOT. ret_fl
** оптимизированная с использованием буфера клавиатуры стабилизация
DO WHILE ( NEXTKEY() == 0 ) .AND. ( .NOT. brws:stabilize() )
ENDDO
IF ( NEXTKEY() == 0 ) .AND. ( RECNO() <> nrc)
nrc := RECNO()
rr := ROW()
cc := COL()
SETCOLOR("bg+/b")
@ t-2 , l+1 SAY " Нормативы профилактики оборудования:"
@ b+2 , l+1 SAY " Тип станка: "
@ b+2 , COL()+1 SAY aa->namest COLOR "w+/b"
SETPOS(rr,cc)
ENDIF
SETCOLOR("gr+/rb")
** ожидаем нажатия клавиши
nkey := Inkey(0)
// если нажата клавиша типового метода - вызовем его
blk := basemet( nKey )
IF blk <> NIL
EVAL( blk , brws )
ELSE
DO CASE
CASE ( bHotkey := SETKEY( nKey ) ) <> NIL
EVAL( bHotkey , PROCNAME() , PROCLINE() , READVAR() )
CASE ( nKey = K_F8 )
DELETE
// потрогаем файловый указатель, если
// возвращаетя EOF() - .T. после Down-Up,
// значит файл пуст
SKIP
SKIP -1
IF RECNO() = RECCOUNT()+1
ret_fl := .T. // завершение просмотра
ENDIF
brws:RefreshAll()
nrc := 0
CASE nKey = K_ESC
ret_fl := .T. // завершение просмотра
CASE ( nKey = K_ENTER )
// Редактирование текущего элемента данных
aaGet(brws ;
, " Редактирование файла aa.dbf" )
nrc := 0 // обновить верхнюю строку
CASE nKey == K_F3
APPEND BLANK
brws:RefreshAll()
ENDCASE
ENDIF
ENDDO
SET RELAT TO
s_r_s(.T.)
r_scr()
RETURN ret
16) п.п. выполнения GET в текущей колонке файла aa.dbf:
PROCEDURE aaGet( brws , z0 )
LOCAL r , c , w , w2 , otb
LOCAL retcurs,retexit // форма курсора и режим выхода из READ
LOCAL retins, retcol // режим вставка-замена в READ
LOCAL indch := .F. // флаг изменений значений полей, входящих в
// индекснове выражение (тогда нужно REFRESHALL(),
// а не REFRESHCURRENT() )
LOCAL col
r := ROW()
c := COL()
// Проверка обновления экрана, корректности базы и т.д.
ForceStable(brws)
// Установка клавиш Up-Arrow и Down-Arrow как клавиш выхода из
// команды READ
retexit := READEXIT(.T.)
// Установка клавиши INS для переключения
// режима вставка/замена
// и соответствующего изменения вида курсора
retins := SetKey( K_INS, {|| Repl_Ins()} )
// эквивалентно Set Key K_INS To Procedure Repl_Ins
// Установка вида курсора по текущему состоянию режима
retcurs := SetCursor( IF(ReadInsert(), SC_NORMAL, SC_INSERT ) )
s_scr()
retcol := SETCOLOR("w+/g")
@ brws:nTop-3,0
@ brws:nTop-3,0 SAY z0
hlp("GET")
SETCOLOR("gr+/n,w+/g")
indch := .F.
DO CASE
CASE brws:colpos = 1
w := aa->idst
@ r,c+2 GET w
READ
IF .NOT.( LASTKEY() = K_ESC ).OR.( aa->idst == w )
REPLACE aa->idst WITH w
indch := .T.
ENDIF
CASE brws:colpos = 2
n := aa->namest
@ r,c+2 GET n
READ
IF .NOT.( LASTKEY() = K_ESC ).OR.( aa->namest == n )
REPLACE aa->namest WITH n
ENDIF
CASE brws:colpos = 3
w := aa->norma
@ r,c+1 GET w
READ
IF .NOT.( ( LASTKEY() = K_ESC ) .OR. ( aa->norma = w ) )
REPLACE aa->norma WITH w
ENDIF
ENDCASE
SETCOLOR(retcol)
r_scr()
SETPOS(r,c)
IF indch
brws:RefreshAll()
ELSE
brws:RefreshCurrent() // Обеспечить перерисовку текущей строки,
ENDIF // поскольку изменялся элемент данных
// Восстановление формы курсора и режима выхода из READ по стрелкам
// и процедуры по клавише K_INS
SetCursor(retcurs)
READEXIT(retexit)
SetKey(K_INS, retIns)
// Проверка требования ухода с текущей записи после GET
nKey := LASTKEY()
IF nKey == K_UP .OR. nKey == K_DOWN .OR. ;
nKey == K_PGUP .OR. nKey == K_PGDN
// управление курсором -- переход к другой записи
KEYBOARD( CHR(nKey) )
ENDIF
RETURN