Shell2Shell(Оболочка для оболочки) запуск SD и не только...

[Alexander]

Дополнил двоичными функциями и выложил: https://github.com/galaxysite/uuencodedecode .
https://codeberg.org/Alexander2024/uuencodedecode

[Alex2013]

Интересно, спасибо !
Зы
Проект Shell2Shell пока пока что "заморожен" ( хотя готовой утилитой пользуюсь постоянно )
Честно говоря "громадё планов" сейчас слишком разветвилось и не очень понятно, что там делать в первую очередь .
( понятно что нужно доработать систему поддержки плагинов но что делать дальше пока "темный лес" )

[Alex2013]

В общем нашел временное решение проблемы запуска оболочки Shell2Shell в Windows 11
(Грок и ДипСек предложили исправить код захвата консоли но там повылезала муть в отладке так что пока отложил правильное решение в долгий ящик ) НО пока неплохо помогает простой запуск от имени администратора ( правда обязательно из программы УЖЕ запущенной от имени администратор почему то прямой "запуск от имени администратора " не помогает) но ярлыке это решается обычным добавлением CMD /C перед именем запускаемого файла .

Или через использование примерно такого батника ...( S2S_Run_To_Win_11.bat ) что пожалуй надежнее будет.

Код: Выделить всё

@echo off
:: Проверка на права администратора
net session >nul 2>&1
if %errorlevel% neq 0 (
    echo Запуск с правами администратора...
      powershell -Command "Start-Process '.\Shell2Shell_fix_5_3.exe' -Verb RunAs"
    exit
)
echo права администратора уже доступны!  
Shell2Shell_fix_5_3.exe

(Проверено в нативной и обновляемой Windows 11 pro работает )

[Alex2013]

Решил застарелую "проблему" с доступом к исходному html-коду загруженной страницы в "модной" библиотеке WebView4Delphi .

Код: Выделить всё

procedure TMainForm.WVBrowser1NavigationCompleted(Sender: TObject;
  const aWebView: ICoreWebView2;
  const aArgs: ICoreWebView2NavigationCompletedEventArgs);

begin
    // Запрашиваем HTML через JavaScript
    WVBrowser1.ExecuteScript('document.documentElement.outerHTML',999);
end ;


function UnescapeJsonString(const JsonStr: string): string;
var
  i: Integer;
begin
  Result := '';
  i := 1;
  while i <= Length(JsonStr) do
  begin
    if (JsonStr[i] = '\') and (i + 1 <= Length(JsonStr)) then
    begin
      case JsonStr[i + 1] of
        'n': Result := Result + #10;   // \n -> перевод строки
        'r': Result := Result + #13;   // \r -> возврат каретки
        't': Result := Result + #9;    // \t -> табуляция
        '\': Result := Result + '\';   // \\ -> обратный слеш
        '"': Result := Result + '"';   // \" -> кавычка
        'u': // Unicode escape типа \u003C
        begin
          if i + 5 <= Length(JsonStr) then
          begin
            Result := Result + Char(StrToInt('$' + Copy(JsonStr, i + 2, 4)));
            i := i + 5;
          end;
        end;
      else
        Result := Result + JsonStr[i]; // оставляем как есть
      end;
      Inc(i, 2);
    end
    else
    begin
      Result := Result + JsonStr[i];
      Inc(i);
    end;
  end;
end;
procedure TMainForm.WVBrowser1ExecuteScriptCompleted(Sender: TObject;
  aErrorCode: HRESULT; const aResultObjectAsJson: wvstring;
  aExecutionID: integer);
begin

if (aErrorCode >= 0) And (aExecutionID=999) then
  begin
   HTMLText:= UnescapeJsonString(aResultObjectAsJson);
   StatusBar1.SimpleText:='HTML получен. Длина: ' + IntToStr(Length(HTMLText));
  end ;

end;

UnescapeJsonString - приблуда временная но вроде работает;
P.S.
Вроде не сложно но юзать JS для доступа к данным в памяти ....
Как там? "Дохтор а не слишком ли я много чая пью? "

[Alex2013]

Дальше больше, сейчас пытаюсь разобраться с мониторингом полей ввода и нажатия кнопок и т.д. в веб-интерфейсе. Идея понятна, нужно записывать журнал работы веб-интерфейса и в перспективе совмещать работу разных приложений, сервисов в единый рабочий процесс.

(Код отвечающий за перехват информации пока не выкладываю (он еще "не устаканился" ) но дело движется )

[Alex2013]

Обнаружил (да да "индеец Зоркий Глаз" и все такое... ) что браузерный движок принципиально не поддерживает доступ к файлам в текущей папке и в начале «ничтоже сумняся» исправил это через батник и скрипт с редиректом .

Код: Выделить всё

@echo off
:: Получаем текущий каталог (где лежит контент)
set CONTENT_DIR=%~dp0
set CONTENT_DIR=%CONTENT_DIR:\=/%
Set REDIRECT_FILE=REDIRECT.HTML

:: Генерируем HTML с редиректом
echo ^<html^>
echo ^<head^>
echo     ^<meta http-equiv="refresh" content="0; url=file:///%CONTENT_DIR%index.html"^>
echo ^</head^>
echo ^<body^>
echo     ^<a href="file:///%CONTENT_DIR%index.html"^>Click if not redirected^</a^>
echo     ^<script^>location.href="file:///%CONTENT_DIR%index.html";^</script^>
echo ^</body^>
echo ^</html^>
) > "%REDIRECT_FILE%"


