ultrakiller
03-12-2009, 09:17
Есть вот такой код, он рабочий..
procedure TForm1.RunDosInMemo(CmdLine:String;AMemo:TMemo);
const
ReadBuffer = 2400;
var
Security : TSecurityAttributes;
ReadPipe,WritePipe : THandle;
start : TStartUpInfo;
ProcessInfo : TProcessInformation;
Buffer : PChar;
BytesRead : DWord;
Apprunning : DWord;
WasOK : Boolean;
begin
Screen.Cursor:=CrHourGlass;
With Security do
begin
nlength := SizeOf(TSecurityAttributes);
binherithandle := true;
lpsecuritydescriptor := nil;
end;
if Createpipe (ReadPipe, WritePipe, @Security, 0) then
begin
Buffer := AllocMem(ReadBuffer + 1);
FillChar(Start,Sizeof(Start),#0);
start.cb := SizeOf(start);
start.hStdOutput := WritePipe;
start.hStdInput := ReadPipe;
start.dwFlags := STARTF_USESTDHANDLES +
STARTF_USESHOWWINDOW;
start.wShowWindow := SW_HIDE;
if CreateProcess(nil,
PWChar(WideString(CmdLine)),
nil,//@Security,
nil,//@Security,
true,
NORMAL_PRIORITY_CLASS,
nil,
nil,
start,
ProcessInfo)
// CreateProcess(nil, 'CmdLine', nil, nil, true, NORMAL_PRIORITY_CLASS, nil, nil, start, ProcessInfo)
then
begin
CloseHandle(WritePipe);
Apprunning := WaitForSingleObject (ProcessInfo.hProcess,100);
try
repeat
WasOK:=ReadFile(ReadPipe,Buffer[0], ReadBuffer,BytesRead,nil);
Buffer[BytesRead]:= #0;
OemToAnsi(PAnsiChar(Buffer),PAnsiChar(Buffer));
AMemo.Text := AMemo.text + String(Buffer);
Application.ProcessMessages;
until (not WasOK) or ( BytesRead = 0 );
finally
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
end;
FreeMem(Buffer);
CloseHandle(ReadPipe);
end;
Screen.Cursor:=CrDefault;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
RunDosInMemo('ping 10.1.0.115',Memo1);
end;
Проблема что при выводе в Memo он выдает квадратики...
Что вы посоветуете
Код взял с форума (http://forum.sources.ru/index.php?showtopic=51460) , и доработал с помощью статьи
статьи (http://programmersforum.ru/showthread.php?p=405168#post405168)
Среда Delphi 2009
procedure TForm1.RunDosInMemo(CmdLine:String;AMemo:TMemo);
const
ReadBuffer = 2400;
var
Security : TSecurityAttributes;
ReadPipe,WritePipe : THandle;
start : TStartUpInfo;
ProcessInfo : TProcessInformation;
Buffer : PChar;
BytesRead : DWord;
Apprunning : DWord;
WasOK : Boolean;
begin
Screen.Cursor:=CrHourGlass;
With Security do
begin
nlength := SizeOf(TSecurityAttributes);
binherithandle := true;
lpsecuritydescriptor := nil;
end;
if Createpipe (ReadPipe, WritePipe, @Security, 0) then
begin
Buffer := AllocMem(ReadBuffer + 1);
FillChar(Start,Sizeof(Start),#0);
start.cb := SizeOf(start);
start.hStdOutput := WritePipe;
start.hStdInput := ReadPipe;
start.dwFlags := STARTF_USESTDHANDLES +
STARTF_USESHOWWINDOW;
start.wShowWindow := SW_HIDE;
if CreateProcess(nil,
PWChar(WideString(CmdLine)),
nil,//@Security,
nil,//@Security,
true,
NORMAL_PRIORITY_CLASS,
nil,
nil,
start,
ProcessInfo)
// CreateProcess(nil, 'CmdLine', nil, nil, true, NORMAL_PRIORITY_CLASS, nil, nil, start, ProcessInfo)
then
begin
CloseHandle(WritePipe);
Apprunning := WaitForSingleObject (ProcessInfo.hProcess,100);
try
repeat
WasOK:=ReadFile(ReadPipe,Buffer[0], ReadBuffer,BytesRead,nil);
Buffer[BytesRead]:= #0;
OemToAnsi(PAnsiChar(Buffer),PAnsiChar(Buffer));
AMemo.Text := AMemo.text + String(Buffer);
Application.ProcessMessages;
until (not WasOK) or ( BytesRead = 0 );
finally
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
end;
FreeMem(Buffer);
CloseHandle(ReadPipe);
end;
Screen.Cursor:=CrDefault;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
RunDosInMemo('ping 10.1.0.115',Memo1);
end;
Проблема что при выводе в Memo он выдает квадратики...
Что вы посоветуете
Код взял с форума (http://forum.sources.ru/index.php?showtopic=51460) , и доработал с помощью статьи
статьи (http://programmersforum.ru/showthread.php?p=405168#post405168)
Среда Delphi 2009