DOS в окне Опции

[Yu Lo]

Интересует то, как можно dos-приложение засунуть в окно(естественно написанное на Delphi), но не только текст, как через пайпы, а все окно, с возможностью управления над ним.

  Пример: Такое окно открывается в Windows, при запуске консольного приложения в режиме "отображать в окне".

[Warlock]

Мне кажется, что никак не получится. Окно дельфиное - это окно. А досовое приложение  - это по-любому запуск VDM (виртуальной машины ДОС).
И как умять одно в другое - я лично без понятия. Есть предположение, что это можно написать с помощью WinAPI, с регистрацией окна, созданием экземпляра VDM и так дальше...

[mj]

Создаёшь консоль, активизирушь её, запускаешь в ней приложение и упровляешь ей...
Всё просто ;)

{*******************************************************}
{                                                       }
{       Borland Delphi 5.5 Runtime Library              }
{       DrvCrt Unit version 1.1.0.1                     }
{                                                       }
{       Copyright (c) 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.