Интересует то, как можно dos-приложение засунуть в окно(естественно написанное на Delphi), но не только текст, как через пайпы, а все окно, с возможностью управления над ним.
Пример: Такое окно открывается в Windows, при запуске консольного приложения в режиме "отображать в окне".
Мне кажется, что никак не получится. Окно дельфиное - это окно. А досовое приложение - это по-любому запуск VDM (виртуальной машины ДОС).
И как умять одно в другое - я лично без понятия. Есть предположение, что это можно написать с помощью WinAPI, с регистрацией окна, созданием экземпляра VDM и так дальше...
Создаёшь консоль, активизирушь её, запускаешь в ней приложение и упровляешь ей...
Всё просто ;)
{*******************************************************}
{ }
{ Borland Delphi 5.5 Runtime Library }
{ DrvCrt Unit version 1.1.0.1 }
{ }
{ Copyright © 2001 MJ Soft (Russia-Ufa) }
{ }
{*******************************************************}
unit DrvCrt;
// Работа с экраном в текстовом режиме
// с многоязыковой поддержкой и без VCL.
interface
uses Windows;
const
CR = #10; // Перевод на следующюю строку при наличии 0 бита в режиме консоли
Ramka_LineH: array[1..2] of Char = (#196, #205); // "-=" Горизонтальная палка
Ramka_LineV: array[1..2] of Char = (#179, #186); // Вертикальная палка
Ramka_LineHV: array[1..4] of Char = (#197, #186, #215, #216); // Крест
Ramka_LineRD: array[1..4] of Char = (#218, #201, #214, #213); // Справа вниз
Ramka_LineLD: array[1..4] of Char = (#191, #187, #183, #184); // Слева вниз
Ramka_LineRU: array[1..4] of Char = (#192, #200, #211, #212); // Справа вверх
Ramka_LineLU: array[1..4] of Char = (#217, #188, #189, #190); // Слева вверх
Ramka_LineVL: array[1..4] of Char = (#180, #185, #181, #182); // Вертикальная палка + Лево
Ramka_LineVR: array[1..4] of Char = (#195, #204, #198, #199); // Вертикальная палка + Право
Ramka_LineHU: array[1..4] of Char = (#193, #202, #208, #207); // Горизонтальная палка + Вверх
Ramka_LineHD: array[1..4] of Char = (#194, #203, #210, #209); // Горизонтальная палка + Вниз
// 1 - Оба направления одиночная полоска
// 2 - Оба направления двойная полоска
// 3 - Первое направления одиночная полоска, второе направление двойная полоска
// 4 - Первое направления двойная полоска, второе направление одиночная полоска
BarChar: array[1..5] of Char = (#219, #220, #221, #222, #223);
// символы-квадраты соответственно: весь, снизу, слева, справа, сверху
PsetChar: array[1..3] of Char = (#176, #177, #178); // Точеки соответственно: мало, средне, много
NumberChar = #252; // Знак "№" (номер)
SolnChar = #253; // Знак "Солнышко"
SqeChar = #251; // Знак "Корень"
CenterPsetChar = #149; // Маленькая точка в центре
CenterMiniPsetChar = #150; // Совсем маленькая точка в центре
type
_CodOut = (ccAnsiChar, ccWideChar);
TCodOut = _CodOut;
TEventCrt = TInputRecord;
var
STDInputHandle: THandle;
STDOutPutHandle: THandle;
STDErrorHandle: THandle;
ActiveCrt: THandle;
{ Начало работы }
procedure InitDrvCrt;
{ Конец работы }
procedure DoneDrvCrt;
{ Создание экрана }
function CreateCrt: THandle;
{ Удаление экрана }
procedure DestroyCrt(Handle: THandle);
{ Установка режима }
procedure SetModeCrt(Handle: THandle; Mode: Cardinal);
{ Чтение режима }
function GetModeCrt(Handle: THandle): Cardinal;
{ Установка активного экрана }
procedure SetActiveCrt(Handle: THandle);
{ Отключение активных экранов }
procedure FreeCrt;
{ Установка названия в панели задач }
procedure SetTitleCrt(Title: String);
{ Чтение названия с панели задач }
function GetTitleCrt: String;
{ Установка позиции курсора }
procedure SetCursorPosCrt(X, Y: SmallInt); overload;
procedure SetCursorPosCrt(Pos: TCoord); overload;
{ Чтение позиции курсора }
procedure GetCursorPosCrt(var X, Y: SmallInt); overload;
procedure GetCursorPosCrt(var Pos: TCoord); overload;
{ Установка цвета вывода текста }
procedure SetTextOutColorCrt(Attr: Word);
{ Вывод текста}
procedure OutTextCrt(Str: Variant; Cod: TCodOut=ccWideChar); overload;
procedure OutTextCrt(X, Y: Integer; Str: Variant; Cod: TCodOut=ccWideChar); overload;
{ Cod - Способ передачи данных }
{ Чтение событий }
function GetEventCrt(Delete: Boolean=True): TEventCrt;
{ Delete True удаляет событие из очереди после чтения }
{ Изменение кодировки строк из Windows кодировки в кодировку Dos }
function WinToDos(Str: String): String; // Работает быстро, но не по стандартам!!!
implementation
{****************************************}
procedure InitDrvCrt;
begin
STDInputHandle := GetStdHandle(STD_Input_Handle);
STDOutPutHandle := GetStdHandle(STD_OutPut_Handle);
STDErrorHandle := GetStdHandle(STD_Error_Handle);
end;
procedure DoneDrvCrt;
begin
CloseHandle(STDInputHandle);
CloseHandle(STDOutPutHandle);
CloseHandle(STDErrorHandle);
end;
function CreateCrt: THandle;
begin
Result := CreateConsoleScreenBuffer(
GENERIC_READ or GENERIC_WRITE,
0, nil, CONSOLE_TEXTMODE_BUFFER, nil);
end;
procedure DestroyCrt(Handle: THandle);
begin
if CloseHandle(Handle) then
if Handle=ActiveCrt then
FreeCrt;
end;
procedure SetModeCrt(Handle: THandle; Mode: Cardinal);
begin
SetConsoleMode(Handle, Mode);
end;
function GetModeCrt(Handle: THandle): Cardinal;
begin
GetConsoleMode(Handle, Result);
end;
procedure SetActiveCrt(Handle: THandle);
begin
if SetConsoleActiveScreenBuffer(Handle) then
ActiveCrt := Handle;
end;
procedure FreeCrt;
begin
if FreeConsole then
ActiveCrt := 0
end;
{****************************************}
procedure SetTitleCrt(Title: String);
begin
SetConsoleTitleA(PChar(Title));
end;
function GetTitleCrt: String;
begin
SetLength(Result, 256);
SetLength(Result, GetConsoleTitleA(PChar(Result), 256));
end;
procedure SetCursorPosCrt(X, Y: SmallInt);
var
Coord: TCoord;
begin
Coord.X := X;
Coord.Y := Y;
SetConsoleCursorPosition(ActiveCrt, Coord);
end;
procedure SetCursorPosCrt(Pos: TCoord);
begin
SetConsoleCursorPosition(ActiveCrt, Pos);
end;
procedure GetCursorPosCrt(var X, Y: SmallInt);
var
CSBI: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(ActiveCrt, CSBI);
X := CSBI.dwCursorPosition.X;
Y := CSBI.dwCursorPosition.Y;
end;
procedure GetCursorPosCrt(var Pos: TCoord);
var
CSBI: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(ActiveCrt, CSBI);
Pos := CSBI.dwCursorPosition;
end;
procedure SetTextOutColorCrt(Attr: Word);
begin
SetConsoleTextAttribute(ActiveCrt, Attr)
end;
procedure OutTextCrt(Str: Variant; Cod: TCodOut=ccWideChar);
var
tC: Cardinal;
WC: WideString;
begin
if Cod=ccWideChar then
begin
WC := String(Str);
WriteConsoleW(ActiveCrt, PWideChar(WC), Length(String(Str)), tC, nil);
end else
WriteConsoleA(ActiveCrt, PChar(String(Str)), Length(String(Str)), tC, nil);
end;
procedure OutTextCrt(X, Y: Integer; Str: Variant; Cod: TCodOut=ccWideChar);
var
tC: Cardinal;
WC: WideString;
begin
SetCursorPosCrt(X, Y);
if Cod=ccWideChar then
begin
WC := String(Str);
WriteConsoleW(ActiveCrt, PWideChar(WC), Length(String(Str)), tC, nil);
end else
WriteConsoleA(ActiveCrt, PChar(String(Str)), Length(String(Str)), tC, nil);
end;
function GetEventCrt(Delete: Boolean=True): TEventCrt;
var
tC: Cardinal;
begin
if Delete then
ReadConsoleInputA(STDInputHandle, Result, 1, tC)
else
PeekConsoleInputA(STDInputHandle, Result, 1, tC);
end;
{****************************************}
function WinToDos(Str: String): String;
var
I: Integer;
begin
Result := '';
if Str='' then
Exit;
for I := 1 to Length(Str) do
case Str[I] of
' ': Result := Result+' ';
'А'..'п': Result := Result+Char(Byte(Str[I])-64);
'р'..'я': Result := Result+Char(Byte(Str[I])-16);
'Ё': Result := Result+'р';
'ё': Result := Result+'с';
else
Result := Result+Str[I];
end;
end;
{****************************************}
initialization
finalization
end.