home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l044 / 4.ddi / DOCDEMOS.ZIP / TVGUID07.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-10-23  |  4.2 KB  |  188 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal 6.0                             }
  4. {   Demo program from the Turbo Vision Guide     }
  5. {                                                }
  6. {   Copyright (c) 1990 by Borland International  }
  7. {                                                }
  8. {************************************************}
  9.  
  10. program TVGUID07;
  11.  
  12. uses Objects, Drivers, Views, Menus, App;
  13.  
  14. const
  15.   FileToRead        = 'TVGUID07.PAS';
  16.   MaxLines          = 100;
  17.   WinCount: Integer =   0;
  18.   cmFileOpen        = 100;
  19.   cmNewWin          = 101;
  20.  
  21. var
  22.   LineCount: Integer;
  23.   Lines: array[0..MaxLines - 1] of PString;
  24.    
  25. type
  26.   TMyApp = object(TApplication)
  27.     procedure InitStatusLine; virtual;
  28.     procedure InitMenuBar; virtual;
  29.     procedure NewWindow;
  30.     procedure HandleEvent(var Event: TEvent); virtual;
  31.   end;
  32.  
  33.   PDemoWindow = ^TDemoWindow;
  34.   TDemoWindow = object(TWindow)
  35.     constructor Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  36.   end;
  37.  
  38.   PInterior = ^TInterior;
  39.   TInterior = object(TView)
  40.     constructor Init(var Bounds: TRect);
  41.     procedure Draw; virtual;
  42.   end;
  43.  
  44. procedure ReadFile;
  45. var
  46.   F: Text;
  47.   S: String;
  48. begin
  49.   LineCount := 0;
  50.   Assign(F, FileToRead);
  51.   {$I-}
  52.   Reset(F);
  53.   {$I+}
  54.   if IOResult <> 0 then
  55.   begin
  56.     Writeln('Cannot open ', FileToRead);
  57.     Halt(1);
  58.   end;
  59.   while not Eof(F) and (LineCount < MaxLines) do
  60.   begin
  61.     Readln(F, S);
  62.     Lines[LineCount] := NewStr(S);
  63.     Inc(LineCount);
  64.   end;
  65.   Close(F);
  66. end;
  67.  
  68. procedure DoneFile;
  69. var
  70.   I: Integer;
  71. begin
  72.   for I := 0 to LineCount - 1 do
  73.     if Lines[I] <> nil then DisposeStr(Lines[i]);
  74. end;
  75.  
  76. { TInterior }
  77. constructor TInterior.Init(var Bounds: TRect);
  78. begin
  79.   TView.Init(Bounds);
  80.   GrowMode := gfGrowHiX + gfGrowHiY;
  81.   Options := Options or ofFramed;
  82. end;
  83.  
  84. procedure TInterior.Draw;
  85. var
  86.   Color: Byte;
  87.   Y: Integer;
  88.   B: TDrawBuffer;
  89. begin
  90.   TView.Draw;
  91.   Color := GetColor(1);
  92.   for Y := 0 to Size.Y - 1 do
  93.   begin
  94.     MoveChar(B, ' ', Color, Size.X);
  95.     if (Y < LineCount) and (Lines[Y] <> nil) then
  96.       MoveStr(B, Copy(Lines[Y]^, 1, Size.X), Color);
  97.     WriteLine(0, Y, Size.X, 1, B);
  98.   end;
  99. end;
  100.  
  101. { TDemoWindow }
  102. constructor TDemoWindow.Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  103. var
  104.   S: string[3];
  105.   Interior: PInterior;
  106. begin
  107.   Str(WindowNo, S);
  108.   TWindow.Init(Bounds, WinTitle + ' ' + S, wnNoNumber);
  109.   GetClipRect(Bounds);
  110.   Bounds.Grow(-1, -1);
  111.   Interior := New(PInterior, Init(Bounds));
  112.   Insert(Interior);
  113. end;
  114.  
  115. { TMyApp }
  116. procedure TMyApp.HandleEvent(var Event: TEvent);
  117. begin
  118.   TApplication.HandleEvent(Event);
  119.   if Event.What = evCommand then
  120.   begin
  121.     case Event.Command of
  122.       cmNewWin: NewWindow;
  123.     else
  124.       Exit;
  125.     end;
  126.     ClearEvent(Event);
  127.   end;
  128. end;
  129.  
  130. procedure TMyApp.InitMenuBar;
  131. var R: TRect;
  132. begin
  133.   GetExtent(R);
  134.   R.B.Y := R.A.Y + 1;
  135.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  136.     NewSubMenu('~F~ile', hcNoContext, NewMenu(
  137.       NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
  138.       NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext,
  139.       NewLine(
  140.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
  141.       nil))))),
  142.     NewSubMenu('~W~indow', hcNoContext, NewMenu(
  143.       NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
  144.       NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
  145.       nil))),
  146.     nil))
  147.   )));
  148. end;
  149.  
  150. procedure TMyApp.InitStatusLine;
  151. var R: TRect;
  152. begin
  153.   GetExtent(R);
  154.   R.A.Y := R.B.Y - 1;
  155.   StatusLine := New(PStatusLine, Init(R,
  156.     NewStatusDef(0, $FFFF,
  157.       NewStatusKey('', kbF10, cmMenu,
  158.       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
  159.       NewStatusKey('~F4~ New', kbF4, cmNewWin,
  160.       NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
  161.       nil)))),
  162.     nil)
  163.   ));
  164. end;
  165.  
  166. procedure TMyApp.NewWindow;
  167. var
  168.   Window: PDemoWindow;
  169.   R: TRect;
  170. begin
  171.   Inc(WinCount);
  172.   R.Assign(0, 0, 24, 7);
  173.   R.Move(Random(55), Random(16));
  174.   Window := New(PDemoWindow, Init(R, 'Demo Window', WinCount));
  175.   DeskTop^.Insert(Window);
  176. end;
  177.  
  178. var
  179.   MyApp: TMyApp;
  180.  
  181. begin
  182.   ReadFile;
  183.   MyApp.Init;
  184.   MyApp.Run;
  185.   MyApp.Done;
  186.   DoneFile;
  187. end.
  188.