[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]

                (***************************************************)
                (*                 The Color Window                *)
                (*-------------------------------------------------*)
                (*  Copyright (c) 1995-`97 UNIVERSAL SOFTWARE Inc  *)
                (*               All Rights Reserved               *)
                (***************************************************)

    { example program at the end !! }

    unit ColorWin;

    {$S-}

    INTERFACE

    uses
     WinTypes,
     WinProcs,
     oWindows;

    (************************************************************)
    (****************** TpCrt types, consts, vars ***************)
    (************************************************************)

    type
     { the color window object }
     pColorWin=^tColorWin;
     tColorWin=object(tWindow)
      ScreenSize:tPoint;
      CharBuffer:pChar;
      AttrBuffer:pChar;
      TextAttr:byte;
      TextChar:char;
      CharSize:tPoint;
      CharAscent:integer;
      Range:tPoint;        { scrollbar ranges }
      Origin:tPoint;       { client area origin }
      ClientSize:tPoint;   { client area dimensions }
      { colorwin methods }
      procedure Byte2bkRgb(c:byte; var bkRGB:tColorRef);
      procedure Byte2fgRgb(c:byte; var fgRGB:tColorRef);
      procedure Byte2rgb(c:byte; var bkRGB:tColorRef; var fgRGB:tColorRef);
      constructor Init(AParent:pWindowsObject; aTitle:pChar);
      destructor Done; virtual;
      procedure SetupWindow; virtual;
      function GetClassName: pChar; virtual;
      procedure GetWindowClass(var aWndClass: tWndClass); virtual;
      procedure wmSize(var Msg:tMessage); virtual wm_First+wm_Size;
      {---}
      function GetNewPos(Action:word; Pos,Page,_Range, Thumb:integer):integer;
      procedure wmVScroll(var Msg:tMessage); virtual wm_First+wm_VScroll;
      procedure wmHScroll(var Msg:tMessage); virtual wm_First+wm_HScroll;
      {---}
      procedure SetScrollBars;
      function CharPtr(X,Y:integer):pChar;
      function AttrPtr(X,Y:integer):pChar;
      procedure Paint(PaintDC:hDC; var PS:tPaintStruct); virtual;
      procedure ClrScr;
      {\-clear current window}
      procedure ScrollTo(X,Y:integer);
      procedure FastWrite(St:string; Row,Col,_Attr:byte);
      {\-write St at Row,Col in Attr (video attribute)}
      procedure FastFill(Number:word; Ch:char; Row,Col,_Attr:byte);
      {\-fill Number chs at Row,Col in Attr (video attribute)}
      procedure FastCenter(St:string; Row,_Attr:byte);
      {\-write St centered on window Row in Attr (video attribute)}
     end;

    IMPLEMENTATION

    { Double word record }
    type
     LongRec=record
      Lo,Hi:integer;
     end;

    const
     vgaColor:array[0..15] of tColorRef=(
      $00000000,   { Black }
      $00800000,   { Dark Cyan }
      $00008000,   { Dark Green}
      $00808000,   { Dark Blue }
      $00000080,   { Dark red }
      $00800080,   { Dark violet }
      $00008080,   { Brown }
      $00C0C0C0,   { light Gray }
      $00808080,   { Dark Gray }
      $00FF0000,   { light blue }
      $0000FF00,   { light green }
      $00FFFF00,   { Blue }
      $000000FF,   { light red }
      $00FF00FF,   { violet }
      $0000FFFF,   { yellow }
      $00FFFFFF    { White }
     );

    type
     BufPtr=^BufferArray;
     BufferArray=array[0..MaxInt] of char;

    function Min(X,Y:integer):integer;
    {Return the smaller of two integer values}
    begin
     if X <Y then Min:=X else Min:=Y;
    end;

    function Max(X,Y:integer):integer;
    {Return the larger of two integer values}
    begin
      if X >Y then Max:=X else Max:=Y;
    end;

    (*** colorwin ***)
    constructor tColorWin.Init(aParent:pWindowsObject; aTitle:pChar);
    begin
     inherited Init(aParent,aTitle);
     Attr.Style:=Attr.Style or ws_HScroll or ws_VScroll or cs_ByteAlignClient;
                 {ws_Border or ws_Child or ws_Visible or
                 ws_HScroll or ws_VScroll or
                 cs_ByteAlignClient;}
     with ScreenSize do begin
      X:=80;  { screen width \ in chars }
      Y:=25;  { screen height/          }
      TextAttr:=$03;
      TextChar:='*';
      CharSize.X:=0;
      CharSize.Y:=0;
      CharAscent:=0;
      Origin.X:=0;
      Origin.Y:=0;
      Range.X:=0;
      Range.Y:=0;
      GetMem(CharBuffer,(ScreenSize.X*ScreenSize.Y)+1);
      GetMem(AttrBuffer,(ScreenSize.X*ScreenSize.Y)+1);
      FillChar(CharBuffer^,ScreenSize.X*ScreenSize.Y,TextChar);
      FillChar(AttrBuffer^,ScreenSize.X*ScreenSize.Y,char(TextAttr));
     end;
    end;

    destructor tColorWin.Done;
    begin
     with ScreenSize do begin
      FreeMem(CharBuffer, X*Y);
      FreeMem(AttrBuffer, X*Y);
     end;
     inherited Done;
    end;

    procedure tColorWin.SetupWindow;
    var
     DC:hDC;
     Metrics:tTextMetric;

    begin
     inherited SetupWindow;
     DC:=GetDC(hWindow);
     SelectObject(DC,GetStockObject(System_Fixed_Font));
     GetTextMetrics(DC,Metrics);
     with Metrics, CharSize  do begin
      X:=tmMaxCharWidth;
      Y:=tmHeight+tmExternalLeading;
      CharAscent:=tmAscent;
     end;
     DeleteDC(DC);
     SetScrollRange(hWindow,sb_Horz,0,ScreenSize.X-1,false);
     SetScrollRange(hWindow,sb_Vert,0,ScreenSize.Y-1,false);
    end;

    function tColorWin.GetClassName:pChar;
    begin
     GetClassName:='ColorWin';
    end;

    procedure tColorWin.GetWindowClass(var aWndClass:tWndClass);
    begin
     inherited GetWindowClass(aWndClass);
     aWndClass.hIcon:=LoadIcon(0,idi_Application);
    end;

    procedure tColorWin.wmSize(var Msg:tMessage);
    var
     x,y:integer;

    begin
     with Msg do begin
      x:=LoWord(Msg.lParam);
      y:=HiWord(Msg.lParam);
     end;
     ClientSize.X:=X div CharSize.X;
     ClientSize.Y:=Y div CharSize.Y;
     Range.X:=Max(0,ScreenSize.X-ClientSize.X);
     Range.Y:=Max(0,ScreenSize.Y-ClientSize.Y);
     Origin.X:=Min(Origin.X, Range.X);
     Origin.Y:=Min(Origin.Y, Range.Y);
     SetScrollBars;
    end;

    function tColorWin.CharPtr(X,Y:integer):pChar;
    {Return pointer to the Char at (X,Y) in the screen buffer}
    begin
     CharPtr:=@CharBuffer[Y*ScreenSize.X+X];
    end;

    function tColorWin.AttrPtr(X,Y:integer):pChar;
    {Return pointer to the Attr at (X,Y) in the screen buffer}
    begin
     AttrPtr:=@AttrBuffer[Y*ScreenSize.X+X];
    end;

    procedure tColorWin.SetScrollBars;
    {Update scroll bars}
    begin
     SetScrollRange(hWindow, sb_Horz, 0, Max(0,Range.X), false);
     SetScrollPos(hWindow, sb_Horz, Origin.X, true);
     SetScrollRange(hWindow, sb_Vert, 0, Max(0,Range.Y), false);
     SetScrollPos(hWindow, sb_Vert, Origin.Y, true);
    end;

    procedure tColorWin.ScrollTo(X,Y:integer);
    {Scroll window to given origin}
    begin
     X:=Max(0,Min(X,Range.X));
     Y:=Max(0,Min(Y,Range.Y));
     if (X <>Origin.X) or (Y <>Origin.Y) then begin
      if X <>Origin.X then SetScrollPos(hWindow,sb_Horz,X,true);
      if Y <>Origin.Y then SetScrollPos(hWindow,sb_Vert,Y,true);
      ScrollWindow(hWindow,(Origin.X-X)*CharSize.X,(Origin.Y-Y)*CharSize.Y, nil,nil);
      Origin.X:=X;
      Origin.Y:=Y;
      UpdateWindow(hWindow);
     end;
    end;

    procedure tColorWin.Byte2bkRgb(c:byte; var bkRGB:tColorRef);
    begin
     bkRGB:=vgaColor[c shr 4];
    end;

    procedure tColorWin.Byte2fgRgb(c:byte; var fgRGB:tColorRef);
    begin
     fgRGB:=vgaColor[c and $F];
    end;

    procedure tColorWin.Byte2rgb(c:byte; var bkRGB:tColorRef; var fgRGB:tColorRef);
    begin
     bkRGB:=vgaColor[c shr 4];
     fgRGB:=vgaColor[c and $F];
    end;

    procedure tColorWin.ClrScr;
    {Clear the screen}
    var
     _y:integer;

    begin
     FillChar(CharBuffer^,ScreenSize.X*ScreenSize.Y,TextChar);
     FillChar(AttrBuffer^,ScreenSize.X*ScreenSize.Y,char(TextAttr));
     Longint(Origin):=0;
     SetScrollBars;
     InvalidateRect(hWindow,nil,false {true});
     UpdateWindow(hWindow);
    end;

    procedure tColorWin.Paint(PaintDC:hDC; var PS:tPaintStruct);
    {wm_Paint message handler}
    var
     X1,X2,Y1,Y2:integer;
     bkRGB,fgRGB:tColorRef;
     i:integer;

    begin
     SelectObject(PaintDC, GetStockObject(System_Fixed_Font));
     {---}
     MoveTo(PaintDC, ScreenSize.X*CharSize.X,0);
     LineTo(PaintDC, ScreenSize.X*CharSize.X,ScreenSize.Y*CharSize.Y);
     LineTo(PaintDC, 0,ScreenSize.Y*CharSize.Y);
     X1:=Max(0, PS.rcPaint.left div CharSize.X+Origin.X);
     X2:=Min((PS.rcPaint.right+CharSize.X-1) div CharSize.X+Origin.X,ScreenSize.X);
     Y1:=Max(0, PS.rcPaint.top div CharSize.Y+Origin.Y-1);
     Y2:=Min((PS.rcPaint.bottom+CharSize.Y-1) div CharSize.Y+Origin.Y,ScreenSize.Y);
     while Y1 <Y2 do begin
      for i:=X1 to X2 do begin
       Byte2rgb(byte(AttrPtr(i,Y1)^),bkRGB,fgRGB);
       SetTextColor(PaintDC,fgRGB);
       SetBkColor(PaintDC,bkRGB);
       if i <ScreenSize.X then
        TextOut(PaintDC,(i-Origin.X)*CharSize.X,(Y1-Origin.Y)*CharSize.Y,CharPtr(i,Y1), 1);
      end;
      Inc(Y1);
     end;
    end;

    procedure tColorWin.FastWrite(St:string; Row,Col,_Attr:byte);
    begin
     Move(St[1],CharPtr(pred(Col),pred(Row))^,Length(St));
     FillChar(AttrPtr(pred(Col),pred(Row))^,Length(St),char(_Attr));
    end;

    procedure tColorWin.FastFill(Number:word; Ch:char; Row,Col,_Attr:byte);
    begin
     if Number >(ScreenSize.X*ScreenSize.Y-(Row*ScreenSize.X+Col)) then
      Number:=ScreenSize.X*ScreenSize.Y-(Row*ScreenSize.X+Col);
     FillChar(CharPtr(pred(Col),pred(Row))^,Number,Ch);
     FillChar(AttrPtr(pred(Col),pred(Row))^,Number,_Attr);
    end;

    procedure tColorWin.FastCenter(St:string; Row,_Attr:byte);
    var
     sL:byte absolute St;

    begin
     if sL >succ(ScreenSize.X-ScreenSize.X) then
      sL:=succ(ScreenSize.X-ScreenSize.X);
     FastWrite(St,ScreenSize.Y+Row,ScreenSize.X+
      succ((succ(ScreenSize.X-ScreenSize.X)-sL) shr 1),_Attr);
    end;

    function tColorWin.GetNewPos(Action:word; Pos,Page,_Range, Thumb:integer):integer;
    begin
     case Action of
      sb_LineUp: GetNewPos:=Pos-1;
      sb_LineDown: GetNewPos:=Pos+1;
      sb_PageUp: GetNewPos:=Pos-Page;
      sb_PageDown: GetNewPos:=Pos+Page;
      sb_Top: GetNewPos:=0;
      sb_Bottom: GetNewPos:=_Range;
      sb_ThumbPosition: GetNewPos:=Thumb;
     else
      GetNewPos:=Pos;
     end;
    end;

    procedure tColorWin.wmHScroll(var Msg:tMessage);
    {wm_HScroll handler}
    var
     X:integer;

    begin
     X:=Origin.X;
     X:=GetNewPos(Msg.wParam, X, ClientSize.X div 2, Range.X, Msg.lParamLo);
     ScrollTo(X, Origin.Y);
    end;

    procedure tColorWin.wmVScroll(var Msg:tMessage);
    {wm_VScroll handler}
    var
     Y:integer;

    begin
     Y:=Origin.Y;
     Y:=GetNewPos(Msg.wParam, Y, ClientSize.Y, Range.Y, Msg.lParamLo);
     ScrollTo(Origin.X, Y);
    end;

    end.

    { ----------------------   CUT  ----------------------- }

                  (************************************************)
                  (* The Demostration Module for tColorWin object *)
                  (************************************************)

    uses
     WinTypes,
     WinProcs,
     oWindows,
     ColorWin;     {-tColorWin object}

    const
     AppName:pChar='tColorWin demo';
     CaptionText:pChar='Color Window test..';

     {===[ This application does nothing but shows you ]===}
     {===[ how to use tColorWin object                 ]===}

    type
     tMyApp=object(tApplication)
      procedure InitMainWindow; virtual;
     end;

     pMyWin=^tMyWin;
     tMyWin=object(tColorWin)
      procedure SetupWindow; virtual;
     end;

    procedure tMyWin.SetupWindow;
    var
     i:byte;

    begin
     inherited SetupWindow;
     for i:=1 to 15 do
      FastWrite('Test string for check ColorWin. Don`t panic! ;-)',i,2,i);
    end;

    procedure tMyApp.InitMainWindow;
    begin
     MainWindow:=New(pMyWin,Init(nil,CaptionText));
    end;

    var
     MyApp:tMyApp;

    begin
     MyApp.Init(AppName);
     MyApp.Run;
     MyApp.Done;
    end.

[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]