Microsoft
Software
Hardware
Network
Question : Fox9 - Having a problem getting color to work using @ ... Gets and @ ... Say
This was written 20 year ago in FoxPro for DOS. I am in the process of upgrading to Fox9. Can you please help me with getting VFP to change the colors on a menu? I woulf like the menu selection items to have a different color depending what is selected by the up/down arrows. Another problem I am having is when I rest the cursor on any menu item, the entire menu goes away. I know I included a lot of code here, but the actual code in use is very small and easy to isolate.
Thank you for being there and helping me with my problem.
* Start of Main Menu
* Enviroment
* Added for VFP
CLEAR ALL
* Commented for VFP9
* PARAMETER
* Added for VFP9
parm1_= .T.
parm2_= .T.
SET DEFAULT TO c:\crit\CODE
SET TALK OFF
SET ECHO OFF
PUBLIC akl_test
IF TYPE('parm1_') = 'L'
akl_test = "Y"
ELSE
IF parm1_ = "test"
akl_test = "Y"
ELSE
akl_test = "N"
ENDIF
ENDIF
PUBLIC akl_system
akl_system = "Y"
* if type('parm2_') = 'L'
* akl_system = "N"
* else
* if parm2_ = "akl"
* akl_system = "Y"
* else
* akl_system = "N"
* endif
* endif
* DEVELOPMENT FLAGS
IF akl_test $ 'Y'
SET DISPLAY TO VGA50
SET ESCAPE ON
SET STATUS ON
* SET VIEW Off
* SET CLOCK TO 48,69
ELSE
* SET CLOCK TO 24,69 Turn clock off for VFP
ENDIF
* ENVIRONMENT
modi_memo = .T.
ON KEY LABEL f12 DO _popcal
ON KEY LABEL ctrl+f12 DO rundos WITH "COMMAND.COM"
IF EMPTY(ON('key','ctrl+o'))
DO fs_setup
ENDIF
SET PROCEDURE TO genlbr
= envrnmnt()
CLEAR WINDOWS
OPTION = ' '
goodpass = .F.
DO COLORS
* All FUNCTION Key code will be removed. FUNCTION KEY SETTINGS
s_zoom_no = 0
s_lastkey = 0 && Save the last key entered
s_prgname = '' && Save the program name using a function
s_FkeyRec = 0 && Save Function Key Record Number
s_FkeyPag = 0 && Save Function Key Page Number
s_FkyMRec = 0 && Save FKey MASTER Record Number. 1/10/97 12:28 am (akl)
&& ---- First needed in PAYABLE when F1 from the Detail.
listmenu = .F. && Did we come from List Menu?
utilmenu = .F. && Did we come from Util Menu?
KeyF1 = .F. && Flag - from anything to Animals
KeyF2 = .F. && Flag - from anything to Bids
KeyF3 = .F. && Flag - from anything to Calendar
KeyF4 = .F. && Flag - from anything to Contracts
KeyF5 = .F. && Flag - from anything to Critters
KeyF6 = .F. && Flag - from anything to Invoices
KeyF8 = .F. && Flag - from anything to Payables
KeyF9 = .F. && Flag - from anything to Prices
KeyF10 = .F. && Flag - from anything to Production Companies
KeyF11 = .F. && Flag - from anything to Receivables
* Commented for VFP
* VARIABLES
choice = 0
prompt1 = ' 1. Animals '
prompt2 = ' 2. Bids '
prompt3 = ' 3. Calendar '
prompt4 = ' 4. Contracts '
prompt5 = ' 5. Critters '
prompt6 = ' 6. Invoices '
prompt7 = ' 7. Labels '
prompt8 = ' 8. Lists '
prompt9 = ' 9. Prices '
* prompt10 = ' P. Print '
prompt10 = ' S. Stats '
prompt11 = ' U. Utilities '
prompt12 = ' Help '
prompt13 = ' Quit '
* Commented for VFP
* WINDOWS
* Commented for VFP
* define window crit from 2,2 to 22,75 ;
title ' Critters Main Menu ' ;
double float shadow color scheme 2 ;
FONT 'Arial Bold', 25
*Added for VFP.
DEFINE WINDOW crit FROM 2,2 TO 90,170 ;
TITLE ' Critters Main Menu ' ;
DOUBLE FLOAT SHADOW COLOR scheme 2 ;
FONT 'Arial Bold', 25
* SCREEN
CLEAR
= explode (2,2,22,75,50,1)
ACTIVATE SCREEN
IF akl_test $ 'Yy'
@ 0,34 SAY 'Testing On' COLOR w+/N
* else
* @ 0,70 say space(9)
ENDIF
*L
* PROCESSING LOOP
DO WHILE .T.
ACTIVATE WINDOW crit
DO disscr
s_choice = mchoice
choice = mchoice
**************************
**********
**********
**********
**********
**********
* *
* This is a tempoary program to look for duplicates in a specific .DBF. *
IF .NOT. akl_test $ 'Yy'
* do dup1chk
* do dup2chk
ENDIF
* *
**************************
**********
**********
**********
**********
**********
ON KEY LABEL f7 DO genhlp WITH PROGRAM() && USER HELP
DO CASE
CASE choice = 0 && <ESC>
RELEASE WINDOW crit
IF akl_test $ "Yy"
RETURN
ELSE
QUIT
ENDIF
CASE choice = 1 .AND. (FILE('ANIMALS.PRG').OR.FI
LE('ANIMAL
S.FXP'))
DO animals WITH PROGRAM()
CASE choice = 2 .AND. (FILE('BIDS.PRG').OR.FILE(
'BIDS.FXP'
))
DO bids WITH PROGRAM()
CASE choice = 3 .AND. (FILE('CALENDAR.PRG').OR.F
ILE('CALEN
DAR.FXP'))
DO calendar WITH PROGRAM()
CASE choice = 4 .AND. (FILE('CONTRACT.PRG').OR.F
ILE('CONTR
ACT.FXP'))
DO contract WITH PROGRAM()
CASE choice = 5 .AND. (FILE('CRITTERS.PRG').OR.F
ILE('CRITT
ERS.FXP'))
DO critters WITH PROGRAM()
CASE choice = 6 .AND. (FILE('INVOICE.PRG').OR.FI
LE('INVOIC
E.FXP'))
DO invoice WITH PROGRAM()
CASE choice = 7 .AND. (FILE('P_LABELS.PRG').OR.F
ILE('P_LAB
ELS.FXP'))
DO p_labels WITH PROGRAM()
CASE choice = 8 .AND. (FILE('LISTS.PRG').OR.FILE
('LISTS.FX
P'))
DO lists
CASE choice = 9 .AND. (FILE('PRICES.PRG').OR.FIL
E('PRICES.
FXP'))
DO prices WITH PROGRAM()
* CASE choice = 10 .and. (file('PRINT.PRG').or.file
('PRINT.FX
P'))
* DO print
CASE choice = 10 .AND. (FILE('STATS.PRG').OR.FILE
('STATS.FX
P'))
DO stats
CASE choice = 11 .AND. (FILE('UTILS.PRG').OR.FILE
('UTILS.FX
P'))
DO utils
CASE choice = 12 .AND. (FILE('CRITHELP.PRG').OR.F
ILE('CRITH
ELP.FXP'))
DO crithelp
CASE choice = 13
IF akl_test $ "Yy"
SUSPEND
ELSE
QUIT
ENDIF
********** akl: Added choice=14 for F8 from Bids to Payable 2/25/96 2:08 am
CASE choice = 14 .AND. (FILE('PAYABLE.PRG').OR.FI
LE('PAYABL
E.FXP'))
DO payable WITH PROGRAM()
**********
********** akl: Added choice=15 for F11 from Bids to Receivables 2/28/96 10:53 am
CASE choice = 15 .AND. (FILE('RECEIVE.PRG').OR.FI
LE('RECEIV
E.FXP'))
DO receive WITH PROGRAM()
**********
ENDCASE
ENDDO
RETURN
*L
PROCEDURE disscr
PUBLIC mchoice, mget, cchoice, cchoices
STORE 0 TO mchoice, mget
STORE "" TO cchoice, cchoices
* nCOL = ROUND(WCOLS()/2,0) - 19
@ 1,34 SAY '2010'
* Left Column
ncol = 20
nrow = 3
DO GET WITH nrow,ncol, "[\<1] - Animals"
nrow = 4
DO GET WITH nrow,ncol, "[\<2] - Bids"
nrow = 5
DO GET WITH nrow,ncol, "[\<3] - Calendar"
nrow = 6
DO GET WITH nrow,ncol, "[\<4] - Contracts"
nrow = 7
DO GET WITH nrow,ncol, "[\<5] - Critters"
nrow = 8
DO GET WITH nrow,ncol, "[\<6] - Invoices"
* Right column
ncol = 40
nrow = 3
DO GET WITH nrow,ncol, "[\<7] - Labels"
nrow = 4
DO GET WITH nrow,ncol, "[\<8] - Lists"
nrow = 5
DO GET WITH nrow,ncol, "[\<9] - Prices"
nrow = 6
DO GET WITH nrow,ncol, "[\<S] - Stats"
nrow = 7
DO GET WITH nrow,ncol, "[\<U] - Utilities"
nrow = 8
DO GET WITH nrow,ncol, "[\<H] - Help"
* Middle column
ncol = 30
nrow = 10
DO GET WITH nrow,ncol, "[\<Q] - Quit"
cchoices = cchoices + "12Q"
cchoice = fnchoice(cchoices, "Q")
RETURN
FUNCTION fncurobj
PARAMETERS mchoice
mchoice = _CUROBJ
RETURN .T.
ENDFUNC
PROCEDURE GET
PARAMETERS nrow, ncol, cfunc, bskip
nsize2 = LEN(STRTRAN(cfunc,"\<")) + 2
@ nrow,ncol GET mget FUNCTION "* "+IIF(bskip,"\\","")+cfunc
;
VALID fnCUROBJ(@mCHOICE) ;
color scheme 1
RETURN
ENDPROC
FUNCTION fnchoice
PARAMETERS cchoices, cdef
READ CYCLE OBJECT mchoice
mchoice = IIF(LASTKEY()=27,AT(cdef,c
choices),m
choice)
RETURN IIF(mchoice > 0,SUBSTR(cchoices,mchoice,
1),"")
ENDFUNC
~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~
~~~~~~~~~~
~~~~~~~~~~
~~~~~~~~~~
~~~~~~~~
* COLORS
origschem1 = "W+/B,W+/BG,GR+/B,GR+/B,R+
/B,W+/GR,G
R+/RB,N+/N
,GR+/B,R+/
B,+"
origschem2 = "BG/W,N/W,N/W,B/W,W/N,N/BG
,W+/W,N+/N
,B/W,W/N,+
"
* 1 2 3 4 5 6 7 8 9 10 11
SET COLOR OF SCHEME 1 TO ;
"W+/B,W+/r,w/B,W+/B,W+/B,r
/w,GR+/RB,
N+/N,GR+/B
,R+/B,+"
* Letters of DeskTop (1)
* DeskTop Background (1)
* User GET Field Letters (2)
* User GET Field Background (2)
* User Border Character (3)
* User Border Background (3)
* User Title Active Letters (4)
* User Title Active Background (4)
* User Title Inactive Letters (5)
* User Title Inactive Background (5)
* Field Select (^A) Letters (6)
* Field Select (^A) Letters Background (6)
* 1 2 3 4 5 6 7 8 9 10 11
SET COLOR OF SCHEME 2 TO ;
"w/b,w/b,w/b,w+/b,W/N,w+/r
,W+/W,N+/N
,B/W,W/N,+
"
* Menu Letters (1)
* Menu Letters Background (1)
* Menu Selection Inactive Letters (2)
* Menu Selection Inactive Background (2)
* Menu Border Characters (3)
* Menu Border Background (3)
* Menu Title Inactive Letters (4)
* Menu Title Background (4)
* Menu Slection Active Letters (6)
* Menu Selection Active Background (6)
*
~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~
~~~~~~~~~~
~~~~~~~~~~
~~~~~~~~~~
~~~
* GENLBR.Prg (General Library)
* GENERAL LIBRARY PROCEDURE(S): GENLBR.PRG
function _add
if zoom_no = 1
go bottom
endif
do str_empty
do default
= add_rec()
return ''
*L
function _begin
if top_mark = 0
go top
else
go top_mark
skip
endif
return ''
*L
function _beginr
go top
return ''
*L
function _canflt
set filter to
= fltrsta()
return ''
*L
function _canfltr
set filter to
= _disstat()
return ''
*L
function _canscop
ndx_exp = sys(14,1)
go bottom
last_rec = recno()
last_val = &ndx_exp
go top
first_rec = recno()
first_val = &ndx_exp
= _disstat()
return ''
*L
function _copy
= add_rec()
return ''
*L
function _delete
if zoom_no < no_zooms
* Are there any children records?
child_num = str(zoom_no + 1, 1)
select &child_num
lnk_var = lnk_var&child_num
seek &lnk_var
if .not. &at_eof
= dismsg(chr(7) + "Subordinate records exist")
select &zoom_num
return ''
endif
select &zoom_num
endif
if confirm('Delete Record')
if right(sys(16,3),9) = 'ADOPT.FXP'
rec_del = .T.
endif
if right(sys(16,3),12) = 'CONTRACT.FXP'
select 3
delete
select 2
delete
select 1
endif
if right(sys(16,3),7) = 'DHR.FXP' && No Show Flag
dhr_delete = .t.
repl dhr_delete with m->dhr_delete
reindex
else
delete
endif
skip && reposition to the next record
if &at_eof() && if last record deleted, go to beginning of database
= _begin()
endif
if &at_eof .and. .not. empty(filter())
* no records left in filter, remove the filter
set filter to
= _begin()
endif
if &at_eof
* Last record deleted, database now empty
= _quit()
endif
endif
return ''
*L
function _disstat
exp_N = max(len(first_val),len(fil
ter()))
define window stat_wndw from 0,1 to 4,17+exp_N ;
shadow color scheme 7
activate window stat_wndw
if .not. empty(filter())
@ 0,0 say ' Filter is : ' + filter()
else
@ 0,0 say ' Filter is : Off'
endif
@ 1,0 say ' From Record: ' + first_val
@ 2,0 say ' To Record : ' + last_val
wait ''
release window stat_wndw
return ''
*L
function _editmemo
parameters is_edit
private memo_field
memo_field = memo_fld&zoom_num
if empty(memo_field)
= dismsg('Has no memo field')
return ''
endif
define window memo_wndw from 12,30 to 18,73 ;
title 'MEMO (ESC to Exit or Ctrl-W to Save)' ;
system float grow zoom close shadow color scheme 11
if is_edit
modify memo &memo_field window memo_wndw
else
modify memo &memo_field noedit window memo_wndw
endif
release window memo_wndw
return ''
*L
function _end
* Go to last record (last child record if Zoomed)
if bot_mark >= 0
go bot_mark
skip -1
else
if bot_mark = -1
go bottom
else
* Find first record outside range
locate while .t. for &at_eof
if eof()
* It is last record in database
bot_mark = -1
else
bot_mark = recno()
endif
skip -1
endif
endif
return ''
*L
function _endr
go bottom
return ''
*L
function _fromrcd
ndx_exp = sys(14,1)
if &ndx_exp <= last_val
first_rec = recno()
first_val = &ndx_exp
else
= dismsg("First record must precede the last record" )
endif
= _disstat()
return ''
*L
function _list
parameters dbf_desc
&& This command is needed because
on key label F7 && do _nohelp && of the SYS(18) problem found.
set help off && (_nohelp is on this page)
&& Notice -->> No func can be called!
&& Nor can a .PRG
if right(sys(16,2),12) = 'CRITTERS.FXP' && No 'GROW' !! (11 hours !)
define window brws_wndw from 9,4 to 19,54 ;
title dbf_desc ;
system zoom float close shadow color scheme 10
else
define window brws_wndw from 9,4 to 19,65 ;
title dbf_desc ;
system zoom float grow close shadow color scheme 10
endif
do list&zoom_num
record_no = recno()
release window brws_wndw
set help on && <<<--- REMEMBER! Remove these statements.
on key label F7 do genhlp with sys(18)
return ''
*L
function _modify
abort = .f.
********** akl: Bids - Multi Edit Window 10/16/95 2:07 am
on key label PGUP do PageUp
on key label PGDN do PageDn
**********
if modify_key
getcond = " 'G' $ fld_usg"
else
getcond = " 'G' $ fld_usg .and. .not. 'K' $ fld_usg"
endif
*--------- akl: Removed - Did not like the way it worked 3/13/96 9:17 pm
********** akl: Added for automatic balance computation 2/11/96 8:42 pm
* if ((prog_name = "PAYABLE" .and. alias() = "PAYDETL") .or. ;
* (prog_name = "RECEIVE" .and. alias() = "RECDETL")) .and. ;
* (option = 'copy' .or. option = 'modify')
* p_amount = 0
* endif
**********
*---------
getcond = "'G'$fld_usg"
if right(sys(16,3),8) = "USDA.FXP" .and. ;
right(sys(16,8),10) <> "G_USDA.FXP"
do getfldA with getcond
read
if m->u_code_2 = "D" .or. m->u_code_2 = "C"
do getfldB with getcond
read
endif
else
do getfld with getcond
********** akl: Allows cursor to UpArrow to Date field 11/16/95 4:17 pm
if right(sys(16,3),9) = "CALLS.FXP"
read cycle
else
read
endif
**********
endif
s_lastkey = lastkey()
* CLEANUP
********** akl: Bids - Multi Edit Window 10/16/95 2:07 am
on key label PgUp
on key label PgDn
**********
********** akl: CRITTERS.PRG - Multi Window Dogs Tricks Screen 7/28/98 10:06 pm
if option = "modify" .and. ;
prog_name = "CRITTERS" .and. ;
(alias() = "CRITDOGS" .or. alias() = "CRITCATS")
s_lastkey = s_lastky2 && Just in case the user pressed Ctrl-W from the first screen
do DogUpDn
endif
**********
set message to
if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
(right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
* (akl) 4/10/99 11:43 pm
* added if statement for the following condition: 2/M/F5/N/Z
* The data screen is erased and a user screen is activated.
* Problem occurs ONLY when Hot-Keying from Bids to Critters Dog's Zoom.
* No user screen is activated because the amount of data won't fit on a
* user screen. So the Desk Top is used. (activate screen).
if .not. (sys(16,5) = "ON... " .and. ;
right(sys(16,6),8) = "BIDS.FXP" .and. ;
right(dbf(),12) = "CRITDOGS.DBF")
set stat off && This had to be put in because the SET
endif
endif
&& STAT OFF alone did not erase the message
if akl_test $ 'Yy'
if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
(right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
if .not. (sys(16,5) = "ON... " .and. ;
right(sys(16,6),8) = "BIDS.FXP" .and. ;
right(dbf(),12) = "CRITDOGS.DBF")
set stat on
endif
endif
endif
if s_lastkey = 27 && Esc
abort = .t.
return ''
endif
if modify_key
if chk_dupl()
return ''
endif
endif
do lookup
do calcul with .t.
if right(sys(16,3),8) = "USDA.FXP" .and. ;
right(sys(16,8),10) <> "G_USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
clear gets
if page_no < last_page && Display next screen page
page_no = page_no + 1
do disscr
do while page_no <= last_page
getcond = "'G'$fld_usg"
********** akl: Bids - Multi Edit Window 10/16/95 2:07 am
* s_lastkey = '' && Commented for F11 key 2/28/96 0:08 pm
PgUpKey = .F.
PgDnKey = .F.
BTabKey = .F.
on key label PGUP do PageUp
on key label PGDN do PageDn
on key label BACKTAB do TabBack
**********
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with getcond
do getfldB with getcond
else
do getfld with getcond
endif
read
if .not. (PgUpKey .or. PgDnKey .or. BTabKey)
s_lastkey = lastkey()
endif
* CLEANUP
********** akl: Bids - Multi Edit Window 10/16/95 2:07 am
on key label PGUP
on key label PGDN
on key label BACKTAB
**********
set message to
set stat off && This had to be put in because the SET
&& STAT OFF alone did not erase the message
&& It should work. Find out why?
if akl_test $ 'Yy'
set stat on
set esca on
endif
if s_lastkey = 27 && Esc
abort = .t.
exit
endif
if s_lastkey = 18 && Page Up Key
if page_no > 1
page_no = page_no - 1
do disscr
loop
endif
endif
if s_lastkey = 3 && Page Down Key
if page_no < last_page
page_no = page_no + 1
do disscr
loop
endif
endif
if s_lastkey = 15 && Back Tab
if page_no > 1
page_no = page_no - 1
do disscr
if page_no = 1
for i = 1 to 18
keyboard chr(9)
next
loop
endif
endif
endif
if type('LArrow') = 'L' && See Contracts (akl) 10/05/99 10:43 am
if page_no = 2
page_no = 1
do disscr
loop
endif
endif
if page_no = first_page
* Check for duplicate (key entered only on first page)
seek &ndx_var
**************************
**********
**********
**********
**********
**********
***
* *
* This IF statement was changed and duplicated because when you ZOOM to an *
* empty database, the system always displays the 'Duplicate Record' error *
* message when the first record is entered. Separate IF statements seems *
* to fix this problem. The difference is the IF statement just before the *
* '= dismsg...' statement. They are different for each condition of ZOOM_NO. *
* (akl) *
**************************
**********
**********
**********
**********
**********
***
* Use this IF statement if zoom_no = 1
if zoom_no = 1
if prog_name = "CONTRACT"
exit && Added because always getting error message when
&& in Contract and ^W used to exit. I did it this
&& way because I know that I will witing a WINDOWS
&& windows version of the program. It is not worth
&& fighting at this time 3/08/2000 2:09 pm (akl)
else
if .not. &at_eof .and. .not. allow_dup&zoom_num
= dismsg(chr(7) + 'Duplicate record not allowed')
abort = .t.
exit
endif
endif
endif
* Use this IF statement if zoom_no > 1
if zoom_no > 1
if .not. (&at_eof .and. allow_dup&zoom_num)
= dismsg(chr(7) + 'Duplicate record not allowed - 2 (akl)')
abort = .t.
exit
endif
endif
endif
* Display lookup fields and computed variables
do lookup
do calcul with .t.
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
clear gets
if page_no < last_page
* Display next screen page
page_no = page_no + 1
do disscr
else
exit
endif
enddo while page_no <= last_page
endif
if .not. ((alias() = 'PAYDETL' .or. alias() = 'RECDETL' ) .and. option = 'modify')
do calcul with .t.
endif
* Restore page number
if page_no > first_page
deact wind all
page_no = first_page
do disscr
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".f."
do getfldB with ".f."
else
do getfld with ".f."
endif
redisp_fld = .t.
clear gets
endif
if .not. abort
********** akl: Check the spelling of the record 3/19/96 1:55 am
if prog_name = "BIDS" .or. prog_name = "CONTRACT" .or. ;
prog_name = "INVOICE" .or. prog_name = "SUBRENT" .or. ;
prog_name = "MAPS" .or. prog_name = "HELTHCRT"
do SpellChk with "Rec" && Record (Rec) or Field (Fld)
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".f."
do getfldB with ".f."
else
do getfld with ".f."
endif
endif
**********
if confirm('Save Record')
save_rec = .T.
if alias() = "CRITDOGS" .or. alias() = "CRITCATS"
LastTKUpd = Date()
if alias() = "CRITDOGS"
select critters
replace LastTKupd with m->LastTKupd
select critdogs
@ 0,67 say dtoc(m.lasttkupd)
else
select critters
replace LastTKupd with m->LastTKupd
select critcats
@ 2,60 say dtoc(lasttkupd)
endif
endif
gather memvar memo
if right(sys(16,3),12) = "CONTRACT.FXP"
sele 2
gather memvar
sele 3
gather memvar
sele 1
endif
endif
endif
return ''
*L
PROCEDURE RunDOS
* Execute a DOS program or batch file, or invoke the DOS command
* interpreter (COMMAND.COM must be in the PATH)
PARAMETERS command_
IF _DOS
ACTIVATE SCREEN
SAVE SCREEN TO DOSscreen
@ 0,0 CLEAR
SET CURSOR ON
* RUN /0 &command_. Commented out: 8/15/95 3:08 am
NewCommand_ = GETENV('COMSPEC') && Added this code to read the true
RUN /0 &NewCommand_ && "COMMAND.COM". Can't always be sure
&& COMMAND.COM will be running.
SET CURSOR ON && Added 11/29/94
* SET CURSOR OFF Commented 11/29/94-(akl)
RESTORE SCREEN FROM DOSscreen
RELEASE SCREEN DOSscreen
ENDIF
RETURN
*L
function PageDn
s_lastkey = lastkey()
if s_lastkey = 3
PgDnKey = .T.
keyboard chr(23)
if option = "modify" .and. ;
prog_name = "CRITTERS" .and. ;
(alias() = "CRITDOGS" .or. alias() = "CRITCATS")
s_lastky2 = s_lastkey && Just in case the user pressed Ctrl-W from the first screen
endif
endif
return
*L
function PageUp
s_lastkey = lastkey()
if s_lastkey = 18
* if .not. (prog_name = "CRITTERS" .and. ;
* option = "modify" .and. ;
* (alias() = "CRITDOGS" .or alias() = "CRITCATS"))
PgUpKey = .T.
keyboard chr(23)
* endif
endif
return
*L
function _next
skip
if &at_eof
= _end()
= dismsg(chr(7) + 'Last record')
endif
return ''
*L
function _nextr
skip
if eof()
= _endr()
= dismsg(chr(7) + 'Last record')
endif
return ''
*L
function _nextpage
last_page = val(substr(page_seq&zoom_n
um,len(pag
e_seq&zoom
_num),1))
if page_no < last_page
page_no = page_no + 1
do disscr
else
= dismsg('No other page')
endif
return ''
*L
function _nohelp
define window help_not from 0,30 to 2,78 shadow color scheme 7
activate window help_not
mess_err = 'Sorry, no HELP is available at this time.'
wait mess_err
release window help_not
return ''
*L
function _prev
skip -1
if &at_bof
= _begin()
= dismsg(chr(7) + 'First record')
endif
return ''
*L
function _prevr
skip -1
if bof()
= _beginr()
= dismsg(chr(7) + 'First record')
endif
return ''
*L
function _prepage
first_page = val(substr(page_seq&zoom_n
um,1,1))
if page_no > first_page
page_no = page_no - 1
do disscr
redisp_fld = .t.
else
= dismsg('No other page')
endif
return ''
*L
function _print
********** Print Selected Entries 9/07/98 9:27 pm (akl)
if right(sys(16,2),12) = 'CRITTERS.FXP' .or. ;
right(sys(16,2),12) = 'P_LABELS.FXP'
do prn_sele
endif
**********
set escape on
define window prnt_wndw from 0,43 to 2,78 ;
shadow color scheme 7
activate window prnt_wndw
s_readkey = 0
@ 0,0 say ' Printing - ESC To Stop '
= init_rpt()
if s_readkey = 268 .or. s_readkey = 12 && Escape was pressed
release window prnt_wndw
return
endif
&& Added Current or All USDA records (02/05/02 akl)
if right(sys(16,6),10) = "P_USDA.FXP" .and. g_all = "A"
if .not. sys(13) = 'OFFLINE' .or. outp_dev <> 'laser' .or. outp_dev <> 'dot'
s_recno = recno()
go top
brk_no = 1
do pgehdr
do while .not. eof()
r_count = 0
do while r_count <> 9
do brkhdr
skip
if eof()
exit
endif
r_count = r_count + 1
enddo
if eof()
exit
endif
enddo
goto s_recno
endif
else
if .not. sys(13) = 'OFFLINE' .or. outp_dev <> 'laser' .or. outp_dev <> 'dot'
do rpthdr
do pgehdr
do rptbdy
do rptftr
line_no = lns_per_pg
do pgeftr
endif
endif
if right(sys(16,2),12) = 'P_LABELS.FXP' .and. group = 1
if akl_system $ 'Y'
set print to LPT1
else
set print to LPT1
endif
set print on
eject
set print off
set printer to
else
= end_rpt()
endif
release window prnt_wndw
if outp_dev = 'screen'
= edit_txt()
endif
set escape off
go record_no
return ''
*L
function _popcal
s_curobj = _curobj
* activate screen
on key label esc keyboard "{CTRL+W}" + "{ENTER}"
* @ 24,0 say padc("Press ESC to return to the data entry screen",80)
activate window calculator
read valid .T.
* @ 24,0
on key label esc
_curobj = s_curobj
set esca on
return
*L
function _quit
if right(sys(16,2),9) <> 'PRINT.FXP' .and. ;
right(sys(16,3),8) <> 'JOBS.FXP'
set filter to
endif
* Hide the window when user Quits to previous window
do case
case right(sys(16,2),12) = 'CRITTERS.FXP'
do case
case zoom_no = 1
wind_hide = 'usr_wndw1'
case zoom_no = 2
clear
wind_hide = 'usr_wndw5'
case zoom_no = 3
clear
wind_hide = 'usr_wndw4'
case zoom_no = 4
wind_hide = 'usr_wndw6'
case zoom_no = 5
wind_hide = 'usr_wndw3'
endcase
s_zoom_no = zoom_no
if zoom_no = 1 .or. KeyF2
zoom_no = 0
else
zoom_no = 1
endif
otherwise
wind_hide = 'usr_wndw'+alltrim(str(zoo
m_no))
zoom_no = zoom_no - 1
* Added if statement for the following condition: 2/M/F5/N/Z
* The data screen is erased and a user screen is activated.
* Problem occurs ONLY when Hot-Keying from Bids to Critters Dog's Zoom.
* No user screen is activated because the amount of data won't fit on a
* user screen. So the Desk Top is used. (activate screen).
if (sys(16,5) = "ON... " .and. ;
right(sys(16,6),8) = "BIDS.FXP" .and. ;
right(dbf(),12) = "CRITDOGS.DBF")
clear
endif
endcase
if wexist('&wind_hide')
hide window &wind_hide
endif
if zoom_no > 0
= x_zoom()
go record_no
do disscr
redisp_fld = .t.
endif
return ''
*L
function _retrieve
* Accept key and seek record; if not found reposition to record_no
d_function = dispage1()
if '' <> trim(ndx_var)
scatter memvar blank memo
do clrfld
do getkey
read
* CLEANUP
set message to
set stat off && This had to be put in because the SET
&& STAT OFF alone did not erase the message
if akl_test $ 'Yy'
set stat on
endif
if lastkey() <> 27 && Esc
if program(3) = "JOBS" .and. alias() = "JOBS"
seek trim(&ndx_var1a)
else
seek trim(&ndx_var)
endif
if &at_eof
= dismsg('Not found')
go record_no
endif
endif
endif
return ''
*L
********** akl: New Select Command 10/23/95 2:25 am
function _select
parameters dbf_desc
&& This command is needed because
on key label F7 && do _nohelp && of the SYS(18) problem found.
set help off && (_nohelp is on this page)
&& Notice -->> No func can be called!
&& Nor can a .PRG
if right(sys(16,2),12) = 'CRITTERS.FXP' && No 'GROW' !! (11 hours !)
define window brws_wndw from 9,4 to 19,54 ;
title dbf_desc ;
system zoom float close shadow color scheme 10
else
define window brws_wndw from 9,4 to 19,65 ;
title dbf_desc ;
system zoom float grow close shadow color scheme 10
endif
do sel&zoom_num
record_no = recno()
release window brws_wndw
set help on && <<<--- REMEMBER! Remove these statements.
on key label F1 do genhlp with sys(18)
return ''
**********
*L
function _skip
* Move forward/backward several records
rec_count = 0
define window skip_wndw from 11,29 to 13,52 ;
shadow color scheme 7
activate window skip_wndw
@ 00,00 say ' Skip Records:' get rec_count picture '@Z 999999'
read
skip rec_count
if &at_eof
= _end()
= dismsg(chr(7) + 'Last Record')
endif
if &at_bof
= _begin()
= dismsg(chr(7) + 'First record')
endif
release window skip_wndw
return ''
*L
function _skipr
* Move forward/backward several records
rec_count = 0
define window skip_wndw from 11,29 to 13,52 ;
shadow color scheme 7
activate window skip_wndw
@ 00,00 say ' Skip Records:' get rec_count picture '@Z 999999'
read
skip rec_count
if eof()
= _endr()
= dismsg(chr(7) + 'Last Record')
endif
if bof()
= _beginr()
= dismsg(chr(7) + 'First record')
endif
release window skip_wndw
return ''
*L
function TabBack
s_lastkey = lastkey()
if s_lastkey = 15
BTabKey = .T.
keyboard chr(23)
endif
return
*L
function _tally
define window count_wndw from 0,35 to 2,78 ;
shadow color scheme 7
activate window count_wndw
@ 0,0 say ' Counting...'
rec_count = 0
= _begin()
count while .not. &at_eof to rec_count
mess_str = str(rec_count,6) + ' record'
if rec_count > 1
mess_str = mess_str + 's'
endif
wait mess_str
go record_no
release window count_wndw
return ''
*L
function _tallyr
define window count_wndw from 0,35 to 2,78 ;
shadow color scheme 7
activate window count_wndw
@ 0,0 say ' Counting...'
rec_count = 0
= _beginr()
count while .not. eof() to rec_count
mess_str = str(rec_count,6) + ' records'
wait mess_str
go record_no
release window count_wndw
return ''
*L
function _tofile
rep_file = space(8)
define window file_wndw from 7,20 to 16,59 ;
title ' Enter Fax Filename ' ;
shadow color scheme 7
activate window usr_wndw1
activate window file_wndw
@ 3, 1 say "Maximum of 8 characters is allowed."
@ 4, 1 say 'The filename, you enter, will have'
@ 5, 1 say '".TXT" added to the end of the name.'
@ 6, 1 say 'Do not use any special characters.'
@ 1,15 get rep_file
read
rep_file = "c:\crit\fax\"+alltrim(rep
_file)+".t
xt"
deactivate window file_wndw
release window file_wndw
define window file_wndw from 7,18 to 19, 60 ;
title ' Your Fax is Ready ' ;
shadow color scheme 7
activate window file_wndw
@ 1, 1 say "After the fax has been printed, go to"
@ 2, 1 say "the Systray, on the desktop, and start"
@ 3, 1 say "WinFax, by Right-Clicking on the fax"
@ 4, 1 say "icon. Next, left-click on send a Fax..."
@ 6, 1 say "File location: "+rep_file
@ 8, 1 say "When the fax has been sent, return here"
@ 9, 1 say "to continue to work as before."
read
release window file_wndw
if .not. empty(rep_file)
outp_dev = 'file'
endif
return ''
*L
function _torcd
ndx_exp = sys(14,1)
if &ndx_exp >= first_val
last_rec = record_no
last_val = &ndx_exp
else
= dismsg("Last record must follow the first record")
endif
= _disstat()
return ''
*L
function _zoom
* susp
if no_zooms = zoom_no
= dismsg('No Zoom File')
else
if right(sys(16,2),12) = 'CRITTERS.FXP'
do case
case anml_type = 'C'
zoom_no = 3
case anml_type = 'D'
zoom_no = 2
case anml_type = 'E'
zoom_no = 4
case anml_type = 'F'
zoom_no = 5
otherwise
* = dismsg('The Animal Type field is NOT C, D, E, or F.')
A_Type = space(1)
define window file_wndw from 8,20 to 16,57 ;
title ' Missing: Animal Type ' ;
shadow color scheme 7
activate window usr_wndw1
activate window file_wndw
@ 1, 1 say "Every animal must have a TYPE that"
@ 2, 1 say "describes a general catagory. The "
@ 3, 1 say "allowed entries are: D, C, F, or E"
@ 4, 1 say " (Dog, Cat, Farm, or Exotic.) "
GoodType = .F.
Do while .not. GoodType
@ 4,34 get A_Type
read
A_Type = Upper(A_Type)
If A_Type $ "DCFE"
GoodType = .T.
else
@ 6, 1 say " Please enter: D, C, F, or E "
EndIf
enddo
deactivate window file_wndw
release window file_wndw
anml_type = A_Type
replace anml_type with m->anml_type
@ 2, 65 say m->anml_type
endcase
else
zoom_no = zoom_no + 1
endif
= x_zoom()
= _begin()
* If a new page, display new screen
if first_page <> page_no
page_no = first_page
endif
if &at_eof
set esca off
= dismsg('Database empty')
set esca on
= _add()
endif
endif
return ''
*L
function add_rec
* Add a record
abort = .f.
no_rcds = &at_eof
* reset to first page
d_function = dispage1()
on key label PGUP do PageUp
on key label PGDN do PageDn
do while page_no <= last_page
********** akl: Bids - Multi Edit Window 10/16/95 2:07 am
*+++++++++ akl: Bids - Allow <BackTab> on Multi Edit Window
if right(sys(16,3),8) = "BIDS.FXP"
on key label PGUP do newPageUp
on key label PGDN do newPageDn
endif
**********
*--------- akl: Removed - Did not like the way it worked 3/13/96 9:17 pm
********** akl: Added for automatic balance computation 2/11/96 8:42 pm
if ((prog_name = "PAYABLE" .and. alias() = "PAYDETL") .or. ;
(prog_name = "RECEIVE" .and. alias() = "RECDETL")) .and. ;
(option = 'copy' .or. option = 'modify'))
p_amount = 0
endif
**********
*---------
getcond = "'G'$fld_usg"
if right(sys(16,3),8) = "USDA.FXP"
do clrfld
@ 14, 1 say space(57)
@ 15, 1 say space(57)
@ 16, 1 say space(57)
@ 17, 1 say space(57)
do getfldA with getcond
read
if m->u_code_2 = "D" .or. m->u_code_2 = "C"
do getfldB with getcond
read
endif
else
do getfld with getcond
********** akl: Allows cursor to UpArrow to Date field. 12/15/95 6:59 pm
if right(sys(16,3),9) = "CALLS.FXP"
read cycle
else
read
endif
**********
endif
********** akl: Bids - Multi Edit Window 10/16/95 2:07 am
*+++++++++ akl: Bids - Allow <BackTab> on Multi Edit Window
if right(sys(16,3),8) = "BIDS.FXP"
on key label PGUP
on key label PGDN
endif
**********
set message to
set stat off && This had to be put in because the SET
&& MESSAGE to does not seem to work !!
if akl_test $ 'Yy'
set stat on
endif
s_lastkey = lastkey()
if s_lastkey = 27 && Esc
abort = .t.
exit
endif
if s_lastkey = 18 && Page Up Key
if page_no > 1
page_no = page_no - 1
do disscr
loop
endif
endif
if s_lastkey = 3 && Page Down Key
if page_no < last_page
page_no = page_no + 1
do disscr
loop
endif
endif
if page_no = first_page
* Check for duplicate (key entered only on first page)
if .not. allow_dup&zoom_num
if right(sys(16,3),8) <> "USDA.FXP"
seek &ndx_var
if .not. (&at_eof)
= dismsg(chr(7) + 'Duplicate record not allowed')
abort = .t.
exit
endif
********** akl: Added individual checking of each key field in USDA 5/31/96 0:26 pm
else
if m.usda = 0
exit
endif
s_recno = recno()
go top
locate for m.name = name
if found()
= dismsg(chr(7) + "Animal's name already in use. Choose another name")
abort = .t.
exit
endif
go top
locate for m.usda = usda
if found()
= dismsg(chr(7) + "USDA number already in use. Choose another number")
abort = .t.
exit
endif
if .not. eof()
goto s_recno
endif
endif
**********
endif
endif
* Display lookup fields and computed variables
do lookup
do calcul with .t.
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
clear gets
if page_no < last_page
* Display next screen page
page_no = page_no + 1
do disscr
else
exit
endif
enddo while page_no <= last_page
* Restore page number
if page_no > first_page
deact wind all
page_no = first_page
do disscr
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
redisp_fld = .t.
endif
abort = iif(abort,.t.,.not. save_rec())
if .not. abort
if no_rcds
= set_bndry()
endif
else
if no_rcds
= _quit()
else
go record_no
endif
endif abort
return ''
*L
function adv_line
* Advance a report/screen line
line_no = line_no + 1
if line_no = lns_per_pg
do pgeftr
= adv_page()
endif
at_top = .f.
return line_no
*L
function adv_page
* Advance report/screen page
page_no = page_no + 1
if right(sys(16,2),12) = 'CRITTERS.FXP' && 9/09/98 9:11 pm (akl)
if page_no = sel_yes + 1
return
endif
endif
if outp_dev = 'laser' .or. outp_dev = 'dot'
eject
else
@ line_no+1,0 say replicate(chr(219),76)
endif
line_no = top_margin
do pgehdr
return ''
*L
function chk_dupl
* Set duplicate to .f. if the key is a duplicate, or to .t. otherwise
private dupl_rec
if ((&at_bof) = (&at_eof)) .or. '' = trim(ndx_var) .or. allow_dup&zoom_num
dupl_rec = .f.
else
seek &ndx_var
if option = 'M'
dupl_rec = record_no <> recno() .and. .not. &at_eof
else
dupl_rec = .not. &at_eof
endif
if dupl_rec
= dismsg(chr(7) + 'Duplicate record not allowed')
else
go record_no
endif
endif
return dupl_rec
*L
function chng_brk
Parameters up
* Increment break level if "up" = .t., decrement otherwise
if up
* Set new report termination condition
brk_field = brk_field&brk_num
new_cond = '&brk_field<>m->&brk_field
' + '.or.'
cond_size&brk_num = len(new_cond)
done_cond = new_cond + done_cond
* Store break field to memory variable
&brk_field = &brk_field
* Zoom up if it is a "zoom" break
if brk_zoom&brk_num
zoom_no = zoom_no + 1
zoom_num = str(zoom_no,1)
frst_child = lnk_var&zoom_num
select &zoom_num
seek &frst_child
endif
* Increment break number
brk_no = brk_no + 1
brk_num = str(brk_no,1)
done = &done_cond
else
brk_no = brk_no - 1
brk_num = str(brk_no,1)
* Reduce the report termination condition
done_cond = substr(done_cond, 1+cond_size&brk_num)
* Zoom down if it is a "zoom" break
if brk_zoom&brk_num
zoom_no = zoom_no - 1
zoom_num = str(zoom_no,1)
select &zoom_num
endif
endif
return ''
*L
function confirm
parameters header
define window con_wndw from 1,50 to 20,100 ;
double color scheme 12 ;
FONT 'Arial Bold', 20 && 1,2,5?,6?,8?,10?,11?,'13'
activate window con_wndw
if (13-len(header)/2) < 0
= dismsg('Error: Header too long. 13 Chars max')
endif
@ 1,00 say space(13-len(header)/2) + header
@ 3,00 say ' < > < > '
@ 3,05 prompt 'Yes'
@ 3,18 prompt 'No'
menu to con_opt
release window con_wndw
return iif(con_opt=1,.t.,.f.)
*L
function con_year
* CONTRACY YEAR returns the year of the contract as specified by Rob
* for his business.
SET CENTURY ON
num_yr = val(right(dtoc(date()),4))
-1981
SET CENTURY OFF
if val(left(dtoc(date()),4)) > 5
num_yr = num_yr + 1
endif
return num_yr
*L
function dismsg
parameters message
define window mess_wndw from 10,78-6-len(message) to 24,100 ;
TITLE "Critters Message" ;
CLOSE FLOAT GROW ZOOM ;
shadow color scheme 7;
FONT 'Arial Bold', 20
activate window mess_wndw
if empty(message)
wait ' Press any key to continue...'
else
wait ' ' + message + '...'
endif
release window mess_wndw
return ''
*L
function dismsgt
parameters message
define window mess_wndw from 0,78-6-len(message) to 2,78 ;
shadow color scheme 7
activate window mess_wndw
if empty(message)
wait ' Press any key to continue...' ;
timeout 2
else
wait ' ' + message + '...' ;
timeout 2
endif
release window mess_wndw
return ''
*L
function DmsgQwQr
* Display Message, Wait ?(yes or no) Release ?(yes or no)
parameters Message, WaitReply, CloseWin
define window mess_wndw from 0,78-6-len(message) to 2,78 ;
shadow color scheme 7
activate window mess_wndw
if WaitReply
if empty(message)
@ 0,1 say 'Press any key to continue...'
read
else
@ 0,1 say message + '...'
read
endif
else
if empty(message)
@ 0,1 say ''
else
@ 0,1 say message + '...'
endif
endif
if CloseWin
release window mess_wndw
endif
return ''
*L
function dispage1
if page_no <> first_page
redisp_fld = .t.
page_no = first_page
do disscr
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
clear gets
endif
return ''
*L
function edit_txt
define window txt_wndw from 1,0 to 24,79 ;
title 'PRINT TO SCREEN (ESC To Exit)' ;
system zoom float grow close color scheme 11
if akl_test $ 'Yy'
modify file gentemp.gtx window txt_wndw && .gtx = GeneralTeXt
else
modify file gentemp.gtx noedit window txt_wndw && .gtx = GeneralTeXt
endif
release window txt_wndw
return ''
*L
function end_rpt
if outp_dev = 'laser' .or. outp_dev = 'dot'
if right(sys(16,3),11) <> 'P_CONTR.FXP' .and. ;
right(sys(16,3),10) <> 'P_INVO.FXP' .and. ;
right(sys(16,5),12) <> 'P_SUBRNT.FXP' .and. ;
right(sys(16,5),10) <> 'P_BIDS.FXP'
if .not. ((right(sys(16,3),12) = 'P_LABELS.FXP' .or. ;
right(sys(16,3),12) = 'P_LABLS1.FXP' .or. ;
right(sys(16,3),12) = 'P_LABLS2.FXP') .and. ;
(m.group = 2 .or. m.group = 3 .or. m.group = 4 .or. m.group = 5))
eject
endif
endif
endif
if outp_dev = 'file'
set printer to
endif
set device to screen
set console on
return ''
* right(sys(16,4),10) <> 'P_BIDS.FXP' && (akl) 6/02/99 0:33 pm
* .and. ; && 2/20/94 (akl)
* right(sys(16,3),12) <> 'P_LABELS.FXP'
*L
function envrnmnt
on error do errfix with error(),message(),message(
1),program
(),lineno(
)
set bell off
set console on
set decimals to 10
set deleted on
set exact off
set exclusive off
set device to screen
set multilocks off
set refresh to 0
set reprocess to 1
set safety off
set talk off
close databases
return ''
*L
function errfix
parameters errnum,errormsg,errormsg1,
prgname,li
neno
* release window err_wndw
do case
case errnum = 108 && file in use by another
if confirm('File In Use, Retry?')
retry
else
if wexist('chkf_wndw')
release window chkf_wndw
endif
= restenv()
return to &callmenu
endif
case errnum = 109 && record locked by another
if confirm('Record In Use, Retry?')
retry
else
return to mainproc
endif
* return to &
case errnum = 110 && file in use by another
= dismsg('File has to be opended exclusively')
return to &callmenu
otherwise
*set esca on
define window err_wndw from 15,3 to 50,170 ;
FONT 'Arial Bold', 16 ;
double float shadow color scheme 2
activate window err_wndw
@ 0,0 say 'Error Number: ' + ltrim(str(errnum))
@ 1,0 say 'Error Message: ' + errormsg
@ 2,0 say 'Line of Text: ' + errormsg1
@ 3,0 say 'Program Name: ' + prgname
@ 4,0 say 'Line Number: ' + ltrim(str(lineno))
@ 5,0 say 'Object: ' + sys(2018)
= dismsg('Error')
release window err_wndw
*set esca off
endcase
return ''
*L
function explode
parameters m_row1,m_col1,m_row2,m_col
2,m_cnt,m_
type
* m_row1 = upper left hand corner of box.
* m_col1 = upper right hand corner of box.
* m_row2 = lower left hand corner of box.
* m_col2 = lower right had corner of box.
* m_cnt = number of steps for explosion determines the speed that box explodes.
* m_type = type of explosion.
* 1 = all sides explode at once.
* 2 = only sides explode.
* 3 = only top and bottom explode.
* 4 = explodes from top to bottom.
* 5 = explodes from bottom to top.
* 6 = explodes from left to right.
* 7 = explodes from right to left.
public explode
save screen to explode
r_pos1 = m_row1
r_pos2 = m_row2
c_pos1 = m_col1
c_pos2 = m_col2
do case
case m_type = 1 && all sides.
store ((m_row2-m_row1)/2)+m_row1
to r_pos1,r_pos2 && row center
store ((m_col2-m_col1)/2)+m_col1
to c_pos1,c_pos2 && col center
r_cnt = (r_pos1-m_row1)/m_cnt && row increment
c_cnt = (c_pos1-m_col1)/m_cnt && col increment
case m_type = 2 && sides only.
store ((m_col2-m_col1)/2)+m_col1
to c_pos1,c_pos2 && col center
c_cnt = (c_pos1-m_col1)/m_cnt && col increment
case m_type = 3 && top and bottom
store ((m_row2-m_row1)/2)+m_row1
to r_pos1,r_pos2 && row center
r_cnt = (r_pos1-m_row1)/m_cnt && row increment
case m_type = 4 && top to bottom
r_pos2 = m_row1
r_cnt = (m_row2-m_row1)/m_cnt && row increment
case m_type = 5 && bottom to top
r_pos1 = m_row2
r_cnt = (m_row2-m_row1)/m_cnt && row increment
case m_type = 6 && left to right
c_pos2 = m_col1
c_cnt = (m_col2-m_col1)/m_cnt && row increment
case m_type = 7 && right to left
c_pos1 = m_col2
c_cnt = (m_col2-m_col1)/m_cnt && row increment
endcase
do while r_pos1 >= m_row1 .and. r_pos2 <= m_row2 .and. ;
c_pos1 >= m_col1 .and. c_pos2 <= m_col2
@ r_pos1,c_pos1,r_pos2,c_pos
2 box 'im;:<mh: '
do case
case m_type = 1
r_pos1 = r_pos1 - r_cnt
r_pos2 = r_pos2 + r_cnt
c_pos1 = c_pos1 - c_cnt
c_pos2 = c_pos2 + c_cnt
case m_type = 2
c_pos1 = c_pos1 - c_cnt
c_pos2 = c_pos2 + c_cnt
case m_type = 3
r_pos1 = r_pos1 - r_cnt
r_pos2 = r_pos2 + r_cnt
case m_type = 4
r_pos2 = r_pos2 + r_cnt
case m_type = 5
r_pos1 = r_pos1 - r_cnt
case m_type = 6
c_pos2 = c_pos2 + c_cnt
case m_type = 7
c_pos1 = c_pos1 - c_cnt
endcase
enddo
clear
*@ m_row1,m_col1,m_row2,m_col
2 box 'im;:<mh: '
return ''
*L
function fltrsta
* (akl) 5/11/99 3:27 pm
* The next IF statement was removed to allow Filter message to be displayed.
* if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
(right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
activate screen
* endif
if .not. empty(filter())
@ 0,70 say 'Filter On' color w+/n
else
* (akl) 5/11/99 3:27 pm
* The next IF statement was changed to display the Right-Top corner of the box..
do case
case right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF'
if PrimDisp
@ 0,70 say "ÍÍÍÍÍÍÍÍÍ"
else
@ 0,70 say "ÍÍÍÍÍÍÍÍÍ»"
endif
case right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'
if PrimDisp
@ 0,70 say space(09)
else
@ 0,70 say "ÍÍ»"+space(06)
endif
otherwise
@ 0,70 say space(09)
endcase
endif
if alias() = 'BIDS'
if type('s_recon_date') = 'D'
if empty(s_recon_date)
@ 0, 1 say space(25)
else
@ 0, 1 say "Recon Date: "+dtoc(s_recon_date) color w+/n
endif
endif
endif
if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
(right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
* (akl) 4/10/99 11:43 pm
* added if statement for the following condition: 2/M/F5/N/Z
* The data screen is erased and a user screen is activated.
* Problem occurs ONLY when Hot-Keying from Bids to Critters Dog's Zoom.
* No user screen is activated because the amount of data won't fit on a
* user screen. So the Desk Top is used. (activate screen).
if .not. (sys(16,5) = "ON... " .and. ;
right(sys(16,6),8) = "BIDS.FXP" .and. ;
right(dbf(),12) = "CRITDOGS.DBF")
activate window usr_wndw&page_num
endif
endif
return ''
*L
function fltrstar
activate screen
if .not. empty(filter())
@ 0,70 say 'Filter On' color w+/n
else
@ 0,70 say space(09)
endif
activate window usr_wndw
return ''
*L
function genhlp
parameters prm1
private org_alias, hlp_topic
org_alias = alias()
if "GENHLP.DBF" $ dbf()
return ''
endif
EditFld = .F. && Rob wants ALL Edit (Memo) fields to point the same
&& help message 1/10/97 1:53 am (akl)
if empty(prm1)
hlp_topic = prog_name
else
if empty(sys(18))
hlp_topic = prm1
else
hlp_topic = sys(18)
if type('&hlp_topic') = 'M'
EditFld = .T.
endif
endif
endif
if .not. file('genhlp.DBF')
if .not. file('genhlp.STR')
= dismsg('genhlp.STR not found')
return ''
else
select 0
create genhlp from genhlp.str
use
endif
endif
select 0
use genhlp
set exact on
if EditFld
locate for trim(topic) = 'BID'
else
locate for trim(topic) = hlp_topic
endif
set exact off
if eof()
if modi_memo
append blank
= rlock()
* replace topic with prm1 && Is this a bug??
replace topic with hlp_topic && If yes, this may be the fix !!
&& The screen where a field has not yet
&& chosen (A or M), replaces a blank.
replace brow with 7, bcol with 10 ;
erow with 16, ecol with 70
unlock
else
&& no help available - ignore or alert msg???
return ''
endif
endif
if modi_memo
define window help_wndw from brow,bcol to erow,ecol ;
title 'HELP (ESC to Exit or F10 to Save)' ;
system zoom float grow close color scheme 11
else
define window help_wndw from brow,bcol to erow,ecol ;
title 'HELP (ESC to Exit)' ;
system zoom close color scheme 11
endif
if modi_memo
if rlock()
on key label F10 do sav_wind with 'HELP (ESC to Exit or F10 to Save)'
modify memo details window help_wndw
unlock
on key label F10
else
= dismsg('Help Record In Use, Retry')
endif
else
modify memo details noedit window help_wndw
endif
use
if ! empty(org_alias)
select &org_alias
endif
release window help_wndw
return ''
*L
function getgrid
* VARIABLES
private choice
private all like prompt*
choice = 0
prompt1 = ' Go '
prompt2 = ' Modi '
prompt3 = ' Quit '
* WINDOWS
define window MAINTMNU from 22,0 to 24,79 ;
title ' Grid Commands Menu ' ;
double float shadow color scheme 2
* SCREEN
activate window MAINTMNU noshow
* 1 2 3
@ 0, 1 say 'Go Modi Quit'
*L
on key label F7 do genhlp with program() && USER HELP
activate window MAINTMNU
@ 0, 1-1 prompt prompt1
@ 0, 4-1 prompt prompt2
@ 0, 9-1 prompt prompt3
menu to choice
do case
case choice = 0
release window MAINTMNU
option = 'quit'
case choice = 1
option = 'go'
case choice = 2
option = 'modify'
case choice = 3
release window MAINTMNU
option = 'quit'
endcase
deactivate window MAINTMNU
return option
*L
function getgrid2
* GetGrid2 has the Select (Sel) command added to the list 3/21/96 6:03 pm
* VARIABLES
private choice
private all like prompt*
choice = 0
prompt1 = ' Go '
prompt2 = ' Modi '
prompt3 = ' Sel '
prompt4 = ' Quit '
* WINDOWS
define window MAINTMNU from 22,0 to 24,79 ;
title ' Grid Commands Menu ' ;
double float shadow color scheme 2
* SCREEN
activate window MAINTMNU noshow
* 1 2 3 4
@ 0, 1 say 'Go Modi Sel Quit'
*L
on key label F7 do genhlp with program() && USER HELP
activate window MAINTMNU
@ 0, 1-1 prompt prompt1
@ 0, 4-1 prompt prompt2
@ 0, 9-1 prompt prompt3
@ 0,13-1 prompt prompt4
menu to choice
do case
case choice = 0
release window MAINTMNU
option = 'quit'
case choice = 1
option = 'go'
case choice = 2
option = 'modify'
case choice = 3
option = 'select'
case choice = 4
release window MAINTMNU
option = 'quit'
endcase
deactivate window MAINTMNU
return option
*L
function getsel
on key label F7 do genhlp with sys(18)
do case
case right(sys(16,2),12) = 'CRITTERS.FXP' .and. zoom_num <> '1'
do maintmnu2
case right(sys(16,2),12)='CONTR
ACT.FXP' .or. right(sys(16,2),11)='INVOI
CE.FXP' .or. ;
right(sys(16,2),11)='ANIMA
LS.FXP' .or. right(sys(16,2),08)='BIDS.
FXP' .or. ;
right(sys(16,3),08)='CREW.
FXP' .or. right(sys(16,2),12)='CRITT
ERS.FXP' .or. ;
right(sys(16,3),07)='DHR.F
XP' .or. right(sys(16,3),08)='ACTS.
FXP' .or. ;
right(sys(16,3),10)='AGENC
Y.FXP' .or. right(sys(16,3),08)='JOBS.
FXP' .or. ;
right(sys(16,3),08)='MAPS.
FXP' .or. right(sys(16,3),11)='MEASU
RE.FXP' .or. ;
right(sys(16,3),11)='PAYAB
LE.FXP' .or. right(sys(16,3),10)='PRICE
S.FXP' .or. ;
right(sys(16,3),12)='PRODU
CTN.FXP' .or. right(sys(16,3),10)='PETSH
P.FXP' .or. ;
right(sys(16,3),11)='RECEI
VE.FXP' .or. right(sys(16,3),11)='SUBRE
NT.FXP' .or. ;
right(sys(16,3),08)='USDA.
FXP' .or. right(sys(16,3),12)='HELTH
CRT.FXP' .or. ;
right(sys(16,3),09)='ADOPT
.FXP'
do maintmnu4 && Added menu for 'Go'
case right(sys(16,3),9) = 'SETUP.FXP'
do maintmnu5
otherwise
do maintmnu
endcase
return option
*L
**************************
**********
**********
**********
**********
******
* *
* For CRITTERS the standard maintenance menu is replaced with: *
* *
* MAINTMNU.prg *
* *
= dismsg('Crit error # 1 - Code not activated. (getsel)')
**************************
**********
**********
**********
**********
******
activate screen
set message to 0
dimension actn_pad(8,2)
dimension data_bar(3)
dimension recd_bar(3)
dimension recs_bar(3)
dimension edit_bar(2)
dimension addr_bar(3)
dimension scrn_bar(2)
dimension filt_bar(2)
dimension quit_bar(1)
* define pad in each popup
actn_pad(1,1) = 'DATABASE '
actn_pad(2,1) = 'RECORD '
actn_pad(3,1) = 'RECORDS '
actn_pad(4,1) = 'EDIT '
actn_pad(5,1) = 'ADD'
actn_pad(6,1) = 'SCREEN '
actn_pad(7,1) = 'FILTER '
actn_pad(8,1) = 'QUIT '
actn_pad(1,2) = 'DATABASE '
actn_pad(2,2) = 'RECORD '
actn_pad(3,2) = 'RECORDS '
actn_pad(4,2) = 'EDIT '
actn_pad(5,2) = 'ADD'
actn_pad(6,2) = 'SCREEN '
actn_pad(7,2) = 'FILTER '
actn_pad(8,2) = 'QUIT '
data_bar(1) = 'List '
data_bar(2) = 'Zoom '
data_bar(3) = 'Tally '
* data_bar(4) = 'Quit '
recd_bar(1) = 'Retrieve'
recd_bar(2) = 'Next '
recd_bar(3) = 'Previous'
recs_bar(1) = 'Begin '
recs_bar(2) = 'End '
recs_bar(3) = 'Skip '
edit_bar(1) = 'Modify '
edit_bar(2) = 'Edit Memo'
addr_bar(2) = 'Delete '
addr_bar(3) = 'Copy '
scrn_bar(1) = 'Next Page'
scrn_bar(2) = 'Prev Page'
filt_bar(1) = 'Set Filter '
filt_bar(2) = 'Cancel Filter '
quit_bar(1) = 'Quit '
menu bar actn_pad,8
menu 1,data_bar,3
menu 2,recd_bar,3
menu 3,recs_bar,3
menu 4,edit_bar,2
menu 5,addr_bar,3
menu 6,scrn_bar,2
menu 7,filt_bar,2
menu 8,quit_bar,1
@ 24,0 say space(80)
read menu bar to sele_row,sele_col save
clear
do case
case sele_row = 1
opt_sel = data_bar(sele_col)
case sele_row = 2
opt_sel = recd_bar(sele_col)
case sele_row = 3
opt_sel = recs_bar(sele_col)
case sele_row = 4
opt_sel = edit_bar(sele_col)
case sele_row = 5
opt_sel = addr_bar(sele_col)
case sele_row = 6
opt_sel = scrn_bar(sele_col)
case sele_row = 7
opt_sel = filt_bar(sele_col)
otherwise
opt_sel = 'Quit'
endcase
if opt_sel <> 'Quit'
@ 0,1 say upper(trim(opt_sel)) color w+/n
endif
activate window usr_wndw&page_num
return lower(trim(opt_sel))
*L
function getseli
activate screen
set message to 0
dimension actn_pad(5,2)
dimension data_bar(4)
dimension recd_bar(7)
dimension scrn_bar(2)
dimension filt_bar(2)
dimension quit_bar(1)
* define pad in each popup
actn_pad(1,1) = 'DATABASE '
actn_pad(2,1) = 'RECORD '
actn_pad(3,1) = 'SCREEN '
actn_pad(4,1) = 'FILTER '
actn_pad(5,1) = 'QUIT '
actn_pad(1,2) = 'DATABASE '
actn_pad(2,2) = 'RECORD '
actn_pad(3,2) = 'SCREEN '
actn_pad(4,2) = 'FILTER '
actn_pad(5,2) = 'QUIT '
* data_bar(1) = iif(no_zooms = zoom_no,'\-','Zoom ')
data_bar(1) = 'List '
data_bar(2) = 'Tally '
data_bar(3) = 'Zoom '
data_bar(4) = 'Quit '
recd_bar(1) = 'Retrieve'
recd_bar(2) = 'Next '
recd_bar(3) = 'Previous'
recd_bar(4) = 'Begin '
recd_bar(5) = 'End '
recd_bar(6) = 'Skip '
recd_bar(7) = 'Memo '
scrn_bar(1) = 'Next Page'
scrn_bar(2) = 'Prev Page'
filt_bar(1) = 'Set Filter'
filt_bar(2) = 'Cancel Filter'
quit_bar(1) = 'Quit '
menu bar actn_pad,5
menu 1,data_bar,4
menu 2,recd_bar,7
menu 3,scrn_bar,2
menu 4,filt_bar,2
menu 5,quit_bar,1
@ 24,0 say space(80)
read menu bar to sele_row,sele_col save
clear
do case
case sele_row = 1
opt_sel = data_bar(sele_col)
case sele_row = 2
opt_sel = recd_bar(sele_col)
case sele_row = 3
opt_sel = scrn_bar(sele_col)
case sele_row = 4
opt_sel = filt_bar(sele_col)
otherwise
opt_sel = 'Quit'
endcase
if opt_sel <> 'Quit'
@ 0,1 say upper(trim(opt_sel)) color w+/n
endif
activate window usr_wndw&page_num
return lower(trim(opt_sel))
*L
function getselr
on key label F7 do genhlp with sys(18)
do maintmnu3
return
**************************
**********
**********
**********
**********
******
* *
* For CRITTERS the standard maintenance menu is replaced with: *
* *
* MAINTMNU.prg *
* *
= dismsg('Crit error # 1 - Code not activated. (getselr)')
**************************
**********
**********
**********
**********
******
activate screen
set message to 0
dimension actn_pad(7,2)
dimension prnt_bar(3)
dimension data_bar(3)
dimension recd_bar(2)
dimension recs_bar(3)
dimension scop_bar(3)
dimension filt_bar(2)
dimension quit_bar(1)
* define pad in each popup
actn_pad(1,1) = 'PRINT '
actn_pad(2,1) = 'DATABASE '
actn_pad(3,1) = 'RECORD '
actn_pad(4,1) = 'RECORDS '
actn_pad(5,1) = 'SCOPE '
actn_pad(6,1) = 'FILTER '
actn_pad(7,1) = 'QUIT '
actn_pad(1,2) = 'PRINT '
actn_pad(2,2) = 'DATABASE '
actn_pad(3,2) = 'RECORD '
actn_pad(4,2) = 'RECORDS '
actn_pad(5,2) = 'SCOPE '
actn_pad(6,2) = 'FILTER '
actn_pad(7,2) = 'QUIT '
prnt_bar(1) = 'To Printer '
prnt_bar(2) = 'To File '
prnt_bar(3) = 'To Screen '
* prnt_bar(4) = 'Print Report'
* prnt_bar(5) = 'Status '
* prnt_bar(6) = 'Quit '
data_bar(1) = 'List '
data_bar(2) = 'Tally '
data_bar(3) = 'Status'
recd_bar(1) = 'Next '
recd_bar(2) = 'Previous'
recs_bar(1) = 'Begin '
recs_bar(2) = 'End '
recs_bar(3) = 'Skip '
scop_bar(1) = 'From Record '
scop_bar(2) = 'To Record '
scop_bar(3) = 'Cancel Scope '
filt_bar(1) = 'Set Filter '
filt_bar(2) = 'Cancel Filter '
quit_bar(1) = 'Quit '
menu bar actn_pad,7
menu 1,prnt_bar,3
menu 2,data_bar,3
menu 3,recd_bar,2
menu 4,recs_bar,3
menu 5,scop_bar,3
menu 6,filt_bar,2
menu 7,quit_bar,1
read menu bar to sele_row,sele_col save
clear
do case
case sele_row = 1
opt_sel = prnt_bar(sele_col)
case sele_row = 2
opt_sel = data_bar(sele_col)
case sele_row = 3
opt_sel = recd_bar(sele_col)
case sele_row = 4
opt_sel = recs_bar(sele_col)
case sele_row = 5
opt_sel = scop_bar(sele_col)
case sele_row = 6
opt_sel = filt_bar(sele_col)
otherwise
opt_sel = 'Quit'
endcase
if opt_sel <> 'Quit'
@ 0,1 say upper(trim(opt_sel)) color w+/n
endif
activate window usr_wndw
return lower(trim(opt_sel))
*L
function init_rpt
do case
case outp_dev = 'laser' .or. outp_dev = 'dot'
if outp_dev = 'dot'
set print to LPT1
endif
if outp_dev = 'laser'
if right(sys(16,3),12) <> 'P_LABELS.FXP' && Move to 95. Change this when possible.
if akl_system $ 'Y'
set print to LPT1
else
set print to LPT1
endif
endif
endif
if right(sys(16,3),12) = 'P_LABELS.FXP'
* if group = 1 .or. group = 2 .or. group = 3 Commented because there
* is not more Dot Printer. 4/11/2000 9:57 pm (akl)
* (akl - 12/31/98 4:31 pm)
* I am removing this if statement. I don't really know why I put it in.
* I contradicted myself. See previous IF statement, just below 'laser'.
* After a long time, remove this IF and END statements.
* if right(sys(16,3),12) <> 'P_LABELS.FXP' && Move to 95. Change this when possible.
if akl_system $ 'Y'
set print to LPT1
else
set print to LPT1
endif
* endif
* endif
endif
if right(sys(16,3),11) = 'P_CONTR.FXP' .or. ;
right(sys(16,3),10) = 'P_INVO.FXP' .or. ;
right(sys(16,3),12) = 'P_SUBRNT.FXP'
if akl_system $ 'Y'
set print to LPT1
else
set print to LPT1
endif
endif
do while sys(13) = 'OFFLINE'
@ 0,0 say ' Please set printer on line ...'
read
s_readkey = readkey()
if s_readkey = 268 .or. s_readkey = 12 && Escape was pressed
set device to screen
set console on
set print off
return
endif
enddo
@ 0,0
@ 0,0 say ' Printing - ESC To Stop '
set device to printer
if outp_dev = 'laser'
* Move to 95. Change this when possible. <- Why ? 11/14/01
if right(sys(16,3),12) <> 'P_LABELS.FXP' .and. ;
right(sys(16,5),10) <> 'P_BIDS.FXP'
set console off
set print on
* @ 0,0 say chr(27)+"E" && Initialize the printer
?? chr(27)+"E"
set print off
set console on
endif
endif
case outp_dev = 'file'
@ 0,0
@ 0,0 say ' Printing - ESC To Stop '
set printer to file &rep_file
set device to file &rep_file
case outp_dev = 'screen'
@ 0,0
@ 0,0 say ' Printing - ESC To Stop '
set printer to file gentemp.gtx
set device to file gentemp.gtx
********** akl: Lines added to stop TOF character going into
eject && file as first character. 8/01/98 1:18 am
set printer to
set device to screen
set printer to file gentemp.gtx
set device to file gentemp.gtx
**********
endcase
page_no = 1
line_no = top_margin
set console off
lnk_var = ''
go first_rec
if .not. empty(filter())
filter_str = filter()
if .not. &filter_str
skip
endif
endif
brk_no = 1
brk_num = '1'
done = &done_cond
at_top = .t.
return ''
*L
function maintmnu
* VARIABLES
private choice
private all like prompt*
choice = 0
prompt1 = ' Add '
prompt2 = ' Beg '
prompt3 = ' Copy '
prompt4 = ' Del '
prompt5 = ' End '
prompt6 = ' Filt '
prompt7 = ' List '
prompt8 = ' Modi '
prompt9 = ' Next '
prompt10 = ' Prev '
prompt11 = ' Quit '
prompt12 = ' Ret '
prompt13 = ' Skip '
prompt14 = ' Tally '
prompt15 = ' Zoom '
* WINDOWS
define window MAINTMNU from 22,0 to 24,79 ;
title ' Maintenance Commands Menu ' ;
double float shadow color scheme 2
* SCREEN
* Commented for VFP
IF .F.
activate window MAINTMNU noshow
* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
@ 0, 1 say 'Add Beg Copy Del End Filt List Modi Next Prev Quit Ret Skip Tally Zoom'
ENDIF
* Commented for VFP
*L
* FUNCTION KEY ASSIGNMENT
on key label F7 do genhlp with program() && USER HELP
do case
case prog_name = "CALENDAR"
on key label F2 do mntmnuf with 2
on key label F10 do mntmnuf with 10
otherwise
on key label F2 do mntmnuf with 2
on key label F8 do mntmnuf with 8
on key label F9 do mntmnuf with 9
on key label F10 do mntmnuf with 10
on key label F11 do mntmnuf with 11
endcase
* Added for VFP
do DispMenu
s_choice = mChoice
choice = mChoice
* Commented for VFP
IF .F.
activate window MAINTMNU
@ 0, 1-1 prompt prompt1
@ 0, 5-1 prompt prompt2
@ 0, 9-1 prompt prompt3
@ 0,14-1 prompt prompt4
@ 0,18-1 prompt prompt5
@ 0,22-1 prompt prompt6
@ 0,27-1 prompt prompt7
@ 0,32-1 prompt prompt8
@ 0,37-1 prompt prompt9
@ 0,42-1 prompt prompt10
@ 0,47-1 prompt prompt11
@ 0,52-1 prompt prompt12
@ 0,56-1 prompt prompt13
@ 0,61-1 prompt prompt14
@ 0,67-1 prompt prompt15
menu to choice
ENDIF
* Commented for VFP
do case
case choice = 0
release window MAINTMNU
option = 'quit'
case choice = 1
option = 'add'
case choice = 2
option = 'begin'
case choice = 3
option = 'copy'
case choice = 4
option = 'delete'
case choice = 5
option = 'end'
case choice = 6
define window fil_wndw from 1,50 to 6,77 double color scheme 12
activate window fil_wndw
header = 'Filter'
@ 1,00 say space(13-len(header)/2) + header
@ 3,04 say '<Set> <Cancel>'
@ 3,05 prompt 'Set'
@ 3,16 prompt 'Cancel'
menu to fil_opt
if fil_opt = 1
option = 'set filter'
endif
if fil_opt = 2
option = 'cancel filter'
endif
release window fil_wndw
case choice = 7
option = 'list'
case choice = 8
option = 'modify'
case choice = 9
option = 'next'
case choice = 10
option = 'previous'
case choice = 11
release window MAINTMNU
option = 'quit'
case choice = 12
option = 'retrieve'
case choice = 13
option = 'skip'
case choice = 14
option = 'tally'
case choice = 15
option = 'zoom'
endcase
deactivate window MAINTMNU
return option
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
function mntmnuf
parameter KeyF_no
do case
case KeyF_no = 2
KeyF2 = .T.
case KeyF_no = 5
KeyF5 = .T.
case KeyF_no = 8
KeyF8 = .T.
case KeyF_no = 9
KeyF9 = .T.
case KeyF_no = 10
KeyF10 = .T.
case KeyF_no = 11
KeyF11 = .T.
endcase
s_FkeyRec = recno()
s_prgname = prog_name
keyboard chr(113) plain
return
*L
function maintmnu2
* VARIABLES
private choice
private all like prompt*
choice = 0
prompt1 = ' Modi '
prompt2 = ' Quit '
prompt3 = ' Del '
prompt4 = ' Filt '
* if ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
* (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
prompt5 = ' Primary '
prompt6 = ' Secondary '
* endif
* WINDOWS
define window MAINTMNU from 22,0 to 24,79 ;
title ' Maintenance Commands Menu (Zoom) ' ;
double float shadow color scheme 2
* SCREEN
ON KEY LABEL Alt+F12 SUSPEND
activate window MAINTMNU noshow
* 1 2 3 4 5 6
@ 0, 1 say 'Modi Quit Del Filt Primary Secondary'
if ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
(right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
* 1 2 3
* 12345678901234567890123456
7890123456
@ 0, 1 say 'Modi Quit Del Filt Primary Secondary'
* Prompt: 1 2 3 4 5 6
endif
*L
on key label F2 do mntmnuf22
on key label F7 do genhlp with program() && USER HELP
if ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
(right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF')) on key label PgDn do DispSecn
on key label PgUp do DispPrim
endif
activate window MAINTMNU
@ 0, 1-1 prompt prompt1
@ 0, 6-1 prompt prompt2
@ 0,11-1 prompt prompt3
@ 0,15-1 prompt prompt4
if (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
@ 0,20-1 prompt prompt5
@ 0,28-1 prompt prompt6
endif
menu to choice
do case
case choice = 0
release window MAINTMNU
option = 'quit'
case choice = 1
option = 'modify'
case choice = 2
release window MAINTMNU
option = 'quit'
case choice = 3
option = 'delete'
case choice = 4
define window fil_wndw from 1,50 to 6,77 double color scheme 12
activate window fil_wndw
header = 'Filter'
@ 1,00 say space(13-len(header)/2) + header
@ 3,04 say '<Set> <Cancel>'
@ 3,05 prompt 'Set'
@ 3,16 prompt 'Cancel'
menu to fil_opt
if fil_opt = 1
option = 'set filter'
endif
if fil_opt = 2
option = 'cancel filter'
endif
release window fil_wndw
case choice = 5
option = 'primary'
do DispPrim
case choice = 6
option = 'secondary'
do DispSecn
endcase
deactivate window MAINTMNU
if (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
(right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF')
on key label PgDn
on key label PgUp
endif
return option
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
function mntmnuf22
KeyF2 = .T.
s_prgname = prog_name
keyboard chr(113) plain
return
*L
function maintmnu3
* VARIABLES
private choice
private all like prompt*
choice = 4
prompt1 = ' Beg '
prompt2 = ' End '
prompt3 = ' Filt '
Prompt4 = ' Go '
prompt5 = ' List '
prompt6 = ' Next '
prompt7 = ' Prev '
prompt8 = ' Quit '
prompt9 = ' Ret '
prompt10 = ' Skip '
prompt11 = ' Tally '
prompt12 = ' < '
prompt13 = ' > '
* WINDOWS
define window MAINTMNU from 22,0 to 24,79 ;
title ' Report Commands Menu ' ;
double float shadow color scheme 2
* SCREEN
activate window MAINTMNU noshow
* 1 2 3 4 5 6 7 8 9 10 11 12 13
@ 0, 1 say 'Beg End Filt Go List Next Prev Quit Ret Skip Tally < >'
*L
on key label F7 do genhlp with program() && USER HELP
activate window MAINTMNU
@ 0, 1-1 prompt prompt1
@ 0, 5-1 prompt prompt2
@ 0, 9-1 prompt prompt3
@ 0,14-1 prompt prompt4
@ 0,17-1 prompt prompt5
@ 0,22-1 prompt prompt6
@ 0,27-1 prompt prompt7
@ 0,32-1 prompt prompt8
@ 0,37-1 prompt prompt9
@ 0,41-1 prompt prompt10
@ 0,46-1 prompt prompt11
@ 0,52-1 prompt prompt12
@ 0,54-1 prompt prompt13
menu to choice
do case
case choice = 0
release window MAINTMNU
option = 'quit'
case choice = 1
option = 'begin'
case choice = 2
option = 'end'
case choice = 3
define window fil_wndw from 1,50 to 6,77 double color scheme 12
activate window fil_wndw
header = 'Filter'
@ 1,00 say space(13-len(header)/2) + header
@ 3,04 say '<Set> <Cancel>'
@ 3,05 prompt 'Set'
@ 3,16 prompt 'Cancel'
menu to fil_opt
if fil_opt = 1
option = 'set filter'
endif
if fil_opt = 2
option = 'cancel filter'
endif
release window fil_wndw
case choice = 4
if right(sys(16,3),11) = 'P_CONTR.FXP'
option = 'to printer'
else
* do out_dev && 11/27/93
endif
case choice = 5
option = 'list'
case choice = 6
option = 'next'
case choice = 7
option = 'previous'
case choice = 8
release window MAINTMNU
option = 'quit'
case choice = 9
option = 'retrieve'
case choice = 10
option = 'skip'
case choice = 11
option = 'tally'
case choice = 12
option = 'from record'
case choice = 13
option = 'to record'
endcase
deactivate window MAINTMNU
return option
*L
function maintmnu4
* 10/19 - Added 'menu4' to allow the 'Go' (print) from a maintnenace window.
* This works the same as the Print Menu 'Go' command. (AKL)
* VARIABLES
private choice
private all like prompt*
choice = 0
prompt1 = ' Add '
prompt2 = ' Beg '
prompt3 = ' Copy '
prompt4 = ' Del '
prompt5 = ' End '
prompt6 = ' Filt '
prompt7 = ' Go '
prompt8 = ' List '
prompt9 = ' Modi '
prompt10 = ' Next '
prompt11 = ' Prev '
prompt12 = ' Quit '
prompt13 = ' Ret '
* New Select Command
if right(sys(16,2),12) = 'CRITTERS.FXP' .or. right(sys(16,3),8) = 'USDA.FXP'
prompt14 = ' Sele '
else
prompt14 = ' Skip '
endif
prompt15 = ' Tally '
prompt16 = ' Zoom '
* WINDOWS
define window MAINTMNU from 95,0 to 105,190 ;
title ' Maintenance Commands Menu ' ;
double float shadow color scheme 2 ;
FONT 'Arial Bold', 19
* SCREEN
ON KEY LABEL Alt+F12 SUSPEND
activate window MAINTMNU
* Commented for VFP
IF .F.
if right(sys(16,2),12) = 'CRITTERS.FXP'
* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
@ 0, 1 say 'Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Sele Tally Zoom'
else
@ 0, 1 say 'Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Skip Tally Zoom'
ENDIF
ENDIF
* Commented for VFP
*L
if .not. right(sys(16,3),11) = "ANIMALS.FXP"
on key label F1 do mntmnuf4 with 1
endif
if .not. right(sys(16,3),8) = "BIDS.FXP"
on key label F2 do mntmnuf4 with 2
endif
if .not. right(sys(16,3),12) = "CALENDAR.FXP"
on key label F3 do mntmnuf4 with 3
endif
if .not. right(sys(16,3),12) = "CONTRACT.FXP"
on key label F4 do mntmnuf4 with 4
endif
if .not. right(sys(16,3),12) = "CRITTERS.FXP"
on key label F5 do mntmnuf4 with 5
endif
if .not. right(sys(16,3),11) = "INVOICE.FXP"
on key label F6 do mntmnuf4 with 6
endif
on key label F7 do genhlp with program() && USER HELP
on key label F8 do mntmnuf4 with 8
if .not. right(sys(16,3),10) = "PRICES.FXP"
on key label F9 do mntmnuf4 with 9
endif
on key label F10 do mntmnuf4 with 10
on key label F11 do mntmnuf4 with 11
activate window MAINTMNU
do DispMenu
s_choice = mChoice
choice = mChoice
* Commented for VFP
IF .F.
@ 0, 1-1 prompt prompt1
@ 0, 5-1 prompt prompt2
@ 0, 9-1 prompt prompt3
@ 0,14-1 prompt prompt4
@ 0,18-1 prompt prompt5
@ 0,22-1 prompt prompt6
@ 0,27-1 prompt prompt7
@ 0,30-1 prompt prompt8
@ 0,35-1 prompt prompt9
@ 0,40-1 prompt prompt10
@ 0,45-1 prompt prompt11
@ 0,50-1 prompt prompt12
@ 0,55-1 prompt prompt13
@ 0,59-1 prompt prompt14
@ 0,64-1 prompt prompt15
@ 0,70-1 prompt prompt16
menu to choice
ENDIF
* Commented for VFP
do case
case choice = 0
release window MAINTMNU
option = 'quit'
case choice = 1
option = 'add'
case choice = 2
option = 'begin'
case choice = 3
option = 'copy'
case choice = 4
option = 'delete'
case choice = 5
option = 'end'
case choice = 6
define window fil_wndw from 1,50 to 6,77 double color scheme 12
activate window fil_wndw
header = 'Filter'
@ 1,00 say space(13-len(header)/2) + header
@ 3,04 say '<Set> <Cancel>'
@ 3,05 prompt 'Set'
@ 3,16 prompt 'Cancel'
menu to fil_opt
if fil_opt = 1
option = 'set filter'
endif
if fil_opt = 2
option = 'cancel filter'
endif
release window fil_wndw
case choice = 7
option = 'go'
case choice = 8
option = 'list'
case choice = 9
option = 'modify'
case choice = 10
option = 'next'
case choice = 11
option = 'previous'
case choice = 12
release window MAINTMNU
option = 'quit'
case choice = 13
option = 'retrieve'
case choice = 14
option = 'skip'
case choice = 15
option = 'tally'
case choice = 16
option = 'zoom'
endcase
deac wind MAINTMNU
rele wind MAINTMNU
deac wind MAINTMNU4
rele wind MAINTMNU4
rele memo like prompt*
return option
*L
* Added for VFP
procedure DispMenu
PUBLIC mCHOICE, mGET, cCHOICE, cCHOICES
STORE 0 TO mCHOICE, mGET
STORE "" TO cCHOICE, cCHOICES
* nCOL = ROUND(WCOLS()/2,0) - 19
* Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Skip Tally Zoom'
nPad = 3
nROW = 0
* 1
nCOL = 0
DO GET WITH nROW,nCOL, "\<Add"
nCOL = nCol + 3 + nPad
DO GET WITH nROW,nCOL, "\<Beg"
nCOL = nCol + 3 + nPad
DO GET WITH nROW,nCOL, "\<Copy"
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Del"
* 5
nCOL = nCol + 3 + nPad
DO GET WITH nROW,nCOL, "\<End"
nCOL = nCol + 3 + nPad
DO GET WITH nROW,nCOL, "\<Filt"
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Go"
nCOL = nCol + 2 + nPad
DO GET WITH nROW,nCOL, "\<List"
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Modi"
* 10
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Next"
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Prev"
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Quit"
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Ret"
nCOL = nCol + 3 + nPad
DO GET WITH nROW,nCOL, "\<Skip"
* 15
nCOL = nCol + 4 + nPad
DO GET WITH nROW,nCOL, "\<Tally"
nCOL = nCol + 5 + nPad
DO GET WITH nROW,nCOL, "\<Zoom"
* Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Skip Tally Zoom'
cCHOICES = cCHOICES + "12Q"
cCHOICE = fnCHOICE(cCHOICES, "Q")
FUNCTION fnCUROBJ
PARAMETERS mCHOICE
mCHOICE = _CUROBJ
RETURN .T.
PROCEDURE GET
PARAMETERS nROW, nCOL, cFUNC, bSKIP
nSIZE2 = LEN(STRTRAN(cFUNC,"\<")) + 2
@ nROW,nCOL GET mGET FUNCTION "* "+IIF(bSKIP,"\\","")+cFUNC
;
VALID fnCUROBJ(@mCHOICE)
* @ nROW,nCOL GET mGET FUNCTION "* "+IIF(bSKIP,"\\","")+cFUNC
;
VALID fnCUROBJ(@mCHOICE)
* DEFAULT 1 SIZE 1,nSIZE2 VALID fnCUROBJ(@mCHOICE)
* Note: nSIZE2 is not used any other place.
RETURN
FUNCTION fnCHOICE
PARAMETERS cCHOICES, cDEF
READ CYCLE OBJECT mCHOICE
mCHOICE = IIF(LASTKEY()=27,AT(cDEF,c
CHOICES),m
CHOICE)
RETURN IIF(mCHOICE > 0,SUBSTR(cCHOICES,mCHOICE,
1),"")
* End - Added for VFP
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
function mntmnuf4
parameter KeyF_no
* suspend
do case
case KeyF_no = 1
KeyF1 = .T.
case KeyF_no = 2
KeyF2 = .T.
case KeyF_no = 3
KeyF3 = .T.
case KeyF_no = 4
KeyF4 = .T.
case KeyF_no = 5
KeyF5 = .T.
case KeyF_no = 6
KeyF6 = .T.
case KeyF_no = 8
KeyF8 = .T.
case KeyF_no = 9
KeyF9 = .T.
case KeyF_no = 10
KeyF10 = .T.
case KeyF_no = 11
KeyF11 = .T.
endcase
s_FkeyRec = recno()
s_prgname = prog_name
if prog_name = "PAYABLE" and alias() = "PAYDETL"
s_FkeyPag = 2
select payable
s_FkyMRec = recno()
endif
keyboard chr(113) plain
return
*L
function maintmnu5
* VARIABLES
private choice
private all like prompt*
choice = 0
prompt1 = ' Quit '
prompt2 = ' Modi '
* WINDOWS
define window MAINTMNU from 22,0 to 24,79 ;
title ' Maintenance Commands Menu ' ;
double float shadow color scheme 2
* SCREEN
ON KEY LABEL Alt+F12 SUSPEND
activate window MAINTMNU noshow
* 1 2
@ 0, 1 say 'Quit Modi'
*L
on key label F7 do genhlp with program() && USER HELP
activate window MAINTMNU
@ 0, 1-1 prompt prompt1
@ 0, 6-1 prompt prompt2
menu to choice
do case
case choice = 0
release window MAINTMNU
option = 'quit'
case choice = 1
release window MAINTMNU
option = 'quit'
case choice = 2
option = 'modify'
endcase
deactivate window MAINTMNU
return option
*L
function out_dev
define window fil_wndw from 1,40 to 6,77 double color scheme 12
activate window fil_wndw
header = 'Print'
@ 1,00 say space(19-len(header)/2) + header
@ 3,04 say '<Screen> <Laser> <File>'
@ 3,05 prompt 'Screen'
@ 3,16 prompt 'Laser'
@ 3,26 prompt 'File'
menu to fil_opt
if fil_opt = 1
option = 'to screen'
endif
if fil_opt = 2
option = 'to laser'
endif
if fil_opt = 3
option = 'to file'
endif
release window fil_wndw
return ''
*L
function restenv
for i=1 to no_pages
i_str = str(i,1)
if wexist('usr_wndw'+i_str)
release window usr_wndw&i_str
endif
endfor
if wexist('maintmnu')
release window maintmnu
endif
acti screen
@ 0,62 say space(7)
@ 0,70 say space(9)
show window all
close databases
return ''
*L
function restenvr
release window usr_wndw
show window all
close databases
return ''
*L
function save_rec
********** akl: First, check the spelling of the record 3/19/96 1:55 am
if prog_name = "BIDS" .or. prog_name = "CONTRACT" .or. ;
prog_name = "INVOICE" .or. prog_name = "SUBRENT" .or. ;
prog_name = "MAPS" .or. prog_name = "HELTHCRT"
do SpellChk with "Rec" && Record (Rec) or Field (Fld)
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
endif
**********
if confirm('Save Record')
append blank
if right(sys(16,3),12) = "CONTRACT.FXP"
sele 2
append blank
sele 3
append blank
sele 1
endif
= rlock()
********** akl: DHR - Field USDA.NAME 7/23/96 12:37 am
if prog_name = "DHR"
usda = usda.usda
endif
**********
gather memvar memo
if right(sys(16,3),12) = "CONTRACT.FXP"
sele 2
gather memvar
sele 3
gather memvar
sele 1
endif
unlock
* reset the filter
if .not. empty(filter())
* Check if record matches filter
record_no = recno()
skip
skip -1
if recno() <> record_no && No match
= _begin()
if &at_eof && Remove filter
set filter to
go record_no
endif
endif
endif
return .t.
endif
return .f.
*L
procedure sav_wind && linked to F10 by gen_hlp
parameter w_name
replace brow with wlrow(w_name), bcol with wlcol(w_name), ;
erow with wlrow(w_name) + wrows(w_name) + 1, ;
ecol with wlcol(w_name) + wcols(w_name) + 1
keyboard chr(23) && Ctrl-W to Exit window with save
return
*L
function set_bndry
* Set boundaries
skip -1
if bof()
top_mark = 0
else
top_mark = recno()
skip 1
endif
skip 1
if eof()
bot_mark = -1
else
bot_mark = recno()
endif
skip -1
return ''
*L
function stp_prnt
on escape
zoom_no = 1
zoom_num = '1'
brk_no = 1
brk_num = '1'
select 1
done_cond = '&ndx_exp>last_val.or.eof(
)'
return to _print
*L
function val_fil
parameters n_vald_fld, ref_fld, vald_alias, getpos, fld_size
vald_fld = &n_vald_fld
if .f.
set view off
acti screen
clear
for i = 1 to 25
?
next
?
? "Parameters:"
? "n_vald_fld >"+n_vald_fld+"<"
? "vald_fld >"+vald_fld+"<"
? "ref_fld = "+ref_fld
? "vald_alias = "+vald_alias
? "getpos = "
?? getpos
? "fld_size = "
?? fld_size
endif
private at_eof,at_bof,record_no
set notify off
is_valid = .f.
at_eof = 'eof()'
at_bof = 'bof()'
save_alias = alias()
empty_field = .F.
select &vald_alias
do case
case type("vald_fld") = 'D'
srch_str = str(year(m->vald_fld),4) + str(month(vald_fld),2)+str
(day(vald_
fld),2)
case type("vald_fld") = 'N'
srch_str = str(vald_fld,fld_size)
if vald_fld = 0
empty_field = .T.
endif
otherwise
srch_str = vald_fld
if len(trim(vald_fld)) = 0
empty_field = .T.
endif
endcase
if type("vald_fld") = 'N'
locate for &ref_fld = val(srch_str)
else
seek srch_str
if .f.
?
? "Seeking to >"+srch_str+"<"
if found()
? "Found"
else
? "NOT found"
endif
endif
endif
if .f.
?
? "eof() = "
?? eof()
endif
if .not. eof() && found
is_valid = .t.
else
if empty_field
if right(sys(16,3),12) = "CRITTERS.FXP"
is_valid = .f.
else
is_valid = .t.
endif
else
set near on
seek srch_str
set near off
leftpos = iif(getpos > 40,4,43)
define window brws_wndw from 6,leftpos to 15,leftpos+30 ;
system zoom float grow close shadow color scheme 10
on key label ENTER keyboard chr(23)
activate window brws_wndw noshow
browse last noappend nomodify nodelete window brws_wndw
release window brws_wndw
if .f.
set view off
acti screen
clear
for i = 1 to 25
?
next
? ">"+type(ref_fld)+"<"
? ">"+ref_fld+"<"
? ">"+&ref_fld+"<"
endif
do case
case type("ref_fld") = 'C'
if .f.
?
? "Field is CHARACTER"
? "type(ref_fld) = >"+type(ref_fld)+"<"
? "ref_fld = >"+ref_fld+"<"
? "&ref_fld = >"+&ref_fld+"<"
on key label ENTER
* suspend
endif
* keyboard &ref_fld
do case
case n_vald_fld = "m->name"
name = &ref_fld
show gets
is_valid = .t.
case n_vald_fld = "m->anml_name"
anml_name = &ref_fld
show gets
is_valid = .t.
case n_vald_fld = "m->crit_name"
crit_name = &ref_fld
show gets
is_valid = .t.
case n_vald_fld = "m->job_no"
job_no = &ref_fld
show gets
is_valid = .t.
case n_vald_fld = "m->map_no"
map_no = &ref_fld
show gets
is_valid = .t.
endcase
case type(ref_fld) = 'D'
keyboard dtoc(&ref_fld)
case type(ref_fld) = 'N'
keyboard ltrim(str(&ref_fld))
endcase
on key label ENTER && Re-assigns orginal value
endif
endif
if .f.
?
? ">"+type(ref_fld)+"<"
? ">"+ref_fld+"<"
? ">"+&ref_fld+"<"
? "is_valid="
?? is_valid
endif
select &save_alias
set notify off
return is_valid
*L
function orig_val_fil
parameters vald_fld, ref_fld, vald_alias, getpos, fld_size
set view off
acti screen
clear
for i = 1 to 25
?
next
?
? "Parameters:"
? "vald_fld >"+vald_fld+"<"
? "ref_fld = "+ref_fld
? "vald_alias = "+vald_alias
? "getpos = "
?? getpos
? "fld_size = "
?? fld_size
private at_eof,at_bof,record_no
set notify off
is_valid = .f.
at_eof = 'eof()'
at_bof = 'bof()'
save_alias = alias()
empty_field = .F.
select &vald_alias
do case
case type("vald_fld") = 'D'
srch_str = str(year(m->vald_fld),4) + str(month(vald_fld),2)+str
(day(vald_
fld),2)
case type("vald_fld") = 'N'
srch_str = str(vald_fld,fld_size)
if vald_fld = 0
empty_field = .T.
endif
otherwise
srch_str = vald_fld
if len(trim(vald_fld)) = 0
empty_field = .T.
endif
endcase
if type("vald_fld") = 'N'
locate for &ref_fld = val(srch_str)
else
seek srch_str
?
? "Seeking to >"+srch_str+"<"
if found()
? "Found"
else
? "NOT found"
endif
endif
?
? "eof() = "
?? eof()
if .not. eof() && found
is_valid = .t.
else
if empty_field
if right(sys(16,3),12) = "CRITTERS.FXP"
is_valid = .f.
else
is_valid = .t.
endif
else
set near on
seek srch_str
set near off
leftpos = iif(getpos > 40,4,43)
define window brws_wndw from 6,leftpos to 15,leftpos+30 ;
system zoom float grow close shadow color scheme 10
on key label ENTER keyboard chr(23)
activate window brws_wndw noshow
browse last noappend nomodify nodelete window brws_wndw
release window brws_wndw
*if .f.
set view off
acti screen
clear
for i = 1 to 25
?
next
? ">"+type(ref_fld)+"<"
? ">"+ref_fld+"<"
? ">"+&ref_fld+"<"
?
if chrsaw()
? "Keyboard buffer is NOT empty"
else
? "Keyboard buffer is empty"
endif
*endif
do case
case type(ref_fld) = 'C'
?
? "Field is CHARACTER"
? "type(ref_fld) = >"+type(ref_fld)+"<"
? "ref_fld = >"+ref_fld+"<"
? "&ref_fld = >"+&ref_fld+"<"
keyboard &ref_fld && plain
case type(ref_fld) = 'D'
keyboard dtoc(&ref_fld)
case type(ref_fld) = 'N'
keyboard ltrim(str(&ref_fld))
endcase
*is_valid = .t.
on key label ENTER && Re-assigns orginal value
endif
endif
if .f.
?
if chrsaw()
? "Keyboard buffer is NOT empty."
? " Buffer contains: >"
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? chr(inkey())
?? "<"
else
? "Keyboard buffer is empty"
endif
endif
?
? ">"+type(ref_fld)+"<"
? ">"+ref_fld+"<"
? ">"+&ref_fld+"<"
? "is_valid="
?? is_valid
* suspend
*endif
select &save_alias
set notify off
return is_valid
*L
function var_get
parameters getcond,fld_usg
* Left Arrow Check
* This function was created because Donna wanted to hit the Left Arrow Key
* and have the cursor go to the last field of the previous screen. At this
* it is set up for Contracts. 10/05/99 10:19 am
if right(sys(16,2),12) = "CONTRACT.FXP"
if page_no = 1
if LArrow = .T.
LArrow = .F.
NewOnum = 28
_curobj = NewOnum
endif
endif
endif
akl=.F.
if right(sys(16,2),11) = "INVOICE.FXP" .and. right(sys(16,7),12) = "FS_SPELL.FXP"
akl=.T.
activate window spell_win
endif
return &getcond
*L
function x_zoom
zoom_num = str(zoom_no,1)
at_bof = at_bof&zoom_num
at_eof = at_eof&zoom_num
ndx_var = ndx_var&zoom_num
first_page = val(substr(page_seq&zoom_n
um,1,1))
last_page = val(substr(page_seq&zoom_n
um,len(pag
e_seq&zoom
_num),1))
* If a new page, display new screen
if first_page <> page_no
page_no = first_page
do disscr
redisp_fld = .t.
endif
* Select new Zoom area, set new top and bottom marks
select &zoom_num
record_no = recno()
if zoom_no = 1 .or. reccount() = 0
top_mark = 0
bot_mark = -1
else
lnk_var = lnk_var&zoom_num
seek &lnk_var
if .not. bof()
skip -1
endif
if bof()
top_mark = 0
else
top_mark = recno()
endif
if .not. eof()
skip
endif
bot_mark = -2 && to be determined in funcion _end
endif zoom_no = 1
return ''
function y2kfix1
parameter FieldName
* Calling Syntax: valid y2kfix1(sys(18))
MoValu = str(month(m.&FieldName),2,
0)
DyValu = str(day(m.&FieldName),2,0)
YrValu = str(year(m.&FieldName),4,0
)
YrRHT = right(YrValu,2)
if val(YrRHT) >= 80 .and. val(YrRHT) <= 99
YrLFT = "19"
else
YrLFT = "20"
endif
YrValu = YrLFT+YrRHT
&FieldName = ctod(MoValu+"/"+DyValu+"/"
+YrValu)
return .T.
*L
**************************
**********
**********
**********
**********
**********
***
* *
* The rest of this library will be for the new scrolling field screens with *
* the ability to <BackTab> from the first field of the current screen to the *
* last field of the previous screen, given that the current screen is not the *
* first screen. In which the <BackTab> key is ignored. The <Tab> key has not *
* been changed in any way. Scrolling - Multi Edit Window 10/16/95 2:07 am *
* Added <BackTab> - 10/29/95 2:10 am *
* *
**************************
**********
**********
**********
**********
**********
***
function _newadd
if zoom_no = 1
go bottom
endif
do str_empty
do default
= newadd_rec()
return ''
*=========================
==========
==========
==========
==========
==========
==
function _newcopy
= newadd_rec()
return ''
*L
function _newmodify
abort = .f.
on key label PGUP do NewPageUp
on key label PGDN do NewPageDn
if modify_key
getcond = " 'G' $ fld_usg"
else
getcond = " 'G' $ fld_usg .and. .not. 'K' $ fld_usg"
endif
getcond = "'G'$fld_usg"
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
read
s_lastkey = lastkey()
* CLEANUP
on key label PGUP
on key label PGDN
set message to
set stat off && This had to be put in because the SET
&& STAT OFF alone did not erase the message
if akl_test $ 'Yy'
set stat on
set esca on
endif
if s_lastkey = 27 && Esc
abort = .t.
return ''
endif
* Check for duplicate
s_recno = recno()
seek &ndx_var
if .not. &at_eof .and. .not. allow_dup&zoom_num
= dismsg(chr(7) + 'Duplicate record not allowed')
abort = .t.
return
endif
goto s_recno
* Display lookup fields and computed variables
do lookup
do calcul with .t.
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".t."
do getfldB with ".t."
else
do getfld with ".t."
endif
clear gets
********** akl: First, check the spelling of the record 3/19/96 1:55 am
if prog_name = "BIDS" .or. prog_name = "CONTRACT" .or. ;
prog_name = "INVOICE" .or. prog_name = "SUBRENT" .or. ;
prog_name = "MAPS" .or. prog_name = "HELTHCRT"
do SpellChk with "Rec" && Record (Rec) or Field (Fld)
if right(sys(16,3),8) = "USDA.FXP"
do getfldA with ".f."
do getfldB with ".f."
else
do getfld with ".f."
endif
endif
**********
do calcul with .t.
if .not. abort
if confirm('Save Record')
save_rec = .T.
gather memvar memo
if right(sys(16,3),12) = "CONTRACT.FXP"
sele 2
gather memvar
sele 3
gather memvar
sele 1
endif
endif
endif
return ''
*L
function NewPageDn
s_lastkey = lastkey()
do case
case _curobj < 20
_curobj = 20
case _curobj = 20
_curobj = 21
case _curobj = 21
_curobj = 22
endcase
return
*=========================
==========
==========
==========
==========
=========
function NewPageUp
s_lastkey = lastkey()
do case
case _curobj = 20
_curobj = 1
case _curobj = 21
_curobj = 20
case _curobj = 22
_curobj = 21
endcase
return
*L
function SpellChk
parameters CheckType
* Check spelling
* To check spelling, one field at a time, put "VALID SPELLCHK('Fld')"
* into the "@ ... GET" statement.
set clock off
if CheckType = "Fld" && This will check a field as it is exited.
FieldToCheck = VarRead()
FieldText = m.&FieldToCheck
if .not. empty(trim(FieldText))
do fs_modal with .T., .F.
endif
endif
if CheckType = "Rec" && This will check ALL fields in a screen.
bu_cancel = 0 && If user cancles, FS_SPELL() will set it to 1.
field_max = FCOUNT() && Number of fields in the current record.
FOR field_num = 1 TO field_max && Loop through all screen fields.
IF TYPE(FIELD(field_num)) $ "MC" && If memo or character field.
fld_name = FIELD(field_num) && Determine field's name.
fld_2check = m.&fld_name && Extract field's contents.
IF len(trim(fld_2check)) > 1 && Need 2 letters to work with.
* ÚÄÄÄÄLeave blank since only used to pass in file names.
* ³ ÚÄÄÄÄPass in copy of memo to be checked.
* ³ ³ ÚÄÄÄÄDon't stop after each memo.
* v v v
= FS_SPELL("", @fld_2check, .F.) && Call Foxspell Checker.
m.&fld_name = fld_2check
ENDIF
ENDIF
IF bu_cancel = 1 && If user canceled, then exit.
WAIT WINDOW "Quit spell checking!"
EXIT
ENDIF
NEXT
endif
s_sel = select(0)
select WORDS1
use
select WORDS2
use
select WORDS3
use
select (s_sel)
set clock on
return .T.
* EOF GENLBR.PRG
Answer : Fox9 - Having a problem getting color to work using @ ... Gets and @ ... Say
procedure sp_FinalDefCountList
requires a
SET NOCOUNT ON at the start
if @finalstring needs to sometimes be returned , then you need to set it up as an output parameter instead.
the initial trigger is very poorly written in that it doesn't cater for multiple updates...
>>SET @CaseID = (Select tblLinkDefendantCounts.Cas
eID from tblLinkDefendantCounts, INSERTED WHERE tblLinkDefendantCounts.Def
endantCoun
tsID = INSERTED.DefendantCountsID
)
>>EXEC sp_UpdateDefCaseCounts @CaseID
needs to be processed in a loop.
Random Solutions
How do I parse a KML with VB.NET
iPhone 4 xcode "Line Drawing app"
windows 2008
Union query
lpr print server issue
quick question
Download Manager
How do I fix odbc call failed #1062 under access vba with a mysql backend?
Progress Bar Bound to Timer
Outlook can not verify valid mailbox