[zxen]

Помогите пожалуйста переделать код под Delphi XE3, проект взят отсюда http://www.delphisources.ru/forum/sh...ad.php?p=79065. Написан видимо в D7.
Программа представляет собой оболочку cmd. В Edit вводишь команду, в Memo получаешь ответ.

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TReadThread = class(TThread)
  private
    buf: array [0..255] of AnsiChar;
    dummy: Cardinal;
    procedure UpdateForm;
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TFormMain = class(TForm)
    MemoConsole: TMemo;
    EditText: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure EditTextKeyPress(Sender: TObject; var Key: Char);
  private
    hPipeInputRead: THandle;
    hPipeInputWrite: THandle;
    hPipeOutputRead: THandle;
    hPipeOutputWrite: THandle;
    hProcess: THandle;
    readthread: TReadThread;
  public
  end;

var
  FormMain: TFormMain;

implementation

{$R *.dfm}

procedure TFormMain.FormCreate(Sender: TObject);
var
  securityattributes: TSecurityAttributes;
  startupinfo: TStartupInfo;
  processinformation: TProcessInformation;
begin
  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));
  startupinfo.cb:=SizeOf(TStartupInfo);
  startupinfo.dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
  startupinfo.wShowWindow:=SW_HIDE;
  startupinfo.hStdInput:=hPipeInputRead;
  startupinfo.hStdOutput:=hPipeOutputWrite;
  startupinfo.hStdError:=hPipeOutputWrite;
  CreateProcess(nil, PChar('cmd'), nil, nil, True, CREATE_NEW_CONSOLE, nil, nil, startupinfo, processinformation); 
  hProcess:=processinformation.hProcess;
  readthread:=TReadThread.Create;
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  TerminateProcess(hProcess, 255);
  WaitForSingleObject(hProcess, INFINITE);
  CloseHandle(hProcess);
  readthread.Terminate;
  CloseHandle(hPipeInputWrite);
  CloseHandle(hPipeInputRead);
  CloseHandle(hPipeOutputWrite);
  CloseHandle(hPipeOutputRead);
  readthread.WaitFor;
  readthread.Free;
end;

procedure TFormMain.EditTextKeyPress(Sender: TObject; var Key: Char);
var
  buf: array [0..255] of AnsiChar;
  dummy: Cardinal;
begin
  if Key=#13 then
  begin
    MemoConsole.Clear;
    StrPCopy(buf, EditText.Text+#13#10);
    WriteFile(hPipeInputWrite, buf, Length(EditText.Text)+2, dummy, nil);
    EditText.Clear;
  end;
end;

{ TReadThread }

constructor TReadThread.Create;
begin
  inherited Create(False);
  FreeOnTerminate:=False;
end;

destructor TReadThread.Destroy;
begin
  inherited Destroy;
end;

procedure TReadThread.Execute;
begin
  while not Terminated do
    if ReadFile(FormMain.hPipeOutputRead, buf, Length(buf), dummy, nil) then Synchronize(UpdateForm);
end;

procedure TReadThread.UpdateForm;
begin
  OemToAnsiBuff(buf, buf, dummy);
  FormMain.MemoConsole.Text:=FormMain.MemoConsole.Text+Copy(buf, 1, dummy);
end;

end.

Сам переделал пару мест, поменял of Char, на of AnsiChar (стр.12, 85). Ошибки в коде исчезли, но теперь при компиляции вылазит это:
Так как с delphi знаком всего пару недель ), на этом встал в тупик.

[angvelem]

Если уж переводить на AnsiChar, то нужно и структуры менять. К примеру, TStartupInfo меняется на TStartupInfoA.

[zxen]

Нарыл и приспособил немножко другой код.. Есть небольшая проблемка, когда программа запускает например пинг. ехе, во время обработки пргрпмму невозжожно закрыть крестиком, вставил паузу (стр. 116) программа не виснет , но крестик все равно не нажимается. И как можно закрывать порограммы, запущенные CreateProcess'om.. тасккил по имени как то тупо.. И еще, как бы сделать так, чтоб текст вывода консоли добавлялся к уже существующему в мемо, а не стирался с каждым новым выводом. Memo1.Text:= Memo1.Text + DosToWin(getcmdval) не работает, выполняется первая команда, дальше вообще ничего в мемо не пишется.

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Winapi.ShellAPI;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Button2: TButton;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);

  private
       function GetDosOutput(const CommandLine:string): string;
  public


  end;

