JHz
Code :
unit uConsoleClass;
interface
uses Windows;
type
TConsoleControl = Class
private
FhStdIn : THandle; // Handle to the standard input
FhStdOut : THandle; // Handle to the standard output
FhStdErr : THandle; // Handle to the standard error (Output)
FbConsoleAllocated : Boolean; // Creation Flag
FBgAttrib : Cardinal; // Currently set BackGround Attribs.
FFgAttrib : Cardinal; // Currently set ForeGround Attribs.
public
constructor Create;
(* Creates a new consolewindow, or connects the current window *)
destructor Destroy;override;
(* Cleanup of the class structures *)
(* Color properties:
The console window does not handle the colors like known form delphi
components. Each color will be created from a red,green,blue and a
intensity part. In fact the resulting colors are the same as the well
known 16 base colors (clwhite .. clBlack).
Black ist if all flags are false, white if all flag are true.
The following two functions will change the color for following
writes *)
procedure SetForegroundColor(bRed,bGreen,bBlue,bIntensity : Boolean);
procedure SetBackgroundColor(bRed,bGreen,bBlue,bIntensity : Boolean);
(* Writing functions :
simple wrapper around WriteConsole
*)
procedure WriteText (const s : string);
procedure WriteTextLine( const s : string);
(* Change the Windowtitle of the command window. If the program has been
executed from a CMD-box the title change is only active while the
programs execution time *)
procedure SetWindowTitle (const sTitle : string);
(* some Cursor manipulation functions *)
procedure ShowCursor ( iSize : Integer);
procedure HideCursor;
procedure GetCursorPos( var x,y : integer);
procedure SetCursorTo(x,y : integer);
(* screen operations:
the screen ist the visible part of a cmd window. Behind the window
there
is a screenbuffer. The screenbuffer may be larger than the visible
window *)
procedure ClearScreen;
function GetScreenLeft : integer;
function GetScreenTop : Integer;
function GetScreenHeight : integer;
function GetScreenWidth : integer;
(* screenbuffer operations *)
procedure ClearBuffer;
function GetBufferHeight : integer;
function GetBufferWidth : integer;
(* sample to read characters from then screenbuffer *)
procedure GetCharAtPos(x,y : Integer;var rCharInfo : Char);
end;
implementation
{ TConsoleControl }
procedure TConsoleControl.ClearBuffer;
var
SBInfo : TConsoleScreenBufferInfo;
ulWrittenChars : Cardinal;
TopLeft : TCoord;
begin
TopLeft.X := 0;
TopLeft.Y := 0;
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
FillConsoleOutputCharacter(FhStdOut,' ',
SBInfo.dwSize.X * SBInfo.dwSize.Y,
TopLeft,
ulWrittenChars);
FillConsoleOutputAttribute( FhStdOut,
FOREGROUND_RED or FOREGROUND_BLUE or
FOREGROUND_GREEN,
(SBInfo.srWindow.Right - SBInfo.srWindow.Left)
*
(SBInfo.srWindow.Bottom -
SBInfo.srWindow.Top),
TopLeft,
ulWrittenChars);
end;
procedure TConsoleControl.ClearScreen;
var
SBInfo : TConsoleScreenBufferInfo;
ulWrittenChars : Cardinal;
TopLeft : TCoord;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
TopLeft.X := SBInfo.srWindow.Left;
TopLeft.Y := SBInfo.srWindow.Top;
FillConsoleOutputCharacter(FhStdOut,' ',
(SBInfo.srWindow.Right - SBInfo.srWindow.Left)
*
(SBInfo.srWindow.Bottom - SBInfo.srWindow.Top),
TopLeft,
ulWrittenChars);
FillConsoleOutputAttribute(FhStdOut,FOREGROUND_RED or FOREGROUND_BLUE or
FOREGROUND_GREEN,
(SBInfo.srWindow.Right - SBInfo.srWindow.Left)
*
(SBInfo.srWindow.Bottom - SBInfo.srWindow.Top),
TopLeft,
ulWrittenChars);
end;
constructor TConsoleControl.Create;
begin
inherited Create;
// A process can be associated with only one console, so the AllocConsole
// function fails if the calling process already has a console.
FbConsoleAllocated := AllocConsole;
// initializing the needed handles
FhStdOut := GetStdHandle(STD_OUTPUT_HANDLE);
FhStdErr := GetStdHandle(STD_ERROR_HANDLE);
FhStdIn := GetStdHandle(STD_INPUT_HANDLE);
end;
destructor TConsoleControl.Destroy;
begin
if FbConsoleAllocated then FreeConsole;
inherited;
end;
function TConsoleControl.GetBufferHeight: integer;
var
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
Result := SBInfo.dwSize.Y;
end;
function TConsoleControl.GetBufferWidth: integer;
var
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
Result := SBInfo.dwSize.X;
end;
procedure TConsoleControl.GetCharAtPos(x, y: Integer; var rCharInfo : Char);
var
CharInfo : array [0..10] of Char;
TopLeft : TCoord;
CharsRead : Cardinal;
begin
TopLeft.x := X;
TopLeft.Y := Y;
ReadConsoleOutputCharacter(FhStdOut,CharInfo,10,TopLeft,CharsRead);
rCharInfo := CharInfo[0];
end;
procedure TConsoleControl.GetCursorPos(var x, y: integer);
var
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
x := SBInfo.dwCursorPosition.X;
y := SBInfo.dwCursorPosition.Y;
end;
function TConsoleControl.GetScreenHeight: integer;
var
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
Result := SBInfo.srWindow.Bottom -SBInfo.srWindow.Top;
end;
function TConsoleControl.GetScreenLeft: integer;
var
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
Result := SBInfo.srWindow.Left;
end;
function TConsoleControl.GetScreenTop: Integer;
var
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
Result := SBInfo.srWindow.Top;
end;
function TConsoleControl.GetScreenWidth: integer;
var
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
Result := SBInfo.srWindow.Right - SBInfo.srWindow.Left;
end;
procedure TConsoleControl.HideCursor;
var
ConsoleCursorInfo : TConsoleCursorInfo;
begin
GetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
if ConsoleCursorInfo.bVisible then begin
ConsoleCursorInfo.bVisible := False;
SetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
end;
end;
procedure TConsoleControl.SetBackgroundColor(bRed, bGreen, bBlue,
bIntensity: Boolean);
begin
FBgAttrib := 0;
if bRed then FBgAttrib := FBgAttrib or BACKGROUND_RED;
if bGreen then FBgAttrib := FBgAttrib or BACKGROUND_GREEN;
if bBlue then FBgAttrib := FBgAttrib or BACKGROUND_BLUE;
if bIntensity then FBgAttrib := FBgAttrib or BACKGROUND_INTENSITY;
SetConsoleTextAttribute(FhStdOut,FBgAttrib or FFgAttrib);
end;
procedure TConsoleControl.SetCursorTo(x, y: integer);
var
Coords : TCoord;
SBInfo : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(FhStdOut,SBInfo);
if x < 0 then Exit;
if y < 0 then Exit;
if x > SbInfo.dwSize.X then Exit;
if y > SbInfo.dwSize.Y then Exit;
Coords.X := x;
Coords.Y := y;
SetConsoleCursorPosition(FhStdOut,Coords);
end;
procedure TConsoleControl.SetForegroundColor(bRed, bGreen, bBlue,
bIntensity: Boolean);
begin
FFgAttrib := 0;
if bRed then FFgAttrib := FFgAttrib or FOREGROUND_RED;
if bGreen then FFgAttrib := FFgAttrib or FOREGROUND_GREEN;
if bBlue then FFgAttrib := FFgAttrib or FOREGROUND_BLUE;
if bIntensity then FFgAttrib := FFgAttrib or FOREGROUND_INTENSITY;
SetConsoleTextAttribute(FhStdOut,FBgAttrib or FFgAttrib);
end;
procedure TConsoleControl.SetWindowTitle(const sTitle: string);
begin
SetConsoleTitle(PChar(sTitle));
end;
procedure TConsoleControl.ShowCursor(iSize: Integer);
var
ConsoleCursorInfo : TConsoleCursorInfo;
begin
GetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
if (not ConsoleCursorInfo.bVisible) or
( ConsoleCursorInfo.dwSize <> iSize ) then begin
ConsoleCursorInfo.bVisible := True;
ConsoleCursorInfo.dwSize := iSize;
SetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);
end;
end;
procedure TConsoleControl.WriteText(const s: string);
var
ulLength : Cardinal;
begin
WriteConsole(FhStdOut,PChar(s),Length(s),ulLength,NIL);
end;
procedure TConsoleControl.WriteTextLine(const s: string);
begin
WriteText(s+#13#10);
end;
end.
---------- end of unit uConsoleClass ------
----------- sample main that simulates a "starfield" ----------
program console;
{$APPTYPE CONSOLE}
uses
SysUtils,
Windows,
uConsoleClass in 'uConsoleClass.pas';
var
MyConsole : TConsoleControl;
procedure Stars ;
var
x,y,w,h : Integer;
x1,y1 : Integer;
CharInfo: Char;
i : integer;
begin
MyConsole.ClearScreen;
x := MyConsole.GetScreenLeft;
y := MyConsole.GetScreenTop;
h := MyConsole.GetScreenHeight div 4;
w := MyConsole.GetScreenWidth div 4;
for i := 1 to 15000 do begin
x1 := x+Random(w)*4;
y1 := y+Random(h)*4;
MyConsole.SetCursorTo(x1,y1);
MyConsole.GetCharAtPos(x1,y1,CharInfo);
MyConsole.SetForegroundColor(Bool(Random(2)),Bool(Random(2)),Bool(Random(2))
,Bool(Random(2)));
if (CharInfo = ' ') or (CharInfo = #0) then begin
MyConsole.WriteText('.');
end
else if CharInfo = '.' then begin
MyConsole.WriteText('+');
end
else if CharInfo = '+' then begin
MyConsole.WriteText('*');
end
else if CharInfo = '*' then begin
MyConsole.WriteText(' ');
end;
sleep (5);
end;
end;
begin
MyConsole := TConsoleControl.Create;
Stars ;
MyConsole.Free;
end.
procedure TfmDbuMain.ExecuteISQL(FileName: string);
const
BufSize = $4000;
type
TPipeHandles = record
hRead,
hWrite: DWORD;
end;
procedure ClosePipe(var Pipe: TPipeHandles);
begin
with Pipe do
begin
if hRead <> 0 then CloseHandle (hRead);
if hWrite <> 0 then CloseHandle (hWrite);
hRead := 0;
hWrite := 0;
end;
end;
function ReadPipe(var Pipe: TPipeHandles): string;
var
ReadBuf: array[0..BufSize] of Char;
BytesRead: Dword;
begin
result := '';
if PeekNamedPipe(Pipe.hRead, nil, 0, nil, @BytesRead, nil) and
(BytesRead > 0) then
begin
ReadFile(Pipe.hRead, ReadBuf, BytesRead, BytesRead, nil);
if BytesRead > 0 then
begin
ReadBuf[BytesRead] := #0;
result := ReadBuf;
end;
end;
end;
var
SecAttr : TSecurityAttributes;
StartupInfo: TStartupInfo;
PipeStdOut: TPipeHandles;
PipeStdErr: TPipeHandles;
Cmd: string;
dwExitCode: DWORD;
outstr: string;
error_msg: string;
begin
SecAttr.nLength := SizeOf(SecAttr);
SecAttr.lpSecurityDescriptor := nil;
SecAttr.bInheritHandle := TRUE;
error_msg := '';
with PipeStdOut do
if not CreatePipe (hRead, hWrite, @SecAttr, BufSize) then
XWinError('Ne mogu kreirati STDOUT pipe');
try
with PipeStdErr do
if not CreatePipe (hRead, hWrite, @SecAttr, BufSize) then
XWinError('Ne mogu kreirati STDERR pipe');
except
ClosePipe(PipeStdOut);
raise;
end;
try
FillChar(StartupInfo,SizeOf(StartupInfo), 0);
with StartupInfo do
begin
cb:= SizeOf(StartupInfo);
dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
hStdOutput := PipeStdOut.hWrite;
hStdError := PipeStdErr.hWrite;
wShowWindow := SW_HIDE;
end;
Cmd := FMSSQLBinnDir + 'isql.exe' +
' -S "'+dmPMXData.DBServerName+'"' +
' -U "'+'sa'+'"' +
' -P "'+''+'"' +
' -d "'+dmPMXData.DBDatabaseName+'"' +
' -w 255 -n ' +
' -i "'+FileName+'"' +
' -r1 -l 10';
if CreateProcess(
nil, PChar(Cmd), nil, nil, true,
DETACHED_PROCESS or NORMAL_PRIORITY_CLASS,
nil, PChar(XWorkDir),
StartupInfo,
ProcessInformation
) then
begin
dwExitCode := STILL_ACTIVE;
Screen.Cursor := crHourglass;
bbTerminate.Enabled := true;
try
repeat
///WaitForSingleObject(ProcessInformation.hProcess, 0);
GetExitCodeProcess(ProcessInformation.hProcess,
dwExitCode);
Application.ProcessMessages;
outstr := ReadPipe(PipeStdOut);
if outstr <> '' then
begin
LogStyle(ltNormal);
meOutput.SelText := outstr;
meOutput.Perform(EM_SCROLLCARET, 0, 0);
end;
outstr := ReadPipe(PipeStdErr);
if outstr <> '' then
begin
LogStyle(ltError);
meOutput.SelText := outstr;
meOutput.Perform(EM_SCROLLCARET, 0, 0);
if (error_msg = '') and (Pos('Msg 1105, Level 17',
outstr) > 0) then
begin
(* Error Message text:
Can't allocate space for object '%.*s' in database
'%.*s' because the
'%.*s' segment is full. If you ran out of space in
Syslogs, dump the
transaction log. Otherwise, use ALTER DATABASE or
sp_extendsegment to increase
the size of the segment.
*)
error_msg := 'Nema mjesta na segmentu baze
podataka, treba pokusati isprazniti transaction log ili pove鎍ti
bazu.';
end;
end;
until dwExitCode <> STILL_ACTIVE;
if not GetExitCodeProcess(ProcessInformation.hProcess,
dwExitCode) then
XWinError('Ne mogu o鑙tati exit code!');
if dwExitCode <> 0 then
raise Exception.Create('Exit code ' +
IntToStr(dwExitCode));
finally
Screen.Cursor := crDefault;
bbTerminate.Enabled := false;
if dwExitCode = STILL_ACTIVE then
TerminateProcess(ProcessInformation.hProcess, 1);
CloseHandle(ProcessInformation.hProcess);
CloseHandle(ProcessInformation.hThread);
ProcessInformation.hProcess := 0;
end;
end
else
XWinError('Ne mogu lansirati ' + FMSSQLBinnDir + 'isql.exe!' +
#10 + 'Cmd: ' + Cmd);
finally
ClosePipe(PipeStdOut);
ClosePipe(PipeStdErr);
end;
if error_msg <> '' then
raise Exception.Create(error_msg);
end;