Не Работает 
точнее работает но снова тупо ждёт конца выполнения
| Код | unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, SyncObjs, uChildProc;
type
TForm1 = class(TForm)
btn1: TButton;
mmo1: TMemo;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TEThread = class(TThread)
private
List: TStringList;
procedure add(Output: TStringList);
protected
constructor Create;
procedure Execute; override;
end;
TCEvent = procedure(Output: TStringList) of object;
const
SCS_VXD_BINARY = 6; {linear executable. Could be OS/2. NT thinks DOS!}
SCS_WIN32_DLL = 7;
SCS_DPMI_BINARY = 8; {guessing a bit here. Based on NE header loader flags}
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure GetExecutableInfo( const Filename: String; var BinaryType, Subsystem: DWORD);
var
f: File;
ImageDosHeader: IMAGE_DOS_HEADER;
ImageFileHeader: IMAGE_FILE_HEADER;
ImageOptionalHeader: IMAGE_OPTIONAL_HEADER;
Signature: DWORD;
NEType: Byte;
OldFileMode: integer;
begin
OldFileMode:=FileMode;
FileMode:=fmOpenRead;
AssignFile(f, Filename);
Reset(f, 1); {note that this will fail if file is open. this is a bug really,
but not a big one. Use Api File calls to work around}
try
BlockRead(f, ImageDosHeader, Sizeof(ImageDosHeader));
if (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) then {not executable}
raise EInOutError.Create('Dos signature not present');
try {16 bit dos program might not have new header}
Seek(f, ImageDosHeader._lfanew);
BlockRead(f, Signature, SizeOf(Signature));
Signature:= Signature and $FFFF;
except
on EInOutError do
Signature:= 0
end;
case Signature of
IMAGE_OS2_SIGNATURE: {New Executable}
begin
Seek(f, FilePos(f) + $32); {loader flags are $36 bytes into NE header, but we
have already read 4 bytes for PE signature}
BlockRead(f, NEType, SizeOf(NEType));
case NEType of
1: BinaryType:= SCS_DPMI_BINARY; {guessing a bit here}
2: BinaryType:= SCS_WOW_BINARY;
else
BinaryType:= SCS_OS216_BINARY; {presumably. I don't have one to check the loader flags!}
end
end;
IMAGE_OS2_SIGNATURE_LE: BinaryType:= SCS_VXD_BINARY;
IMAGE_NT_SIGNATURE: BinaryType:= SCS_32BIT_BINARY;
else
BinaryType:= SCS_DOS_BINARY;
end;
Subsystem:= IMAGE_SUBSYSTEM_UNKNOWN;
if (BinaryType = SCS_32BIT_BINARY)then
begin
BlockRead(f, ImageFileHeader, SizeOf(ImageFileHeader));
if (ImageFileHeader.Characteristics and IMAGE_FILE_EXECUTABLE_IMAGE) = 0 then
raise EInOutError.Create('File is not executable'); {could be COFF obj}
if (ImageFileHeader.Characteristics and IMAGE_FILE_DLL) = IMAGE_FILE_DLL then
begin
BinaryType:= SCS_WIN32_DLL
end else
begin
BlockRead(f, ImageOptionalHeader, SizeOf(ImageOptionalHeader));
Subsystem:= ImageOptionalHeader.Subsystem
end
end
finally
CloseFile(f);
FileMode:=OldFileMode;
end
end;
function ExecConsoleApp(const ApplicationName, Parameters: string;
AppOutput: TStringList; {will receive output of child process}
OnNewLine: TCEvent {if assigned called on each new line}
): DWORD;
const
CR = #$0D;
LF = #$0A;
TerminationWaitTime = 5000;
ExeExt = '.EXE';
ComExt = '.COM'; {the original dot com}
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
SecurityAttributes: TSecurityAttributes;
TempHandle,
WriteHandle,
ReadHandle: THandle;
ReadBuf: array[0..$100] of Char;
BytesRead: Cardinal;
LineBuf: array[0..$100] of Char;
LineBufPtr: Integer;
Newline: Boolean;
i: Integer;
BinType, SubSyst: DWORD;
Ext, CommandLine: string;
AppNameBuf: array[0..MAX_PATH] of Char;
ExeName: PChar;
{$IFDEF DEBUG}
ReadCount: Integer;
StartExec,
EndExec,
PerfFreq: Int64;
{$ENDIF}
procedure OutputLine;
begin
LineBuf[LineBufPtr] := #0;
with AppOutput do
if Newline then
Add(LineBuf)
else
Strings[Count - 1] := LineBuf; {should never happen with count = 0}
Newline := false;
LineBufPtr := 0;
if Assigned(OnNewLine) then
OnNewLine(AppOutput);
Application.ProcessMessages;
end;
begin
{Find out about app}
Ext := UpperCase(ExtractFileExt(ApplicationName));
if (Ext = '.BAT') or ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Ext = '.CMD')) then
begin {just have a bash}
FmtStr(CommandLine, '"%s" %s', [ApplicationName, Parameters])
end else
if (Ext = '') or (Ext = ExeExt) or (Ext = ComExt) then {locate and test the application}
begin
if SearchPath(nil, PChar(ApplicationName), ExeExt, SizeOf(AppNameBuf), AppNameBuf, ExeName) = 0 then
raise EInOutError.CreateFmt('Файл %s не найден', [ApplicationName]);
if Ext = ComExt then
BinType := SCS_DOS_BINARY
{in fact, there is no way of telling, but we will just try to run the program. NT is
equally ignorant and will blindly run anything with a .COM extension}
else
GetExecutableInfo(AppNameBuf, BinType, SubSyst);
if ((BinType = SCS_DOS_BINARY) or (BinType = SCS_DPMI_BINARY)) and
(Win32Platform = VER_PLATFORM_WIN32_NT) then
FmtStr(CommandLine, 'cmd /c""%s" %s"', [AppNameBuf, Parameters])
else
if (BinType = SCS_32BIT_BINARY) and (SubSyst = IMAGE_SUBSYSTEM_WINDOWS_CUI) then
FmtStr(CommandLine, '"%s" %s', [AppNameBuf, Parameters])
else
raise EInOutError.Create('Образ исполняемого файла не является поддерживаемым типом')
{Supported types are Win32 Console or MSDOS under Windows NT only}
end else
begin
raise EInOutError.CreateFmt('Файл %s имеет неправильное расширение', [ApplicationName])
end;
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
FillChar(ReadBuf, SizeOf(ReadBuf), 0);
FillChar(SecurityAttributes, SizeOf(SecurityAttributes), 0);
{$IFDEF DEBUG}
ReadCount := 0;
if QueryPerformanceFrequency(PerfFreq) then
QueryPerformanceCounter(StartExec);
{$ENDIF}
LineBufPtr := 0;
Newline := true;
with SecurityAttributes do
begin
Application.ProcessMessages;
nLength := Sizeof(SecurityAttributes);
bInheritHandle := true
end;
if not CreatePipe(ReadHandle, WriteHandle, @SecurityAttributes, 0) then
RaiseLastOSError;
{create a pipe to act as StdOut for the child. The write end will need
to be inherited by the child process}
try
{Read end should not be inherited by child process}
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if not SetHandleInformation(ReadHandle, HANDLE_FLAG_INHERIT, 0) then
RaiseLastOSError
end else
begin
Application.ProcessMessages;
{SetHandleInformation does not work under Window95, so we
have to make a copy then close the original}
if not DuplicateHandle(GetCurrentProcess, ReadHandle,
GetCurrentProcess, @TempHandle, 0, True, DUPLICATE_SAME_ACCESS) then
RaiseLastOSError;
CloseHandle(ReadHandle);
ReadHandle := TempHandle
end;
with StartupInfo do
begin
Application.ProcessMessages;
cb := SizeOf(StartupInfo);
dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
wShowWindow := SW_HIDE;
hStdOutput := WriteHandle
end;
if not CreateProcess(nil, PChar(CommandLine),
nil, nil,
true, {inherit kernel object handles from parent}
CREATE_NO_WINDOW,
nil,
nil,
StartupInfo,
ProcessInfo) then
RaiseLastOSError;
CloseHandle(ProcessInfo.hThread);
{not interested in threadhandle - close it}
CloseHandle(WriteHandle);
try
while ReadFile(ReadHandle, ReadBuf, SizeOf(ReadBuf), BytesRead, nil) do
begin
Application.ProcessMessages;
{There are much more efficient ways of doing this: we don't really
need two buffers, but we do need to scan for CR & LF &&&}
{$IFDEF Debug}
Inc(ReadCount);
{$ENDIF}
for i := 0 to BytesRead - 1 do
begin
Application.ProcessMessages;
if (ReadBuf[i] = LF) then
begin
Newline := true
end else
if (ReadBuf[i] = CR) then
begin
OutputLine
end else
begin
LineBuf[LineBufPtr] := ReadBuf[i];
Inc(LineBufPtr);
if LineBufPtr >= (SizeOf(LineBuf) - 1) then {line too long - force a break}
begin
Newline := true;
OutputLine
end
end
end
end;
WaitForSingleObject(ProcessInfo.hProcess, TerminationWaitTime);
GetExitCodeProcess(ProcessInfo.hProcess, Result);
OutputLine {flush the line buffer}
{$IFDEF DEBUG}; {that's how much I dislike null statements!
Is there a nobel prize for pedantry?}
if PerfFreq > 0 then
begin
QueryPerformanceCounter(EndExec);
AppOutput.Add(Format('Отладка: (readcount = %d), ExecTime = %.3f мс',
[ReadCount, ((EndExec - StartExec) * 1000.0) / PerfFreq]))
end else
begin
AppOutput.Add(Format('Отладка: (readcount = %d)', [ReadCount]))
end
{$ENDIF}
finally
CloseHandle(ProcessInfo.hProcess)
end
finally
CloseHandle(ReadHandle)
end
end;
//==============================================================================
// Начинаем страдать хернёй
//==============================================================================
constructor TEThread.Create;
begin
FreeOnTerminate := True;
inherited Create(false);
end;
procedure TEThread.add(Output: TStringList);
begin
Form1.mmo1.Lines.Assign(Output);
end;
procedure TEThread.Execute;
var
d: TStringList;
sd: DWORD;
Method: TCEvent;
begin
d := TStringList.Create;
Method := add;
ExecConsoleApp('precomp','-r arch.pcf',d, Method);
end;
procedure TForm1.btn1Click(Sender: TObject);
var
e,d,f,a: TStringList;
sd: DWORD;
Method: TCEvent;
EThread: TEThread;
begin
EThread := TEThread.Create;
end;
end. |
|
