hmmm, eto tuk neshto , deto moje da ti svarshi rabota.
bqh popadal na neshto predi i go prigodih za moite nuzdi.
svarshi rabota. e verno che e malko izmisleno , no vse pak raboti.
shte se radvam da vidq po-hitar nachin.

const
CmdFilename = 'cmdline.bat';

var
cmdfile : textfile;

//***************************************
// Запис на ДОС-командата в .BAT file
//
procedure FillCmd(CmdLine: string);
begin
Rewrite(cmdfile);

Writeln(cmdfile, cmdline);

CloseFile(cmdfile);
end;

//********************************************************
// Основна функция
//
procedure ConsoleCmd(CmdLine:String; OutMemo:TMemo);
const
BUFSIZE = 2000;
var
SecAttr : TSecurityAttributes; // uses Windows
hReadPipe,
hWritePipe : THandle;
StartupInfo: TStartUpInfo;
ProcessInfo: TProcessInformation;
Buffer : Pchar;
WaitReason,
BytesRead : DWord;
begin
FillCmd(CmdLine);

with SecAttr do
begin
nlength := SizeOf(TSecurityAttributes);
bInheritHandle := true;
lpSecurityDescriptor := nil;
end;

if CreatePipe (hReadPipe, hWritePipe, @SecAttr, 0) then
begin
Buffer := AllocMem(BUFSIZE + 1);

FillChar(StartupInfo, Sizeof(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.hStdOutput := hWritePipe;
StartupInfo.hStdInput := hReadPipe;
StartupInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_HIDE;

if CreateProcess(nil,
PChar(CmdFilename),
@SecAttr,
@SecAttr,
true,
NORMAL_PRIORITY_CLASS,
nil,
nil,
StartupInfo,
ProcessInfo) then
begin
//
repeat
WaitReason := WaitForSingleObject( ProcessInfo.hProcess,100);
Application.ProcessMessages;
until (WaitReason <> WAIT_TIMEOUT);
//
Repeat
BytesRead := 0;
ReadFile(hReadPipe, Buffer[0], BUFSIZE, BytesRead, nil);
// Терминиране на стринга:
Buffer[BytesRead]:= #0;

OemToAnsi(Buffer,Buffer);
// Показва се изхода
OutMemo.Text := OutMemo.text + String(Buffer);
until (BytesRead < BUFSIZE);
end;
FreeMem(Buffer);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(hReadPipe);
CloseHandle(hWritePipe);
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
ConsoleCmd('dir', Memo1); // тест за dir командата
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
AssignFile(cmdfile, CmdFilename);
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
var
line : string;
row : integer;
begin
if not (Key = #13) then
Exit;

row := Memo1.CaretPos.Y;

line := Memo1.Lines.Strings[row];

if line < #32 then Exit; // Избягване на контролните ESC-последователности

if CompareText(line,'cls') = 0 then // Малко измислено , но .... засега е така
Memo1.Clear
else
ConsoleCmd(line, Memo1);

Memo1.SelStart := Length(Memo1.Text);
end;

Щом не върви от първия път, значи има шанс

Редактирано от LongJohn на 26.09.02 10:34.