rmdir C:\S2S_Current 2>nul
mklink /J C:\S2S_Current "%~dp0"
:: Создаем уникальный редиректор 
:: C:\S2S_Current\REDIRECT.html

Echo  REDIRECT ON
timeout /t 2 /nobreak >nul
rmdir C:\S2S_Current 2>nul
Echo  REDIRECT OFF
timeout /t 2 /nobreak >nul

А в программе использовал «функцию мониторинга консоли» с ожиданием сообщения «REDIRECT ON» и освежением браузера после его появления. (Всё потому, что лениво лезть в основной код из-за такой ерунды...)

Но, столкнувшись с разными «более другими» особенностями программы (например, программа «сбрасывает браузер» после завершения скрипта, что логично для её основного назначения, и не поддерживает «автозапуск» консольного скрипта, что тоже было логично), решил, что возиться с «резидентным скриптом», который откатывает страницу назад при «опустошении» браузера и т. д., уже точно чересчур, и всё же сделал «Спешал Эдишн» с галкой «Файл» и возможностью понимать вместо URL что-то вроде «./мой-файл.html».

Но, как я и ожидал (не желая лезть в код), всё оказалось не так просто, как кажется на первый взгляд (особенно доставило хлопот открытие локального файла в новом окне). Но всё же более-менее разобрался, и теперь работает как-то так (безопасность сохраняется, потому что работает только для локального файла и при включении советующей галки в локальных настройках).

[Alex2013]

Исправленная версия захвата "реальной консоли"
(работает без необходимости запуска с правами администратора в Windows 11 )

Код: Выделить всё

//Panel11:TРanel; в форме 

Const  Con_h:hwnd =0;
       SearchHandle:hwnd =0;


var
si:STARTUPINFO;
pi:PROCESS_INFORMATION;

function EnumProc(hwnd: HWND; lParam: LPARAM): BOOL; stdcall;
var
  Pid: DWORD;
  ClassName: array[0..255] of Char;
begin
  GetWindowThreadProcessId(hwnd, @Pid);
  if Pid = DWORD(lParam) then
  begin
    GetClassName(hwnd, ClassName, 256);
    if (StrComp(ClassName, 'ConsoleWindowClass') = 0) or
       (StrComp(ClassName, 'CASCADIA_HOSTING_WINDOW_CLASS') = 0) then  // Windows Terminal
    begin
      SearchHandle := hwnd;
      Result := False;   // останавливаем перечисление
      Exit;
    end;
  end;
  Result := True;
