1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:

unit Console32;

{$WEAKPACKAGEUNIT}

////////////////////////////////////
//********************************//
//*        Console32 Unit        *//
//* (c) 2005 by Gothicware, Inc  *//
//*                              *//
//*  This Libary is OPENSOUCURE  *//
//*  and shared under the therms *//
//*  of the  GNU Puplic License  *//
//********************************//
////////////////////////////////////
{
This is free software, get info about GPL, LGPL and opensource at
http://www.gnu.org

This software comes with absolutely no guaranty, so use it at your own risk!
}


interface

uses
  SysUtils, Classes, Windows;

const
  FG_STANDARD   = $007;
  FG_BLACK      = $000;
  FG_DARKBLUE   = $001;
  FG_DARKGREEN  = $002;
  FG_WEIRDBLUE  = $003;
  FG_RED        = $004;
  FG_ROSA       = $005;
  FG_BROWN      = $006;
  FG_LITEGRAY   = $007;
  FG_DARKGRAY   = $008;
  FG_BLUE       = $009;
  FG_GREEN      = $00A;
  FG_LITEBLUE   = $00B;
  FG_LITERED    = $00C;
  FG_LITEROSA   = $00D;
  FG_YELLOW     = $00E;
  FG_WHITE      = $00F;

  BG_STANDARD   = $000;
  BG_BLACK      = $000;
  BG_DARKBLUE   = $010;
  BG_DKGREEN    = $020;
  BG_WEIRDBLUE  = $030;
  BG_RED        = $040;
  BG_ROSA       = $050;
  BG_BROWN      = $060;
  BG_LITEGRAY   = $070;
  BG_DARKGRAY   = $080;
  BG_BLUE       = $090;
  BG_GREEN      = $0A0;
  BG_LITEBLUE   = $0B0;
  BG_LITERED    = $0C0;
  BG_LITEROSA   = $0D0;
  BG_YELLOW     = $0E0;
  BG_WHITE      = $0F0;

  {Register of Functions and Procedures}
          procedure Clear; stdcall;
          procedure PaintLine(row: Integer; color: dword; char: char); stdcall;
          procedure SetCurPos(column,row:Integer); stdcall;
          function  GetCurPos:Coord; stdcall;
          procedure SetColor(color:dword); stdcall;
          function  GetColor:dword; stdcall;
          procedure SetCodepage(Codepage:dword); stdcall;
          function  GetCodepage:dword; stdcall;
          procedure SetTitle(title:string); stdcall;
          function  GetTitle:string; stdcall;
          procedure SetCurDir(Directory:string); stdcall;
          function  GetCurDir:string; stdcall;
          procedure TextOut(column,row: integer; color: dword; text: string); stdcall;
          procedure TextOutLeft(row: integer; color: dword; text: string); stdcall;
          procedure TextOutCenter(row: integer; color: dword; text: string); stdcall;
          procedure TextOutRight(row: integer; color: dword; text: string); stdcall;
          function  KeyPressed: boolean; stdcall;
          function  ReadKey: Char; stdcall;

implementation

procedure Clear;
var hConsole: THandle;
    coordScreen: Coord;
    bSuccess: boolean;
    cCharsWritten: dword;
    csbi: CONSOLE_SCREEN_BUFFER_INFO;
    dwConSize: dword;
begin
  coordScreen.X := 0;
  coordScreen.Y := 0;
  hConsole := GetStdHandle(STD_OUTPUT_HANDLE);
  bSuccess := GetConsoleScreenBufferInfo(hConsole, csbi);
  dwConSize := csbi.dwSize.X * csbi.dwSize.Y;
  bSuccess := FillConsoleOutputCharacter(hConsole, ' ', dwConSize, coordScreen, cCharsWritten);
  bSuccess := GetConsoleScreenBufferInfo(hConsole, csbi);
  bSuccess := FillConsoleOutputAttribute(hConsole, csbi.wAttributes, dwConSize, coordScreen, cCharsWritten);
  bSuccess := SetConsoleCursorPosition(hConsole, coordScreen);
end;

procedure PaintLine(row: Integer; color: dword; char: char);
var oldcolor: dword;
    i: Integer;
begin
oldcolor:= getcolor;
for i := 0 to 79 do TextOut(i,row,color,char);
setcolor(oldcolor);
end;

