Диагональные линии в FoxPro/WINDOWS
Дуг Бланк
Грустно, но это правда. Вы не можете нарисовать диагональную линию в FoxPro. Я пытался даже использовать Windows API, и, действительно, вы можете нарисовать все что угодно в окне FoxPro, только FoxPro ничего не знает об этом. Следовательно, после того как вы закроете окно и снова откроете его, линия пропадет. Стоит вам поместить другое окно поверх того, где нарисована линия, и она не будет перерисована. В итоге я пришел к решению, описанному ниже. Программа довольно неплохо справляется с задачей рисования произвольных линий. При необходимости можно отрегулировать размеры точки. Эти параметры необходимы, так как при трансляции целых чисел в экранные координаты нужно учитывать особенности графического интерфейса.
Процедура вызывается так:
=drawline(1,5,11,30,.T.)
Используя предложенный метод, вы можете рисовать круги, кривые и т. п. Поместите приведенную функцию в вашу программу или закоментируйте первую строку и сохраните файл как DRAWLINE.PRG. Это не самый быстрый или самый гладкий подход, но он работает. Скорее всего вам не удастся сделать линию тоньше, это связано с трансляцией расчетных значений в экранные координаты. Вы можете изменить цвета посредством функции RGB() или даже добавить структуру CASE для использования всех возможных цветов, добавления теней и т. д.
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 && вертикальная линия
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
Как сохранить структуры таблиц в каталоге Читаем структуры всех таблиц в каталоге и записываем их в текстовый файл:
* STRSAV.PRG
SET TALK OFF
CLEAR ALL
PRIVATE ALL LIKE l
** Просим пользователя выбрать каталог
ldirectory = GETDIR(CURDIR(), ;
"Select a directory containing tables:")
* убедимся, что каталог выбран
IF !EMPTY(ldirectory)
*
* считываем имена всех таблиц в массив
lhits = ADIR(ltables, ldirectory + "*.DBF")
*
* убедимся, что в каталоге есть таблицы
IF lhits == 0
WAIT WINDOW ;
"No tables found in " + ldirectory
ELSE
WAIT WINDOW "Processing tables..." NOWAIT
SELECT 0
*
* создаем временную таблицу
CREATE CURSOR ;
WORK (filename c(8), struclist m(10))
*
* обрабатываем каждую таблицу в каталоге
FOR lcount = 1 TO lhits
*
* создаем имя временного файла
ltempfile = SYS(3) + ".TXT"
*
* строим полный путь к файлу
* и открываем таблицу
lfilespec = ldirectory + ltables[lCount, 1]
SELECT 0
USE (lfilespec)
*
* записываем информацию о структуре таблицы
* во временный файл
DISPLAY STRUCTURE NOCONSOLE ;
TO FILE (ltempfile)
*
* добавляем новую запись для данной таблицы
INSERT INTO WORK (filename) ;
VALUES (ltables[lCount,1])
*
* закрываем таблицу
USE
SELECT WORK
*
* загружаем временный файл в memo-поле
APPEND MEMO struclist FROM (ltempfile)
*
* уничтожаем временный файл
DELETE FILE (ltempfile)
*
* сюда можно поместить дальнейшую обработку
ENDFOR
GO TOP
* это самый простой способ
* писать в текстовый файл
SET TEXTMERGE ON
SET TEXTMERGE TO STRUC.txt NOSHOW
\Table Structure Listing \----------------
*
* для каждой записи выводим
* содержимое memo-поля в текстовый файл
SCAN
\<>
ENDSCAN
SET TEXTMERGE TO
SET TEXTMERGE OFF
USE
WAIT WINDOW ALLTRIM(STR(lhits)) + ;
" tables processed!"NOWAIT
ENDIF
ENDIF
RETURN
Как сохранить определения индексов и фильтров для таблиц в текущем каталоге
Эли Линков
* INDEXSAV.PRG
* Эта программа может быть использована
* для создания справочника
* по всем индексам и фильтрам в каталоге
* проекта. Таблица, куда записывается
* информация, называется DBINFO.DBF.
* Структура справочника
* поле dbfname 12 символов
* поле infomemo memo
*
* В memo-поле помещается имя индекса,
* выражение индексации и дополнительное
* ограничение индексного выражения
* в виде <имя индекса>/<выражение>%<фильтр>,
* определение одного индекса занимает
* строку в memo-поле
*
* Программу следует запускать
* когда приложение готово к инсталляции,
* она создаст справочник и
* соответствующий FPT-файл.
* Этот справочник нужно хранить
* в "системном" каталоге приложения
* вместе с исполняемой версией
* программы INDEXMAK.
* INDEXMAK.EXE должна быть доступна
* только через меню администратора
* и не должна появляться как пиктограмма
* в окне Program Manager.
* Для восстановления индексов
* нужно запустить программу INDEXMAK.EXE
CLOSE DATABASES
* Следующие две строки указывают
* на системные каталоги проекта
datapath = ;
GETDIR("",'Where the indexed tables')
workpath = ;
GETDIR("",'Where the system EXE is')
IF NOT FILE(workpath + "dbfinfo.dbf")
SET DEFAULT TO (workpath)
* создаем таблицу-справочник
* (используется программой 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 ALLT((dbfinfo.dbfname)) EXCLUSIVE
DIMENSION taglist(1,3)
indexstr = ""
arrct = 1
DO WHILE NOT EMPTY(TAG(arrct))
taglist(arrct,1) = TAG(arrct)
* имя индекса
taglist(arrct,2) = SYS(14,arrct)
* выражение индексации
taglist(arrct,3) = SYS(2021,arrct)
* фильтр индексации (если есть)
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
PROCEDURE INDEXMAK
* indexmak.prg
* Эта программа используется
* для восстановления индексов
* в том случае, если таблицы проекта
* оказались повреждены.
* Программа использует справочник DBFINFO.DBF,
* созданный программой INDEXSAV.PRG,
* для восстановления имен индексов,
* выражений индексации и фильтров индексов.
*
* Программу нужно поместить в виде
* исполняемого файла и дать доступ к ней
* только администратору системы.
*
CLOSE DATABASES
* путь к "системному" каталогу проекта
* (укажите свой путь)
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)
* имя индекса
tagname = SUBSTR(fred,colno1 + 1,;
(colno2 - colno1 - 1))
* выражение индексации
tagfilt = ALLTRIM ;
(RIGHT(fred,LEN(fred) - colno2))
* фильтр индексации
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
Пароли
* Пример 1
* (Брайан Копеланд /Brian Copeland/)
* Это пример использования INKEY()
* для ввода пароля и вывода '*' в поле.
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
EXIT
CASE BETWEEN(mkey,48,57)
* это число
mpassword=mpassword+CHR(mkey)
mshowpass = mshowpass+'*'
CASE BETWEEN(mkey,97,122)
* это буква в нижнем регистре
mpassword=mpassword+CHR(mkey)
mshowpass = mshowpass+'*'
CASE BETWEEN(mkey,65,90)
* это буква в верхнем регистре
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
* Пример 2 (Р. Премкумар /R. Premkumar/)
*
* Процедура проверки ввода пароля:
* если пароль верен, возвращает .t.,
* иначе возвращает .f.
* или включает системы защиты (сирену)
* n = максимальная длина пароля,
* по вашему усмотрению
* c = строка, которая появляется
* по мере ввода пароля
* (вместо звездочек вы можете увидеть текст
* "С добрым утром", который появляется
* по мере ввода пароля
* t = заголовок окна
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> ]]] )'
* в программе вы можете вызвать
* эту функцию как: a=password()
RETURN
ENDIF
IF PARA()=0
N=7
* длина пароля по умолчанию.
* Используется при вызове функции
* без параметров
ENDIF
IF PARA()<3
t='ENTER PASSWORD' && Заголовок по умолчанию
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,'.'))
* по умолчанию выводим звездочки
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