home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / textwndw.swg / 0005_WINDOWS2.PAS.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  4.6 KB  |  169 lines
  1. Uses Crt;
  2.  
  3. Type
  4.  
  5.    BufferType = Array[0..3999] of Byte; { screen size      }
  6.    PtrBufferType = ^BufferType;         { For dynamic use  }
  7.  
  8. Var
  9.   Screen: BufferType Absolute $B800:$0; { direct access to }
  10.                                         { Text screen      }
  11.  
  12. Function CharS(Len:Byte; C: Char): String;
  13. Var
  14.   S: String;
  15. begin                       { This Function returns a String of }
  16.   FillChar(S, Len+1, C);    { Length Len and of Chars C.        }
  17.   S[0] := Chr(Len);
  18.   CharS := S;
  19. end;
  20.  
  21. Function Center(X1, X2: Byte; S: String): Byte;
  22. Var
  23.   L, Max: Integer;
  24. begin                           { This Function is used to center     }
  25.   Max := (X2 - (X1-1)) div 2;   { a String between two X coordinates. }
  26.   L := Length(S);
  27.   if Odd(L) then Inc(L);
  28.   Center := X1 + (Max - (L div 2));
  29. end;
  30.  
  31.  
  32. Procedure DrawBox(X1, Y1, X2, Y2: Integer; Attr: Byte; Title: String);
  33. Var
  34.   L, Y, X: Integer;
  35.   S: String;
  36.  
  37. begin
  38.   X := X2 - (X1-1);      { find box width  }
  39.   Y := Y2 - (Y1-1);      { find box height }
  40.   { draw box }
  41.   S := Concat('╔', CharS(X-2, '═'), '╗');
  42.   GotoXY(X1, Y1);
  43.   TextAttr := Attr;
  44.   Write(S);
  45.   Title := Concat('╡ ', Title,' ╞');
  46.   GotoXY(Center(X1, X2, Title), Y1);
  47.   Write(Title);
  48.   For L := 2 to (Y-1) do
  49.     begin
  50.       GotoXY(X1, Y1+L-1);
  51.       Write('║', CharS(X-2, ' '), '║');
  52.     end;
  53.   GotoXY(X1, Y2);
  54.    Write('╚', CharS(X-2, '═'), '╝');
  55.  
  56. end;
  57.  
  58. Procedure SaveBox(X1, Y1, X2, Y2: Integer; Var BufPtr: PtrBufferType);
  59. Var
  60.   Poff, Soff, Y, XW, YW, Size: Integer;
  61.  
  62. begin
  63.   XW := X2 - (X1 -1);   { find box width  }
  64.   YW := Y2 - (Y1 -1);   { find box height }
  65.   Size := (XW*2 ) * YW; { size needed to store background }
  66.   GetMem(BufPtr, Size); { allocate memory to buffer }
  67.   For Y := 1 to YW do   { copy line by line to buffer }
  68.     begin
  69.       Soff := (((Y1-1) + (Y-1)) * 160) + ((X1-1)*2);
  70.       Poff := ((XW * 2) * (Y-1));
  71.       Move(Screen[Soff], BufPtr^[Poff], (XW * 2)); { Write to buffer }
  72.     end;
  73. end;
  74.  
  75. (*************** end of PART 1 of 2. *****************************)
  76. (****** PART 2 of 2 ********************************)
  77. Procedure RestoreBox(X1, Y1, X2, Y2: Integer; Var BufPtr: PtrBufferType);
  78. Var
  79.   Poff, Soff, X, Y, XW, YW, Size: Integer;
  80.   F: File;
  81.  
  82. begin
  83.   XW := X2 - (X1-1); { once again...find box width }
  84.   YW := Y2 - (Y1-1); { find height }
  85.   Size := (XW *2) * YW; { memory size to deallocate from buffer }
  86.   For Y := 1 to YW do   { move back, line by line }
  87.     begin
  88.       Soff := (( (Y1-1) + (Y-1)) * 160) + ((X1-1)*2);
  89.       Poff := ((XW*2) * (Y-1));
  90.       Move(BufPtr^[Poff], Screen[Soff],  (XW*2));
  91.     end;
  92.   FreeMem(BufPtr, Size);
  93. end;
  94.  
  95.  
  96. Procedure Shadow(X1, Y1, X2, Y2: Byte);
  97. Var
  98.   Equip: Byte Absolute $40:$10;
  99.   Vert, Height, offset: Integer;
  100.  
  101. begin
  102.   if (Equip and 48) = 48 then Exit;
  103.  
  104.   For Vert := (Y1+1) to (Y2+1) do
  105.     For Height := (X2+1) to (X2+2) do
  106.       begin
  107.         offset := (Vert - 1) * 160 + (Height-1) * 2 + 1;
  108.         Screen[offset] := 8;
  109.       end;
  110.   Vert := Y2 + 1;
  111.   For Height := (X1+2) to (X2+2) do
  112.     begin
  113.       offset := (Vert-1) * 160 + (Height-1) * 2 + 1;
  114.       Screen[offset] := 8;
  115.     end;
  116. end;
  117.  
  118. Procedure Hello;
  119. Var
  120.   BufPtr: PtrBufferType;
  121. begin
  122.   { note, that if you use shadow, save an xtra 2 columns
  123.     and 1 line to accomadate what Shadow does }
  124.    {             V   V   }
  125.   SaveBox(7, 7, 73, 15, BufPtr);
  126.   DrawBox(7, 7, 71, 13, $4F, 'Hello');
  127.   Shadow(7, 7, 71, 13);
  128.   GotoXY(9, 9);
  129.   Write('Hello Terry! I hope this is what you were asking For.');
  130.   GotoXY(9, 11);
  131.   Write('Press Enter');
  132.   While ReadKey <> #13 do;
  133.   RestoreBox(7, 7, 73, 14, BufPtr);
  134. end;
  135.  
  136. Procedure Disclaimer;
  137. Var
  138.   BufPtr: PtrBufferType;
  139. begin
  140.   SaveBox(5, 5, 77, 21, BufPtr);
  141.   DrawBox(5, 5, 75, 20, $1F, 'DISCLAIMER');
  142.   Shadow(5, 5, 75, 20);
  143.   Window(7, 7, 73, 19);
  144.   Writeln('  Seeing as I came up With these Procedures For');
  145.   Writeln('my own future Programs (I just recently wrote these)');
  146.   Writeln('please don''t Forget who wrote them originally if you');
  147.   Writeln('decide to use them in your own.  Maybe a ''thanks to Eric Miller');
  148.   Writeln('For Window routines'' somewhere in your doCs?');
  149.   Writeln;
  150.   Writeln('  Also, if anyone can streamline this source, well, I''d');
  151.   Writeln('I''d like to see it...not that too much can be done.');
  152.   Writeln;
  153.   Writeln('                    Eric Miller');
  154.   Window(1,1,80,25);
  155.   Hello;
  156.   TextAttr := $1F;
  157.   GotoXY(9, 18);
  158.   Writeln('Press Enter...');
  159.   While ReadKey <> #13 do;
  160.   RestoreBox(5, 5, 77, 21, BufPtr);
  161. end;
  162.  
  163. begin
  164.   TextAttr := $3F;
  165.   ClrScr;
  166.   Disclaimer;
  167. end.
  168. (***** end of PART 1 of 2 ******************************)
  169.