Место общения программистов, форум разработчиков БД на Clarion
https://forum.clarionlife.net/
Код: Выделить всё
PROGRAM
INCLUDE('KEYCODES.CLW')
INCLUDE('ERRORS.CLW') ! Shur -- добавить коды ошибок
MAP
Main PROCEDURE
END
CODE
Main
Main PROCEDURE
?EditEntry EQUATE(100)
EditEntry string(64)
Columns SHORT,DIM(8)
ChDb SHORT(0) ! флаг внесения изменений в базу и он же счетчик измененных полей
isOpen SHORT(0)
cnt LONG(0)
DropL LONG(10)
Q QUEUE,PRE(Q)
Tel STRING(5)
Fam STRING(27)
Adr STRING(27)
UPP STRING(4)
Dom STRING(4)
Kvr STRING(4)
Kat STRING(5)
Ust STRING(8)
GP STRING(4)
PR STRING(4)
END
FileName STRING(64),STATIC !Переменная имени файла
StrFlt STRING(64),STATIC
S1 STRING(5),STATIC
S2 STRING(5),STATIC
aster byte(0)
i byte(0)
F FILE,DRIVER('TOPSPEED'),NAME(FileName),PRE(FDB),BINDABLE|
,CREATE ! Shur -- чтобы можно было создать файл
K KEY(FDB:Tel),PRIMARY ! Shur -- восстанавливаем ключ
R RECORD
Tel STRING(5)
Fam STRING(27)
Adr STRING(27)
UPP STRING(4)
Dom STRING(4)
Kvr STRING(4)
Kat STRING(5)
Ust STRING(8)
GP STRING(4)
PR STRING(4)
. .
V VIEW(F)
PROJECT(FDB:TEL,FDB:FAM,FDB:ADR,FDB:UPP,FDB:DOM,FDB:KVR,FDB:KAT,FDB:UST,FDB:GP,FDB:PR)
END
NewRecWin WINDOW('Новая запись'),AT(150,70,280,150),GRAY,MAX
GROUP('Ввод данных абонента'),AT(4,4,210,142),USE(?Gr3),BOXED
STRING('Номер телефона'),AT(08,15); ENTRY(@S5), AT(80,15,25,10), USE(?NewTel)
STRING('Aбонент'), AT(08,30); ENTRY(@S28), AT(80,30,128,10), USE(?NewFam)
STRING('Адрес'), AT(08,45); ENTRY(@S28), AT(80,45,128,10), USE(?NewAdr)
STRING('Ул/Пер'), AT(08,60); ENTRY(@S4), AT(80,60,16,10), USE(?NewUpp)
STRING('Дом'), AT(08,75); ENTRY(@S4), AT(80,75,16,10), USE(?NewDom)
STRING('Квартира'), AT(08,90); ENTRY(@S4), AT(80,90,16,10), USE(?NewKvr)
STRING('Категория'), AT(08,105);ENTRY(@S4), AT(80,105,16,10), USE(?NewKat)
STRING('Дата установки'),AT(08,120);ENTRY(@S8), AT(80,120,50,10), USE(?NewUst)
STRING('Громполоса'), AT(08,35); ENTRY(@S4), AT(80,135,16,10), USE(?NewGP)
STRING('Пара'), AT(08,50); ENTRY(@S4), AT(80,150,16,10), USE(?NewPR)
END
BUTTON('Добавить'), AT(219,08,53,27), USE(?OKnewrec), icon('OK.ICO')
BUTTON('Отменить'), AT(219,45,53,27), USE(?NOnewrec), icon('EXIT.ICO')
END
WinEditRec WINDOW('Редактирование записи'),AT(150,70,280,199),GRAY,MAX
GROUP('Изменение данных по абоненту'),AT(4,4,210,189),USE(?Gr2),BOXED
STRING('Номер телефона'),AT(8,15); ENTRY(@S5), AT(80,15,25,10), USE(?UpdTel)
STRING('Aбонент'), AT(8,30); ENTRY(@S28), AT(80,30,128,10), USE(?UpdFam)
STRING('Адрес'), AT(8,45); ENTRY(@S28), AT(80,45,128,10), USE(?UpdAdr)
STRING('Ул/Пер'), AT(8,60); ENTRY(@S4), AT(80,60,16,10), USE(?UpdUpp)
STRING('Дом'), AT(8,75); ENTRY(@S4), AT(80,75,16,10), USE(?UpdDom)
STRING('Квартира'), AT(8,90); ENTRY(@S4), AT(80,90,16,10), USE(?UpdKvr)
STRING('Категори<255>'), AT(8,105);ENTRY(@S4), AT(80,105,16,10), USE(?UpdKat)
STRING('Дата установки'),AT(8,120);ENTRY(@S8), AT(80,120,50,10), USE(?UpdUst)
STRING('Громполоса'), AT(8,135);ENTRY(@S4), AT(80,135,16,10), USE(?UpdGP)
STRING('Пара'), AT(8,150);ENTRY(@S4), AT(80,150,16,10), USE(?UpdPR)
END
BUTTON('Применить'), AT(219,8,53,27), USE(?UpdRec), ICON('OK.ICO')
BUTTON('Выход'), AT(219,45,53,27), USE(?ExitRec), ICON('EXIT.ICO')
END
Win1 WINDOW('ТЕЛЕФОННЫЙ СПРАВОЧНИК Технологической св<255>зи '),AT(0,1,556,272),SYSTEM,GRAY
GROUP(' Фильтр '),AT(4,4,215,55),USE(?Group1),BOXED
STRING('По номеру телефона:'),AT(8,16,65,10),USE(?pont),DISABLE
ENTRY(@s5),AT(84,12,25,10),USE(?Tel),DISABLE
STRING('По имени:'),AT(8,32,30,10),USE(?poim),DISABLE
ENTRY(@S31),AT(56,28,100,10),USE(?Im),DISABLE
STRING('По адресу:'),AT(8,44,34,10),USE(?poad),DISABLE
ENTRY(@S31),AT(56,44,100,10),USE(?Adr),DISABLE
BUTTON('Применить'),AT(164,12,50,40),USE(?BF),DISABLE,ICON('TLF7.ICO')
END
LIST,AT(4,80,548,180),USE(?List),HVSCROLL,ALRT(EnterKey),ALRT(MouseLeft2),ALRT(MouseLeft), |
FORMAT( '32L@s05@~Телефон~' &|
'99L@s27@~| Абонент~' &|
'99L@s27@~| Адрес~' &|
'27L@s04@~| ул/пер~' &|
'19L@s04@~| Дом~' &|
'22L@s04@~| Квар~' &|
'40L@s05@~| Категори<255>~' &|
'60L@s08@~| Дата установки~' &|
'47L@s04@~| Громполоса~' &|
'05L@s04@~| Пара~'),FROM(Q)
BUTTON('Выход'),AT(504,8,46,48),USE(?Cancel),ICON('EXIT.ICO')
BUTTON('Открыть базу'),AT(228,12,60,20),USE(?OpBase) !,ICON('OPEN.ICO') !ENTRY(@S15),AT(280,10,80,15),USE(STR1)
BUTTON('Нова<255> запись'),AT(292,12,60,20),USE(?NewRec),DISABLE
BUTTON('Редактировать'),AT(228,36,60,20),USE(?EditRec),DISABLE !,ICON('EXIT.ICO')
BUTTON('Удалить запись'),AT(292,36,60,20),USE(?DelRec),DISABLE
PROGRESS,USE(?Pr),DISABLE,AT(4,64,548,14),RANGE(0,300)
END
CODE
BIND('FDB:TEL',FDB:TEL) ! Shur 20120604 -- BIND обязательно нужен, чтобы работал фильтр. То же самое и для других полей, которые будут использоваться в фильтре
OPEN(Win1)
ACCEPT
CASE FIELD()
OF ?List
CASE EVENT()
OF EVENT:PreAlertKey
CYCLE
OF EVENT:AlertKey
CASE KEYCODE()
!IF KEYCODE()=MouseRight
! EXECUTE POPUP('ONE|TWO')
! END
!END
OF EnterKey OROF MouseLeft2
GET(Q,CHOICE())
OF MouseLeft
IF ?List{PROPLIST:MouseDownRow} = 0
!Message(Columns[?List{PROP:COLUMN}])
EXECUTE Columns[?List{PROPLIST:MouseDownField}]
!EXECUTE Columns[?List{PROP:COLUMN}]
SORT(Q,Q.Tel)
SORT(Q,Q.Fam)
SORT(Q,Q.ADR)
SORT(Q,Q.UPP)
SORT(Q,Q.DOM)
SORT(Q,Q.KVR)
SORT(Q,Q.KAT)
SORT(Q,Q.UST)
SORT(Q,Q.GP)
SORT(Q,Q.PR)
END
?List{PROP:Edit,?List{PROP:Column}} = 0 ! скрыть поле редактирования
SELECT(?) ! остаться в текущем контроле
END
END ! case keycode()
!----------------
OF event:accepted
END ! case event
OF ?OpBase
CASE EVENT() ! Shur -- чтобы не отрабатывалось по нескольку раз
of EVENT:ACCEPTED ! Shur
IF FileName <> '' ! ЕСЛИ ОТКРЫВАЕМ 2-Ю БАЗУ
close(F); close(V)
end
IF FILEDIALOG('Выберите базу для работы',FileName, 'Bases|*.TPS', FILE:LongName+FILE:NoError) ! Shur -- добавлено +FILE:NoError, иначе если файл базы не существует, то нельзя выйти
! подготовить дисковый файл
if ~EXISTS(FileName) ! Shur -- если файл не существует,
CREATE(F) ! Shur -- то создать его
if errorcode() ! Shur -- проверить на ошибку
message('Ошибка '&errorcode()&': '&error(),'ОШИБКА')
cycle
end
end
OPEN(F,42h); ! Shur -- открыть файл немонопольно
if errorcode() ! Shur -- проверить на ошибку
message('Ошибка '&errorcode()&': '&error(),'ОШИБКА')
cycle ! Shur -- если ошибка, то выскочить из дальнейшей обработки
end
IF NOT RECORDS(F)
MESSAGE('База пуста.','Информация',ICON:Clarion,,,0) ! Shur -- а если я её только что создал?
.
SET(F)
! подготовить виртуальный файл
OPEN(V); set(V); free(Q)
! подготовить очередь
DO LoadQueue
DISPLAY
ENABLE(?BF); ENABLE(?EditRec); ENABLE(?NewRec); ENABLE(?DelRec)
ENABLE(?pont); ENABLE(?Tel); ENABLE(?poim); ENABLE(?Im);
ENABLE(?poad); ENABLE(?Adr);
! читаем первую запись
SET(V)
NEXT(V)
!Q=F.R
SELECT(?List,1) ! ставим курсор на первую запись
END ! filedialog
END ! CASE EVENT:ACCEPTED ! Shur
!=====================================================================
OF ?EditRec ! редактировать запись
CASE EVENT() ! Shur
of EVENT:ACCEPTED ! Shur
GET(Q,CHOICE(?List))
F:Tel = Q.Tel
WATCH(F) ! Shur -- запустить контроль изменений записи
GET(F,FDB:K) ! Shur -- проверить наличие редактируемой записи (её могли удалить с другой машины)
if errorcode() ! Shur -- проверить на ошибку
message('Ошибка '&errorcode()&':'&error(),'ОШИБКА')
do LoadQueue ! Shur -- если есть ошибка, то перечитать очередь
cycle
end
Q :=: FDB:R ! Shur -- копируем данные из файла в очередь (они могли измениться другой машиной), а нам нужны только актуальные
PUT(Q) ! Shur -- сохранить в очередь
display
OPEN(WinEditRec)
?UpdTel{PROP:USE}=Q.Tel; ?UpdFam{PROP:USE}=Q.Fam; ?UpdAdr{PROP:USE}=Q.Adr; ?UpdUpp{PROP:USE}; ?UpdDom{PROP:USE}=Q.Dom;
?UpdKvr{PROP:USE}=Q.Kvr; ?UpdKat{PROP:USE}=Q.Kat; ?UpdUst{PROP:USE}=Q.Ust; ?UpdGP{PROP:USE}=Q.GP; ?UpdPR{PROP:USE}=Q.PR
ACCEPT
CASE ACCEPTED()
OF ?UpdRec ! кнопка сохранить
Q.Tel=?UpdTel{PROP:USE}; Q.Fam=?UpdFam{PROP:USE}; Q.Adr=?UpdAdr{PROP:USE}; Q.Upp=?UpdUpp{PROP:USE}; Q.Dom=?UpdDom{PROP:USE};
Q.Kvr=?UpdKvr{PROP:USE}; Q.Kat=?UpdKat{PROP:USE}; Q.Ust=?UpdUst{PROP:USE}; Q.GP=?UpdGP{PROP:USE}; Q.PR=?UpdPR{PROP:USE}
F.R=Q ! подготовить файловую запись
!message('3:' & pointer(V))
IF DUPLICATE(F) ! Shur -- проверка на уникальность ключа
message('Дублирование телефонного номера!','ОШИБКА')
BREAK
END
LOGOUT(.2,F) ! Shur -- открыть транзакцию
PUT(F) ! записать ее
IF ERRORCODE() = RecordChangedErr ! Shur -- If changed by another station
ROLLBACK ! Shur -- если запись была изменена с другой машины за время редактирования, то откатить транзакцию
F:Tel = Q.Tel
WATCH(F) ! Shur -- снова взвести контроль изменения записи
GET(F,FDB:K)
if errorcode() ! Shur -- проверить на ошибку
message('Ошибка '&errorcode()&': '&error(),'ОШИБКА')
do LoadQueue ! Shur -- если ошибка, то запись могла быть удалена (или изменён ключ) с другой машины --> перечитать файл
BREAK
end
Q :=: FDB:R ! Shur -- считанную запись из файла
PUT(Q) ! Shur -- сохранить запись в очереди
if message('Запись была изменена с другой станции!|Повторить ввод?','ВНИМАНИЕ!',ICON:Question,BUTTON:Yes+BUTTON:No,BUTTON:Yes) = BUTTON:Yes
DISPLAY
CYCLE
end
elsif errorcode() ! Shur -- иные другие ошибки --> просто откатить транзакцию и показать ошибку
ROLLBACK
message('Ошибка '&errorcode()&': '&error(),'ОШИБКА')
else ! Shur -- если ошибок нет
COMMIT ! Shur -- завершить транзакцию и обновить запись в очереди
PUT(Q) ! обновить запись в очереде
end
DISPLAY
break
OF ?ExitRec ! кнопка выхода без сохранения
BREAK
.
.
if accepted()=?UpdRec
!!message('--------')
end
CLOSE(WinEditRec)
DISPLAY
END ! CASE EVENT:ACCEPTED ! Shur
OF ?Cancel ! завершить программу
CASE EVENT() ! Shur
of EVENT:ACCEPTED ! Shur
close(F)
close(V)
CLOSE(Win1)
RETURN
END ! CASE EVENT:ACCEPTED ! Shur
! обработка поля фильтра
OF ?BF
CASE EVENT() ! Shur
of EVENT:ACCEPTED ! Shur
aster=0
StrFlt=?tel{prop:use}
S1 = StrFlt
S2 = StrFlt
loop i=1 to 5
if StrFlt[i]='*'
S1[i]=0
S2[i]=9
aster = 1
. .
if aster=1
V{PROP:FILTER} = 'FDB:TEL>' & S1 & ' and FDB:TEL<' & S2 ! Shur 29120604 -- здесь надо сделать тоже кавычки
else
!V{PROP:FILTER} = 'FDB:TEL=' & StrFlt ! Shur 20120604 -- это неправильное задание фильтра
V{PROP:FILTER} = 'FDB:TEL=''' & clip(StrFlt) & '''' ! Shur 20120604 -- FDB:TEL - имеет тип STRING, поэтому нужны кавычки (не стоит полагаться на неявное преобразование типов)
end
SET(V)
FREE(Q)
DO LoadQueue
display(?)
END ! CASE EVENT:ACCEPTED ! Shur
! ввести новую запись
OF ?NewRec
CASE EVENT() ! Shur -- избежать повторных срабатываний
of EVENT:ACCEPTED ! Shur
OPEN(NewRecWin)
ACCEPT
CASE ACCEPTED()
OF ?OKnewrec
Q.Tel=?NewTel{PROP:USE}; Q.Fam=?NewFam{PROP:USE}; Q.Adr=?NewAdr{PROP:USE}; Q.Upp=?NewUpp{PROP:USE}; Q.Dom=?NewDom{PROP:USE};
Q.Kvr=?NewKvr{PROP:USE}; Q.Kat=?NewKat{PROP:USE}; Q.Ust=?NewUst{PROP:USE}; Q.GP=?NewGP{PROP:USE}; Q.PR=?NewPR{PROP:USE}
F.R=Q ! подготовить файловую запись
IF DUPLICATE(F) ! Shur -- проверка на уникальность ключа
message('Дублирование телефонного номера!','ОШИБКА')
BREAK
END
LOGOUT(.2,F) ! Shur -- открыть транзакцию
ADD(F) ! записать ее
if errorcode() ! Shur -- если ошибка записи,
ROLLBACK ! Shur -- то откатить транзакцию
message('Ошибка '&errorcode()&':'&error(),'ОШИБКА')
else ! Shur -- если ошибок нет,
COMMIT ! Shur -- то завершить транзакцию
ADD(Q) ! Shur -- добавить запись в очередь
end
BREAK
OF ?NOnewrec
BREAK
END
END
CLOSE(NewRecWin)
SELECT(?List,POINTER(Q))
END ! CASE EVENT:ACCEPTED ! Shur
! удалить запись
OF ?DelRec
CASE EVENT() ! Shur
of EVENT:ACCEPTED ! Shur
GET(Q,CHOICE(?List))
F:Tel = Q.Tel
GET(F,FDB:K) ! Shur -- взять запись файла по ключу
if errorcode() ! Shur -- если ошибка (запись могла быть удалена с другой машины),
message('Ошибка '&errorcode()&': '&error(),'ОШИБКА') ! Shur -- показать ошибку
cycle ! Shur -- и выйти изобработки
end
LOGOUT(.2,F) ! Shur -- если ошибки нет, то открыть транзакцию
DELETE(F) ! Shur -- удалить запись
if errorcode() ! Shur -- если ошибка удаления,
ROLLBACK ! Shur -- откатить транзакцию
message('Ошибка '&errorcode()&': '&error(),'ОШИБКА')
else
COMMIT ! Shur -- если ошибки нет, то закрыть транзакцию,
DELETE(Q) ! Shur -- и удалить запись в очереди
end
DISPLAY(?)
END ! CASE EVENT:ACCEPTED ! Shur
END ! case field()
END
UNBIND('FDB:TEL') ! Shur 20120604 -- UNBIND парный оператор для BIND
LoadQueue ROUTINE
free(Q) ! Shur -- очистить очередь
clear(F:R) ! Shгк -- задать начальные условия для SET()
SET(FDB:K,FDB:K) ! Shur -- задать порядок считывания для NEXT()
LOOP
NEXT(V)
IF ERRORCODE()
break
.
Q.TEL = CLIP(FDB:TEL)
Q.FAM = CLIP(FDB:FAM)
Q.ADR = CLIP(FDB:ADR)
Q.UPP = CLIP(FDB:UPP)
Q.DOM = CLIP(FDB:DOM)
Q.KVR = CLIP(FDB:KVR)
Q.KAT = CLIP(FDB:KAT)
Q.UST = CLIP(FDB:UST)
Q.GP = CLIP(FDB:GP)
Q.PR = CLIP(FDB:PR)
ADD(Q)
.
Попытался вникнуть в тему, так и не получилось. Насколько я понял Ваш List должен содержать поля QUEUE?EugeneR писал(а):Добрый день!Подскажите начинающему. Можно ли LIST использовать как полноценный BROWSE? Редактирование полей, удаление - добавление записей, сортировки, установки фильтров и т.д. Спасибо.
У каждого есть свои причудыНо если обрабатываемый файл находится на диске - то зачем этот геморрой?