var
  Form1: TForm1;


implementation

{$R *.dfm}

var stopfunc: Integer;

function DosToWin(ASource: AnsiString): AnsiString;
 var
   Ch: PAnsiChar;
 begin
   Ch := AnsiStrAlloc(Length(ASource) + 1);
   OemToAnsi(PAnsiChar(ASource), Ch);
   Result := StrPas(Ch);
   StrDispose(Ch);
 end;


function TForm1.GetDosOutput(const CommandLine:string): string;
var
  SA: TSecurityAttributes;
  SI: TStartupInfoA;
  PI: TProcessInformation;
  StdOutPipeRead, StdOutPipeWrite: THandle;
  WasOK: Boolean;
  Buffer: array[0..255] of AnsiChar;
  BytesRead: Cardinal;
  WorkDir, Line: String;
  i:Integer;
begin
stopfunc:=0;
  Application.ProcessMessages;
  with SA do
  begin
    nLength := SizeOf(SA);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;

  CreatePipe(StdOutPipeRead,
             StdOutPipeWrite,
             @SA,
             0
             );
  try

    with SI do
    begin
      FillChar(SI, SizeOf(SI), 0);
      cb := SizeOf(SI);
      dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow := SW_HIDE;
      hStdInput := GetStdHandle(STD_INPUT_HANDLE);
      hStdOutput := StdOutPipeWrite;
      hStdError := StdOutPipeWrite;
    end;

    WorkDir := ExtractFilePath(CommandLine);
    
    WasOK:=CreateProcessa(nil, PAnsiChar(AnsiString(CommandLine)), nil, nil, True, 0, nil, PAnsiChar('C:\WINDOWS\system32\'), SI, PI);
    //WasOK := CreateProcess(nil, PChar('C:\WINDOWS\system32\cmd.exe'), nil, nil, True, 0, nil, PChar(WorkDir), SI, PI);

    CloseHandle(StdOutPipeWrite);

    if not WasOK then
      raise Exception.Create('Could not execute command line!')
    else
      try

        Line := '';
        repeat

          WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
          if BytesRead > 0 then

          begin

            Buffer[BytesRead] := #0;
            Line := Line + Buffer;
            if (Copy(Form1.Edit1.text,1,4) = 'ping') then begin 

             Form1.Memo1.text := DosToWin(Line); // конвертим вывод в мемо, с ОЕМ в Анси
              Memo1.Perform(EM_LINESCROLL,0,Memo1.Lines.Count-1); // автопрокрутка мемо вниз
               //////////////////////////  пауза, чтоб не висло окно при пинге и множественных выводов консоли

              i := 0;
               while i<100 do begin
              sleep(12);
              Application.ProcessMessages;
              inc(i);
              end;
                //// убиваем процессы
              if stopfunc = 1 then
               begin
               CloseHandle(PI.hThread);
               CloseHandle(PI.hProcess);
               shellexecute(0,'Open',Pchar('taskkill'),'/im cmd.exe /f',0,SW_HIDE);
               shellexecute(0,'Open',Pchar('taskkill'),'/im ping.exe /f',0,SW_HIDE);
              Exit;
             end;
            end;


          end;
        until not WasOK or (BytesRead = 0);
        WaitForSingleObject(PI.hProcess, INFINITE);
      finally
        CloseHandle(PI.hThread);
        CloseHandle(PI.hProcess);
      end;
  finally
      result:=Line;
      CloseHandle(StdOutPipeRead);
  end;
end;
  //// выполняем команду CMD
procedure TForm1.Button1Click(Sender: TObject);
 var cmdinput, getcmdval, memotxt: string;

begin

   Edit1.Text:= Trim(Edit1.Text); // удаляем пробелы в начале и в конце в строке ввода
   cmdinput:= 'cmd.exe /c ' + Edit1.Text; // текст посылаемый в функцию

    memotxt:= Memo1.Text;
    getcmdval:= GetDosOutput(cmdinput);


    Memo1.Text:=  DosToWin(getcmdval);
end;
      /// останавливаем выполнение CMD
procedure TForm1.Button2Click(Sender: TObject);
begin
stopfunc:=1;
end;

end.