end;

// Создать и инкапсулировать реальную консоль
procedure TMainForm.Run_IN_RealConsle;
var
ExecInfo: TShellExecuteInfoA;
buf:array[1..100] of char;

S:String;
P:Pointer;
Var
   StartTime:QWord;

begin


  ZeroMemory(@si, sizeof(si));
  si.cb:=SizeOf(si);
  si.dwFlags :=STARTF_USESHOWWINDOW;
  si.wShowWindow :=  SW_HIDE;  //  SW_SHOW;

  P:=@EnumProc;

  CreateProcess(nil, 'cmd /C "ping -n 2 127.0.0.1 >nul & TmpListCmd.Bat"', nil, nil, false, CREATE_NEW_CONSOLE, nil, nil, @si,@pi);
  SearchHandle:=0;
  sleep(150);
  StartTime:=GetTickCount64;

  While (SearchHandle=0) and ( GetTickCount64-StartTime<2000) do
  begin
    Windows.EnumWindows(@EnumProc,Lparam( pi.dwProcessId) );
   Application.ProcessMessages;
   sleep(50);
  end;

//  Memo1.Hide; 

if SearchHandle<>0 then  begin
Con_H:=SearchHandle;
   Timer2.Enabled:=True;
   windows.SetWindowLong(Con_H, GWL_STYLE, WS_VISIBLE + WS_POPUP);

   windows.SetParent(Con_h,panel11.Handle);

   ShowWindow(Con_H, SW_SHOW);
   windows.MoveWindow(Con_h,0,0,panel11.Width,panel11.Height,true);
      SetConsoleGoodFont(Con_H);
        SetConsoleGoodFont(Con_H);
      SetWindowPos(Con_H, 0, 0, 0,
               Panel11.ClientWidth,
                Panel11.ClientHeight,
               SWP_NOZORDER or SWP_FRAMECHANGED or SWP_SHOWWINDOW);

   windows.MoveWindow(Con_h,0,0,panel11.Width,panel11.Height,true);
   SetConsoleTextAttribute(GetStdHandle(Con_h), FOREGROUND_GREEN);
      SetConsoleTextAttribute(GetStdHandle(Con_h), FOREGROUND_GREEN);
   end
 end
end;
  

// Контроль размера  консоли
procedure TMainForm.Panel11Resize(Sender: TObject);
Var
 H,HF:Integer;
   begin

    H:=panel11.Height-2 ;
    if ( Con_h<>0 ) and  windows.IsWindow(Con_h) then
  begin
  HF:= panel11.Font.GetTextHeight('F')*2;
  If H < HF then h:=HF;
  If H < 0 then h:=0;
    MoveWindow(Con_h,0,0,panel11.Width-2,H,true);
 end
end;