procedure SetCurPos(column,row:Integer);
var coordScreen: Coord;
begin
  coordScreen.X := column;
  coordScreen.Y := row;
  SetConsoleCursorPosition(GetStdHandle(STD_OUTPUT_HANDLE), coordScreen);
end;

function GetCurPos:Coord;
var csbi: CONSOLE_SCREEN_BUFFER_INFO;
    coordScreen: Coord;
begin
if GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),csbi) then
coordScreen := csbi.dwCursorPosition;
end;

procedure SetColor(color: dword);
begin
  SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE), color);
end;

function GetColor: dWord;
var csbi: CONSOLE_SCREEN_BUFFER_INFO;
begin
if GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),csbi) then
result := csbi.wAttributes;
end;

procedure SetCodepage(Codepage: dword);
begin
SetConsoleCP(Codepage);
end;

function GetCodepage:dword;
begin
result := GetConsoleCP;
end;

procedure SetTitle(title: string);
begin
SetConsoleTitle(PChar(title));
end;

function GetTitle:string;
begin
GetConsoleTitle(PChar(result),255);
end;

procedure SetCurDir(directory :string);
begin
SetCurrentDirectory(PChar(directory));
end;

function GetCurDir:string;
begin
GetCurrentDirectory(255,PChar(result));
end;

procedure TextOut(column,row: integer; color: dword; text: string);
var oldcolor: dword;
begin
  oldcolor := GetColor;
  SetCurPos(column,row);
  SetColor(color);
  Write(text);
  SetColor(oldcolor);
end;

procedure TextOutLeft(row: integer; color: dword; text: string);
var oldcolor: dword;
begin
  oldcolor := GetColor;
  SetCurPos(0,row);
  SetColor(color);
  WriteLn(text);
  SetCurPos(0,row+1);
  SetColor(oldColor);
end;

procedure TextOutCenter(row: integer; color: dword; text: string);
var oldcolor: dword;
begin
  oldcolor := GetColor;
  SetCurPos(39-(Length(text) div 2),row);
  SetColor(color);
  WriteLn(text);
  SetCurPos(0,row+1);
  SetColor(oldColor);
end;

procedure TextOutRight(row: integer; color: dword; text: string);
var oldcolor: dword;
begin
  oldcolor := GetColor;
  SetCurPos(79-(Length(text)),row);
  SetColor(color);
  WriteLn(text);
  SetCurPos(0,row+1);
  SetColor(oldcolor);
end;

function KeyPressed: boolean;
var
  NumberOfEvents: Cardinal;
begin
  GetNumberOfConsoleInputEvents(GetStdHandle(STD_INPUT_HANDLE), NumberOfEvents);
  result := NumberOfEvents > 0;
end;

function ReadKey: Char;
var
  NumRead: Cardinal;
  InputRec: TInputRecord;
begin
  while ((not ReadConsoleInput(GetStdHandle(STD_INPUT_HANDLE), InputRec, 1, NumRead)) or (InputRec.EventType <> KEY_EVENT)) do ;
  Result := InputRec.Event.KeyEvent.AsciiChar;
end;

end.                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:

program Console;

{$APPTYPE CONSOLE}   

uses
  SysUtils,
  Classes,
  Windows,
  Console32;

var inputstr:string;
begin
        Clear;
        SetTitle('Console Test - Gothicware, Inc.');
        PaintLine(0,FG_YELLOW xor BG_RED,' ');
        TextOutCenter(0,FG_YELLOW xor BG_RED,'Welcome to Console Test Ultil');
        TextOut(0,2,FG_GREEN,'  CodePage: ');
        TextOut(GetCurPos.x,2,FG_YELLOW,IntToStr(GetCodepage));
        SetColor(FG_STANDARD);
        TextOut(0,24,FG_STANDARD,GetCurDir);
  while Ord(ReadKey) <> 27 do
        begin
        Readln;
        Clear;
        SetTitle('Console Test - Gothicware, Inc.');
        PaintLine(0,FG_YELLOW xor BG_RED,' ');
        TextOutCenter(0,FG_YELLOW xor BG_RED,'Welcome to Console Test Ultil');
        TextOut(0,2,FG_GREEN,'  CodePage: ');
        TextOut(GetCurPos.x,2,FG_YELLOW,IntToStr(GetCodepage));
        SetColor(FG_STANDARD);
        TextOut(0,24,FG_STANDARD,GetCurDir);
        end;
end.