Вот рабочий код по работе с консолью (спасибо КД и Горбань)
[more]
var
Form1: TForm1;
implementation
var
FChildStdoutRd, FChildStdoutWr,FChildStdinRd, FChildStdinWr, Tmp1,Tmp2 :THAndle;
{$R *.DFM}
function CreateChildProcess(ExeName, CommadLine: String; StdIn,
StdOut: THandle): Boolean;
Var
piProcInfo: TProcessInformation;
siStartInfo: TStartupInfo;
begin
// Set up members of STARTUPINFO structure.
ZeroMemory(@siStartInfo, SizeOf(TStartupInfo));
siStartInfo.cb:=SizeOf(TStartupInfo);
siStartInfo.hStdInput:=StdIn;
siStartInfo.hStdOutput:=StdOut;
siStartInfo.dwFlags:=STARTF_USESTDHANDLES;
// Create the child process.
Result:=CreateProcess(Nil,
PChar(ExeName+' '+CommadLine), // command line
Nil, // process security attributes
Nil, // primary thread security attributes
TRUE, // handles are inherited
0, // creation flags
Nil, // use parent's environment
Nil, // use parent's current directory
siStartInfo, // STARTUPINFO pointer
piProcInfo); // receives PROCESS_INFORMATION
end;
procedure NewPipe;
var
FSaAttr
SECURITYATTRIBUTES;
begin
New(FsaAttr);
FsaAttr.nLength:=SizeOf(SECURITY_ATTRIBUTES);
FsaAttr.bInheritHandle:=True;
FsaAttr.lpSecurityDescriptor:=Nil;
CreatePipe(FChildStdoutRd, FChildStdoutWr, FsaAttr, 0);
CreatePipe(FChildStdinRd, FChildStdinWr, FsaAttr, 0);
//Делаем НЕ наследуемые дубликаты
//Это нужно, чтобы не тащить лишние хэндлы в дочерний процесс...
DuplicateHandle(GetCurrentProcess(), FChildStdoutRd,
GetCurrentProcess(), @Tmp1, 0, False, DUPLICATE_SAME_ACCESS);
DuplicateHandle(GetCurrentProcess(), FChildStdinWr,
GetCurrentProcess(), @Tmp2, 0, False, DUPLICATE_SAME_ACCESS);
CloseHandle(FChildStdoutRd);//Закроем наследуемый вариант "Читального" хэндла
CloseHandle(FChildStdinWr); //Закроем наследуемый вариант "Писального" хэндла
FChildStdoutRd:=Tmp1; //И воткнем их места НЕ наследуемые дубликаты
FChildStdinWr:=Tmp2; //И воткнем их места НЕ наследуемые дубликаты
CreateChildProcess('cmd.exe', '', FChildStdinRd, FChildStdoutWr)
end;
function WriteToChild(Data: String):
Boolean;
Var
dwWritten, BufSize: DWORD;
chBuf: PChar;
begin
//Обратите внимание на Chr($0D)+Chr($0A)!!! Без них - будет работать с ошибками
//На досуге - подумайте почему...
//Для тех, кому думать лень - подскажу - это пара символов конца строки.
//(вообще-то можно обойтись одним, но так надежнее, программы-то бывают разные)
chBuf:=PChar(Data+Chr($0D)+Chr($0A));
BufSize:=Length(chBuf);
Result:=WriteFile(FChildStdinWr, chBuf^, BufSize, dwWritten, Nil);
Result:=Result and (BufSize = dwWritten);
end;
function ReadStrFromChild(Timeout: Integer): String;
Var
i: Integer;
dwRead, BufSize, DesBufSize: DWORD;
chBuf: PChar;
Res: Boolean;
begin
Try
BufSize:=0;
New(chBuf);
Repeat
For i:=0 to 9 do
begin
Res:=PeekNamedPipe(FChildStdoutRd, nil, 0, nil, @DesBufSize, nil);
Res:=Res and (DesBufSize > 0);
If Res Then
Break;
Sleep(Round(Timeout/10));
end;
If Res Then
begin
If DesBufSize > BufSize Then
begin
FreeMem(chBuf);
GetMem(chBuf, DesBufSize);
BufSize:=DesBufSize;
end;
Res:=ReadFile(FChildStdoutRd, chBuf^, BufSize, dwRead, Nil);
Result:=Result+ChBuf;
end;
Until not Res;
Except
Result:='Read Err';
End;
end;
function DosToWin(St: string): string;
var
Ch: PChar;
begin
Ch := StrAlloc(Length(St) + 1);
OemToAnsi(PChar(St), Ch);
Result := Ch;
StrDispose(Ch)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not WriteToChild(Edit1.Text) then ShowMessage('error');
Memo1.Lines.Add(DosToWin(ReadStrFromChild(100)));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Memo1.Lines.Add(DosToWin(ReadStrFromChild(100)));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
NewPipe;
Memo1.Lines.Add(DosToWin(ReadStrFromChild(100)));
end;
[/more]
в едите посылал разные команды типа cd\ И подобных, все работало норм.