ЗЫ
Разъясняю фишку с CreateProcess(nil, 'cmd /C "ping -n 2 127.0.0.1 >nul & TmpListCmd.Bat"'...:
команда ping -n 2 127.0.0.1 >nul просто ожидание в течении секунды ( нужно для того чтобы консоль успела правильно настроить текстовый вывод в принципе ping вполне можно заменить на более "модную" команду timeout /t 1 /nobreak >nul но так теряется гипотетически возможная совместимость с Windows XP )

Напрямую перехватывать выводимый в "реальную консоль" текст нельзя, но можно сделать внешний мониторинг вывода .

[Alex2013]

"Виртуальная консоль" RunDosInMemo тоже как выяснилось нуждается в модификации
(в Windows 11 сыпала иероглифами) "Виртуальная консоль" не так полезна как "Реальная" но зато производит полный захват текстового вывода в мемо. (что может быть полезно для контролируемого запуска простых утилит)
С кодировкой правда есть странности если в внутри консоли поменять кодировку это никак не отразится на выводе в мемо. (Что вроде бы логично но в тоже время не совсем )

Код: Выделить всё

function ConsoleBytesToUTF8(Data: Pointer; Size: Integer): string;
var
  Wide: WideString;
  Len: Integer;
begin
  Result := '';
  if (Data = nil) or (Size <= 0) then Exit;

  // OEM (обычно CP866) → Unicode
  Len := MultiByteToWideChar(CP_OEMCP, 0, Data, Size, nil, 0);
  if Len <= 0 then Exit;

  SetLength(Wide, Len);
  MultiByteToWideChar(CP_OEMCP, 0, Data, Size, PWideChar(Wide), Len);

  // Unicode → UTF-8 (то, что ждёт TMemo в Lazarus)
  Result := UTF8Encode(Wide);
end;
 procedure RunDosInMemo(const CmdLine: string; AMemo: TMemo);
const
  ReadBuffer = 4095;
var
  Security: TSecurityAttributes;
  OutReadPipe, OutWritePipe: THandle;
  InReadPipe, InWritePipe: THandle;
  Start: TStartupInfo;
  ProcessInfo: TProcessInformation;
  Buffer: array of Byte;
  BytesRead, Avail, NotRead: DWORD;
  AppRunning: DWORD;
  S: string;
begin
  Process_stop := False;
  fsDuration := '';
  fsProgress := '';
  fsVideo := '';
  vsSpeed := '';

  // Security attributes
  FillChar(Security, SizeOf(Security), 0);
  Security.nLength := SizeOf(Security);
  Security.bInheritHandle := True;

  // Создаём пайпы
  if not CreatePipe(OutReadPipe, OutWritePipe, @Security, 0) then Exit;
  if not CreatePipe(InReadPipe, InWritePipe, @Security, 0) then
  begin
    CloseHandle(OutReadPipe);
    CloseHandle(OutWritePipe);
    Exit;
  end;

  try
    SetLength(Buffer, ReadBuffer + 1);

    FillChar(Start, SizeOf(Start), 0);
    Start.cb := SizeOf(Start);
    Start.hStdOutput := OutWritePipe;
    Start.hStdError  := OutWritePipe;   // stderr тоже в тот же пайп
    Start.hStdInput  := InReadPipe;
    Start.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    Start.wShowWindow := SW_HIDE;

    FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);

    if not CreateProcess(nil, PChar(CmdLine), @Security, @Security, True,
                         NORMAL_PRIORITY_CLASS, nil, nil, Start, ProcessInfo) then
      Exit;

    // Закрываем write-конец пайпа в родителе (важно!)
    CloseHandle(OutWritePipe);
    OutWritePipe := 0;
    CloseHandle(InWritePipe);
    InWritePipe := 0;

    try
      repeat
        AppRunning := WaitForSingleObject(ProcessInfo.hProcess, 50);

        // Есть данные в пайпе?
        if PeekNamedPipe(OutReadPipe, nil, 0, nil, @Avail, nil) and (Avail > 0) then
        begin
          if Avail > ReadBuffer then
            Avail := ReadBuffer;

          if ReadFile(OutReadPipe, Buffer[0], Avail, BytesRead, nil) and (BytesRead > 0) then
          begin
            // === Правильное преобразование кодировки ===
            // Вариант A: OEM (CP866) → UTF-8  (классическая консоль)
            S := ConsoleBytesToUTF8(@Buffer[0], BytesRead);

            // Вариант B: если программа пишет в UTF-8 — раскомментируй это:
            // S := UTF8Encode(TEncoding.UTF8.GetString(@Buffer[0], BytesRead)); // или просто
            // SetString(S, PAnsiChar(@Buffer[0]), BytesRead); // если уже UTF-8

            // Добавляем в Memo (правильный способ)
            AMemo.SelStart := Length(AMemo.Text);
            AMemo.SelText := S;
            // или: AMemo.Lines.Add(S); — но тогда будут лишние переводы строк
          end;
        end
        else
        begin
          // Данных нет. Если процесс уже завершился — выходим
          if AppRunning <> WAIT_TIMEOUT then
            Process_stop := True;
        end;

        Application.ProcessMessages;
      until Process_stop;

      // Дочитываем остатки после завершения процесса
      while PeekNamedPipe(OutReadPipe, nil, 0, nil, @Avail, nil) and (Avail > 0) do
      begin
        if Avail > ReadBuffer then Avail := ReadBuffer;
        if ReadFile(OutReadPipe, Buffer[0], Avail, BytesRead, nil) and (BytesRead > 0) then
        begin
          S := ConsoleBytesToUTF8(@Buffer[0], BytesRead);
          AMemo.SelStart := Length(AMemo.Text);
          AMemo.SelText := S;
        end;
      end;

    finally
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
    end;

  finally
    if OutReadPipe  <> 0 then CloseHandle(OutReadPipe);
    if OutWritePipe <> 0 then CloseHandle(OutWritePipe);
    if InReadPipe   <> 0 then CloseHandle(InReadPipe);
    if InWritePipe  <> 0 then CloseHandle(InWritePipe);
  end;

  AMemo.Lines.Add('');
  if fsVideo <> '' then
    AMemo.Lines.Add(fsVideo)
  else
    KillProcessTree(ProcessInfo.dwProcessId);

  AMemo.Lines.Add('');
  AMemo.Lines.Add('==== процесс завершён ====');
