菜鸟求解，Delphi源码改Lazarus，类不过去……

zyphio

菜鸟求解，Delphi源码改Lazarus，类不过去……


unit Unit1;


{$mode objfpc}{$H+}


interface


uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  StdCtrls;


type


  { TForm1 }


  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;


var
  Form1: TForm1;


implementation


{ TForm1 }
procedure _AddInfo(mmInfo:TMemo; S: string; var line: string);
var
    i, p: Integer;
begin
    if mmInfo.Lines.Count > 800 then
      mmInfo.Lines.Clear;
    for i := 0 to Length(S) - 1 do
      if S = #13 then S := ' ';
    line := line + S;
    p := Pos(#10, line);
    if p > 0 then
    begin
      mmInfo.Lines.Add(Copy(line, 1, p - 1));
      line := Copy(line, p + 1, Length(line) - p);
    end;
end;


procedure CmdExecAndView(FileName: string; memo: TMemo);
var
  hReadPipe, hWritePipe: THandle;
  si: STARTUPINFO;
  lsa: SECURITY_ATTRIBUTES;
  pi: PROCESS_INFORMATION;
  cchReadBuffer: DWORD;
  ph: PChar;
  fname: PChar;
  line: string;
begin
    fname := allocmem(1024);
    ph := AllocMem(1024);
    lsa.nLength := sizeof(SECURITY_ATTRIBUTES);
    lsa.lpSecurityDescriptor := nil;
    lsa.bInheritHandle := True;
    if CreatePipe(hReadPipe, hWritePipe, @lsa, 0) = false then
        Exit;
    fillchar(si, sizeof(STARTUPINFO), 0);
    si.cb := sizeof(STARTUPINFO);
    si.dwFlags := (STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW);
    si.wShowWindow := SW_HIDE;
    si.hStdOutput := hWritePipe;
    si.hStdError := hWritePipe;
    StrPCopy(fname, FileName);
    if CreateProcess(nil, fname, nil, nil, true, 0, nil, nil, si, pi) = False then
    begin
        FreeMem(ph);
        FreeMem(fname);
        Exit;
    end;
    CloseHandle(hWritePipe);
    while (true) do
    begin
        if not PeekNamedPipe(hReadPipe, ph, 1, @cchReadBuffer, nil, nil) then break;
        if cchReadBuffer <> 0 then
        begin
            if ReadFile(hReadPipe, ph^, 512, cchReadBuffer, nil) = false then break;
            ph[cchReadbuffer] := chr(0);
            _AddInfo(memo, ph, line);
        end
        else if (WaitForSingleObject(pi.hProcess, 0) = WAIT_OBJECT_0) then break;
        Application.ProcessMessages;
        Sleep(200);
    end;
    ph[cchReadBuffer] := chr(0);
    _AddInfo(memo, ph, line);
    CloseHandle(hReadPipe);
    CloseHandle(pi.hThread);
    CloseHandle(pi.hProcess);
    FreeMem(ph);
    FreeMem(fname);
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
CmdExecAndView('ping 192.168.1.1',Memo1);
end;


initialization
  {$I Unit1.lrs}


end.

sail2000

Uses
    Windows;

sail2000

[pre]
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation
uses Windows;
{$R *.lfm}

{ TForm1 }

procedure _AddInfo(mmInfo: TMemo; S: string; var line: string);
var
  i, p: integer;
begin
  if mmInfo.Lines.Count > 800 then
    mmInfo.Lines.Clear;
  for i := 0 to Length(S) - 1 do
    if S = #13 then
      S := ' ';
  line := line + S;
  p := Pos(#10, line);
  if p > 0 then
  begin
    mmInfo.Lines.Add(Copy(line, 1, p - 1));
    line := Copy(line, p + 1, Length(line) - p);
  end;
end;

procedure CmdExecAndViewEx(FileName: string; memo: TMemo);
const
  BufferDiLettura = 2400;
var
  AttrSicurezza: TSecurityAttributes;
  CodaDiLettura, CodaDiScrittura: THandle;
  Inizio: TStartUpInfo;
  InfoDelProcesso: TProcessInformation;
  Buffer: PChar;
  ByteLetti: DWord;
  AppAttiva: DWord;
begin
  with AttrSicurezza do
  begin
    nlength := SizeOf(TSecurityAttributes);
    binherithandle := True;
    lpsecuritydescriptor := nil;
  end;
  if Createpipe(CodaDiLettura, CodaDiScrittura, @AttrSicurezza, 0) then
  begin
    Buffer := AllocMem(32767);
    // alloca memoria per 32k sostituisci con 65536 per 64k
    FillChar(Inizio, Sizeof(Inizio), #0);
    Inizio.cb := SizeOf(Inizio);
    Inizio.hStdOutput := CodaDiScrittura;
    Inizio.hStdInput := CodaDiLettura;
    Inizio.dwFlags := STARTF_usesTDHANDLES + STARTF_usesHOWWINDOW;
    Inizio.wShowWindow := SW_HIDE;
    if CreateProcess(nil, PChar(FileName), @AttrSicurezza, @AttrSicurezza, True,
      NORMAL_PRIORITY_CLASS, nil, nil, Inizio, InfoDelProcesso) then
    begin
      repeat
        AppAttiva := WaitForSingleObject(InfoDelProcesso.hProcess, 100);
        Application.ProcessMessages;
      until (AppAttiva <> WAIT_TIMEOUT);
      repeat
        ByteLetti := 0;
        ReadFile(CodaDiLettura, Buffer[0], BufferDiLettura, ByteLetti, nil);
        Buffer[ByteLetti] := #0;
        OemToAnsi(Buffer, Buffer);
        Memo.Text := Memo.Text + string(Buffer);
      until (ByteLetti < BufferDiLettura);
    end;
    FreeMem(Buffer); // libero la memoria
    CloseHandle(InfoDelProcesso.hProcess);
    CloseHandle(InfoDelProcesso.hThread);
    CloseHandle(CodaDiLettura);
    CloseHandle(CodaDiScrittura);
  end;
end;

procedure CmdExecAndView(FileName: string; memo: TMemo);
var
  hReadPipe, hWritePipe: THandle;
  si: STARTUPINFO;
  lsa: SECURITY_ATTRIBUTES;
  pi: PROCESS_INFORMATION;
  cchReadBuffer: DWORD;
  ph: PChar;
  fname: PChar;
  line: string;
begin
  fname := allocmem(1024);
  ph := allocmem(1024);
  lsa.nLength := sizeof(SECURITY_ATTRIBUTES);
  lsa.lpSecurityDescriptor := nil;
  lsa.bInheritHandle := True;
  if CreatePipe(hReadPipe, hWritePipe, @lsa, 0) = false then
    Exit;
  fillchar(si, sizeof(STARTUPINFO), 0);
  si.cb := sizeof(STARTUPINFO);
  si.dwFlags := (STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW);
  si.wShowWindow := SW_HIDE;
  si.hStdOutput := hWritePipe;
  si.hStdError := hWritePipe;
  StrPCopy(fname, FileName);
  if CreateProcess(nil, fname, nil, nil, True, 0, nil, nil, si, pi) = false then
  begin
    FreeMem(ph);
    FreeMem(fname);
    Exit;
  end;
  CloseHandle(hWritePipe);
  while (True) do
  begin
    if not PeekNamedPipe(hReadPipe, ph, 1, @cchReadBuffer, nil, nil) then
      break;
    if cchReadBuffer <> 0 then
    begin
      if ReadFile(hReadPipe, ph^, 512, cchReadBuffer, nil) = false then
        break;
      ph[cchReadBuffer] := chr(0);
      _AddInfo(memo, ph, line);
    end
    else if (WaitForSingleObject(pi.hProcess, 0) = WAIT_OBJECT_0) then
      break;
    Application.ProcessMessages;
    Sleep(200);
  end;
  ph[cchReadBuffer] := chr(0);
  _AddInfo(memo, ph, line);
  CloseHandle(hReadPipe);
  CloseHandle(pi.hThread);
  CloseHandle(pi.hProcess);
  FreeMem(ph);
  FreeMem(fname);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CmdExecAndViewEx('ping 192.168.1.1', Memo1);
end;

end.
[/pre]

zyphio

Uses
Windows;

谢谢……


居然忘记引用Windows…还研究了半天…   


在64位下编译通过，生成exe后，Lazarus崩溃……   


重开工程后一切正常……