(* INFO_FMS использует: CRUF_FMS *)
(* DEBI_FMS *)
(* D_UNIT *)
(* EXEC_FMS *)
(* EXPO_FMS *)
(* FACE_FMS *)
(* FILE_FMS *)
(* FORM_FMS *)
(* HELP_FMS *)
(* KEYS_FMS *)
(* LAYS_FMS *)
(* LOAD_FMS *)
(* MENU_FMS *)
(* OKHO_FMS *)
(* OPEN_FMS *)
(* OVER_FMS *)
(* SELE_FMS *)
(* SHOW_FMS *)
(* STAK_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O+,R+,S+,V+,X-}
{$M 16384,0,65536}
Unit INFO_FMS;
INTERFACE
Uses DOS, FILE_FMS, UNIF_FMS, TYPE_FMS, LOAD_FMS,
CRT, STAK_FMS, OKHO_FMS, CRUF_FMS, SELE_FMS,
D_Unit, KEYS_FMS, FACE_FMS, MENU_FMS, HELP_FMS,
DEBI_FMS, LAYS_FMS, OPEN_FMS, OVER_FMS,
SHOW_FMS, EXPO_FMS, FORM_FMS, EXEC_FMS;
function INFORMAT : boolean; { F4 : Ввод в альт.форме }
procedure EXPORTer; { F5 : Экспорт из БД }
function IMPORTer : boolean; { F6 : Импорт из БД | ...}
procedure INKEYSER(PTH : String); { Ввод по ключу }
function Full_F07 : integer;
TYPE LoadProc = procedure;
function ParDBF( S : String ) : String;
function LoadKfile(var S,PTH : String; LProc : LoadProc) : integer;
IMPLEMENTATION
var LEREST : array [1..10] of byte; { Ограничения на представление полей в меню }
{ NoGru = TRUE, если сообщение не является составным }
{ Вспомогательная для INIT_BASEL }
function NoGru : boolean;
var I : integer;
begin NoGru:=false;
for I:=1 to FogMed do
if PthMed[I] <> 0 then Exit;
NoGru:=true end;
{ CXOT : [Ha,Ko] -> [Ha',Ko'] }
{ [Ha,Ko] - диапазон полей сообщения }
{ Fg - поле (представитель) генератора }
{ Сократить диапазон поиска }
procedure CXOT(var Ha,Ko : integer; Fg : integer);
var I,F,X,Hx,Kx : integer;
begin F:=abs(FITEK);
with MEAD^ do begin
X:=Grupa_VRF(BDS[Fg].VRF).K-1;
Hx:=0;
Kx:=Ha-1;
for I:=Ha to Ko do
if BDS[I].LFT = X then begin
if F <= I then begin
Ha:=Kx+1;
Ko:=I;
Exit
end;
Hx:=Kx+1;
Kx:=I
end;
if 0 < Hx then begin Ha:=Hx; Ko:=Kx end
end end;
{ INIT_BASEL : Настроить процедуру DefaultSelector }
{ PFT = TRUE - анализировать FROM-часть }
{ PFT = FALSE - анализировать TO-часть }
{ RES = 1|2... - Физ.номер поля-"зацепки" }
{ 0 - Встретились селекторы разных групп }
function INIT_BASEL(PFT : boolean) : integer;
var DEEP,GENS : array [1..255] of integer;
ABC,DEF : TYPE_HABOPOT;
I,L,M,K : integer;
F,T : String;
procedure DEAL(var S : String); { Внести в DEEP лог.номера }
var I,L : integer; { настраиваемых селекторов }
C : String;
begin while S <> '' do
if NORC(C,S) then begin { C='nnn.*' ? }
L:=Pos('.',C);
if 0 < L then begin
C[0]:=chr(L-1);
if OnlyNumb(C,-1) then begin
Val_Int(C,L,I);
if I = 0 then
if L <= FogMed then DEEP[L]:=L
end
end
end
end;
function SameGr(M : integer) : boolean; { Селекторы одной группы ? }
var I,J,K,N : integer;
begin SameGr:=false;
while 0 < M do begin
N:=0;
K:=0;
for I:=1 to L do begin
if DEEP[I] = M then begin
J:=GENS[I];
if K = 0 then K:=J; { Первый раз }
if K <> J then Exit; { Плохой случай }
if 0 < M then GENS[I]:=PthMed[J]
else GENS[I]:=0
end;
DEEP[I]:=M-1;
if N < DEEP[I] then N:=DEEP[I]
end;
M:=N { Новый Max глубины }
end;
SameGr:=true
end;
begin INIT_BASEL:=1;
FACE_FMS.BASEL:='';
if NoGru then Exit;
F:='';
while (not eof(F_text)) and (F <> 'LOAD') do begin
Readln(F_text,F);
TwoPress(F);
end;
FillChar(DEEP,SizeOf(DEEP),0);
while From_To(F,T) do
if PFT then DEAL(F)
else DEAL(T);
L :=0; { Количество лог.полей }
DEF[0]:=0; { Max глубина вложенности }
for I:=1 to FogMed do
if DEEP[I] <> 0 then begin
FISQ_HABOPOT(I,ABC);
if 0 < ABC[0] then begin
L:=L+1;
DEEP[L]:= ABC[0]; { Глубина }
GENS[L]:=PthMed[I]; { Самый внутренний генератор }
if DEF[0] < ABC[0] then DEF:=ABC { Наворот Max глубины }
end
end;
if not SameGr(DEF[0]) then begin { Обнаружены селекторы }
Cls_Text(F_text); { независимых групп }
INIT_BASEL:=0;
Exit
end;
Reset(F_text);
L:=1;
K:=MEAD^.HSF;
for I:=1 to DEF[0] do CXOT(L,K,DEF[I]);
SetDefaultSelector(K);
INIT_BASEL:=K end;
CONST LELE = 40;
VAR T_text : text;
W_text : boolean;
Modifing : boolean; { признак изменений в сообщениии}
function AddrForm(E : LongInt; DKN : integer) : String;
var S : String[LELE];
begin Return_SP(E-(LELE+3)*DKN);
POP(S);
AddrForm:=S end;
function ElemForm(E : LongInt; N,K : integer) : String;
var T : LongInt;
begin T:=Get_SP;
ElemForm:=AddrForm(E,K-N);
Return_SP(T) end;
procedure ErroForm(C : String);
var T : LongInt;
S : String[LELE];
begin T:=Get_SP;
with Glob_Menu do begin
S:=AddrForm(LongInt(Pindx),Kall-Base-Curs);
Codul[Curs]:=0
end;
C:=' '+C;
S:=LappStr(C,12)+Copy(S,13,LELE-12);
PUSH(S,LELE+1);
Return_SP(T) end;
function IFS_LOAD_HALT(Tname : String; VaName : PrName) : String;
var R,I : integer;
begin R:=IFS_LOAD(Tname,VaName);
if (400 <= R) and (R <= 499) then begin
EmpWin(1,1,80,25,$4F);
for I:=2 to 24 do OnScrCYA(I,$4F,'SFM-2: Фатальная ошибка при '+
'попытке создать в сообщении '+
'новые группы полей');
BornServ('Повторная Загрузка',Name_Of_File);
Good_HALT(R) { OPEN_FMS }
end;
IFS_LOAD_HALT:=NNN(R) end;
procedure IFS_LOAD_PLUS(Tname : String; VaName : PrName);
begin Tname:=IFS_LOAD_HALT(Tname,VaName);
if Tname = '0' then begin
ErroForm('=выполнено=');
Modifing:=true
end else ErroForm('*отказ '+Tname) end;
function Open_DBF(var S : String; Rw : boolean) : boolean;
begin OpnDeB(S,Rw);
Open_DBF:=false;
if DeBi.Errors = 0 then Open_DBF:=true
else ErroForm('*нет БД*') end;
{ NameForm : '' | имя файла }
function NameForm(E : LongInt; N,K : integer) : String;
var S : String;
begin S:=ElemForm(E,N,K);
LimitStr(S,12);
if S[1] = ' ' then S:='' else begin
Psps(S);
N:=Pos(' ',S);
if 0 < N then S[N]:='.';
LefPress(S)
end;
NameForm:=S end;
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;; Menu_F04 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
{ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; }
procedure BornElem_F04(O : pMenuRec; H,K : integer);
var I : integer;
S : String;
begin with O^ do
for I:=H to K do begin
S:=ElemForm(LongInt(Pindx),Base+I,Kall);
OnScrXYA(Mafi.XH+1,Mafi.YH+I-1,CoMa,S)
end end;
procedure ElseBody_F04(O : pMenuRec);
begin with O^ do begin
if Teke = F1 then Help_Win(2,'EF4');
Rend:=(Teke = ESC) or (Teke = Enter)
end end;
procedure MenuBody_F04(O : pMenuRec);
begin MenuBody_All(O,ElseBody_F04) end;
procedure Menu_Hch;
var T : LongInt;
begin T:=Get_SP;
PUSH(SCR,SizeOf(SCR));
PUSH(Glob_Menu,SizeOf(Glob_Menu));
CuSh(false);
Move(T,Glob_Menu.Pindx,4) end; { Конец элементов меню }
procedure AboutGroup;
var S : String[80];
C : String[16];
I : integer;
begin C:=BASEL;
S:='';
for I:=1 to Length(C) do S:=S+'.'+NNN(ord(BASEL[I]));
if S <> '' then begin
S[1]:='<';
OnScrCYA(19,SVpam,'Группа: '+S+'>')
end end;
procedure Menu_Bgn(C : String);
var L : integer;
begin Menu_Hch;
with Glob_Menu do begin
CoMa:=$20; {SVpam;}
CoCu:=SVbar;
L:=LELE div 2 + 2;
RescFul(Mafi,40-L,5,41+L,00);
if BASEL = '' then Mafi.YK:=18
else Mafi.YK:=19;
RescWit(Mafi,CoMa);
AboutGroup;
RescExt(Mafi,-1, 0);
Mafi.YK:=18;
RescPAM(Mafi,CoMa,Wodul);
RescExt(Mafi,-1,-1);
with Mafi do begin
COEXYY(XH+13,YH-1,YK+1);
RescFul(Grad,XK+1,YH,XK+1,YK);
XK:=XK-1;
OnScrCYA(YH-1,CoMa,C)
end;
Curs:=1
end end;
function Menu_All(K : integer; MenuBody_Fnn : TypeBody) : integer;
begin if K = 0 then begin
OnScrCYA(11,aGLOB^.CoMa,'Не обнаружены');
PressAnyKey
end else begin
MenuInit(aGlob,K);
MenuRun (aGlob,CodeElem_All,
BornElem_F04,
KillElem_All,
BornCurs_All,
MenuBody_Fnn);
with Glob_Menu do
if Teke = Enter then K:=Base+Curs
else K:=0
end;
Menu_All:=K;
POP(Glob_Menu);
POP(SCR);
CuSh(true) end;
function INFORMAT : boolean;
var K,N,X,Y : integer;
C : String;
T : LongInt;
begin X:=WhereX;
Y:=WhereY;
T:=Get_SP;
C:=DIRS[OWN]+'\FORMS.MGE\';
K:=EXPO_FORD(C,'SCREEN_FORM',LELE);
if K = 1 then N:=1 else begin
Menu_Bgn(' Формы ввода ');
N:=Menu_All(K,MenuBody_F04)
end;
if 0 < N then C:=C+NameForm(Get_SP,N,K);
Return_SP(T);
INFORMAT:=false;
if 0 < N then begin
Wite_Gey;
if OpenText(C) then INFORMAT:=ALT_FORM(INIT_BASEL(false),C)
end;
Goto_Scurs(X,Y) end;
procedure Wrt_Text(var S : String);
begin if not W_text then Exit;
{$I-} writeln(T_text,S);
{$I+} W_text:=(IOresult = 0) end;
{ TakeSubf : C - селектор }
{ Res = '' | значение, введенное в поле }
procedure TakeSubf(var C : String);
var H : pHead;
N : integer;
begin if Pth_Load(C,false,H,N)
then UnoStr(C,H,N,false)
else C:='' end;
{ FIRVAL : S - строка TO }
{ RES = строка-значение }
function FIRVAL(S : String) : String;
var V,C : String;
begin V:=''; { V - значение }
while S <> '' do begin
if NORC(C,S) then begin
DefaultSelector(C);
TakeSubf(C)
end;
V:=V+C
end;
FIRVAL:=V end;
{ LNR : F - строка FROM | строка TO }
{ = количество имен в строке }
{ + F = ЛевыйКонтекст+ПравыйКонтекст+Имя+ if Res = 0 | 1 }
{ в противном случае значение F неопределено }
function LNR(var F : String) : integer;
var LC,NM,RC,C : String;
N : integer;
begin LC:='';
NM:='';
RC:='';
N:=0;
while F <> '' do { Счетчик имен }
if NORC(C,F) then begin N:=N+1; NM:= C end
else if N = 0 then LC:=LC+C
else RC:=RC+C;
LNR:=N;
SummStr(F,LC);
SummStr(F,RC);
SummStr(F,NM) end;
procedure KillCont(var S,F : String);
var C : String;
L,K : integer;
procedure Fins;
begin if Fin_Str(C,F) then;
L:=Length(C)
end;
begin Fins;
if Pos(C,S) = 1 then Delete(S,1,L);
Fins;
K:=Length(S)+1-L;
if Copy(S,K,L) = C then Delete(S,K,L);
Fins;
F:=C end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
function ParEmp(S : String) : String;
begin ParEmp:='' end;
function ParDBF(S : String) : String;
var K : integer;
begin ParDBF:='';
K:=NmbFld(S);
if 0 < K then begin
RdsFld(K,S);
LefPress(S);
if DeBi.Errors <> 0 then S:='';
if TypFld(K) = 'D' then
if Length(S) = 8 then Delete(S,1,2); { Обработка дат !!! }
ParDBF:=S
end end;
{ FOREST : S - значение параметра RESTR }
{ Сформировать массив ограничений LEREST }
procedure FOREST(S : String);
var I,N : integer;
L : LongInt;
C : String;
begin FillChar(LEREST,SizeOf(LEREST),0);
S:=S+' ';
Psps(S);
N:=0;
while Fin_Str(C,S) do begin
N:=N+1;
Val(C,L,I);
if I = 0 then
if 0 < L then
if L < 256 then LEREST[N]:=L
end end;
{ KeyDBF - Информация о ключевых полях }
TYPE KeyDBF = record CKO : integer; { Количество }
NUF : array [1..10] of integer; { Номера }
LEC : String; { Левые контексты }
RIC : String; { Правые контексты }
SLC : String; { Селекторы полей }
end;
function ReadNumbFlds(var F : integer) : boolean;
var S : String;
begin ReadNumbFlds:=false; { ReadNumbFlds = FALSE - }
if eof(F_text) then Exit; { конец раздела FIELD }
Readln(F_text,S); { TRUE - прочитана оч.строка }
TwoPress(S); { + F = -1 | NmbFld }
if S = 'LOAD' then Exit;
ReadNumbFlds:=true;
F:=-1;
if Pos('RESTR:',S) = 1 then begin
Delete(S,1,6);
FOREST(S);
Exit
end;
if Pos('FIELD:',S) = 1 then begin
Delete(S,1,6);
LefPress(S);
F:=NmbFld(S)
end end;
{ LoadKeys - заполнить структуру KeyDBF }
procedure LoadKeys(var RK : KeyDBF);
var S,G : String;
I,F : integer;
function InNUF(C : String) : boolean;
var I : integer;
begin F:=NmbFld(C);
with RK do
for I:=1 to CKO do
if abs(NUF[I]) = F then begin
InNUF:=true;
F:=I;
Exit
end;
InNUF:=false
end;
procedure PrStr(var C : String);
var I : integer;
begin S:='';
with RK do
for I:=1 to CKO do
if 0 < NUF[I] then SummStr(S,NumbStr(I,C));
C:=S
end;
begin with RK do begin
CKO:=0;
LEC:='';
RIC:='';
SLC:='';
FillChar(LEREST,SizeOf(LEREST),0);
while ReadNumbFlds(F) do
if (0 < F) and (CKO < 10) then begin
CKO:=CKO+1;
NUF[CKO]:=-F
end;
while (0 < CKO) and From_To(S,G) do
if (LNR(S) = 1) and (LNR(G) = 1) then
if InNUF(NumbStr(3,S)) then begin
G:=NumbStr(3,G);
DefaultSelector(G);
NUF[F]:=abs(NUF[F]);
ExchStr(F,LEC,NumbStr(1,S));
ExchStr(F,RIC,NumbStr(2,S));
ExchStr(F,SLC, G )
end;
PrStr(LEC);
PrStr(RIC);
PrStr(SLC);
F:=0;
for I:=1 to CKO do
if 0 < NUF[I] then begin
F:=F+1;
NUF[F]:=NUF[I];
end;
CKO:=F
end end;
{ Превратить в KeyDBF.SLC N-й селектор в его чистое значение }
procedure Val_Key(var RK : KeyDBF; N : integer);
var S,C : String;
L,K : integer;
begin with RK do begin
S:=NumbStr(N,SLC); { Селектор }
TakeSubf(S); { Значение }
C:=NumbStr(N,LEC);
L:=Length(C);
if Pos(C,S) = 1 then Delete(S,1,L);
C:=NumbStr(N,RIC);
L:=Length(C);
K:=Length(S)+1-L;
if Copy(S,K,L) = C then Delete(S,K,L);
ExchStr(N,SLC,S)
end end;
CONST C60 = 68;
{ LoaDBF : Подготовить меню выбора записи в DBF-файле }
{ Res = M - ширина меню (к-во символов); }
{ Lr - количество записей - число эл-тов }
{ Сu - позиция курсора }
function LoaDBF(var M,Lr,Cu : integer) : String;
var I,J,K,L,F,Nr,Mr : integer;
S,G : String;
LeF : array [ 1..10] of integer;
ASC : array [10..12] of LinSCR;
FS : String[C60];
RK : KeyDBF;
procedure HOMEP(N : integer);
var S : String[30];
begin S:=Csps(8)+NNN(N)+Csps(8);
while 7 < Length(S) do begin
Delete(S, 1 ,1);
Delete(S,Length(S),1)
end;
OnScrCYA(11,SVpam,S)
end;
function SOLUTION(F,R : integer) : integer; { Вычислить }
begin if R = 0 then SOLUTION:=F { длину }
else if F < R then SOLUTION:=F { представления }
else SOLUTION:=R { поля }
end;
begin for I:=10 to 12 do ASC[I]:=SCR[I];
OnScrCYA(10,SVpam,' +---- БД ----+ ');
OnScrCYA(11,SVpam,' | | ');
OnScrCYA(12,SVpam,' +------------+ ');
FS:=''; { Имена полей }
LoadKeys(RK);
Cls_Text(F_text);
with RK do begin
K:=0; { Количество полей для показа на экране }
M:=0; { Количество позиций, занятых на экране }
J:=0; { Количество позиций - органичитель цикла }
for I:=1 to CKO do
if J <= C60 then begin
L:=SOLUTION(LenFld(NUF[I]),LEREST[I]);
J:=M+L+1;
if J <= C60 then begin
K:=I;
LeF[K]:=L;
NamFld(NUF[I],S);
FS:=FS+' '+LappStr(S,L); { Список имен полей }
M:=J
end
end;
if K = 0 then begin
K:=1;
if CKO = 0 then NUF[1]:=1;
L:=LenFld(NUF[1]);
if L < C60 then LeF[1]:=L
else LeF[1]:=C60-1;
NamFld(NUF[1],S);
FS:=' '+LappStr(S,LeF[1]); { Список имен полей }
M:=LeF[1]+1
end;
Delete(FS,1,1);
for I:=1 to CKO do Val_Key(RK,I);
if 32760 < DeBi.LogRec then Mr:=32760
else Mr:=DeBi.LogRec;
HOMEP(Mr); { Mr - осталось нерассмотренных записей }
Lr:=0; { Количество неудаленных записей }
Nr:=0; { Физический номер очередной записи }
Cu:=0;
while 0 < Mr do begin { Пока имеем нерассмртренные записи }
Nr:=Nr+1;
Mr:=Mr-1;
if ((Mr mod 10) = 0) or (Mr <= 10) then HOMEP(Mr);
G:='';
AdrRec(Nr);
if ExiRec then begin
Lr:=Lr+1;
G:='';
for J:=1 to K do begin
RdsFld(NUF[J],S);
LefPress(S);
if TypFld(NUF[J]) = 'D' then { ДАТА! }
if Length(S) = 8 then S:=Csps(2)+Copy(S,3,6);
G:=G+' '+LappStr(S,LeF[J])
end;
ComPress(G);
if G = '' then begin { G:=' Запись N '+NNN(I); }
for J:=1 to M do G[J]:='/';
G[0]:=chr(M)
end;
G:=LappStr(G,M)+chr(Hi(Nr))+chr(Lo(Nr));
Delete(G,1,1);
PUSH(G,M+2);
if Cu = 0 then
for J:=1 to CKO do begin
RdsFld(NuF[J],S);
LefPress(S);
UpCaseStr(S);
if S = NumbStr(J,SLC) then Cu:=I
end
end
end
end;
if Cu = 0 then Cu:=1;
ClsDeB;
for I:=10 to 12 do SCR[I]:=ASC[I];
LoaDBF:=FS end;
{ SeleReco : C - имя DBF-файла }
{ Res = 0 | Номер поля }
function SeleReco(var C : String) : integer;
var K,F,M,L,J : integer;
S,G : String;
FS : String[C60];
Q : LongInt;
begin SeleReco:=0;
Q:=Get_SP;
if not Open_DBF(C,true) then begin
Cls_Text(F_text);
Exit
end;
FS:=LoaDBF(M,K,J);
{ M - Ширина меню }
{ K - Количество элементов меню }
{ J = 0 | Позиция курсора }
if K = 0 then begin
ErroForm('*пустая БД*'); { В БД нет записей }
Exit
end;
Menu_Hch;
with Glob_Menu do begin
if M < 24 then M:=24;
L:=M div 2 + 3;
CoMa:=SVpam; { $21; }
CoCu:=SVbar;
RescFul(Mafi,40-L,{7}3,41+L,23);
RescWit(Mafi,CoMa);
RescExt(Mafi,-1, 0);
RescPAM(Mafi,CoMa,Wodul);
with Mafi do begin
COEXXY(XH,XK,21);
RescInc(Mafi,+1,+2,-1,-3);
EmpWin(XH+1,22,XK-8,22,$0E);
OnScrXYA(XK-6,22,CoMa,'Ctrl+L');
OnScrXYA(XK-6,23,CoMa,'Ctrl+S');
RescFul(Grad,XK+1,YH,XK+1,YK);
XK:=XK-1;
OnScrCYA( YH-2,CoMa,' Выбор записи ');
OnScrXYA(XH+1,YH-1,{ $2E }(SVpam and $F0) or $0E,FS)
end
end;
MenuInit(aGlob,K);
AddrCurs(aGlob,J);
CuSh(true);
EXPO_MENU; { EXPO_FMS }
CuSh(false);
with Glob_Menu do
if Teke = Enter then SeleReco:=Curs;
POP(Glob_Menu);
POP(SCR);
Return_SP(Q) end;
{ OpenMenuText : Открыть F_text, указанный в меню }
{ XXX - номер директории }
{ C - полное имя файла }
function OpenMenuText(var C : String; XXX : integer) : boolean;
begin Wite_Gey;
OpenMenuText:=false;
with Glob_Menu do
C:=NameForm(LongInt(Pindx),Base+Curs,Kall);
if C <> '' then begin
C:=DIRS[XXX]+C;
OpenMenuText:=OpenText(C)
end end;
procedure Load_F06;
var F : integer;
C,S : String;
begin if not OpenMenuText(C,SHB) then Exit;
if INIT_BASEL(false) < 1 then begin
ErroForm('*НепрСел-ры');
Exit
end;
if not FORT('DBF :',S) then begin { Простой загрузчик }
IFS_LOAD_PLUS('',ParEmp);
Cls_Text(F_text);
Exit
end;
F:=SeleReco(S); { Загрузка из БД }
if 0 < F then { F - номер записи }
if Open_DBF(S,true) then begin
AdrRec(F);
if DeBi.Errors = 0 then IFS_LOAD_PLUS(C,ParDBF) { Open + Close for F_text }
else ErroForm('*Нет записи');
ClsDeB
end end;
procedure ElseBody_F06(O : pMenuRec);
begin with O^ do
case Teke of
F1 : Help_Win(2,'EF6');
ESC : Rend:=true;
Enter : Load_F06
end end;
procedure MenuBody_F06(O : pMenuRec);
begin MenuBody_All(O,ElseBody_F06) end;
function IMPORTer : boolean;
var T : LongInt;
K : integer;
begin Modifing:=false;
T:=Get_SP;
K:=EXPO_FORD(DIRS[SHB],'INPUT',LELE);
Menu_Bgn(' Импорт данных из: ');
K:=Menu_All(K,MenuBody_F06);
IMPORTer:=Modifing;
Return_SP(T) end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
function Fld_SP(P : integer) : LongInt;
var R : LongInt;
begin with DeBi do begin
R:=Get_SP - Colly[NumCol+1]+1 - 3*NumCol; { SP - начало }
R:=R+abs(Colly[P+1])-1 + 3*P
end;
Fld_SP:=R end;
{ Wr_Rec : Процедура записи строки S в поле C }
procedure Wr_Rec(var C,S : String);
var F : integer;
T : LongInt;
G : String;
begin F:=NmbFld(C);
if F < 1 then Exit;
T:=Get_SP;
Return_SP(Fld_SP(F-1)); { -1 т.к. запись! }
F:=LenFld(F);
G:=Copy(S,1,F); ComPress(G);
Delete(S,1,F);
PUSH(G,F+1);
Return_SP(T) end;
{ VALY : N - номер поля; }
{ RES = Строка-значение }
{ UKV True - если значение не задано }
function VALY(N : integer; var UKV : boolean) : String;
var R : LongInt;
S : String;
begin R:=Get_SP;
Return_SP(Fld_SP(N));
POP(S);
Return_SP(R);
VALY:=S;
UKV:=(Length(S) = 255) end;
{ Rd_Pth : значение подполя, заданного селектором }
function Rd_Pth(S : String) : String;
var H : pHead;
N : integer;
C : String;
begin Rd_Pth:='';
DefaultSelector(S);
C:=S;
if Pth_Audi(S) = 0 then
if Pth_Load(C,false,H,N) then begin
UnoStr(C,H,N,false);
Rd_Pth:=C
end end;
{ Find_Rec = false, если такая запись уже имеется }
Type TYFD = array [0..128] of byte;
function Find_Rec(var FD : TYFD; F : integer) : boolean;
var S,C,G : String;
I : integer;
W,V : boolean;
T : LongInt;
begin S:=VALY(F,V);
T:=0;
repeat
T:=FndRec(T+1,S,F);
W:=(0 < T);
for I:=F+1 to FD[0] do
if W then begin
C:=VALY(FD[I],V);
if not V then begin
RdsFld(FD[I],G);
LefPress(G);
UpCaseStr(G);
W:=(G = C) { W - запись найдена }
end
end;
until W or (T < 0);
Find_Rec:=W end;
procedure FoReCo(var S : String);
var I,F : integer;
V,W : boolean;
FD : TYFD;
R : LongInt;
T : String;
procedure FUDB(F : integer);
var I : integer;
V : boolean;
begin for I:=F to DeBi.NumCol do begin
S:=VALY(I,V);
if not V then WrtFld(I,S,'S')
end;
ErroForm('=выполнено=')
end;
begin if not Open_DBF(S,false) then begin { FALSE - для записи !!! }
Cls_Text(F_text);
Exit
end;
FillChar(LEREST,SizeOf(LEREST),0);
FD[0]:=0; { Составить список ключевых полей }
while ReadNumbFlds(F) do
if 0 < F then begin
Inc(FD[0]);
FD[FD[0]]:=F
end;
R:=Get_SP; { Создать пустую запись в SP }
S[0]:=chr(255); { Признак незадействованного поля }
for I:=1 to DeBi.NumCol do PUSH(S,LenFld(I)+1);
while From_To(S,T) do UniTra(S,T,Rd_Pth,Wr_Rec);
Cls_Text(F_text);
if FD[0] = 0 then begin { Архивное сохранение без ключей }
FD[0]:=DeBi.NumCol;
for I:=1 to FD[0] do FD[I]:=I;
F:=0;
repeat
F:=F+1; { Поиск первого заполненного поля }
T:=VALY(F,V); { F - номер; S - значение }
W:=not V;
until W or (FD[0] <= F);
if not W then ErroForm('*пуст.зап*')
else
if Find_Rec(FD,F) then ErroForm('=повтор=') else begin
NewRec;
FUDB(F)
end
end else begin { Запись по ключу }
W:=true;
for I:=FD[0] downto 1 do
if W then begin
T:=VALY(I,V);
W:=not V
end;
if not W then ErroForm('*нек.ключ*') else begin
if not Find_Rec(FD,1) then NewRec;
FUDB(1)
end
end;
Return_SP(R);
ClsDeB;
Init_Gey end;
procedure Load_F05;
var S : String;
F : integer;
begin if OpenMenuText(S,RDY) then begin
if INIT_BASEL(true) < 1 then begin { Настройка селекторов }
ErroForm('*НепрСел-ры'); { (FROM) по умолчанию }
Exit
end;
if FORT('DBF :',S) then FoReCo(S)
else Cls_Text(F_text)
end end;
procedure ElseBody_F05(O : pMenuRec);
begin with O^ do
case Teke of
F1 : Help_Win(2,'EF5');
ESC : Rend:=true;
Enter : Load_F05
end end;
procedure MenuBody_F05(O : pMenuRec);
begin MenuBody_All(O,ElseBody_F05) end;
procedure EXPORTer;
var T : LongInt;
K : integer;
begin T:=Get_SP;
K:=EXPO_FORD(DIRS[RDY],'OUTPUT',LELE);
Menu_Bgn(' Экспорт данных в: ');
K:=Menu_All(K,MenuBody_F05);
Return_SP(T) end;
{;;;;;;;;;;;;;;;;; Основные блоки загрузки по ключу ;;;;;;;;;;;;;;;;;;;;;;;;}
{ FindKparam : S (до) - селектор }
{ Res : True, если п/поле - ключевое }
{ + S (после) - имя параметра из Config.sfm }
function FindKparam(var S : String) : boolean;
var H : pHead;
K,N : integer;
begin FindKparam:=false;
if Pth_Load(S,false,H,N) then
with H^.BDS[N] do begin
if VRF = NIL then Exit;
S:='/'+VRF^;
UpCaseStr(S);
K:=Pos('/KEY/',S); if K = 0 then Exit;
Delete(S,1,K+4);
K:=MinPos('/',S);
S[0]:=chr(K-1); FindKparam:=(S <> '')
end end;
{ LoadKfile : S - Имя файла загрузки по ключу }
{ PTH - Селектор ключевого п/поля }
{ LProc - Процедура загрузки F_Text -> Message }
{ Res : 0 - O'K }
{ 2|3|4|5|6|7 - коды ошибок см. INKEYSER }
function LoadKfile(var S,PTH : String; LProc : LoadProc) : integer;
var K,E : integer;
RK : KeyDBF;
function MyNumb(C : String) : boolean;
begin MyNumb:=true;
K:=0;
while Fin_Str(S,C) do begin
K:=K+1;
if S = PTH then Exit
end;
MyNumb:=false
end;
begin E:=0;
if not FindFile(S) then E:=2 else
if not OpenText(S) then E:=3 else
if INIT_BASEL(false) < 1 then E:=8 else begin
if not FORT('DBF :',S) then E:=4 else begin
OpnDeB(S,true);
if DeBi.Errors <> 0 then E:=5 else begin
LoadKeys(RK);
if not MyNumb(RK.SLC) then E:=6 else begin
Val_Key(RK,K);
S:=NumbStr(K,RK.SLC);
if FndRec(1,S,RK.NUF[K]) < 0 then E:=7
else LProc
end;
ClsDeB
end
end;
Cls_Text(F_text)
end;
LoadKfile:=E end;
procedure LoadKrecrd;
begin if IFS_LOAD_HALT('',ParDBF) = '' then;
Init_Gey;
B_Ha_Gey(903) end;
{ INKEYSER : PTH - селектор подполя }
procedure INKEYSER(PTH : String);
var E : integer;
S : String;
SC : array [1..3] of LinSCR;
begin Wite_Gey;
S:=PTH;
if not FindKparam(S) then Exit;
Move(SCR[10],SC,3*SizeOf(LinSCR));
OnScrCYA(10,SVpam,' +-------------------+ ');
OnScrCYA(11,SVpam,' | Загрузка по ключу | ');
OnScrCYA(12,SVpam,' +-------------------+ ');
if SiConfig_RP(S) then E:=LoadKfile(S,PTH,LoadKrecrd)
else E:=1;
Move(SC,SCR[10],3*SizeOf(LinSCR));
case E of
0 : Exit;
1 : S:='В Config.sfm нет параметра: '+S;
2 : S:='Нет файла: '+S;
3 : S:='Не могу открыть файл: '+S;
4 : S:='В шаблоне не указан DBF-файл';
5 : S:='Не могу открыть DBF-файл: '+S;
6 : S:='В шаблоне не указано ключевое поле: '+S;
7 : S:='Не найден ключ: '+S;
8 : S:='Неправильные селекторы';
end;
Terr_Gey(NIL,0,S) end;
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;; Full_F07 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;}
{ Full_F07 = 0 | НомерПоляДляУстановки курсора }
function Full_F07 : integer;
var Tn,S,Pr,Ar : String;
F,R : integer;
T : LongInt;
procedure DELETES;
var H : pHead;
N : integer;
begin F:=abs(FITEK);
while not eof(F_text) do begin
Readln(F_text,S);
if Pth_Load(S,true,H,N) then begin
GrandCorr:=true;
S:='';
Val_Load(S,H,N);
N:=abs(FITEK);
if N < F then F:=N
end
end;
Full_F07:=F;
Cls_Text(F_text);
WritField
end;
begin Full_F07:=0;
Cush(false);
if not GATA
then SHOM_CR('Отказ: Сообщение заполнено некорректно')
else begin
PUSH(SCR,SizeOf(SCR));
Wite_Gey;
T:=Get_SP;
Tn:=DIRS[TMR];
if Crunf(Tn) then R:=Spec_F07(Tn) { OVER_FMS}
else R:=1;
if R <> 0
then SHOM_CR('Ошибка чтения-записи на HD.')
else begin
Pr:=DIRS[OWN]+'MGE_'+MESSAGE^.ABB+'.EXE';
Ar:=Tn+' X(*';
{ex-Full_Exec}R:=Call_Exec(Pr,Ar); { R:=DosError }
if R <> 0
then SHOM_CR('Ошибка вызова MGE_nnn.EXE, DosError = '+NNN(R))
else if DosExitCode = 0 then begin
if OpenText(Tn)
then DELETES
else SHOM_CR('Некорректный выход из MGE_nnn.EXE');
KEYS_FMS.SKY:=true
end
end;
KillFile(Tn);
Return_SP(T);
POP(SCR)
end;
Cush(true) end;
end.
procedure INIT_BASEL; { Настроить процедуру DefaultSelector }
var F,L : integer; { на подстановку наворота по умолчанию }
ABC : TYPE_HABOPOT;
S : String[16];
begin F:=abs(FITEK);
L:=MEAD^.BDS[F].LFT;
FISQ_HABOPOT(L,ABC); { D_INIT }
MACC_HABOPOT(F,ABC); { OVER_FMS }
S:='';
for L:=1 to ABC[0] do S:=S+chr(ABC[L]);
FACE_FMS.BASEL:=S end;
|