end;

[Alex2013]

Сильно доработанная версия "Виртуальной консоли "

AppendText- защита от "дребезга" при перерисовке
AppendSmooth - красивый "вывод по буквам" (необязательно но эффектно )
RunDosInMemo - основная процедура "Виртуальной консоли "

(консоль по прежнему Вариант A: OEM (CP866) → UTF-8 (классическая консоль)
но есть и Вариант B: если консоль пишет в UTF-8 - еще не пробовал )

Возможность клавиатурного ввода пока недоделал ( но она тут не очень то и нужна)

Код: Выделить всё

procedure AppendText(AMemo: TMemo; const S: string);
begin
  if S = '' then Exit;

  SendMessage(AMemo.Handle, WM_SETREDRAW, WPARAM(False), 0);
  try
    AMemo.SelStart := Length(AMemo.Text);
    AMemo.SelLength := 0;
    AMemo.SelText := S;

    SendMessage(AMemo.Handle, EM_SCROLLCARET, 0, 0);
  finally
    SendMessage(AMemo.Handle, WM_SETREDRAW, WPARAM(True), 0);
    AMemo.Invalidate;
  end;
   // Принудительно прокручиваем вниз
  AMemo.SelStart := Length(AMemo.Text);
end;

procedure AppendSmooth(AMemo: TMemo; const S: string; ChunkSize: Integer = 4);
var
  i, Len, NextBreak: Integer;
  Part: string;
