THE FoxPRO FAQ
PART 4b: MORE TIPS etc
Comment and suggestions are invited.
DISCLAIMER: Most of the information in this FAQ is unsupported
by Microsoft. No guarantees of any sort are made about the information
contained in this FAQ. If you use something you find here and wind up
clobbering all your data, it's your problem solely.
INDEX
DIAGONAL LINES IN FOXPRO/WINDOWS (Doug Blank)
IT is sad but true: you cannot draw a diagonal line in FoxPro. I did try
dropping down to the windows API, and you can in fact draw any thing
that you want in the fox window --- but Fox doesn't "know" about it.
Therefore, if you close the window and reopen it your line is gone.
Any time that you cover your line, it won't be redrawn.
So, I finally ended up with the solution below. It does a pretty good
job on arbitrary lines. You may have to adjust x and y dotsize. These
parameters exist because of translation problems from real-valued
points to screen coordinates (welcome to the world of GUI's!)
To use, call with:
=drawline(1,5,11,30,.T.) && to produce a color line from @ 1,5 to 11,30 or
=drawline(1,5,11,30) && to produce a black line
Using this method, you can draw circles, splines, etc. Put the
function below in your program, or comment out the first line and
place in a file named DRAWLINE.PRG. It's not real fast nor smooth,
but it works. You probably can't make the line any thinner due to
related problems with real-valued vs. screen coordinates, so pensize
and penlength probaly can't be changed. You can change the RGB()
funtion to make any colors you want, or even add a CASE statement to
do them all, add shadows, etc.
FUNCTION drawline
PARAMETER x1,y1,x2,y2,color
PRIVATE x,y,B,slope
#DEFINE xdotsize (.2)
#DEFINE ydotsize (.5)
#DEFINE pensize (3)
#DEFINE penlen (.7)
IF m.y1 = m.y2 && vertical line
IF x1 < x2
IF color
@m.x1,m.y1 to m.x2,m.y1 pen pensize color ;
RGB(0,255,0,255,255,255) style "T"
ELSE
@m.x1,m.y1 to m.x2,m.y1 pen pensize color ;
RGB(255,0,255,255,255,255) style "T"
ENDIF
ELSE
IF color
@m.x2,m.y1 to m.x1,m.y1 pen pensize color ;
RGB(0,255,0,255,255,255) style "T"
ELSE
@m.x2,m.y1 to m.x1,m.y1 pen pensize color ;
RGB(255,0,255,255,255,255) style "T"
ENDIF
ENDIF
ELSE
m.slope = (m.x1 - m.x2)/(m.y1 - m.y2)
m.B = m.x1 - (m.slope * m.y1)
IF ABS((m.x1 - m.x2) / xdotsize) > ABS((m.y1 - m.y2) / ;
ydotsize)
FOR m.x = m.x1 TO m.x2 STEP xdotsize * ;
IIF( m.x1 > m.x2, -1, 1)
m.y = (m.x - m.B) / m.slope
IF color
@m.x,m.y to m.x,m.y+penlen pen ;
pensize color RGB(0,255,0,255,255,255) ;
style "T"
ELSE
@m.x,m.y to m.x,m.y+penlen pen ;
pensize color RGB(255,0,255,255,255,255) ;
style "T"
ENDIF
ENDFOR
ELSE
FOR m.y = m.y1 TO m.y2 STEP ydotsize * IIF( m.y1 > ;
m.y2, -1, 1)
m.x = (m.slope * m.y) + m.B
IF color
@m.x,m.y to m.x,m.y+penlen pen ;
pensize color RGB(0,255,0,255,255,255);
style "T"
ELSE
@m.x,m.y to m.x,m.y+penlen pen ;
pensize color RGB(255,0,255,255,255,255) ;
style "T"
ENDIF
ENDFOR
ENDIF
ENDIF
RETURN
Return to Index
SAVE STRUCTURES FOR TABLES IN A DIRECTORY
Read all the table structures for files in a given directory and
output them to a text file.:
SET TALK OFF
CLEAR ALL
PRIVATE ALL LIKE l*
*prompt the user for a directory
lDirectory = GETDIR(CURDIR(), "Select a directory containing tables:")
* make sure they selected one
IF !EMPTY(lDirectory)
* *read all of the names of tables into an array
lHits = ADIR(lTables, lDirectory + "*.DBF")
* *make sure we have found some tables
IF lHits == 0
WAIT WINDOW "No tables found in " + lDirectory
ELSE
WAIT WINDOW "Processing tables..." NOWAIT
SELECT 0
* *we need some temporary work space
CREATE CURSOR work (FileName C(8), StrucList M(10))
* *process each table in the array
FOR lCount = 1 TO lHits
* *get a temporary file name
lTempFile = SYS(3) + ".TXT"
* *build the full path to the file, then open the table
lFileSpec = lDirectory + lTables[lCount, 1]
SELECT 0
USE (lFileSpec)
* *write the structure info out to the temporary file
DISPLAY STRUCTURE NOCONSOLE TO FILE (lTempFile)
* *add a new record for this table
INSERT INTO work (FileName) VALUES (lTables[lCount, 1])
* *we no longer need the table open
USE
SELECT work
* *load the temporary file into the memo field
APPEND MEMO StrucList FROM (lTempFile)
* *ensure we clean up the temporary file
DELETE FILE (lTempFile)
* *any further processing goes here, for instance one might
* *want to parse out useful info into separate fields
ENDFOR
GO TOP
* *this is the easiest way to write to a text file
SET TEXTMERGE ON
SET TEXTMERGE TO struc.txt NOSHOW
\Table Structure Listing
\-----------------------
* *for each record, output the structure memo
SCAN
\<>
ENDSCAN
SET TEXTMERGE TO
SET TEXTMERGE OFF
USE
WAIT WINDOW ALLTRIM(STR(lHits)) + " tables processed!" NOWAIT
ENDIF
ENDIF
RETURN
Return to Index
SAVE INDEXES AND FILTERS FOR TABLES IN A DIRECTORY (Eli Linkov)
*INDEXSAV.PRG
* this program can be used to set up a .DBF in the system directory of a
* project which holds the project's table names and the index (and filter,
* if any names of each table. The table name is DBINFO.DBF.
* The structure of the table is
* field dbfname 12 chars
* field infomemo memo field
*
* The memo field will hold the index name, index expression
* and filter, if any, as indexname/expression%filter
* on one line of the memo per index
*
* This program should be run to create the dbfinfo table and ass'd memo
* once the system is ready for installation.
* The table/memo should be installed at the user site in the "system"
* directory, together with an EXE version of the INDEXMAK program.
* The INDEXMAK.EXE should only be available via the file manager to
* the system caretaker, and should not have an program manager icon
* associated with it.
* To recover indexing on the project tables, INDEXMAK.EXE should be run
* if the indexes are suspected of being corrupted.
CLOSE DATABASES
* the next 2 lines should be amended to suit the project path names
datapath = "C:\sxc\sxcbuild\" && where the indexed tables are
workpath = "C:\sxc\sxcmaint\" && where the system EXE is
IF NOT FILE(workpath + "dbfinfo.dbf")
SET DEFAULT TO (workpath)
* create the table to be used by INDEXMAK.PRG
CREATE TABLE dbfinfo (dbfname C(12), infomemo m)
ENDIF
SET DEFAULT TO &datapath
DIMENSION filelist(1)
=ADIR(filelist,"*.dbf")
CLOSE DATA
SET DEFAULT TO &workpath
SELECT 0
USE dbfinfo EXCLUSIVE
SET SAFETY OFF
ZAP
SET SAFETY ON
APPEND FROM ARRAY filelist
RELEASE filelist
GO TOP
SET DEFAULT TO &datapath
SCAN
TEXT = ALLTRIM(dbfname)
IF TEXT = "DBFINFO.DBF"
ELSE
REPLACE dbfname WITH LEFT(TEXT,LEN(TEXT) - 4)
SELECT 0
USE (dbfinfo.dbfname) EXCLUSIVE
DIMENSION taglist(1,3)
indexstr = ""
arrct = 1
DO WHILE NOT EMPTY(TAG(arrct))
taglist(arrct,1) = TAG(arrct) && the tag name
taglist(arrct,2) = SYS(14,arrct) && the tag expression
taglist(arrct,3) = sys(2021,arrct) && the tag filter (if any)
arrct = arrct + 1
DIMENSION taglist(arrct,3)
ENDDO
SELECT dbfinfo
FOR x = 1 TO arrct - 1
indexstr=indexstr+taglist(x,1)+"/"+taglist(x,2);
+"%"+taglist(x,3)+CHR(13)
ENDFOR
REPLACE infomemo WITH indexstr
ENDIF
ENDSCAN
SET DEFAULT TO &workpath
CLOSE DATA
*INDEXMAK.PRG
* This program is used to recover indexes when the project tables are
* suspected of being corrupted. It uses the DBFINFO.DBF table produced
* by the program INDEXSAV.PRG to recover the index names, expressions and
* filters and re-applies this information to the tables.
*
* This program should be installed at the user site as an EXE file, only
* useable via the file manager. It should not have an icon associated
* with it for use via the program manager.
*
* the table was set up by indexsav.prg in the system directory
* fields - dbfname C 12
* - infomemo M
CLOSE DATABASES
* set this path for data tables & system EXE
datapath = "C:\sxc\sxcbuild\"
workpath = "c:\sxc\sxcmaint\"
SET DEFAULT TO &workpath
SELECT 0
USE dbfinfo EXCLUSIVE
SET SAFETY OFF
GO TOP
SET DEFAULT TO &datapath
SCAN
TEXT = ALLTRIM(dbfname)
IF TEXT = "DBFINFO.DBF"
ELSE
SELECT 0
USE (dbfinfo.dbfname) EXCLUSIVE
DELETE TAG ALL
memct = 1
fred = dbfinfo.infomemo
IF NOT EMPTY(fred)
DO WHILE NOT EMPTY(MLINE(dbfinfo.infomemo,memct))
fred = ALLTRIM(MLINE(dbfinfo.infomemo,memct))
colno1 = AT("/",fred)
colno2 = AT("%",fred)
tagfield = LEFT(fred,colno1 - 1) && tag name
tagname = SUBSTR(fred,colno1 + 1,;
(colno2 - colno1 - 1)) && tag expression
tagfilt = alltrim(RIGHT(fred,LEN(fred) - colno2)) && tag filter
IF tagfilt <> ""
INDEX ON &tagfield FOR &tagfilt TAG &tagname
ELSE
INDEX ON &tagfield TAG &tagname
ENDIF
memct = memct + 1
ENDDO
ENDIF
ENDIF
ENDSCAN
SET DEFAULT TO &workpath
SET SAFETY ON
CLOSE DATA
Return to Index
PASSWORDS - EXAMPLE1 (Brian Copeland)
This example is a quick and dirty demo of how to use inkey() in a
procedure to input the password and echo '*'s to the field.
CLEAR
mpassword=''
mshowpass=''
@ 10,10 GET mshowpass DEFAULT '' SIZE 1,10 WHEN checkpass()
READ
PROCEDURE checkpass
DO WHILE .T.
mkey=INKEY(0)
DO CASE
CASE mkey=13
* enter/return
EXIT
CASE BETWEEN(mkey,48,57)
* is a number
mpassword=mpassword+CHR(mkey)
mshowpass = mshowpass+'*'
CASE BETWEEN(mkey,97,122)
* is lowercase letter
mpassword=mpassword+CHR(mkey)
mshowpass = mshowpass+'*'
CASE BETWEEN(mkey,65,90)
* is uppercase letter
mpassword=mpassword+CHR(mkey)
mshowpass = mshowpass+'*'
CASE mkey=127
* backspace
mpassword=LEFT(mpassword,LEN(mpassword)-1)
mshowpass=LEFT(mshowpass,LEN(mshowpass)-1)
ENDCASE
SHOW GETS
ENDDO
CLEAR READ
* routine to check password
* if password ok return .t.
* otherwise return .f. or invoke security
* procedure
RETURN
Return to Index
PASSWORDS - EXAMPLE2 (R. Premkumar)
* n = max length of password which you want to allow
* c = character string for display (instead of stars, you may want "Good
* Morning" to appear progressively as the user types in the password
* t = title of the window
PROCEDURE password
PARAMETERS N,C,t
PRIVATE ALL
IF (PARA()>0 AND TYPE('n')#'N') OR (PARA()>1 AND TYPE('c')#'C') OR ;
(PARA()>2 AND TYPE('t')#'C')
WAIT WINDOW NOWAIT ;
'Usage : ? PASSWORD( [ length [, display string [, title ]]] )'
*In a program you can call this function as, say: a=password()
RETURN
ENDIF
IF PARA()=0
N=7
* Default length of password. Used when you call the function
* without any parameters
ENDIF
IF PARA()<3
t='ENTER PASSWORD' &&Default title
ENDIF
DEFINE WINDOW paswrd DOUBLE TITLE t ;
FROM 11,IIF(MAX(N,LEN(t))<10,30,CEIL(35-MAX(N,LEN(t))/2)) ;
TO 13,IIF(MAX(N,LEN(t))<10,50,CEIL(45+MAX(N,LEN(t))/2))
ACTIVATE WINDOW paswrd
SET COLOR TO x/N
cd=IIF(PARA()<2,REPL('*',N),PADR(C,N,'.')) &&By default, show stars
ps=""
FOR i=1 TO N
@0,5+i
p=INKEY(0)
DO CASE
CASE LAST()=127 &&backspace
IF i>1
@0,5+i-1 SAY " "
ps=LEFT(ps,LEN(ps)-1)
ENDIF
i=i-2
i=IIF(i<0,0,i)
CASE LAST()=13 &&Return
EXIT
OTHERWISE
@0,5+i SAY SUBSTR(cd,i,1) COLOR W/N
ps=ps+CHR(p)
ENDCASE
ENDFOR
SET COLOR TO
RELEASE WINDOW paswrd
RETURN ps
Return to Index
PASSWORDS - EXAMPLE3 (John Torrance)
Will accept a password and check it against the password passed
into the procedure as a parameter. The procedure returns .T. or
.F. indicating if the user was correct. Optional parameters control
the number of attempts that the user gets, and the timeout for
waiting for the user to enter a password. If no password is
passed in as a parameter, the procedure will return .T.
_PassWord - The password to verify against. Not case sensitive!
_NumTries - Number of times computer will ask before giving
up. Optional, defaults to 1.
_TimeOut - Time the computer will wait for the user to enter
a KEYSTROKE. If the user does not press a key (even
in the middle of a password) for this amount of
seconds, whatever typed to that point is checked as
the password. Optional, defaults to 0 which means
wait forever.
PROCEDURE password
PARAMETER _password, _numtries, _timeout
PRIVATE m.password, m.retval, i
m.retval = .T.
m.talkstat = SET("TALK")
SET TALK OFF
IF !EMPTY( _password )
** Set default number of tries (1), and timeout (0=none)
IF EMPTY( _numtries )
_numtries = 1
ENDIF
IF EMPTY( _timeout )
_timeout = 0
ENDIF
** Define and activate window
DEFINE WINDOW lw_pass AT 0,0 SIZE 4.5,100 ;
FONT "MS Sans Serif", 8 NOFLOAT NOCLOSE NOMINIMIZE ;
SYSTEM COLOR RGB(,,,192,192,192)
MOVE WINDOW lw_pass CENTER
ACTIVATE WINDOW lw_pass
** Initialize counter of tries and set the return value to 'false'
i = 0
m.retval = .F.
** Loop until they enter the correct password or run out of tries
DO WHILE !m.retval .AND. i < _numtries
** Display prompt and get word entered (via function)
@ 1.385,4.4 SAY "Please enter password:" ;
FONT "MS Sans Serif", 12 STYLE "BT"
m.password = passenter( _timeout )
** Check the password for validity
DO CASE
CASE TRIM(m.password) == TRIM(UPPER(LEFT(_password+SPACE(32),32)))
m.retval = .T.
*-- This allows them to escape (returning false) if they press
*-- enter with a blank password.
CASE EMPTY( m.password )
i = _numtries - 1
OTHERWISE
SET BELL TO 220,18
WAIT WINDOW NOWAIT " Invalid Password "
?? CHR(7)
SET BELL TO
ENDCASE
i = i + 1
ENDDO
RELEASE WINDOW lw_pass
ENDIF
SET TALK &talkstat
SET BELL TO
WAIT CLEAR
RETURN m.retval
** This procedure gets a word from the user without echoing it.
PROCEDURE passenter
PARAMETER _timeout
PRIVATE _x, _retval
curset = SET("CURSOR")
SET CURSOR OFF
_x = 0
_retval = ''
_falsepass = SPACE(32)
@ 1.8,43.5 GET _falsepass SIZE 1,32.5 DEFAULT " " ;
FONT "FoxFont", 9 COLOR ,RGB(,,,255,255,255)
CLEAR GETS
DO WHILE _x <> 13
_x = INKEY( _timeout )
DO CASE
CASE _x = 127 .OR. _x = 19 && Backspace or left arrow
IF LEN( _retval ) > 0
_retval = LEFT( _retval, LEN( _retval ) - 1 )
ELSE
SET BELL TO 440,2
?? CHR(7)
SET BELL TO
ENDIF
CASE _x = 0
_x = 13
CASE _x = 13
OTHERWISE
_retval = _retval + CHR( _x )
ENDCASE
_falsepass = LEFT(REPLICATE('', LEN(TRIM(_retval)))+SPACE(32), 32)
@ 1.8,43.5 GET _falsepass SIZE 1,32.5 DEFAULT " " ;
FONT "FoxFont", 9 COLOR ,RGB(,,,255,255,255)
CLEAR GETS
ENDDO
SET CURSOR &curset
RETURN UPPER(TRIM(_retval))
Return to Index
DISABLING ESCAPE KEY DURING SCREEN INPUT (Timothy A. Callahan)
The SET ESCAPE and ON ESCAPE are methods on handling escapes during a
program execution, e.g., push a button which executes to loop a 100 times
and press escape to interrupt the loop. In short, when any code is
executing and escape is pressed the action specified by the ON ESCAPE is
fired, provided SET ESCAPE ON.
When your program is waiting for input, pressing escape has a different
result. The ON ESCAPE is not used in this case. BTW, this is your problem,
because the READ from your screen is expecting input. As you found out,
escape by default terminates the read.
Possible solutions:
1) Use the ON KEY LABEL ESCAPE command. This is similiar to the ON ESCAPE,
except ON KEY LABEL... intercepts the escape when your program is waiting
for input. ON KEY LABEL... does not interrupt program execution. I would
recommend not using ON ESCAPE with ON KEY LABEL ESCAPE. These two commands
are mutually exclusive.
ON KEY LABEL ESCAPE * has the program do nothing when an escape is encountered.
2) If you have a Cancel push button, you can define it as an Escape button
(\?).
3) Use read VALID snippet to handle ESCAPE:
IF LASTKEY() = 27
WAIT WINDOW "Escape pressed!" NOWAIT
DO resetkey && Make sure LASTKEY() does not return 27 anymore
RETURN .F. && Stay in screen
ENDIF
RETURN .T. && Terminate read
4) Use the readkey() function. (Mark Waters)
This function returns a value corresponding to the key pressed to exit a read.
Specifically, it returns 3 if a termination control was chosen. I use the
following code in the read validation function to only allow the read,
and window, to end by using a control button.
IF READKEY(1) # 3
* do not terminate read unless a terminating control was chosen
RETURN .f.
ENDIF
Return to Index
PRECISE WINDOW PLACEMENT (Stephen Del Rea)
Q.
I am trying to bring up a second window on top of the first window so
that the bottom edge of the second window is exactly on the bottom
edge of the first window (using MOVE WINDOW in FPW 2.5b). I'm not
A.
I've found that the key to getting precise placements is to realize that
the MOVE WINDOW command bases its coordinates on the default
font in the Main FoxPro Screen, not the default font in the window
being moved. Therefore, if the default fonts are different between the
two windows, you will have to adjust for this difference using the
FONTMETRIC height and average width values for the two fonts.
At the beginning of your app, or in the Setup snippet of your top-level
screen, define the PUBLIC variables "mainheight" and "mainwidth" to
be the character height and average width for the font in the main
screen (note that a blank window name in WFONT returns the font for
the main screen):
mainheight = FONTMETRIC(1,WFONT(1,""),WFONT(2,""))
mainwidth = FONTMETRIC(6,WFONT(1,""),WFONT(2,""))
Then, in the Setup snippet of the second (child) window, get the
coordinates and height of the first (parent) window (as PUBLIC
variables):
w1wlrow = WLROW()
w1wlcol = WLCOL()
w1wrows = WROWS()
And, in the Window Activate snippet of the second (child) window, get
the row coordinate by subtracting the row height of the second window
from the coordinate of the bottom edge of the first (parent) window.
(The column coordinate will be the same as the first window, with the
left edges of the two windows aligned.) Adjust both coordinates to the
main screen by multiplying them by the ratio of the current window's
font size to the main screen's font size, and move the second window
to that resulting coordinate:
w2wlrow = (w1wlrow + w1wrows - WROWS('WINDOW2')) *
FONTMETRIC(1) / mainheight
w2wlcol = w1wlcol * FONTMETRIC(6) / mainwidth
MOVE WINDOW WINDOW2 TO w2wlrow,w2wlcol
So, regardless of the fonts being used, which may be different from
what you specified if the user doesn't have those fonts installed, the
windows should line up correctly using this code. (I'm assuming that
the font specified for the parent window is the same as that specified
for the child window.)
During this testing, I have found what appears to be a bug in FPW
2.5b, and possibly other versions as well. If the first (parent) window
is located at (-1,-1), the second (child) window becomes offset from
the bottom edge by around one row vertically and around 1/4 column
horizontally. Moving the first window diagonally away from (-1,-1)
results in the second window being positioned correctly. I've
compensated for this problem by putting the following code into the
Window Activate snippet of the first (parent) window:
r = WLROW()
c = WLCOL()
IF (r = -1) OR (c = -1)
r = IIF(r = -1,0,r)
c = IIF(c = -1,0,c)
MOVE WINDOW WINDOW1 TO r,c
ENDIF