dxcrt.pas

Well known and usefull component for delphi 7

unit DXCrt;

///////////////////////////////////////////////////////////////////////////////
//         Unit: DXCRT
//       Author: G.E. Ozz Nixon Jr. ([e-mail])
// ========================================================================
// Source Owner: DX, Inc. 1995-2002
//    Copyright: All code is the property of DX, Inc. Licensed for
//               resell by Brain Patchwork DX (tm) and part of the
//               DX (r) product lines, which are (c) 1999-2002
//               DX, Inc. Source may not be distributed without
//               written permission from both Brain Patchwork DX,
//               and DX, Inc.
//      License: (Reminder), None of this code can be added to other
//               developer products without permission. This includes
//               but not limited to DCU's, DCP's, DLL's, OCX's, or
//               any other form of merging our technologies. All of
//               your products released to a public consumer be it
//               shareware, freeware, commercial, etc. must contain a
//               license notification somewhere visible in the
//               application.
//               Example is Internet Explorer - Help->About screen
//               shows the licensed code contained in the application.
// Code Version: (1st Generation Code)
// ========================================================================
//  Description: Non-Component Implementation of CRT for Console Apps.
// ========================================================================
// Version 1.0
// Implemented basic CRT commands
//
// To-Do:
// 1. Implement a true Window Command w/ Scrolling
// 2. Convert to a TObject/TComponent Design
// 3. Implement MKCRT Region Features
// 4. Clone, to a TCanvas based CRT too
// 5. Implement OPCRT, so I can use my old ObjectPro code!
///////////////////////////////////////////////////////////////////////////////
// ReadKey Result Chart (ASCII scan codes)
// F1=0,59 F2=0,60 F3=0,61 F4=0,62 F5=0,63 F6=0,64
// F7=0,65 F8=0,66 F9=0,67 F10=0,68 F11=0,87 F12=0,88
// Ctrl+Tab=0,15
// Ctrl+BS=127
// Ctrl-Enter=10
// Ctrl-ScrlLock=Ctrl-Break {abort program if console mode!}
// CapLock=0,58
// LeftWindowButton=0,91
// RightWindowButton=0,92
// PopupBotton=0,93
// NumLock=0,69 ScrlLock=0,70 Home=0,71 Up=0,72, PgUp=0,73,
// ???=0,74 Left=0,75 5=0,76 Right=0,77 ???=0,78
// End=0,79 Dn=0,80 PgDn=0,81 Ins=0,82 Del=0,83
///////////////////////////////////////////////////////////////////////////////

interface
{$WARNINGS OFF}
const
  BW40          = 0;
  CO40          = 1;
  C40           = CO40;
  BW80          = 2;
  CO80          = 3;
  C80           = CO80;
  Mono          = 7;
  Font8x8       = 256;

{ Foreground and background color constants }
  Black        = 0;
  Blue         = 1;
  Green        = 2;
  Cyan         = 3;
  Red          = 4;
  Magenta      = 5;
  Brown        = 6;
  LightGray    = 7;
  DarkGray     = 8;
  LightBlue    = 9;
  LightGreen   = 10;
  LightCyan    = 11;
  LightRed     = 12;
  LightMagenta = 13;
  Yellow       = 14;
  White        = 15;
  Blink        = 128;
{ not used only declared by means of compatibility }
  DetectMultitasking : Boolean = True;

var
   StdIn,
   StdOut,
   StdErr:Integer;
   CheckBreak,
   CheckEOF,
   DirectVideo,        { not used only declared by means of compatibility }
   CheckSnow:Boolean;  { not used only declared by means of compatibility }
   TextAttr:byte;
   WindMin,            {Window XLow and YLow: 0..24, 0..79 format}
   WindMax,            {Window XHigh and YHigh: 0..24, 0..79 format}
   LastMode:word;      {current video mode in low byte / 8x8 flag in high byte}

Function GetWindowName:String;
Procedure SetWindowName(Value:String);
Procedure ProcessWindowsMessageQueue;

procedure TextMode(mode: integer);
procedure Window(x1, y1, x2, y2: byte);
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure GotoXY(x,y:byte);
function WhereX: byte;
function WhereY: byte;
procedure TextColor(Color:byte);
procedure TextBackground(Color:byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
function KeyPressed:boolean;
function ReadKey:char;
procedure Delay(ms: word);
procedure Sound(Hz:word);
procedure NoSound;

procedure Write(buf:string);
procedure Writeln(buf:string);
procedure WriteInt(buf:Integer);

{- write to screen, without effecting current xy and color!}
Procedure FastWrite(Buf:String;X,Y,Attr:Integer);
Procedure DoFrame(xl,yl,xh,yh,boxtype:Byte);
Procedure DoFrameFilled(xl,yl,xh,yh,boxtype:Byte);

Procedure InitializationHook;

implementation

Uses
{$IFNDEF LINUX}
   Windows,
{$ELSE}
   Libc,
{$ENDIF}
   DXString,
   Classes;

{$IFDEF VER100}
type
  CONSOLE_SCREEN_BUFFER_INFO = TConsoleScreenBufferInfo;
  COORD = TCOORD;
{$ENDIF}
Var
   NormAttr : byte;
   CurrentCrtSize : word;
   SpecialKey : boolean;
   AttrInfo : CONSOLE_SCREEN_BUFFER_INFO;
   CurMode:Word;
   LastAttr:Byte;

Procedure ProcessWindowsMessageQueue;
Var
   MsgRec:TMsg;

Begin
   while PeekMessage(MsgRec,0,0,0,PM_REMOVE) do begin
      TranslateMessage(MsgRec);
      DispatchMessage(MsgRec)
   end;
End;

Procedure DoFrame(xl,yl,xh,yh,boxtype:Byte);
Var
   Ty:Byte;
   Ws:String;
   TopLeft,
   TopRight,
   BottomLeft,
   BottomRight,
   Horizline,
   Vertline:Char;

Const
   Frame: String = '赏缓燃';

Begin
   case boxtype of
      0:begin
            TopLeft:=' ';
            BottomLeft:=' ';
            TopRight:=' ';
            BottomRight:=' ';
            horizline:=' ';
            vertline:=' ';
        end;
      1:begin
            TopLeft:='