home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / Samples / MCUNIT10.ARJ / MCMENU10.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-02-17  |  51.4 KB  |  1,580 lines
  1. {*******************************************************************************
  2. *   Unit name: MCMENU10 interface
  3. *      Author: Martin CEKAL
  4. *        Date: February 2, 1993
  5. *     Version: 1.1
  6. *     Purpose: put, delete and handle with windows(menu) and status line
  7. ********************************************************************************}
  8. Unit MCMENU10;
  9.  
  10. interface
  11.  
  12. uses dos;
  13.  
  14. type
  15.   { type Win - window(menu) definition }
  16.   pnt = record                    { other windows's parametres }
  17.     xr,yb:integer;                { right-down corner }
  18.     pos:1..16;                    { actual position in list }
  19.     p,q:array[1..16] of byte;     { scan codes of hot keys }
  20.     p_menu:pointer;               { pointer to saved screen }
  21.     xms_ok:boolean;               { screen succesfully in XMS }
  22.     handle:word;                  { handle for XMS }
  23.   end;
  24.  
  25.   Point  = ^pnt;                   { pointer to other window's parametres }
  26.   PtrWin = ^Win;                   { pointer to window }
  27.   aWin = array[1..12] of PtrWin;   {array of Win}
  28.  
  29.   { array of lines (items) }
  30.   it = record
  31.      case u:boolean of                   { used/unused item }
  32.        true:(text:string[50];            { text of item (left justified) }
  33.              enable:boolean;             { enable/disable item }
  34.        case k:1..5 of                    { type of item }
  35.          2:(yes:boolean);                { switch Yes/No }
  36.          3:(n,i:byte;                    { n:number of items; i:position in list }
  37.            a:array[1..8] of string[5]);  { swith among "a" items }
  38.          4:(v,min,max:real;              { edit of number "v"; min,max:range }
  39.            lv,d:shortint);               { lv:lenght; d:decimals }
  40.          5:(s:string[50];ls:shortint));  { edit of string "s"; ls:lenght }
  41.   end; 
  42.  
  43.   { main body of Win }
  44.   Win = record
  45.     x,y:integer;            { left up corner of window }
  46.     ni:1..16;               { number of lines (items) }
  47.     vert:boolean;           { orientation =true:vertical }
  48.     titl:string[50];        { title of window }
  49.     hlp:PtrWin;             { pointer to help window }
  50.     pt:Point;               { pointer to other parametres of window }
  51.     its:array[1..16] of it; { array of lines (items) }
  52.   end;
  53.  
  54.   fWin = file of Win;              {file of Win}
  55.  
  56.   xms = record                {XMS info structure}
  57.     xms_ok,in_conv:boolean;   {xms_ok: XMS succesfully used;
  58.                               in_conv: flag if the win is in conventional memory}
  59.     handle:word;              {unique handler}
  60.     pw:ptrwin;                {pointer to window}
  61.   end;
  62.   pxms=^xms;                  {pointer to XMS info structure}
  63.  
  64.   { full name of file }
  65.   fname = record
  66.     s:string[50]; {define name of file}
  67.     p:pathstr;    {path}
  68.     d:dirstr;     {directory}
  69.     n:namestr;    {name}
  70.     e:extstr;     {.extension}
  71.     chg:boolean;  {change name(s) }
  72.     io:boolean;   {I/O O.K.}
  73.   end;
  74.  
  75.   { array of items }
  76.   stl = record
  77.      case u:boolean of                 { used/unused item }
  78.        true:(ltext,rtext:string[10];   { text of item (ltext-hotkey) }
  79.              code:word;                { code of key(s) }
  80.              enable:boolean);          { enable/disable item }
  81.   end;
  82.  
  83.   { main body of StatLine }
  84.   StLine = record
  85.     ni:1..5;                 { number of lines (items) }
  86.     pt:pointer;              { pointer to other saved screen }
  87.     its:array[1..5] of stl;  { array of items }
  88.   end;
  89.  
  90. var
  91.   init_mouse:byte;
  92.  
  93. {*******************************************************************************
  94. *        Name: RegWin
  95. *  Parametres: MyWin:Win
  96. *              PWin:PtrWin      pointer to window
  97. *        Date: June 26, 1992
  98. *     Version: 1.0
  99. *     Purpose: Load variable MyWin:Win to the heap
  100. ********************************************************************************}
  101. procedure RegWin(MyWin:Win; var PWin:PtrWin);
  102.  
  103. {*******************************************************************************
  104. *        Name: UnregWin
  105. *  Parametres: PWin:PtrWin      pointer to window
  106. *        Date: January 14, 1993
  107. *     Version: 1.0
  108. *     Purpose: Free the heap
  109. ********************************************************************************}
  110. procedure UnregWin(PWin:PtrWin);
  111.  
  112. {*******************************************************************************
  113. *        Name: RegWinXMS
  114. *  Parametres: MyWin:Win
  115. *              px:pxms      pointer to XMS info structure
  116. *        Date: February 2, 1993
  117. *     Version: 1.0
  118. *     Purpose: Load variable MyWin:Win to the XMS heap
  119. ********************************************************************************}
  120. procedure RegWinXMS(MyWin:Win;var px:pxms);
  121.  
  122. {*******************************************************************************
  123. *        Name: UnregWinXMS
  124. *  Parametres: px:pxms      pointer to XMS info structure
  125. *        Date: February 2, 1993
  126. *     Version: 1.0
  127. *     Purpose: Free the XMS heap
  128. ********************************************************************************}
  129. procedure UnRegWinXMS(px:pxms);
  130.  
  131. {*******************************************************************************
  132. *        Name: UseWinXMS
  133. *  Parametres: px:pxms      pointer to XMS info structure
  134. *              pwn:PtrWin   pointer to window
  135. *        Date: February 2, 1993
  136. *     Version: 1.0
  137. *     Purpose: Prepares win for usage (moves it from and to XMS)
  138. ********************************************************************************}
  139. procedure UseWinXMS(var px:pxms; var pwn:ptrwin);
  140.  
  141. {*******************************************************************************
  142. *        Name: NewPalete
  143. *  Parametres: desktop,bground,frame,text,dtext,hotkey:byte
  144. *        Date: June 26, 1992
  145. *     Version: 1.0
  146. *     Purpose: Set new colors and redraw backgound
  147. ********************************************************************************}
  148. procedure NewPalete(desktop,bground,frame,text,dtext,hotkey:byte);
  149.  
  150. {*******************************************************************************
  151. *        Name: PutWin
  152. *  Parametres: MyWin:Win   definition of window(menu)
  153. *        Date: June 26, 1992
  154. *     Version: 1.0
  155. *     Purpose: Insert window(menu) to desktop
  156. ********************************************************************************}
  157. procedure PutWin(var MyWin:Win);
  158.  
  159. {*******************************************************************************
  160. *        Name: DelWin
  161. *  Parametres: MyWin:Win   definition of window(menu)
  162. *        Date: June 26, 1992
  163. *     Version: 1.0
  164. *     Purpose: Remove window(menu) from desktop
  165. ********************************************************************************}
  166. procedure DelWin(MyWin:Win);
  167.  
  168. {*******************************************************************************
  169. *        Name: HandleWin
  170. *  Parametres: MyWin:Win   definition of window(menu)
  171. *              Code:byte   position in menu (Esc=0)
  172. *        Date: June 26, 1992
  173. *     Version: 1.0
  174. *     Purpose: Handle with window(menu)
  175. ********************************************************************************}
  176. procedure HandleWin(var MyWin:Win;var code:byte);
  177.  
  178. {*******************************************************************************
  179. *        Name: SaveWin
  180. *  Parametres: fn:fname    name of file
  181. *              n:integer   number of records Win
  182. *              fdat:aWin   array of Win
  183. *        Date: June 26, 1992
  184. *     Version: 1.0
  185. *     Purpose: Save definitions of window(menu) to file
  186. ********************************************************************************}
  187. procedure SaveWin(var fn:fname;n:integer;var fdat:aWin);
  188.  
  189. {*******************************************************************************
  190. *        Name: LoadWin
  191. *  Parametres: fn:fname    name of file
  192. *              n:integer   number of records Win
  193. *              fdat:aWin   array of Win
  194. *        Date: June 26, 1992
  195. *     Version: 1.0
  196. *     Purpose: Load definitions of window(menu) to array fdat
  197. ********************************************************************************}
  198. procedure LoadWin(var fn:fname;n:integer;var fdat:aWin);
  199.  
  200. {*******************************************************************************
  201. *        Name: HandlelStLine
  202. *  Parametres: MyStLine:StLine   definition of status line
  203. *              code:word;        code of key;
  204. *        Date: June 26, 1992
  205. *     Version: 1.0
  206. *     Purpose: Handle with status line
  207. ********************************************************************************}
  208. procedure HandleStLine(MyStLine:StLine;var code:word);
  209.  
  210. {*******************************************************************************
  211. *        Name: DelStLine
  212. *  Parametres: MyStLine:StLine   definition of status line
  213. *        Date: June 26, 1992
  214. *     Version: 1.0
  215. *     Purpose: Delete status line from desktop
  216. ********************************************************************************}
  217. procedure DelStLine(MyStLine:StLine);
  218.  
  219. {*******************************************************************************
  220. *        Name: PutStLine
  221. *  Parametres: MyStLine:StLine   definition of status line
  222. *        Date: June 26, 1992
  223. *     Version: 1.0
  224. *     Purpose: Insert status line to desktop
  225. ********************************************************************************}
  226. procedure PutStLine(var MyStLine:StLine);
  227.  
  228. {*******************************************************************************
  229. *        Name: HandleAll
  230. *  Parametres: MyWin:Win       definition of window(menu)
  231. *              Code:byte       position in menu (Esc=0)
  232. *              MyStLine:StLine definition of sttus line
  233. *              Codest:word     status line code
  234. *        Date: December 20, 1992
  235. *     Version: 1.0
  236. *     Purpose: Handle with all (window+status line)
  237. ********************************************************************************}
  238. procedure HandleAll(var MyWin:Win;var code:byte;
  239.                     var MyStLine:StLine;var codest:word);
  240.  
  241. {*******************************************************************************
  242. *        Name: PrtScreen
  243. *  Parametres: MinX,MaxX,MinY,MaxY:integer  upper left and lower right
  244. *                                           corner of printed window
  245. *              lq:boolean quality of print lq=true  - letter quiality
  246. *                                          lq=false - draft
  247. *        Date: January 10, 1993
  248. *     Version: 1.0
  249. *     Purpose: Print part of screen in graphic mode
  250. ********************************************************************************}
  251. procedure  PrtScreen(MinX,MaxX,MinY,MaxY:integer;lq:boolean);
  252.  
  253. {*******************************************************************************
  254. *   Unit name: MCMENU10 implementation
  255. *      Author: Martin CEKAL
  256. *        Date: February 2, 1993
  257. *     Version: 1.1
  258. *     Purpose: put, delete and handle with windows(menu) and status line
  259. ********************************************************************************}
  260. implementation
  261.  
  262. uses crt,printer,graph,mcmice10,mcxms10;
  263.  
  264. type
  265.   { color palette }
  266.   palete = record
  267.     desktop,bground,frame,    { colors of desktop, back ground, frame, }
  268.     text,dtext,hotkey:byte;   { text, disabled text and hotkeys }
  269.   end;
  270.  
  271.   {information about files in directory}
  272.   afile = record
  273.     ni:byte;                          {number of files in directory}
  274.     first:byte;                       {first file to fill}
  275.     fil:array[1..100] of string[30];  {array of files in directory}
  276.   end;
  277.  
  278. const
  279.   y = true;
  280.   n = false;
  281.   fh = 16;     htitl = 30;
  282.   hofs = 20;   vofs = 10;
  283.   { dafault paltte for monochrome monitor }
  284.   pal_mono:palete=(desktop:1;bground:10;frame:1;text:1;dtext:3;hotkey:15);
  285.   { dafault paltte for color monitor }
  286.   pal_co:palete=(desktop:1;bground:7;frame:0;text:0;dtext:8;hotkey:4);
  287.  
  288.   {error message-out of range}
  289.   Out:win=(x:200;y:100;ni:3;vert:y;titl:'ERROR';hlp:nil;pt:nil;
  290.      its:((u:y;text:'Out of valid range   ';enable:y;k:1),
  291.           (u:y;text:'Valid range is: ';enable:y;k:1),
  292.           (u:y;text:'';enable:y;k:1),
  293.           (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n),
  294.           (u:n),(u:n),(u:n),(u:n),(u:n),(u:n)));
  295.  
  296.   {load file}
  297.   LoadSet:win=(x:50;y:50;ni:3;vert:y;titl:'';hlp:nil;pt:nil;
  298.          its:((u:y;text:'~Change path';enable:y;k:1),
  299.               (u:y;text:'~Previous';enable:y;k:1),
  300.               (u:y;text:'~Next';enable:y;k:1),
  301.               (u:y;text:'N~ew file';enable:y;k:1),
  302.               (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),
  303.               (u:n),(u:n),(u:n),(u:n),(u:n),(u:n)));
  304.  
  305.   {change directory or extension}
  306.   ChgDir:win=(x:200;y:105;ni:2;vert:y;titl:'';hlp:nil;pt:nil;
  307.         its:((u:y;text:'~Directory';enable:y;k:5;s:'';ls:30),
  308.              (u:y;text:'~Extension';enable:y;k:5;s:'';ls:4),
  309.              (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n),
  310.              (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n)));
  311.  
  312.   {help for I/O operations}
  313.   HLoadSet:win=(x:100;y:70;ni:7;vert:y;titl:'Help';hlp:nil;pt:nil;
  314.          its:((u:y;text:'This menu supports I/O operations';enable:y;k:1),
  315.               (u:y;text:'';enable:y;k:1),
  316.               (u:y;text:'"Change path" enable to change path and extension';enable:y;k:1),
  317.               (u:y;text:'"Previos" moves in the list of files back';enable:y;k:1),
  318.               (u:y;text:'"Next" moves in the list of files forward';enable:y;k:1),
  319.               (u:y;text:'"New" enable to enter new name of output file';enable:y;k:1),
  320.               (u:y;text:'Press Enter on file to/from you want read/write';enable:y;k:1),
  321.               (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n)));
  322.  
  323.  
  324.   {information about I/O operation}
  325.   scioe:win=(x:300;y:70;ni:1;vert:y;titl:'';hlp:nil;pt:nil;
  326.          its:((u:y;text:'';enable:y;k:1),
  327.               (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n),
  328.               (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n)));
  329.  
  330.   {input of new filename}
  331.   NewFile:win=(x:200;y:105;ni:1;vert:y;titl:'';hlp:nil;pt:nil;
  332.          its:((u:y;text:'New file';enable:y;k:5;s:'';ls:12),
  333.              (u:y;text:'~Extension';enable:y;k:5;s:'';ls:4),
  334.               (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n),
  335.               (u:n),(u:n),(u:n),(u:n),(u:n),(u:n),(u:n)));
  336.  
  337. var
  338.   pal:palete;
  339.  
  340. {*******************************************************************************
  341. *        Name: MyOrd:longint
  342. *  Parametres: MyStr:string
  343. *        Date: June 26, 1992
  344. *     Version: 1.0
  345. *     Purpose: returns lenght of showed string (without ~ )
  346. ********************************************************************************}
  347. function MyOrd(MyStr:string):longint;
  348. var i,j:integer;
  349. begin
  350.   j:=0;
  351.   for i:=1 to ord(MyStr[0]) do begin
  352.     if MyStr[i] <> '~' then inc(j);
  353.   end;
  354.   MyOrd:=j;
  355. end;
  356.  
  357. {*******************************************************************************
  358. *        Name: RegWin
  359. *  Parametres: MyWin:Win
  360. *              PWin:PtrWin      pointer to window
  361. *        Date: June 26, 1992
  362. *     Version: 1.0
  363. *     Purpose: Load variable MyWin:Win to the heap
  364. ********************************************************************************}
  365. procedure RegWin(MyWin:Win; var PWin:PtrWin);
  366. begin
  367.   new(PWin);
  368.   PWin^:=MyWin;
  369. end; {*** end RegWin ***}
  370.  
  371. {*******************************************************************************
  372. *        Name: UnregWin
  373. *  Parametres: PWin:PtrWin      pointer to window
  374. *        Date: January 14, 1993
  375. *     Version: 1.0
  376. *     Purpose: Free the heap
  377. ********************************************************************************}
  378. procedure UnregWin(PWin:PtrWin);
  379. begin
  380.   dispose(PWin);
  381. end; {*** end UnregWin ***}
  382.  
  383. {*******************************************************************************
  384. *        Name: RegWinXMS
  385. *  Parametres: MyWin:Win
  386. *              px:pxms      pointer to XMS info structure
  387. *        Date: February 2, 1993
  388. *     Version: 1.0
  389. *     Purpose: Load variable MyWin:Win to the XMS heap
  390. ********************************************************************************}
  391. procedure RegWinXMS(MyWin:Win;var px:pxms);
  392. var p:pointer;
  393. begin
  394.   new(px);
  395.   with px^ do begin
  396.     getxms(handle,sizeof(MyWin),xms_ok);
  397.     if xms_ok then begin
  398.       awakepointer(handle,p,xmswritemode);
  399.       move(MyWin,p^,sizeof(MyWin));
  400.       sleeppointer(handle);
  401.     end
  402.     else RegWin(MyWin,pw);
  403.     in_conv:=false;
  404.   end;
  405. end; {*** end RegWinXMS ***}
  406.  
  407. {*******************************************************************************
  408. *        Name: UnregWinXMS
  409. *  Parametres: px:pxms      pointer to XMS info structure
  410. *        Date: February 2, 1993
  411. *     Version: 1.0
  412. *     Purpose: Free the XMS heap
  413. ********************************************************************************}
  414. procedure UnRegWinXMS(px:pxms);
  415. begin
  416.   if px^.xms_ok then freexms(px^.handle);
  417. end; {*** end UnRegWinXMS ***}
  418.  
  419. {*******************************************************************************
  420. *        Name: UseWinXMS
  421. *  Parametres: px:pxms      pointer to XMS info structure
  422. *              pwn:PtrWin   pointer to window
  423. *        Date: February 2, 1993
  424. *     Version: 1.0
  425. *     Purpose: Prepares win for usage (moves it from and to XMS)
  426. ********************************************************************************}
  427. procedure UseWinXMS(var px:pxms; var pwn:ptrwin);
  428. var p:pointer;
  429. begin
  430.   if px=nil then exit;
  431.   with px^ do begin
  432.     if xms_ok then begin
  433.       awakepointer(handle,p,xmsreadwritemode);
  434.       if in_conv then  move(pw^,p^,sizeof(pw^))
  435.       else move(p^,pw^,sizeof(pw^));
  436.       in_conv:=not in_conv;
  437.       sleeppointer(handle);
  438.     end;
  439.     pwn:=pw;
  440.   end;
  441. end; {*** end UseWinXMS ***}
  442.  
  443. {*******************************************************************************
  444. *        Name: NewPalete
  445. *  Parametres: desktop,bground,frame,text,dtext,hotkey:byte
  446. *        Date: June 26, 1992
  447. *     Version: 1.0
  448. *     Purpose: Set new colors and redraw backgound
  449. ********************************************************************************}
  450. procedure NewPalete(desktop,bground,frame,text,dtext,hotkey:byte);
  451. begin
  452.   pal.desktop:=desktop;
  453.   pal.bground:=bground;
  454.   pal.frame:=frame;
  455.   pal.text:=text;
  456.   pal.dtext:=dtext;
  457.   pal.hotkey:=hotkey;
  458.   setbkcolor(desktop);
  459. end; {*** end NewPalete ***}
  460.  
  461. {*******************************************************************************
  462. *        Name: DelWin
  463. *  Parametres: MyWin:Win   definition of window(menu)
  464. *        Date: June 26, 1992
  465. *     Version: 1.0
  466. *     Purpose: Remove window(menu) from desktop
  467. ********************************************************************************}
  468. procedure Delwin(MyWin:Win);
  469. begin
  470.   with MyWin do begin
  471.     setviewport(0,0,getmaxx,getmaxy,clipon);
  472.     if pt^.xms_ok then awakepointer(pt^.handle,pt^.p_menu,xmsreadmode);
  473.     putimage(x,y,pt^.p_menu^,0);
  474.     if pt^.xms_ok then begin
  475.       sleeppointer(pt^.handle);
  476.       freeXMS(pt^.handle);
  477.     end
  478.     else freemem(pt^.p_menu,imagesize(x,y,pt^.xr,pt^.yb));
  479.   end;
  480. end; {*** end DelWin ***}
  481.  
  482. {*******************************************************************************
  483. *        Name: MyReadKey:word
  484. *        Date: June 26, 1992
  485. *     Version: 1.0
  486. *     Purpose: Returns scan code, for extended codes returns code+1000
  487. ********************************************************************************}
  488. function MyReadKey:word;
  489. var c:word;
  490. begin
  491.   c:=ord(readkey);
  492.   if c=0 then c:=ord(readkey)+1000;
  493.   MyReadKey:=c;
  494. end;
  495.  
  496. {*******************************************************************************
  497. *        Name: InsText
  498. *  Parametres: MyWin:Win    definition of window(menu)
  499. *              inv:boolean  true-inverse colors; false-default colors
  500. *              all:boolean  true-whole line; false-right side of line
  501. *        Date: June 26, 1992
  502. *     Version: 1.0
  503. *     Purpose: Insert menu items
  504. ********************************************************************************}
  505. procedure InsText(MyWin:Win;inv,all:boolean);
  506. var
  507.   cb,ct,cdt,ch:word;
  508.   xp,yp,i:integer;
  509.   vals:string;
  510. begin
  511.   if inv then begin
  512.     cb:=pal.text;          ct:=pal.bground;
  513.     cdt:=pal.bground;      ch:=pal.bground;
  514.    end
  515.    else begin
  516.      cb:=pal.bground;      ct:=pal.text;
  517.      cdt:=pal.dtext;       ch:=pal.hotkey;
  518.    end;
  519.    with MyWin do begin
  520.     if vert then begin
  521.       xp:=x+hofs;
  522.       yp:=y+fh*pt^.pos+vofs;
  523.     end
  524.     else begin
  525.       xp:=hofs;
  526.       for i:=1 to (pt^.pos-1) do xp:=xp+MyOrd(its[i].text)*8+hofs;
  527.       yp:=y+fh+vofs;
  528.     end;
  529.     if titl <> '' then yp:=yp+htitl;
  530.     if all then begin
  531.       settextjustify(0,0);
  532.       setcolor(cdt);
  533.       if its[pt^.pos].enable then setcolor(ct);
  534.       for i:=1 to ord(its[pt^.pos].text[0]) do begin
  535.         if its[pt^.pos].text[i] <> '~' then begin
  536.           outtextxy(xp,yp,its[pt^.pos].text[i]);
  537.           xp:=xp+8;
  538.         end
  539.         else begin
  540.           if its[pt^.pos].enable then setcolor(ch);
  541.           inc(i);
  542.           if i <= ord(its[pt^.pos].text[0]) then outtextxy(xp,yp,its[pt^.pos].text[i]);
  543.           xp:=xp+8;
  544.           if its[pt^.pos].enable then begin
  545.             setcolor(ct);
  546.             pt^.p[pt^.pos]:=ord(its[pt^.pos].text[i]);
  547.             pt^.q[pt^.pos]:=pt^.p[pt^.pos];
  548.             if (pt^.p[pt^.pos] >= 65) and (pt^.p[pt^.pos] <= 90) then pt^.q[pt^.pos]:=pt^.p[pt^.pos]+32;
  549.             if (pt^.p[pt^.pos] >= 97) and (pt^.p[pt^.pos] <= 122) then pt^.q[pt^.pos]:=pt^.p[pt^.pos]-32;
  550.           end;
  551.         end;
  552.       end;
  553.     end;
  554.     if its[pt^.pos].enable then setcolor(ct)
  555.     else setcolor(cdt);
  556.     if vert then begin
  557.       settextjustify(2,0);
  558.       xp:=pt^.xr-hofs;
  559.       case its[pt^.pos].k of
  560.         2: if its[pt^.pos].yes then outtextxy(xp,yp,'Yes')
  561.            else outtextxy(xp,yp,'No');
  562.         3: outtextxy(xp,yp,its[pt^.pos].a[its[pt^.pos].i]);
  563.         4: begin
  564.              str(its[pt^.pos].v:0:its[pt^.pos].d,vals);
  565.              outtextxy(xp,yp,vals);
  566.            end;
  567.         5: outtextxy(xp,yp,its[pt^.pos].s);
  568.       end;
  569.     end;
  570.   end;
  571. end; {*** end InsText ***}
  572.  
  573. {*******************************************************************************
  574. *        Name: HandleBar
  575. *  Parametres: MyWin:Win    definition of window(menu)
  576. *              put:boolean  true-insert bar; false-remove bar
  577. *              all:boolean  true-whole bar; false-right part of bar (edit)
  578. *        Date: June 26, 1992
  579. *     Version: 1.0
  580. *     Purpose: Insert and remove bar
  581. ********************************************************************************}
  582. procedure HandleBar(MyWin:Win; put,all:boolean);
  583. const
  584.   hofs1=2;
  585. var
  586.   xl,yt,xr,yb,i:integer;
  587. begin
  588.   with MyWin do begin
  589.     if put then begin
  590.       setfillstyle(1,pal.text);
  591.       setcolor(pal.bground);
  592.     end
  593.     else begin
  594.       setfillstyle(1,pal.bground);
  595.       setcolor(pal.text);
  596.     end;
  597.     if vert then begin
  598.       xr:=pt^.xr-hofs+hofs1;
  599.       yt:=y+fh*pt^.pos-2;
  600.       if all then begin
  601.         xr:=pt^.xr-hofs+hofs1;
  602.         xl:=x+hofs-hofs1;
  603.       end
  604.       else begin
  605.         if its[pt^.pos].k = 4 then xl:=its[pt^.pos].lv*8;
  606.         if its[pt^.pos].k = 5 then xl:=its[pt^.pos].ls*8;
  607.         xr:=pt^.xr-hofs+8;
  608.         xl:=xr-xl-8;
  609.       end;
  610.     end
  611.     else begin
  612.       xr:= x+2;
  613.       for i:=1 to pt^.pos do xr:=xr+MyOrd(its[i].text)*8+hofs;
  614.       xl:=xr-4-MyOrd(its[pt^.pos].text)*8;
  615.       yt:=y+fh-2;
  616.      end;
  617.     if titl <> '' then yt:=yt+htitl;
  618.     bar(xl,yt,xr,yt+14);
  619.     InsText(MyWin,put,all);
  620.   end;
  621. end; {*** end HandleBar ***}
  622.  
  623. {*******************************************************************************
  624. *        Name: Edit         (includes others functions and procedures)
  625. *  Parametres: MyWin:Win    definition of window(menu)
  626. *        Date: June 26, 1992
  627. *     Version: 1.0
  628. *     Purpose: Edit of values and strings
  629. ********************************************************************************}
  630. procedure Edit(var MyWin:Win);
  631.  
  632. {*******************************************************************************
  633. *        Name: CrsrPut
  634. *  Parametres: pcx,pcy:integer     position of cursor
  635. *              is:boolean          =true insert mode
  636. *              put:boolean         =true insert cursor
  637. *        Date: June 26, 1992
  638. *     Version: 1.0
  639. *     Purpose: Inserts and deletes cursor
  640. ********************************************************************************}
  641. procedure CrsrPut(pcx,pcy,cpos:integer;vals:string;is,put:boolean);
  642. begin
  643.   pcx:=pcx-(cpos-1)*8;
  644.   if put then setcolor(pal.bground)
  645.   else setcolor(pal.text);
  646.   if is then begin
  647.     outtextxy(pcx,pcy+1,'_');
  648.     outtextxy(pcx,pcy+2,'_');
  649.   end
  650.   else begin
  651.     if put then setfillstyle(1,pal.bground)
  652.     else setfillstyle(1,pal.text);
  653.     bar(pcx-9,pcy-10,pcx-1,pcy);
  654.     if put then setcolor(pal.text)
  655.     else setcolor(pal.bground);
  656.     if cpos <> 0 then outtextxy(pcx,pcy,vals[ord(vals[0])-cpos+1]);
  657.   end;
  658. end; {*** end CrsrPut ****}
  659.  
  660. {*******************************************************************************
  661. *        Name: CrsrMove
  662. *  Parametres: pcx,pcy:integer     position of cursor
  663. *              is:boolean          =true insert mode
  664. *              right:boolean       =true move to right
  665. *              lv:integer          lenght of string
  666. *              j:integer           position of cursor in the string
  667. *        Date: June 26, 1992
  668. *     Version: 1.0
  669. *     Purpose: Moves cursor right and left
  670. ********************************************************************************}
  671. procedure CrsrMove(pcx,pcy,lv:integer;var cpos:integer;vals:string;is,right:boolean);
  672. begin
  673.   CrsrPut(pcx,pcy,cpos,vals,is,false);
  674.   if right then begin
  675.     dec(cpos);
  676.     if cpos=-1 then cpos:=0;
  677.   end
  678.   else begin
  679.     inc(cpos);
  680.     if cpos > lv then dec(cpos);
  681.   end;
  682.   CrsrPut(pcx,pcy,cpos,vals,is,true);
  683. end; {*** end CrsrMove ***}
  684.  
  685. {*******************************************************************************
  686. *        Name: tovalue:real
  687. *  Parametres: MyWin:Win           definition of window(menu)
  688. *              vals:string         string to changing
  689. *        Date: June 26, 1992
  690. *     Version: 1.0
  691. *     Purpose: Changes string to real value
  692. ********************************************************************************}
  693. function tovalue(MyWin:Win;vals:string):real;
  694. var
  695.   vv:real;
  696.   cd:integer;
  697.   OutRange:Win;
  698.   outst,st:string;
  699.  
  700. begin
  701.   OutRange:=Out;
  702.   with MyWin.its[MyWin.pt^.pos] do begin
  703.     if k<>4 then exit;
  704.     val(vals,vv,cd);
  705.     if cd=0 then begin
  706.       if (vv >=  min) and (vv <= max) then tovalue:=vv
  707.       else begin
  708.         tovalue:=v;
  709.         str(min:0:d,outst);
  710.         str(max:0:d,st);
  711.         outst:=outst+' - '+st;
  712.         Outrange.its[3].text:=outst;
  713.         putwin(outrange);
  714.         repeat until keypressed;
  715.         cd:=myreadkey;
  716.         delwin(outrange);
  717.       end;
  718.     end;
  719.   end;
  720. end; {*** end tovalue ***}
  721.  
  722. {*******************************************************************************
  723. *        Name: towin
  724. *  Parametres: xp,yp               position of text
  725. *              ovals:string        old string for delete
  726. *              vals:string         new string for output
  727. *        Date: June 26, 1992
  728. *     Version: 1.0
  729. *     Purpose: Deletes old and puts new text to window(menu)
  730. ********************************************************************************}
  731. procedure towin(xp,yp:integer;var ovals,vals:string);
  732. var
  733.   vv:real;
  734.   cd:integer;
  735.   vals1:string;
  736.  
  737. begin
  738.   settextjustify(2,0);
  739.   setcolor(pal.text);
  740.   outtextxy(xp,yp,ovals);
  741.   setcolor(pal.bground);
  742.   with MyWin.its[MyWin.pt^.pos] do begin
  743.     if k=4 then begin
  744.       val(vals,vv,cd);
  745.       if cd=0 then str(vv:lv:d,vals1);
  746.       if (vals='') or (vals='-') then cd:=0;
  747.       if (ord(vals1[0]) > lv) or (ord(vals[0]) > lv)  then vals:=ovals;
  748.       if cd <> 0 then vals:=ovals;
  749.     end
  750.     else if ord(vals[0]) > ls then vals:=ovals;
  751.   end;
  752.   outtextxy(xp,yp,vals);
  753. end; {*** end towin ***}
  754.  
  755. {*** begin Edit ***}
  756. var
  757. key:word;
  758. ovals,vals:string;
  759. yp,xp,xpc,cpos,ii:integer;
  760. ex,iins:boolean;
  761. label 1;
  762.  
  763. begin
  764.   cpos:=0;
  765.   iins:=true;
  766.   with MyWin do begin
  767.     yp:=y+fh*pt^.pos+vofs;
  768.     if titl <> '' then yp:=yp+htitl;
  769.     xp:=pt^.xr-hofs;
  770.   end;
  771.   HandleBar(MyWin,false,true);
  772.   HandleBar(MyWin,true,false);
  773.   with MyWin.its[MyWin.pt^.pos] do begin
  774.     if k=4 then str(v:0:d,ovals)
  775.     else ovals:=s;
  776.   end;
  777. 1:repeat until keypressed;
  778.   key:=MyReadKey;
  779.   case key of
  780.     1059:begin
  781.       if MyWin.hlp <> nil then begin
  782.         PutWin(MyWin.hlp^);
  783.         repeat until keypressed;
  784.         key:=MyReadKey;
  785.         DelWin(MyWin.hlp^);
  786.       end;
  787.       goto 1;
  788.     end;
  789.     13,27: begin
  790.       HandleBar(MyWin,false,false);
  791.       exit;
  792.     end;
  793.     1082:begin
  794.       iins:=not iins;
  795.       CrsrPut(xp,yp,cpos,ovals,iins,true);
  796.       vals:=ovals;
  797.     end;
  798.     1077,1075:begin
  799.       CrsrPut(xp,yp,cpos,ovals,iins,true);
  800.       vals:=ovals;
  801.     end;
  802.     else begin
  803.       with MyWin.its[MyWin.pt^.pos] do begin
  804.         if key < 1000 then vals:=chr(key);
  805.         towin(xp,yp,ovals,vals);
  806.         CrsrPut(xp,yp,cpos,vals,iins,true);
  807.       end;
  808.     end;
  809.   end;
  810.   ex:=false;
  811.   repeat
  812.     repeat until keypressed;
  813.     key:=MyReadKey;
  814.     with MyWin.its[MyWin.pt^.pos] do begin
  815.       case key of
  816.         1059:begin
  817.           if MyWin.hlp <> nil then begin
  818.             PutWin(MyWin.hlp^);
  819.             repeat until keypressed;
  820.             key:=MyReadKey;
  821.             DelWin(MyWin.hlp^);
  822.           end;
  823.         end;
  824.         13: begin
  825.           if k=4 then v:=tovalue(MyWin,vals)
  826.           else s:=vals;
  827.           ex:=true;
  828.         end;
  829.         27:ex:=true;
  830.         8:begin
  831.           ovals:=vals;
  832.           if ord(vals[0]) > 0 then begin
  833.             for ii:=ord(vals[0])-cpos to ord(vals[0])-1 do
  834.               vals[ii]:=vals[ii+1];
  835.             vals[0]:=chr(ord(vals[0])-1);
  836.             towin(xp,yp,ovals,vals);
  837.           end;
  838.         end;
  839.         1083:begin
  840.           ovals:=vals;
  841.           if (ord(vals[0]) > 0) and (cpos > 0) then begin
  842.             for ii:=ord(vals[0])-cpos+1 to ord(vals[0])-1 do
  843.               vals[ii]:=vals[ii+1];
  844.             vals[0]:=chr(ord(vals[0])-1);
  845.             towin(xp,yp,ovals,vals);
  846.             if ovals <> vals then CrsrMove(xp,yp,ord(vals[0]),cpos,vals,iins,true);
  847.           end;
  848.         end;
  849.         1082:begin
  850.           CrsrPut(xp,yp,cpos,vals,iins,false);
  851.           iins:=not iins;
  852.           CrsrPut(xp,yp,cpos,vals,iins,true);
  853.         end;
  854.         1075:CrsrMove(xp,yp,ord(vals[0]),cpos,vals,iins,false);
  855.         1077:CrsrMove(xp,yp,ord(vals[0]),cpos,vals,iins,true);
  856.         else begin
  857.           if key<1000 then begin
  858.             ovals:=vals;
  859.             if cpos=0 then vals:=ovals+chr(key)
  860.             else if (ord(ovals[0])-cpos)=0 then begin
  861.               if iins then vals:=chr(key)+ovals
  862.               else vals[1]:=chr(key);
  863.             end
  864.             else begin
  865.               if iins then begin
  866.                 vals:='';
  867.                 for ii:=1 to  ord(ovals[0]) do begin
  868.                   if ii=(ord(ovals[0])-cpos) then vals:=vals+ovals[ii]+chr(key)
  869.                   else vals:=vals+ovals[ii];
  870.                 end;
  871.               end
  872.               else vals[ord(vals[0])-cpos+1]:=chr(key);
  873.             end;
  874.             towin(xp,yp,ovals,vals);
  875.             if (not iins) and (ovals <> vals) then
  876.                CrsrMove(xp,yp,ord(vals[0]),cpos,vals,iins,true)
  877.             else CrsrPut(xp,yp,cpos,ovals,iins,true);
  878.           end;
  879.         end;
  880.       end;
  881.     end;
  882.   until ex;
  883.   HandleBar(MyWin,false,false);
  884. end; {*** end Edit ***}
  885.  
  886. {*******************************************************************************
  887. *        Name: HandleMenu
  888. *  Parametres: MyWin:Win   definition of window(menu)
  889. *              Code:byte   position in menu (Esc=0)
  890. *              event:byte  number of event
  891. *              key:word    value of pressed key
  892. *        Date: December 20, 1992
  893. *     Version: 1.0
  894. *     Purpose: Handle with menu
  895. ********************************************************************************}
  896. procedure HandleMenu(var MyWin:Win; var code:byte;event:byte;key:word);
  897. var
  898.   go:boolean;
  899.   j:integer;
  900.  
  901. begin
  902.   go:=false;
  903.   with MyWin do begin
  904.     case event of
  905.       1,2,8:begin
  906.         if event=1 then begin
  907.           for j:=1 to ni do begin
  908.             if (key=pt^.p[j]) or (key=pt^.q[j]) then begin
  909.               HandleBar(MyWin,false,true);
  910.               pt^.pos:=j;
  911.               HandleBar(MyWin,true,true);
  912.               j:=ni;
  913.               go:=true;
  914.             end;
  915.           end;
  916.         end;
  917.         if ((event=8) or (event=2)) and (its[pt^.pos].enable) then go:=true;
  918.         if go then begin
  919.           case its[pt^.pos].k of
  920.             1:begin
  921.               code:=pt^.pos;
  922.               HandleBar(MyWin,false,true);
  923.             end;
  924.             2:begin
  925.               its[pt^.pos].yes:=not its[pt^.pos].yes;
  926.               HandleBar(MyWin,true,true);
  927.             end;
  928.             3:begin
  929.               inc(its[pt^.pos].i);
  930.               if its[pt^.pos].i > its[pt^.pos].n then its[pt^.pos].i:=1;
  931.               HandleBar(MyWin,true,true);
  932.             end;
  933.             4,5:Edit(MyWin);
  934.           end;
  935.         end;
  936.       end;
  937.       4:begin
  938.         if vert then begin
  939.           HandleBar(MyWin,false,true);
  940.           inc(pt^.pos);
  941.           if its[pt^.pos].text='-' then inc(pt^.pos);
  942.           if pt^.pos > ni then pt^.pos:=1;
  943.           HandleBar(MyWin,true,true);
  944.         end;
  945.       end;
  946.       5:begin
  947.         if vert then begin
  948.           HandleBar(MyWin,false,true);
  949.           dec(pt^.pos);
  950.           if its[pt^.pos].text='-' then dec(pt^.pos);
  951.           if pt^.pos < 1 then pt^.pos:=ni;
  952.           HandleBar(MyWin,true,true);
  953.         end;
  954.       end;
  955.       6:begin
  956.         if not vert then begin
  957.           HandleBar(MyWin,false,true);
  958.           inc(pt^.pos);
  959.           if pt^.pos > ni then pt^.pos:=1;
  960.           HandleBar(MyWin,true,true);
  961.         end;
  962.       end;
  963.       7:begin
  964.         if not vert then begin
  965.           HandleBar(MyWin,false,true);
  966.           dec(pt^.pos);
  967.           if pt^.pos < 1 then pt^.pos:=ni;
  968.           HandleBar(MyWin,true,true);
  969.         end;
  970.       end;
  971.       3,9: code:=0;
  972.       10:begin
  973.         if MyWin.hlp <> nil then begin
  974.           PutWin(MyWin.hlp^);
  975.           repeat until keypressed;
  976.           key:=MyReadKey;
  977.           DelWin(MyWin.hlp^);
  978.         end;
  979.       end;
  980.     end;
  981.   end;
  982. end; {*** end HandleMenu ***}
  983.  
  984. {*******************************************************************************
  985. *        Name: HandleWin
  986. *  Parametres: MyWin:Win   definition of window(menu)
  987. *              Code:byte   position in menu (Esc=0)
  988. *        Date: December 20, 1992
  989. *     Version: 1.1
  990. *     Purpose: Handle with window(menu)
  991. ********************************************************************************}
  992. procedure HandleWin(var MyWin:Win;var code:byte);
  993. const
  994.   m_step=10;
  995. var
  996.   event:0..10;
  997.   xm,ym,xmn,ymn:integer;
  998.   key:word;
  999.  
  1000. begin
  1001.   HandleBar(MyWin,y,y);
  1002.   event:=0;
  1003.   xmn:=0;  ymn:=0;
  1004.   code:=100;
  1005.   getmmotion(xm,ym);
  1006.   repeat
  1007.     if keypressed then begin
  1008.       key:=MyReadKey;
  1009.       case key of
  1010.         1080: event:=4;
  1011.         1072: event:=5;
  1012.         1077: event:=6;
  1013.         1075: event:=7;
  1014.         1059: event:=10;
  1015.           13: event:=8;
  1016.           27: event:=9;
  1017.         else  event:=1;
  1018.       end;
  1019.     end
  1020.     else begin
  1021.       if pressedbutton(1) then begin
  1022.         event:=2;   repeat until not pressedbutton(1);
  1023.       end  else if pressedbutton(2) then begin
  1024.         event:=3;   repeat until not pressedbutton(2);
  1025.       end  else begin
  1026.         getmmotion(xm,ym);
  1027.         xmn:=xmn+xm;
  1028.         ymn:=ymn+ym;
  1029.         if ymn > m_step then event:=4;
  1030.         if ymn < -m_step then event:=5;
  1031.         if xmn > m_step then event:=6;
  1032.         if xmn < -m_step then event:=7;
  1033.         if (event >=4) and (event <= 7) then begin
  1034.           xmn:=0;
  1035.           ymn:=0;
  1036.         end;
  1037.       end;
  1038.     end;
  1039.   until event <> 0;
  1040.   HandleMenu(MyWin,code,event,key);
  1041. end; {*** end HandleWin ***}
  1042.  
  1043. {*******************************************************************************
  1044. *        Name: PutWin
  1045. *  Parametres: MyWin:Win   definition of window(menu)
  1046. *        Date: June 26, 1992
  1047. *     Version: 1.0
  1048. *     Purpose: Insert window(menu) to desktop
  1049. ********************************************************************************}
  1050. procedure PutWin(var MyWin:Win);
  1051. var
  1052.   w,w_max,xr,h,yb,i,j:integer;
  1053.   pi:pointer;
  1054.   cl,han:word;
  1055.   ok:boolean;
  1056.  
  1057. begin
  1058.   cl:= getcolor;
  1059.   with MyWin do begin
  1060.     if vert then begin
  1061.       w_max:=ord(titl[0]);
  1062.       for i:=1 to ni do begin                  { Fix position and size }
  1063.         w:=MyOrd(its[i].text);                 { Horizontal }
  1064.         case its[i].k of
  1065.           2: w:=w+6;
  1066.           3: w:=w+8;
  1067.           4: w:=w+its[i].lv+3;
  1068.           5: w:=w+its[i].ls+3;
  1069.         end;
  1070.         if w > w_max then w_max:=w;
  1071.         w:=w_max*8+2*hofs;
  1072.       end;
  1073.     end
  1074.     else begin
  1075.       w_max:=0;
  1076.       for i:=1 to ni do w_max:=w_max+MyOrd(its[i].text);
  1077.       w:=w_max*8+(ni+1)*hofs;
  1078.     end;
  1079.     xr:=x+w;
  1080.     if xr+4 > getmaxx then begin
  1081.       xr:=getmaxx-5;
  1082.       x:=xr-w;
  1083.     end;
  1084.     if vert then begin
  1085.       if titl ='' then h:=0                    { Vertical }
  1086.       else h:=htitl;
  1087.       h:=h+ni*fh+2*vofs+4;
  1088.     end
  1089.     else h:=fh+2*vofs+4;
  1090.     yb:=y+h;
  1091.     if yb+4 > getmaxy then begin
  1092.       yb:=getmaxy-5;
  1093.       y:=yb-h;
  1094.     end;
  1095.     setviewport(0,0,getmaxx,getmaxy,clipon);   { Frame and title }
  1096.     getxms(han,imagesize(x,y,xr,yb),ok);
  1097.     if ok then awakepointer(han,pi,xmswritemode)
  1098.     else getmem(pi,imagesize(x,y,xr,yb));
  1099.     getimage(x,y,xr,yb,pi^);
  1100.     if ok then sleeppointer(han);
  1101.     setviewport(x,y,xr,yb,clipon);
  1102.     clearviewport;
  1103.     setfillstyle(1,pal.bground);
  1104.     bar(0,0,w,h);
  1105.     setcolor(pal.frame);
  1106.     rectangle(8,8,w-8,h-8);
  1107.     rectangle(10,10,w-10,h-10);
  1108.     if titl <> '' then begin
  1109.       line(10,htitl+vofs,w-10,htitl+vofs);
  1110.       settextjustify(1,0);
  1111.       outtextxy(round(w/2),htitl,titl);
  1112.     end;
  1113.     setviewport(0,0,getmaxx,getmaxy,clipon);
  1114.     new(pt);                                   { Save parametres of window }
  1115.     pt^.xr:=xr;      pt^.yb:=yb;     pt^.p_menu:=pi;
  1116.     pt^.xms_ok:=ok;  pt^.handle:=han;
  1117.     for j:= 1 to ni do begin                   { write items }
  1118.       pt^.pos:=j;
  1119.       if its[j].text='-' then begin
  1120.         setcolor(pal.frame);
  1121.         h:=y+vofs+j*fh-4;
  1122.         if titl <> '' then h:=h+htitl;
  1123.         line(x+10,h,x+w-10,h);
  1124.       end
  1125.       else InsText(MyWin,false,true);
  1126.     end;
  1127.     pt^.pos:=1;
  1128.   end;
  1129.   setcolor(cl);           { Set color back }
  1130. end; {*** end PutWin ***}
  1131.  
  1132. {*******************************************************************************
  1133. *        Name: ioer
  1134. *  Parametres: fil:string      string to output
  1135. *              io:boolean      I/O O.K. - io=true
  1136. *        Date: June 26, 1992
  1137. *     Version: 1.0
  1138. *     Purpose: Put the echo about I/O operation
  1139. ********************************************************************************}
  1140. procedure ioer(fil:string;var io:boolean);
  1141. var
  1142.   tcioe:win;
  1143.   temp:string;
  1144.  
  1145. begin
  1146.   io:=false;
  1147.   tcioe:=scioe;
  1148.   case ioresult of
  1149.     0: begin
  1150.       temp:='OK';
  1151.       io:=true;
  1152.     end;
  1153.     100:temp:='Disk read error';
  1154.     101:temp:='Disk write error';
  1155.     102:temp:='File not assigned';
  1156.     103:temp:='File not open';
  1157.     104:temp:='File not open for input';
  1158.     105:temp:='File not open for output';
  1159.     106:temp:='Invalid numeric format';
  1160.     159,160:temp:='Printer fault';
  1161.   end;
  1162.   tcioe.its[1].text:=fil+' : '+temp;
  1163.   PutWin(tcioe);
  1164.   delay(1000);
  1165.   DelWin(tcioe);
  1166. end; {*** end ioer ***}
  1167.  
  1168. {*******************************************************************************
  1169. *        Name: FilWin
  1170. *  Parametres: MyWin:Win       definition of window(menu)
  1171. *              iofiles:afile   information about files
  1172. *        Date: June 26, 1992
  1173. *     Version: 1.0
  1174. *     Purpose: Fills MyWin with names of files
  1175. ********************************************************************************}
  1176. procedure FilWin(var MyWin:Win;var iofiles:afile);
  1177. var
  1178.    i,max,pos,dif:integer;
  1179.  
  1180. begin
  1181.   if iofiles.first < 1 then iofiles.first:=1;
  1182.   max:=iofiles.first+11;
  1183.   if max > iofiles.ni then max:=iofiles.ni;
  1184.   dif:=max-iofiles.first;
  1185.   MyWin.ni:=dif+1+4;
  1186.   if iofiles.first = 1 then MyWin.its[2].enable:=false
  1187.   else MyWin.its[2].enable:=true;
  1188.   if max = iofiles.ni then MyWin.its[3].enable:=false
  1189.   else MyWin.its[3].enable:=true;
  1190.   pos:=4;
  1191.   for i:=iofiles.first to max do begin
  1192.     inc(pos);
  1193.     MyWin.its[pos].k:=1;
  1194.     MyWin.its[pos].enable:=true;
  1195.     MyWin.its[pos].text:=iofiles.fil[i];
  1196.   end;
  1197. end; {*** end FilWin ***}
  1198.  
  1199. {*******************************************************************************
  1200. *        Name: DirFil
  1201. *  Parametres: MyWin:Win       definition of window(menu)
  1202. *              iofiles:afile   information about files
  1203. *              fn:fname        name of file
  1204. *        Date: June 26, 1992
  1205. *     Version: 1.0
  1206. *     Purpose: Fills iofiles with names of files
  1207. ********************************************************************************}
  1208. procedure dirfil(var MyWin:win;var iofiles:afile;fn:fname);
  1209. var s:searchrec;
  1210.  
  1211. begin
  1212.   iofiles.ni:=0;
  1213.   findfirst(fn.d+'*'+fn.e,$3f,s);
  1214.   while doserror = 0 do begin
  1215.     inc(iofiles.ni);
  1216.     iofiles.fil[iofiles.ni]:=fn.d+s.name;
  1217.     findnext(s);
  1218.   end;
  1219.   iofiles.first:=1;
  1220.   FilWin(MyWin,iofiles);
  1221. end; {*** end dirfil ***}
  1222.  
  1223. {*******************************************************************************
  1224. *        Name: ChFil
  1225. *  Parametres: MyWin:Win       definition of window(menu)
  1226. *              fn:fname        name of file
  1227. *        Date: June 26, 1992
  1228. *     Version: 1.0
  1229. *     Purpose: Changes directory and extension and chooses file for I/O
  1230. ********************************************************************************}
  1231. procedure chfil(var MyWin:Win; var fn:fname);
  1232. var codel,codeg:byte;
  1233.     ex:boolean;
  1234.     iofiles:afile;
  1235.     pTWin,pChgDir:PtrWin;
  1236.  
  1237. begin
  1238.   RegWin(ChgDir,pChgDir);
  1239.   RegWin(HLoadSet,pChgDir^.hlp);
  1240.   dirfil(MyWin,iofiles,fn);
  1241.   PutWin(MyWin);
  1242.   ex:=false;
  1243.   fn.io:=true;
  1244.   repeat
  1245.     HandleWin(MyWin,codel);
  1246.     case codel of
  1247.       1:begin
  1248.         pChgDir^.its[1].s:=fn.d;
  1249.         pChgDir^.its[2].s:=fn.e;
  1250.         PutWin(pChgDir^);
  1251.         repeat
  1252.           HandleWin(pChgDir^,codeg);
  1253.         until codeg=0;
  1254.         DelWin(pChgDir^);
  1255.         DelWin(MyWin);
  1256.         if pChgDir^.its[1].s[length(pChgDir^.its[1].s)]<>'\'
  1257.           then pChgDir^.its[1].s:=pChgDir^.its[1].s+'\';
  1258.         fn.d:=pChgDir^.its[1].s;
  1259.         if length(pChgDir^.its[2].s)=3 then
  1260.           pChgDir^.its[2].s:='.'+pChgDir^.its[2].s;
  1261.         fn.e:=pChgDir^.its[2].s;
  1262.         dirfil(MyWin,iofiles,fn);
  1263.         PutWin(MyWin);
  1264.       end;
  1265.       2:begin
  1266.         iofiles.first:=iofiles.first-12;
  1267.         DelWin(MyWin);
  1268.         FilWin(MyWin,iofiles);
  1269.         PutWin(MyWin);
  1270.       end;
  1271.       3:begin
  1272.         iofiles.first:=iofiles.first+12;
  1273.         DelWin(MyWin);
  1274.         FilWin(MyWin,iofiles);
  1275.         PutWin(MyWin);
  1276.       end;
  1277.       4:begin
  1278.         RegWin(NewFile,pTwin);
  1279.         PutWin(pTWin^);
  1280.         repeat
  1281.           HandleWin(pTWin^,codeg);
  1282.         until codeg=0;
  1283.         DelWin(pTWin^);
  1284.         fn.p:=fn.d+pTWin^.its[1].s;
  1285.         fsplit(fn.p,fn.d,fn.n,fn.e);
  1286.         ex:=true;
  1287.       end;
  1288.       0:begin
  1289.         fn.io:=false;
  1290.         ex:=true;
  1291.       end;
  1292.       else if codel <= MyWin.ni then begin
  1293.         fsplit(MyWin.its[codel].text,fn.d,fn.n,fn.e);
  1294.         ex:=true;
  1295.       end;
  1296.     end;
  1297.   until ex;
  1298.   DelWin(MyWin);
  1299.   fn.p:=fn.d+fn.n+fn.e;
  1300.   fn.s:=fn.p;
  1301.   UnregWin(pChgDir);
  1302.   UnregWin(pChgDir^.hlp);
  1303. end; {*** end chfil ***}
  1304.  
  1305. {*******************************************************************************
  1306. *        Name: SaveWin
  1307. *  Parametres: fn:fname    name of file
  1308. *              n:integer   number of records Win
  1309. *              fdat:aWin   array of Win
  1310. *        Date: June 26, 1992
  1311. *     Version: 1.0
  1312. *     Purpose: Save definitions of window(menu) to file
  1313. ********************************************************************************}
  1314. procedure SaveWin(var fn:fname;n:integer;var fdat:aWin);
  1315. var i:integer;
  1316.     fil:string[50];
  1317.     tdata:fWin;
  1318.     tLoadSet:Win;
  1319.  
  1320. begin
  1321.   tLoadSet:=LoadSet;
  1322.   RegWin(HLoadSet,tLoadSet.hlp);
  1323.   tLoadSet.titl:='Save Setup';
  1324.   tLoadSet.its[4].enable:=true;
  1325.   fn.p:=fexpand(fn.s);
  1326.   fsplit(fn.p,fn.d,fn.n,fn.e);
  1327.   fn.io:=true;
  1328.   if fn.chg then chfil(tLoadSet,fn);
  1329.   if fn.io then begin
  1330.     {$I-}
  1331.     assign(tdata,fn.p);
  1332.     rewrite(tdata);
  1333.     for i:=1 to n do write(tdata,fdat[i]^);
  1334.     close(tdata);
  1335.     {$I+}
  1336.     fil:='Writting '+fn.p;
  1337.     ioer(fil,fn.io);
  1338.   end;
  1339.   UnregWin(tLoadSet.hlp);
  1340. end; {*** end SaveWin ***}
  1341.  
  1342. {*******************************************************************************
  1343. *        Name: LoadWin
  1344. *  Parametres: fn:fname    name of file
  1345. *              n:integer   number of records Win
  1346. *              fdat:aWin   array of Win
  1347. *        Date: June 26, 1992
  1348. *     Version: 1.0
  1349. *     Purpose: Load definitions of window(menu) to array fdat
  1350. ********************************************************************************}
  1351. procedure LoadWin(var fn:fname;n:integer;var fdat:aWin);
  1352. var i:integer;
  1353.     fil:string[50];
  1354.     tdata:fWin;
  1355.     tempWin,tLoadSet:Win;
  1356.  
  1357. begin
  1358.   tLoadSet:=LoadSet;
  1359.   RegWin(HLoadSet,tLoadSet.hlp);
  1360.   tLoadSet.titl:='Load Setup';
  1361.   tLoadSet.its[4].enable:=false;
  1362.   fn.p:=fexpand(fn.s);
  1363.   fsplit(fn.p,fn.d,fn.n,fn.e);
  1364.   fn.io:=true;
  1365.   if fn.chg then chfil(tLoadSet,fn);
  1366.   if fn.io then begin
  1367.     {$I-}
  1368.     assign(tdata,fn.p);
  1369.     reset(tdata);
  1370.     for i:=1 to n do begin
  1371.       read(tdata,tempWin);
  1372.       RegWin(tempWin,fdat[i]);
  1373.     end;
  1374.     close(tdata);
  1375.     {$I+}
  1376.     fil:='Reading '+fn.p;
  1377.     ioer(fil,fn.io);
  1378.   end;
  1379.   UnregWin(tLoadSet.hlp);
  1380. end; {*** end LoadWin ***}
  1381.  
  1382. {*******************************************************************************
  1383. *        Name: HandlelStLine
  1384. *  Parametres: MyStLine:StLine   definition of status line
  1385. *              code:word;        code of key;
  1386. *        Date: June 26, 1992
  1387. *     Version: 1.0
  1388. *     Purpose: Handle with status line
  1389. ********************************************************************************}
  1390. procedure HandleStLine(MyStLine:StLine;var code:word);
  1391. var cKey:word;
  1392.     i:integer;
  1393. begin
  1394.   code:=0;
  1395.   if keypressed then begin
  1396.     cKey:=MyReadKey;
  1397.     with MyStLine do begin
  1398.       for i:=1 to ni do
  1399.         if (its[i].code=cKey) and its[i].enable then code:=its[i].code;
  1400.     end;
  1401.   end;
  1402. end; {*** end HandleStLine ***}
  1403.  
  1404. {*******************************************************************************
  1405. *        Name: DelStLine
  1406. *  Parametres: MyStLine:StLine   definition of status line
  1407. *        Date: June 26, 1992
  1408. *     Version: 1.0
  1409. *     Purpose: Delete status line from desktop
  1410. ********************************************************************************}
  1411. procedure DelStLine(MyStLine:StLine);
  1412. begin
  1413.   with MyStLine do begin
  1414.     setviewport(0,0,getmaxx,getmaxy,clipon);
  1415.     putimage(0,getmaxy-12,pt^,0);
  1416.     freemem(pt,imagesize(0,getmaxy-12,getmaxx,getmaxy));
  1417.   end;
  1418. end; {*** end DelStLine ***}
  1419.  
  1420. {*******************************************************************************
  1421. *        Name: PutStLine
  1422. *  Parametres: MyStLine:StLine   definition of status line
  1423. *        Date: June 26, 1992
  1424. *     Version: 1.0
  1425. *     Purpose: Insert status line to desktop
  1426. ********************************************************************************}
  1427. procedure PutStLine(var MyStLine:StLine);
  1428.  
  1429. var
  1430.   cl,maxx,maxy,ps,i:integer;
  1431.  
  1432. begin
  1433.   cl:= getcolor;
  1434.   maxx:=getmaxx;
  1435.   maxy:=getmaxy;
  1436.   with MyStLine do begin
  1437.     setviewport(0,0,maxx,maxy,clipon);
  1438.     getmem(pt,imagesize(0,maxy-12,maxx,maxy));
  1439.     getimage(0,maxy-12,maxx,maxy,pt^);
  1440.     setviewport(0,maxy-12,maxx,maxy,clipoff);
  1441.     clearviewport;
  1442.     setfillstyle(1,pal.bground);
  1443.     bar(0,0,maxx,maxy);
  1444.     settextjustify(0,0);
  1445.     ps:=-10;
  1446.     for i:=1 to ni do begin
  1447.       ps:=ps+25;
  1448.       if its[i].enable then  setcolor(pal.text) else setcolor(pal.dtext);
  1449.       outtextxy(ps,10,its[i].ltext);
  1450.       ps:=ps+length(its[i].ltext)*8+8;
  1451.       if its[i].enable then  setcolor(pal.hotkey)   else setcolor(pal.dtext);
  1452.       outtextxy(ps,10,its[i].rtext);
  1453.       ps:=ps+length(its[i].rtext)*8;
  1454.     end;
  1455.   end;
  1456.   setviewport(0,0,getmaxx,getmaxy,clipon);
  1457.   setcolor(cl);           { Set color back }
  1458. end; {*** end PutStLine ***}
  1459.  
  1460.  
  1461. {*******************************************************************************
  1462. *        Name: HandleAll
  1463. *  Parametres: MyWin:Win       definition of window(menu)
  1464. *              Code:byte       position in menu (Esc=0)
  1465. *              MyStLine:StLine definition of sttus line
  1466. *              Codest:word     status line code
  1467. *        Date: December 20, 1992
  1468. *     Version: 1.0
  1469. *     Purpose: Handle with all (window+status line)
  1470. ********************************************************************************}
  1471. procedure HandleAll(var MyWin:Win;var code:byte;
  1472.                     var MyStLine:StLine;var codest:word);
  1473. const
  1474.   m_step=10;
  1475. var
  1476.   event:0..10;
  1477.   xm,ym,xmn,ymn,i:integer;
  1478.   key:word;
  1479.  
  1480. begin
  1481.   HandleBar(MyWin,y,y);
  1482.   event:=0;
  1483.   xmn:=0;  ymn:=0;
  1484.   code:=100;
  1485.   codest:=0;
  1486.   getmmotion(xm,ym);
  1487.   repeat
  1488.     if keypressed then begin
  1489.       key:=MyReadKey;
  1490.       case key of
  1491.         1080: event:=4;
  1492.         1072: event:=5;
  1493.         1077: event:=6;
  1494.         1075: event:=7;
  1495.         1059: event:=10;
  1496.           13: event:=8;
  1497.           27: event:=9;
  1498.         else  event:=1;
  1499.       end;
  1500.       with MyStLine do begin
  1501.         for i:=1 to ni do
  1502.           if (its[i].code=key) and its[i].enable then begin
  1503.             codest:=its[i].code;
  1504.             exit;
  1505.           end;
  1506.       end;
  1507.     end
  1508.     else begin
  1509.       if pressedbutton(1) then begin
  1510.         event:=2;   repeat until not pressedbutton(1);
  1511.       end  else if pressedbutton(2) then begin
  1512.         event:=3;   repeat until not pressedbutton(2);
  1513.       end  else begin
  1514.         getmmotion(xm,ym);
  1515.         xmn:=xmn+xm;
  1516.         ymn:=ymn+ym;
  1517.         if ymn > m_step then event:=4;
  1518.         if ymn < -m_step then event:=5;
  1519.         if xmn > m_step then event:=6;
  1520.         if xmn < -m_step then event:=7;
  1521.         if (event >=4) and (event <= 7) then begin
  1522.           xmn:=0;
  1523.           ymn:=0;
  1524.         end;
  1525.       end;
  1526.     end;
  1527.   until event <> 0;
  1528.   HandleMenu(MyWin,code,event,key);
  1529. end; {*** end HandleAll ***}
  1530.  
  1531. {*******************************************************************************
  1532. *        Name: PrtScreen
  1533. *  Parametres: MinX,MaxX,MinY,MaxY:integer  upper left and lower right
  1534. *                                           corner of printed window
  1535. *              lq:boolean quality of print lq=true  - letter quiality
  1536. *                                          lq=false - draft
  1537. *        Date: January 10, 1993
  1538. *     Version: 1.0
  1539. *     Purpose: Print part of screen in graphic mode
  1540. ********************************************************************************}
  1541. procedure  PrtScreen(MinX,MaxX,MinY,MaxY:integer;lq:boolean);
  1542.  
  1543. var
  1544.    i,j,k : word;
  1545.    n : byte;
  1546.    x1, x2 : char;
  1547. begin
  1548.    x1 := Chr((MaxX-MinX+1) mod 256);
  1549.    x2 := Chr((MaxX-MinX+1) div 256);
  1550.    {$I-}
  1551.    for j := MinY div 8 to MaxY div 8 do begin
  1552.      write(Lst,Chr(13));
  1553.      write(Lst,Chr(27),'J',Chr(24));             { LineFeed 24/216" }
  1554.      write(Lst,'     ');                         { Start offset }
  1555.      if lq then write(Lst,Chr(27),'L',x1, x2)    {'L' - LQ }
  1556.      else write(Lst,Chr(27),'Y',x1, x2);         {'Y' - Draft }
  1557.      for i := MinX to MaxX do begin
  1558.        n := 0;
  1559.        for k := 0 to 7 do
  1560.          if GetPixel(i, 8*j+k) > 0 then n:=n Or ($80 shr k);
  1561.        write(Lst,Chr(n));
  1562.      end;
  1563.    end;
  1564.    write(Lst,Chr(13));
  1565.    {$I+}
  1566.    ioer('Printing: ',lq);
  1567. end;
  1568.  
  1569.  
  1570. { Main body of unit }
  1571. var
  1572.   GrD,GrM:integer;
  1573.  
  1574. Begin
  1575.   DetectGraph(GrD,GrM);
  1576.   if (GrD=5) or (GrD=7) then pal:=pal_mono
  1577.   else pal:=pal_co;
  1578.   initmouse(init_mouse);
  1579. End. {*** unit MCMENU10 ***}
  1580.