Показать сообщение отдельно
  #9  
Старый 04.08.2011, 12:57
Аватар для Aristarh Dark
Aristarh Dark Aristarh Dark вне форума
Модератор
 
Регистрация: 07.10.2005
Адрес: Москва
Сообщения: 2,907
Версия Delphi: Delphi XE
Репутация: выкл
По умолчанию

Допилил я таки модуль для запуска консольных приложений, чтобы он нормально работал в XE
Кому не влом, протестируйте на семерке к примеру, ну или на любой дельфе которая не юникодовская.
Код:
unit ConsoleAppRunner;

interface
uses
  Classes;
procedure RunConsoleApplication(CmdLine,Params:String;OutStrings:TStrings);

implementation
uses
  SysUtils,Windows;
const
  UnprintableSymbols = [
    #$00,#$01,#$02,#$03,#$04,#$05,#$06,#$07,#$08,#$09,#$0A,#$0B,#$0C,#$0D,#$0E,#$0F,
    #$10,#$11,#$12,#$13,#$14,#$15,#$16,#$17,#$18,#$19,#$1A,#$1B,#$1C,#$1D,#$1E,#$1F,
    #$7F
                        ];
type
  TAnsiBuf = array [0..1023] of AnsiChar;
  TCharBuf = array [0..1023] of Char;
procedure MoveLeft(var Data:TAnsiBuf; From,Len,Shift:integer);
var
  i:integer;
begin
  for i := From to From+Len do
    Data[i]:=Data[i-Shift];
end;
procedure AnsiBufToCharBuf(AnsiBuf:TAnsiBuf;var CharBuf:TCharBuf;Len:integer);
var
  i:integer;
begin
  for I := 0 to Len do
    begin
      if CharInSet(AnsiBuf[i],UnprintableSymbols) then
        CharBuf[i]:=Char(AnsiBuf[i])
      else
        OemToChar(@AnsiBuf[i],@CharBuf[i]);
    end;
end;
procedure RunConsoleApplication(CmdLine,Params:String;OutStrings:TStrings);
var
  securityattributes: TSecurityAttributes;
  startupinfo: TStartupInfo;
  processinformation: TProcessInformation;
  hPipeInputRead: THandle;
  hPipeInputWrite: THandle;
  hPipeOutputRead: THandle;
  hPipeOutputWrite: THandle;
  WaitResult:Cardinal;
  AnsiBuf: TAnsiBuf;
  CharBuf: TCharBuf;
  dummy: Cardinal;
  s:string;
begin
//  OutStrings.Append(#13#10);              //<---------
  securityattributes.nLength:=SizeOf(TSecurityAttributes);
  securityattributes.lpSecurityDescriptor:=nil;
  securityattributes.bInheritHandle:=True;
  CreatePipe(hPipeInputRead, hPipeInputWrite, @securityattributes, 0);
  CreatePipe(hPipeOutputRead, hPipeOutputWrite, @securityattributes, 0);
  ZeroMemory(@startupinfo, SizeOf(TStartupInfo));
  ZeroMemory(@processinformation, SizeOf(TProcessInformation));
  with startupinfo do
    begin
      cb:=SizeOf(TStartupInfo);
      dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow:=SW_HIDE;
      hStdInput:=hPipeInputRead;
      hStdOutput:=hPipeOutputWrite;
      hStdError:=hPipeOutputWrite;
    end;
  OutStrings.BeginUpdate;
  OutStrings.Append(CmdLine+' '+Params);
  OutStrings.EndUpdate;
  if CreateProcess(nil, PChar(CmdLine+' '+Params), nil, nil, True, CREATE_NEW_CONSOLE,
    nil, PChar(ExtractFileDir(CmdLine)), startupinfo, processinformation) then
    begin
      repeat
        WaitResult:=WaitForSingleObject(processinformation.hProcess, 100);
        if ReadFile(hPipeOutputRead, AnsiBuf, Length(AnsiBuf), dummy, nil) then
          begin
            AnsiBufToCharBuf(AnsiBuf, CharBuf, dummy);
            OutStrings.BeginUpdate;
            OutStrings.Text:=OutStrings.Text+Copy(CharBuf, 1, dummy);
//            if Pos(#8,OutStrings.Text)>0 then  //<---------
//              begin                            //<---------
//                s:=OutStrings.Text;            //<---------
//                Delete(s,Pos(#8,s)-3,4);       //<---------
//                OutStrings.Text:=s;            //<---------
//              end;                             //<---------
            OutStrings.EndUpdate;
          end;
      until WaitResult<>WAIT_TIMEOUT;
      CloseHandle(processinformation.hProcess);
    end
  else
    begin
      OutStrings.BeginUpdate;
      OutStrings.Append(SysErrorMessage(GetLastError));
      OutStrings.EndUpdate;
    end;
  CloseHandle(hPipeInputWrite);
  CloseHandle(hPipeInputRead);
  CloseHandle(hPipeOutputWrite);
  CloseHandle(hPipeOutputRead);
end;
end.
на закомментаренные строчки внимания не обращайте, это мне нужно для внутренних нужд (тафталогия блин).
пример вызова:
Код:
uses ConsoleAppRunner;
...
  RunConsoleApplication('c:\windows\system32\ping.exe','192.168.104.104',ListBox1.Items);
ЗЫЖ Естественно консоль эмулируется не на 100%
__________________
Некоторые программисты настолько ленивы, что сразу пишут рабочий код.

Если вас наказали ни за что - радуйтесь: вы ни в чем не виноваты.
Ответить с цитированием