begin
  if S = '' then Exit;

  Len := Length(S);
  i := 1;

  while (i <= Len) and StartMode do
  begin
    // Ищем ближайший перевод строки
    NextBreak := Pos(#10, Copy(S, i, MaxInt));
    if NextBreak = 0 then
      NextBreak := Pos(#13, Copy(S, i, MaxInt));

    // Если горизонтальный скроллер уже сдвинулся
    if AMemo.HorzScrollBar.Position > 0 then
    begin
      if NextBreak > 0 then
      begin
        Part := Copy(S, i, NextBreak);
        Inc(i, NextBreak);
      end
      else
      begin
        Part := Copy(S, i, MaxInt);
        i := Len + 1;
      end;

      AppendText(AMemo, Part);   // ← используем быструю вставку
      Continue;
    end;

    // Обычный плавный вывод
    Part := Copy(S, i, ChunkSize);
    Inc(i, ChunkSize);

    AppendText(AMemo, Part);     // ← тоже через AppendText
    Application.ProcessMessages;
  end;

  // На всякий случай ставим курсор в конец
  AMemo.SelStart := Length(AMemo.Text);
end;

 procedure RunDosInMemo(const CmdLine: string; AMemo: TMemo);
const
  ReadBuffer = 4095;
var
  Security: TSecurityAttributes;
  OutReadPipe, OutWritePipe: THandle;
  InReadPipe, InWritePipe: THandle;
  Start: TStartupInfo;
  ProcessInfo: TProcessInformation;
  Buffer: array of Byte;
  BytesRead, Avail, NotRead: DWORD;
  AppRunning: DWORD;
  S: string;
begin
  Process_stop := False;
  fsDuration := '';
  fsProgress := '';
  fsVideo := '';
  vsSpeed := '';
  AMemo.HorzScrollBar.Position :=0;
  // Security attributes
  FillChar(Security, SizeOf(Security), 0);
  Security.nLength := SizeOf(Security);
  Security.bInheritHandle := True;

  // Создаём пайпы
  if not CreatePipe(OutReadPipe, OutWritePipe, @Security, 0) then Exit;
  if not CreatePipe(InReadPipe, InWritePipe, @Security, 0) then
  begin
    CloseHandle(OutReadPipe);
    CloseHandle(OutWritePipe);
    Exit;
  end;

  try
    SetLength(Buffer, ReadBuffer + 1);

    FillChar(Start, SizeOf(Start), 0);
    Start.cb := SizeOf(Start);
    Start.hStdOutput := OutWritePipe;
    Start.hStdError  := OutWritePipe;   // stderr тоже в тот же пайп
    Start.hStdInput  := InReadPipe;
    Start.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    Start.wShowWindow := SW_HIDE;

    FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);

    if not CreateProcess(nil, PChar(CmdLine), @Security, @Security, True,
                         NORMAL_PRIORITY_CLASS, nil, nil, Start, ProcessInfo) then
      Exit;

    // Закрываем write-конец пайпа в родителе (важно!)
    CloseHandle(OutWritePipe);
    OutWritePipe := 0;
    CloseHandle(InWritePipe);
    InWritePipe := 0;

    try
      repeat
        AppRunning := WaitForSingleObject(ProcessInfo.hProcess, 50);

        // Есть данные в пайпе?
        if PeekNamedPipe(OutReadPipe, nil, 0, nil, @Avail, nil) and (Avail > 0) then
        begin
          if Avail > ReadBuffer then
            Avail := ReadBuffer;

          if ReadFile(OutReadPipe, Buffer[0], Avail, BytesRead, nil) and (BytesRead > 0) then
          begin
            // === Правильное преобразование кодировки ===
            // Вариант A: OEM (CP866) → UTF-8  (классическая консоль)
            S := ConsoleBytesToUTF8(@Buffer[0], BytesRead);

            // Вариант B: если программа пишет в UTF-8 — раскомментируй это:
            // S := UTF8Encode(TEncoding.UTF8.GetString(@Buffer[0], BytesRead)); // или просто
            // SetString(S, PAnsiChar(@Buffer[0]), BytesRead); // если уже UTF-8

            // Добавляем в Memo (правильный способ)

            AMemo.SelStart := Length(AMemo.Text);
            AppendSmooth(AMemo,S);
            //AMemo.SelText := S;

            // или: AMemo.Lines.Add(S); — но тогда будут лишние переводы строк
          end;
        end
        else
        begin
          // Данных нет. Если процесс уже завершился — выходим
          if AppRunning <> WAIT_TIMEOUT then
            Process_stop := True;
        end;

        Application.ProcessMessages;
      until Process_stop;

      // Дочитываем остатки после завершения процесса
      while PeekNamedPipe(OutReadPipe, nil, 0, nil, @Avail, nil) and (Avail > 0) do
      begin
        if Avail > ReadBuffer then Avail := ReadBuffer;
        if ReadFile(OutReadPipe, Buffer[0], Avail, BytesRead, nil) and (BytesRead > 0) then
        begin
          S := ConsoleBytesToUTF8(@Buffer[0], BytesRead);
          AMemo.SelStart := Length(AMemo.Text);
          AppendSmooth(AMemo,S);
        //AMemo.SelText := S;
        end;
      end;

    finally
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
    end;

  finally
    if OutReadPipe  <> 0 then CloseHandle(OutReadPipe);
    if OutWritePipe <> 0 then CloseHandle(OutWritePipe);
    if InReadPipe   <> 0 then CloseHandle(InReadPipe);
    if InWritePipe  <> 0 then CloseHandle(InWritePipe);
  end;

  AMemo.Lines.Add('');
  if fsVideo <> '' then
    AMemo.Lines.Add(fsVideo)
  else
    KillProcessTree(ProcessInfo.dwProcessId);

  AMemo.Lines.Add('');
  AMemo.Lines.Add('==== процесс завершён ====');
end;

зы

Обычно TerminateProcess(hProcess, NO_ERROR); достаточно но если процесс порождает процессы то лучше использовать что-то вроде KillProcessTree

Код: Выделить всё

function KillProcessTree(const PID: Cardinal;F:boolean=True ): boolean;
var hProc, hSnap,
    hChildProc  : THandle;
    pe          : TProcessEntry32;
    bCont       : BOOL;
    Int:TIniFile;
begin
    Result := true;
    FillChar(pe, SizeOf(pe), #0);
    pe.dwSize := SizeOf(pe);

    hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

    if (hSnap <> INVALID_HANDLE_VALUE) then
    begin

        if (Process32First(hSnap, pe)) then
        begin
            hProc := OpenProcess(PROCESS_ALL_ACCESS, false, PID);

            if (hProc <> 0) then
            begin
                if F then begin
                Result := Result and TerminateProcess(hProc, 1);
                WaitForSingleObject(hProc, INFINITE);
                end
                else  GenerateConsoleCtrlEvent (CTRL_CLOSE_EVENT {CTRL_C_EVENTC TRL_BREAK_EVENT},hProc);
                CloseHandle(hProc);
            end;

            bCont := true;
            while bCont do
            begin
                if (pe.th32ParentProcessID = PID) then
                begin
                    KillProcessTree(pe.th32ProcessID,F);

                    hChildProc := OpenProcess(PROCESS_ALL_ACCESS, FALSE, pe.th32ProcessID);

                    if (hChildProc <> 0) then
                    begin
                        if F then begin
                        Result := Result and TerminateProcess(hChildProc, 1);
                        WaitForSingleObject(hChildProc, INFINITE);
                        end
                        else  GenerateConsoleCtrlEvent (CTRL_CLOSE_EVENT {CTRL_C_EVENT CTRL_BREAK_EVENT}, hChildProc);

                        CloseHandle(hChildProc);
                    end;
                end;
                bCont := Process32Next(hSnap, pe);
            end;
        end;

        CloseHandle(hSnap);
    end;
end;

[Alex2013]

Забабахал Лог для "реальной консоли" ( в начале писал сам но запутался в "комбинаторике" того что в сильно упрощенной версии стало функций GetNewCompleteLines потом подключил Грок. Грок сказал "верной дорогой шагаешь товарищ... но нетуда" ... и тут-же сам забрел на "дровяной склад" но дружными усилиями мы все-же преодолели большую часть преград !

Код: Выделить всё

var
  LastConsoleText: String = '';   // для Memo — чтобы не дёргать перерисовку зря
  LastLoggedLines: Integer = 0;   // для файла — сколько строк уже записали

  procedure TMainForm.AppendNewConsoleLines(const Text: String);
  var
    Lines: TStringList;
    fs: TFileStream;
    s: UTF8String;
    i: Integer;
  begin
    Lines := TStringList.Create;
    try
      Lines.Text := Text;

      // Если строк стало меньше (прокрутилось/очистилось) —
      // либо сбрасываем, либо ничего не пишем. Пишем только прирост.
      if Lines.Count <= LastLoggedLines then Exit;

      fs := TFileStream.Create(
        ExtractFilePath(ParamStr(0)) + 'console.log',
        fmCreate or fmOpenWrite or fmShareDenyNone);
      try
        fs.Position := fs.Size;
        for i := LastLoggedLines to Lines.Count - 1 do
        begin
          s := UTF8String(Lines[i] + sLineBreak);
          fs.Write(s[1], Length(s));
        end;
      finally
        fs.Free;
      end;

      LastLoggedLines := Lines.Count;
    finally
      Lines.Free;
    end;
  end;

function GetNewCompleteLines(const OldText, NewText: string;
                             out IncompleteLine: string): string;
var
  SLOld, SLNew: TStringList;
  i, CommonCount: Integer;
  OldComplete, NewComplete: string;
begin
  Result := '';
  IncompleteLine := '';

  if NewText = '' then Exit;

  // Убираем незавершённую последнюю строку из обоих текстов
  OldComplete := OldText;
  NewComplete := NewText;

  if (OldComplete <> '') and (OldComplete[Length(OldComplete)] <> #10) then
  begin
    // есть незавершённая строка в старом тексте — отрезаем её
    i := LastDelimiter(#10, OldComplete);
    if i > 0 then
      OldComplete := Copy(OldComplete, 1, i)
    else
      OldComplete := '';
  end;

  if (NewComplete <> '') and (NewComplete[Length(NewComplete)] <> #10) then
  begin
    i := LastDelimiter(#10, NewComplete);
    if i > 0 then
    begin
      IncompleteLine := Copy(NewComplete, i + 1, MaxInt);  // сохраняем незавершённую
      NewComplete := Copy(NewComplete, 1, i);
    end
    else
    begin
      IncompleteLine := NewComplete;
      NewComplete := '';
    end;
  end;

  if NewComplete = '' then Exit;          // пока только незавершённая строка
  if NewComplete = OldComplete then Exit; // ничего нового

  SLOld := TStringList.Create;
  SLNew := TStringList.Create;
  try
    SLOld.Text := OldComplete;
    SLNew.Text := NewComplete;

    // Считаем общую часть с начала
    CommonCount := 0;
    while (CommonCount < SLOld.Count) and
          (CommonCount < SLNew.Count) and
          (SLOld[CommonCount] = SLNew[CommonCount]) do
      Inc(CommonCount);

    // Всё после общей части — новые полные строки
    for i := CommonCount to SLNew.Count - 1 do
      Result := Result + SLNew[i] + LineEnding;

  finally
    SLOld.Free;
    SLNew.Free;
  end;
end;

procedure TMainForm.LogTimerTimer(Sender: TObject);
var
  Text, NewLines, Incomplete: string;
begin
  if not IsWindow(con_h) then Exit;

  Text := ReadConsoleAllText(con_h,
                             Cardinal(uShell2Shell.PI.dwProcessId),
                             True);
  if Text = '' then Exit;
  if Text = LastConsoleText then Exit;

  NewLines := GetNewCompleteLines(LastConsoleText, Text, Incomplete);

  if NewLines <> '' then
  begin
    Memo2.Lines.BeginUpdate;
    try
      Memo2.Lines.Add(TrimRight(NewLines));
    finally
      Memo2.Lines.EndUpdate;
    end;

    Memo2.SelStart  := Memo2.GetTextLen;
    Memo2.SelLength := 0;
    Memo2.Perform(EM_SCROLLCARET, 0, 0);

    AppendNewConsoleLines(NewLines);
  end;

  // Важно: запоминаем полный текст, включая незавершённую строку
  LastConsoleText := Text;
end;

Код еще сыроват но в целом работает неплохо.

Зы
Забавно смотреть как ИИ любит тащить в свой вариант кода любые идеи из кода написанного пользователем (иногда доходя в этом до абсурда) но в принципе это правильно пользователю проще вникнуть в свой шаблон алгоритма, а не мучать "совершенно нового зверя" с нуля.