Console emulation

Hi everybody!

It's been a while since I've been here, so I'll stop by to see how your good'n'old delphi dudes are doing - so let's see how much this site has developed your skills ;-)

The problem:

1. I want to write a windows application with a memo on it running in Windoes NT.
2. I want the application to spawn a process running Windows NT 'Cmd.exe'
3. I want to redirect the standard input and output handles so I'll be able to control the input and read the output as it comes to me.
4. I want to have my application reacting upon standard events from keyboard and mouse, which means you'll need to use the WinAPI method 'WriteConsoleInput'.
5. I do NOT want ANY links to support.microsoft.com - but I though got a sample, that I think is the closest thing to what I can get. The sample is written in C++ and uses standard WinAPI functions, which is also available in Delphi, so here it is: http://www.blem.ac.cn/books/vc_unleashed/vcu14fi.htm#I11

Happy nut-cracking :-)

Regards,
Williams
LVL 3
williams2Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

williams2Author Commented:
Edited text of question.
0
interCommented:
after spawning cmd what are you planiing to do?
igor
0
intheCommented:
Hi Williams
  ;-)


Listening....
0
Introduction to R

R is considered the predominant language for data scientist and statisticians. Learn how to use R for your own data science projects.

williams2Author Commented:
You are mostly welcome :-)

...anyway

Aftwer I have spawned the command I planned to use this as a alternative console, though I'm well aware of the requirements to the PSECURITY_DESCRIPTOR

...But it still doesn't seems like I can get it to work :-(

Regards,
Williams
0
williams2Author Commented:
.A couple of interesting links:

http://www.borland.com/delphi/deltips/1999/tip010499.html
http://community.borland.com/article/1,1410,10387,00.html

...Well, keep on trying, a windows telnet server wouldn't damage anyone either, which is exactly what you can do with this thing.

regards,
Williams
0
simonetCommented:
Following...®
0
brainwareCommented:
Spying on Williams :)
0
rarigoCommented:
better listen....
0
williams2Author Commented:
Hmm... I didn't realize that it was that hard a question, or ?

...An answer is now 500 points worth !
0
interCommented:
let's see what I can...
0
interCommented:
Hi,

I have found a piece of code in my repository (we were trying to do something with ronit if I am not wrong). So, my magic function is as follows:

// ***********************************************
// this procedure executes a console application
// waits its completion and returns all the output
// of the execution in strings (OutPut)
// ***********************************************

procedure ExecWithPipe(FName: PChar; OutPut: TStrings);
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  Buffer: array[0..255] of char;
  bRead: integer;
  hRead, hWrite: THandle;
  saAttr: TSECURITYATTRIBUTES;
  OutSt: TMemoryStream; //this is where we transfer all the output at the end
begin
  // Set the bInheritHandle flag so pipe handles are inherited.
  saAttr.nLength := sizeof(TSECURITYATTRIBUTES);
  saAttr.bInheritHandle := true;
  saAttr.lpSecurityDescriptor := nil;
  if not CreatePipe(hRead, hWrite, @saAttr, 0) then
  begin
    ShowMessage('Can not create the pipe!');
    Exit;
  end;
  try
    FillChar(StartupInfo, Sizeof(StartupInfo), #0);
    StartupInfo.cb := Sizeof(StartupInfo);
    StartupInfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    StartupInfo.wShowWindow := SW_HIDE;
    //Associate our handles with our child process
    StartupInfo.hStdInput := 0;
    StartupInfo.hStdOutput := hWrite; //we catch output
    StartupInfo.hStdError := hWrite; //and also error
    if not CreateProcess(nil,
      FName,
      nil, nil,
      true, //!!!!!!!we should inherit handles
      NORMAL_PRIORITY_CLASS, //the child should use our CONSOLE
      nil, nil, StartupInfo, ProcessInfo) then
      ShowMessage('Can not create process')
    else
    begin
      //loop until terminated
      while WaitforSingleObject(ProcessInfo.hProcess, 0)
        <> WAIT_OBJECT_0 do ;
      //now read all the output of the child and put it to a memo
      OutSt := TMemoryStream.Create;
      repeat
        if ReadFile(hRead, Buffer, 80, bRead, nil) then
          OutSt.WriteBuffer(Buffer, bRead)
        else break;
      until bRead <> 80;
      OutSt.Seek(0, 0); //seek to begining
      //read memo from stream
      OutPut.LoadFromStream(OutSt);
      OutSt.Free;
    end;
  finally
    //close read and write handles of our pipe
    CloseHandle(hRead); CloseHandle(hWrite);
  end;
end;


*** NOTES:
0 - You are on NT so need right privilages.

1 - The application windows is kept close. If you want to change this just change the StartUpInfo attributes.

2 - If you execute command promt call the above function as follows:
  ExecWithPipe(PChar('cmd /c ' + Edit1.Text), Memo1.Lines);
where Edit1.Text is you command such as DIR and Memo1.Lines are where all the output is stored.

3- If you want to execute any other command line application you just pass its name.

Not too complicated isn't it?
regards.
igor
0
williams2Author Commented:
I'll have a try :-) ...thanks igor (And nice to see you)

....
0
williams2Author Commented:
You are right, that is not very complicated, but it is still not what I asked for.. Your approach is VERY similar to the example I brought here:
http://www.borland.com/delphi/deltips/1999/tip010499.html

1. I cannot use it for a console / telnetserver as I do not have access to the console during the time running the process
2. I cannot write any events to the pipe as mouse or keyboard events, but raw bytes (though your file handle)
3. writing output to a file on disk can be hasardous, if this console application is not beeing terminated often, as you cannot delete the file as the process is running and grows.

BUT THAT IS OK! Because you are still the first one coming up with an example, and I agree with you that this is the approach. Now that you have done so much, I will come up with an example I made, very similar to what I want, but still not good enough :-(((

There is porbably some mess in the sample, but I've been doing a lot of debugginh lately!

I use to call '.MyCon.WriteString()' to execute commands.

----------------------------------------------

unit ConUnit;

interface

Uses
  Windows, Classes, SysUtils, dialogs;

Const
  BufferSize = 8192;
  TIMEOUT = 2000;
Type
  TAppInfo = Record
    newstdin,
    newstdout,
    write_stdin,
    read_stdout,
    hAppThread,
    hAppProcess: THandle;
  End;

  TConReadCompleteEvent = Procedure(dwErrorCode, dwNumberOfBytesTransfered: DWORD;
      Var Overlapped: _OVERLAPPED) of Object;

  TConWriteEvent = procedure(Sender: TObject; Const Buffer; Size: Integer) of object;

  TErrorEvent = procedure(Sender: TObject; Const ErrorCode: Integer) of object;

  TState = (stReady, stWaiting);

  TConInterface = class(TThread)
  private
    FCritSec: TRTLCriticalSection;
    Events: TWOHandleArray;//Array[0..1] of THandle;
    FCon: TAppInfo;
    FOnWrite: TConWriteEvent;
    FOnError: TErrorEvent;
    function CreateDOSProcessRedirected(const CommandLine, InputFile:string;
      Var AppInfo: TAppInfo): Boolean;
    procedure CloseApp;
    procedure WaitForApp;
  protected
    irBuffer: INPUT_RECORD;
    NextString: String;
    PConReadCompleteEvent: ^TConReadCompleteEvent;
    FBytesRead: DWORD;
    FOutput: TStrings;
    FPrevChar,
    FConBuffer: Array[0..BufferSize] of Char;
    FConOverlapped,
    FOutputOverlapped: _OVERLAPPED;
    FState: TState;

    ThreadInputRead,
    ThreadInputWrite: THandle;

    Counter: Integer;
    FOnCount: TNotifyEvent;
    LastError: Integer;
    procedure DoNotify;
    Procedure DoCount;
    Procedure SyncFailed;
    Procedure Fail(Const Success: Boolean);
    Procedure Execute; Override;
  public
    Constructor Create;
    Destructor Destroy; Override;
    Procedure WriteString(Const Buffer: String);
    Property Output: TStrings read FOutput;
    Property OnWrite: TConWriteEvent read FOnWrite write FOnWrite;
    Property OnCount: TNotifyEvent read FOnCount write FOnCount;
    Property OnError: TErrorEvent read FOnError write FOnError;
  End;

implementation

Constructor TConInterface.Create;
Var
  Path: String;
  System: Array[0..MAX_PATH] of Char;
  S: String;
Begin
  Inherited Create(False);
  InitializeCriticalSection(FCritSec);
  FPrevChar:= #0;
  Path:= ExtractFilePath(ParamStr(0));
  GetSystemDirectory(System, MAX_PATH);
  S:= StrPas(System)+'\Cmd.exe';
  CreateDOSProcessRedirected(S, Path+'Test.bat', FCon);


//  FOutput:= TStringlist.Create;
//  FOutput.Add('');


  FOutputOverlapped.Offset:= 0;
  FOutputOverlapped.OffsetHigh:= 0;
  FOutputOverlapped.hEvent:= CreateEvent(nil, True, False, nil);
  Events[0]:= FOutputOverlapped.hEvent;

  FConOverlapped.Offset:= 0;
  FConOverlapped.OffsetHigh:= 0;
  FConOverlapped.hEvent:= CreateEvent(nil, True, False, nil);
  Events[1]:= FConOverlapped.hEvent;

  //FState:= stWaiting;


  FreeOnTerminate:= True;
End;

Destructor TConInterface.Destroy;
Begin
  If FCon.hAppProcess <> 0 then CloseApp;
  DeleteCriticalSection(FCritSec);
  //CloseHandle(Events[0]);
  //CloseHandle(Events[1]);
  //FOutput.Free;
End;

procedure TConInterface.SyncFailed;
Begin
  if Assigned(FOnError) then FOnError(Self, LastError);
End;

procedure TConInterface.DoNotify;
Begin
  if Assigned(FOnWrite) then
    FOnWrite(Self, FConBuffer, FBytesRead);
End;

Procedure TConInterface.DoCount;
Begin
  If Assigned(FOnCOunt) THen FOnCount(Self);
End;

Procedure onReadComplete(dwErrorCode,
                                 // completion code
                                 dwNumberOfBytesTransfered: DWORD;
                                 // number of bytes transferred
                                 Var Overlapped: TOverlapped);
Var                              // structure with I/O information
  i: DWord;
Begin
  i:= dwNumberOfBytesTransfered;
  ShowMessage('Done! ' + IntToStr(i));
End;

Procedure TConInterface.WriteString(Const Buffer: String);
Var
  Buf: pChar;
  Written, Size: DWORD;
begin
  EnterCriticalSection(FCritSec);
  Size:= Length(Buffer)+1;
  Buf:= AllocMem(Size);
  StrPCopy(Buf, Buffer);
  Try
    WriteFile(ThreadInputWrite, Buf^, Size-1, Written, @FConOverlapped);
  Finally
    FreeMem(Buf, Size);
  End;
  LeaveCriticalSection(FCritSec);
End;

Procedure TConInterface.Fail(Const Success: Boolean);
Begin
  If not(Success) then
  Begin
    LastError:= GetLastError;
    Synchronize(SyncFailed);
  End;
End;

Procedure TConInterface.Execute;
Var
  stdin, Res: DWORD;
  Avail: DWORD;
  Failed: Boolean;
Begin
  Sleep(500);
  Failed:= False;
  Repeat

      FBytesRead:= 0;

      SleepEx(100, True);

      Fail(PeekNamedPipe(FCon.read_stdout, @FConBuffer, BufferSize, @FBytesRead, @avail, nil));
      //check to see if there is any data to read from stdout

      if FBytesRead > 0 Then
      begin
        FillChar(FConBuffer, BufferSize, 0);
        if (avail > BufferSize - 1) then
        Begin
          while (FBytesRead >= BufferSize - 1) do
          Begin
            Fail(ReadFile(FCon.read_stdout, FConBuffer, BufferSize - 1, FBytesRead, @FOutputOverlapped));  //read the stdout pipe
            Synchronize(DoNotify);
            FillChar(FConBuffer, BufferSize, 0);
          End;
        End else
        Begin
          Fail(ReadFile(FCon.read_stdout, FConBuffer, BufferSize - 1, FBytesRead, @FOutputOverlapped));
          Synchronize(DoNotify);
        End;
      End;

      Res:= WaitForMultipleObjectsEx(2, @Events, False, INFINITE, True);

      If Res = WAIT_OBJECT_0 then
      begin
        Fail(ResetEvent(FOutputOverlapped.hEvent));
      End else
      If res = WAIT_OBJECT_0 + 1 then
      Begin
        Fail(ReadFile(ThreadInputRead, FConBuffer, BufferSize - 1, FBytesRead, @FConOverlapped));
        Fail(WriteFile(FCon.write_stdin, FConBuffer, FBytesRead, Avail, nil));
        Fail(ResetEvent(FConOverlapped.hEvent));
      End;

  Until Terminated;
End;

procedure TConInterface.CloseApp;
Begin
  With FCon do
  Begin
    If ThreadInputRead<>0 then CloseHandle(ThreadInputRead);
    If ThreadInputWrite<> 0 then CLoseHandle(ThreadInputWrite);
    if newstdin <> 0 then CloseHandle(newstdin);
    if newstdout <> 0 then CloseHandle(newstdout);
    if read_stdout <> 0 then CloseHandle(read_stdout);
    if hAppThread <> 0 then CloseHandle(hAppThread);
    if hAppProcess <> 0 then CloseHandle(hAppProcess);
    WaitforSingleObject(hAppProcess, INFINITE);
  End;
End;

Procedure TConInterface.WaitForApp;
Begin
  WaitforSingleObject(FCon.hAppProcess, INFINITE);
  CloseApp;
End;


Function TConInterface.CreateDOSProcessRedirected(const CommandLine, InputFile: string;
  Var AppInfo: TAppInfo): Boolean;
const
  ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
var
  pCommandLine  : array[0..MAX_PATH] of char;
  pInputFile    : array[0..MAX_PATH] of char;
  StartupInfo   : TStartupInfo;
  ProcessInfo   : TProcessInformation;
  SecAtrrs      : TSecurityAttributes;
  SecDescr      : TSecurityDescriptor;
begin
  Result := False;

  { Check for InputFile existence }
  With AppInfo do
  Begin
    { Initialize handles avoiding side-effects }
    newstdin:= 0;
    newstdout:= 0;
    write_stdin:= 0;
    read_stdout:= 0;
    hAppThread:= 0;
    hAppProcess:= 0;
    ThreadInputRead:= 0;
    ThreadInputWrite:= 0;

    if not FileExists(InputFile)
    then
      raise Exception.CreateFmt(ROUTINE_ID          + #10 +  #10 +
                                'Input file * %s *' + #10 +
                                'does not exist', [InputFile]);

    { Copy the parameter Pascal strings to null terminated
      strings }
    StrPCopy(pCommandLine, CommandLine);
    StrPCopy(pInputFile, InputFile);
  //  StrPCopy(pOutPutFile, OutputFile);

    TRY

      { Prepare SecAtrrs structure for the CreateFile calls.
        This SecAttrs structure is needed in this case because
        we want the returned handle can be inherited by child
        process. This is true when running under WinNT.
        As for Win95, the documentation is quite ambiguous }

      InitializeSecurityDescriptor(@SecDescr,SECURITY_DESCRIPTOR_REVISION);
      If not SetSecurityDescriptorDacl(@SecDescr, true, nil, true) then
        Showmessage('Failed to setup ACL');

      FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
      SecAtrrs.nLength              := SizeOf(SecAtrrs);
      SecAtrrs.lpSecurityDescriptor := @SecDescr;
      SecAtrrs.bInheritHandle       := True;

      { Create the appropriate handle for the input file }

      If not CreatePipe(
        read_stdout,
          // Ouput Handle for reading from the buffer
        newstdout,
          // Ouput Handle for writing to the buffer
        @SecAtrrs,
          // Security attributes
        8192
          //Allocated bytes for buffer
        ) Then Exit;
      If not CreatePipe(
        newstdin,
          // Ouput Handle for reading from the buffer
        write_stdin,
          // Ouput Handle for writing to the buffer
        @SecAtrrs,
          // Security attributes
        8192
          //Allocated bytes for buffer
        ) Then Exit;

      If not CreatePipe(
        ThreadInputRead,
          // Ouput Handle for reading from the buffer
        ThreadInputWrite,
          // Ouput Handle for writing to the buffer
        @SecAtrrs,
          // Security attributes
        8192
          //Allocated bytes for buffer
        ) Then Exit;



//This didn't work: I got an 'ACCESS DENIED'
{      write_stdin := CreateFile(
           'CONIN$',
             // pointer to name of the file
           GENERIC_READ OR GENERIC_WRITE,
             // access (read-write) mode
           FILE_SHARE_READ,// or FILE_SHARE_WRITE,
             // share mode
           @SecAtrrs,
             // pointer to security attributes
           OPEN_EXISTING, //OPEN_ALWAYS,
             // how to create
           FILE_ATTRIBUTE_NORMAL
           or FILE_FLAG_WRITE_THROUGH,
              // file attributes
           0 ); // handle to file with attributes to copy
}
      if write_stdin = INVALID_HANDLE_VALUE
      then
        raise Exception.CreateFmt(ROUTINE_ID + #10 +  #10 +
              'WinApi function CreateFile returned an' +
              'invalid handle value'  + #10 +
              'for the write_stdin input  ' + #10 +
              'Error: %s',
              [IntToStr(GetLastError)]);

      if newstdin = INVALID_HANDLE_VALUE
      then
        raise Exception.CreateFmt(ROUTINE_ID + #10 +  #10 +
              'WinApi function CreateFile returned an' +
              'invalid handle value'  + #10 +
              'for the newstdin input  ' + #10 +
              'Error: %s',
              [IntToStr(GetLastError)]);


//This one didn't work, though I copied a direct examlpe from Borland
{       hInputFile:= CreateFile('CONIN$', GENERIC_READ OR GENERIC_WRITE,
                    FILE_SHARE_READ, nil, OPEN_EXISTING,
                    FILE_ATTRIBUTE_NORMAL, 0);
}


      // Is hInputFile a valid handle?
      if write_stdin = INVALID_HANDLE_VALUE
      then
        raise Exception.CreateFmt(ROUTINE_ID + #10 +  #10 +
              'WinApi function CreateFile returned an' +
              'invalid handle value'  + #10 +
              'for the input file * %s *',
              [InputFile]);


      // Create the appropriate handle for the output file

      // Prepare StartupInfo structure
      FillChar(StartupInfo, SizeOf(StartupInfo), #0);
      StartupInfo.cb          := SizeOf(StartupInfo);
      StartupInfo.dwFlags     := STARTF_USESHOWWINDOW or
                                 STARTF_USESTDHANDLES;
      StartupInfo.wShowWindow := SW_HIDE;
      StartupInfo.hStdOutput  := newstdout;
      StartupInfo.hStdInput   := newstdin;
//      StartupInfo.hStdInput   := GetStdHandle(STD_INPUT_HANDLE);
      Fail(StartupInfo.hStdInput <> INVALID_HANDLE_VALUE);
      // Create the app
      Result := CreateProcess(nil,
             // pointer to name of executable module
          pCommandLine,
             // pointer to command line string
          nil,
             // pointer to process security attributes
          nil,
             // pointer to thread security attributes
          True,
             // handle inheritance flag
          IDLE_PRIORITY_CLASS,
             // creation flags
          nil,
             // pointer to new environment block
          nil,
             // pointer to current directory name
          StartupInfo,
             // pointer to STARTUPINFO
          ProcessInfo);
             // pointer to PROCESS_INF

      { wait for the app to finish its job and take the
        handles to free them later }

      if Result then
      begin
        hAppProcess  := ProcessInfo.hProcess;
        hAppThread   := ProcessInfo.hThread;
      end else
        raise Exception.Create(ROUTINE_ID          + #10 +  #10 +
                               'Function failure');


    FINALLY
      // Close the handles.
      //  Kernel objects, like the process and the files
      //  we created in this case, are maintained by a usage
      //  count.  So, for cleaning up purposes, we have to
      //  close the handles to inform the system that we don't
      //  need the objects anymore
      If not(Result) then
      Begin
        if newstdin <> 0 then CloseHandle(newstdin);
        if newstdout <> 0 then CloseHandle(newstdout);
        if write_stdin <> 0 then CloseHandle(write_stdin);
        if read_stdout <> 0 then CloseHandle(read_stdout);
        if hAppThread <> 0 then CloseHandle(hAppThread);
        if hAppProcess <> 0 then CloseHandle(hAppProcess);
        If ThreadInputRead<>0 then CloseHandle(ThreadInputRead);
        If ThreadInputWrite<> 0 then CLoseHandle(ThreadInputWrite);
        ShowMessage('No process were created!');
      End;
    END;
  End;
end;    // CreateDOSProcessRedirected


end.
0
interCommented:
Ok then,
If we post some more code here the page will blow. So post your mail here or to me:
guclu.ongun@isbank.net.tr
we discuss it here and exchange the code in email. The visitors could ask code from us.
c.u.
igor
0
williams2Author Commented:
I guess you are right, but it's still a hard nut to crack...

You can send anything to my email williams90@hotmail.com

C.u. 2

Williams
0
interCommented:
I have sent some more code to your hotmail account. Use the more recent one.
0
williams2Author Commented:
I'm happy to say, that Inter cracked the nut nice and (almost) painless. So if you are so kind, you may put your sample and reply as an answer - it deserves an A since this is actually as close as the system can possibly get, and I will see to do the rest ..I allready added a few new'n'nice features like mouseevents etc. ..Now I just need to read the screenbuffer, but with Igors sample, that's a piece of cake :-)))))

Please note, I will not be able to grade the question until monday, as I have to go visit my family during week-end.

Regards
Williams
0
interCommented:
Working on it to enhance...have a nice trip.
igor ;-)
0
interCommented:
I have sent new version, when you examine it drop a comment and I will drop an answer if nobody could do the better.
regards, igor
0
williams2Author Commented:
Dear Igor,

Thanks, I had a really nice trip :-) ...

This is a fabulous example you have put together, I'm overwellmed by your efforts in the target of this thread. You surely deserves every single point I can offer you in this question, and you do not have to worry about competition, as you so far are the only man for the job.

Please post your answer,
and I'll be more than happy to give you the points.

Regards and thanks,
Williams
0
interCommented:
Hi, and welcome,
do I post las pas and dfm here?
igor
0
williams2Author Commented:
Yes, Igor, just post it separated with lines of '-', then I guess the rest can think what to do.. :-)

Regards,
Williams
0
interCommented:
Hi there, code follows,
c.u. Will and all, many thanks for your kind words;-)
regards,
Igor

---- Consoler.pas, cut below ------

unit consoler;

interface

// performance penalty vs higher responsiveness, examine taskmanager...
{$DEFINE CAPTURE_MOUSE_MOVE}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Spin;

type
  TForm1 = class(TForm)
    TermPb: TPaintBox;
    Panel1: TPanel;
    Button2: TButton;
    Label1: TLabel;
    FontSize: TSpinEdit;
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure TermMouseUpDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure TermMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormShow(Sender: TObject);
    procedure FontSizeChange(Sender: TObject);
    procedure TermPbPaint(Sender: TObject);
  private
    { Private declarations }
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
  public
    { Public declarations }
    procedure PaintScreen;
  end;

  TConOutThread = class(TThread)
  private
    procedure Execute; override;
    procedure Refresh;
  public
    WHandle: THandle;
    constructor Create(AHandle: THandle);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

// these are for dynamic windowing but I could not do it by now
// I use a 80x25 static screen buffer
type
  PScreenLine = ^TScreenLine;
  TScreenLine = array[0..511] of TCharInfo; //max chars in line be set as 512
  TScreenBuffer = array[0..80] of PScreenLine; //max rows are 81
var
  BeginCapture: boolean = false;
  scrBufInfo: TConsoleScreenBufferInfo;
  TermCharW, TermCharH: Integer;
  hConIn, hConOut, hRead, hWrite, hErr: THandle;
  ProcessInfo: TProcessInformation;
  hConsoleWindow: THandle; //************* I find the console window from its caption
  scrBuf: array[0..24, 0..79] of TCharInfo;

function StartUpConsole(FName: PChar): boolean;
var
  StartupInfo: TStartupInfo;
  saAttr: TSECURITYATTRIBUTES;
begin
  Result := false;
  // Set the bInheritHandle flag so pipe handles are inherited.
  saAttr.nLength := sizeof(TSECURITYATTRIBUTES);
  saAttr.bInheritHandle := true;
  saAttr.lpSecurityDescriptor := nil;
  FillChar(StartupInfo, Sizeof(StartupInfo), #0);
  StartupInfo.cb := Sizeof(StartupInfo);
  StartupInfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := SW_SHOW;
  StartupInfo.hStdError := hErr;
  StartupInfo.hStdInput := hRead;
  StartupInfo.hStdOutput := hWrite;
  //Associate our handles with our child process
  if not CreateProcess(nil,
    FName,
    nil, nil,
    true, //!!!!!!!we should inherit handles
    NORMAL_PRIORITY_CLASS, //the child should use our CONSOLE
    nil, nil, StartupInfo, ProcessInfo) then
    ShowMessage('Can not create process')
  else
  begin
    WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
    repeat
      hConsoleWindow := FindWindow(nil, 'MyUnqiueuConsole');
    until hConsoleWindow <> 0;
    Result := true;
  end;
end;

procedure ExecFunc(S: string);
var
  bWritten: integer;
  buffer: array[0..255] of char;
begin
  StrPCopy(buffer, S + #13#10);
  WriteFile(hWrite, buffer, Length(S) + 2, bWritten, nil);
end;

procedure ReBindConsole;
begin
  if hConIn <> 0 then CloseHandle(hConIn);
  if hConOut <> 0 then CloseHandle(HConOut);
  // acquire redirected handles
  hConIn := CreateFile('CONIN$', GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
    0, 0);
  hConOut := CreateFile('CONOUT$', GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
    0, 0);
  if hConIn = INVALID_HANDLE_VALUE then hConIn := 0;
  if hConOut = INVALID_HANDLE_VALUE then hConOut := 0;
  // acquire and build the internal screen buffer
  GetConsoleScreenBufferInfo(hConOut, scrBufInfo);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if StartUpConsole('cmd') then
  begin
    button2.Enabled := false;
    ReBindConsole;
    TConOutThread.Create(hConOut);
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if hConIn <> 0 then CloseHandle(hConIn);
  if hConOut <> 0 then CloseHandle(hConOut);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  AllocConsole;
  hRead := GetStdHandle(STD_INPUT_HANDLE);
  hWrite := GetStdHandle(STD_OUTPUT_HANDLE);
  hErr := GetStdHandle(STD_ERROR_HANDLE);
  SetConsoleTitle('MyUnqiueuConsole');
end;

function GetExtKeyFlags(const KeyData: DWord): Integer;
begin
  Result := 0;
  if KeyData and $01000000 <> 0 then Result := Result or ENHANCED_KEY;
  if GetKeyState(VK_SHIFT) < 0 then Result := Result or SHIFT_PRESSED;
  if GetKeyState(VK_CONTROL) < 0 then Result := Result or LEFT_CTRL_PRESSED;
  if GetKeyState(VK_MENU) < 0 then Result := Result or LEFT_ALT_PRESSED;
  if KeyData and $20000000 <> 0 then Result := Result or LEFT_ALT_PRESSED;
  if GetKeyState(VK_CAPITAL) and $1 > 0 then Result := Result or CAPSLOCK_ON;
  if GetKeyState(VK_NUMLOCK) and $1 > 0 then Result := Result or NUMLOCK_ON;
  if GetKeyState(VK_SCROLL) and $1 > 0 then Result := Result or SCROLLLOCK_ON;
end;

procedure TForm1.TermPbPaint(Sender: TObject);
const
  ConColors: array[0..15] of TColor = (
    $00000000, $00800000, $00008000, $00808000, $00000080, $00800080,
    $00008080, $00C0C0C0, $00000000, $00FF0000, $0000FF00, $00FFFF00,
    $000000FF, $00FF00FF, $0000FFFF, $00FFFFFF);
var
  I, J: Integer;
  dx, dy: Integer;
  Attr: Word;
begin
  with TermPb.Canvas do
  begin
    dx := TermCharW; dy := TermCharH;
    for I := 0 to 24 do
    begin
      for j := 0 to 79 do
      begin
        Attr := scrBuf[I, J].Attributes;
        // process attributes
        Brush.Color := ConColors[(Attr and $F0) shr 4];
        Font.Color := ConColors[Attr and $0F];
        TextOut(j * dx, i * dy, scrBuf[I, J].AsciiChar);
      end;
    end;
  end;
end;

procedure TForm1.PaintScreen;
var
  r: Trect;
begin
  r := TermPb.ClientRect;
  InvalidateRect(Handle, @R, false);
end;

procedure ParseKeyState(Msg: TWMKey; var InRec: TInputRecord);
begin
  with InRec.KeyEvent do
  begin
    wRepeatCount := Msg.KeyData and $FFFF;
    wVirtualKeyCode := Msg.CharCode;
    wVirtualScanCode := MapVirtualKey(Msg.CharCode, 0); //Msg.KeyData and $FF0000;
    //    AsciiChar := Char(Msg.CharCode);//
    AsciiChar := Char(MapVirtualKey(Msg.CharCode, 2));
    dwControlKeyState := GetExtKeyFlags(Msg.KeyData);
  end;
end;

procedure TForm1.WMKeyDown(var Message: TWMKeyDown);
var
  InRec: TInputRecord;
  nWritten: integer;
begin
  InRec.EventType := KEY_EVENT;
  InRec.KeyEvent.bKeyDown := true;
  ParseKeyState(Message, InRec);
  if hConIn = 0 then WriteConsoleInput(hRead, InRec, 1, nWritten)
  else WriteConsoleInput(hConIn, InRec, 1, nWritten);
  inherited;
  Message.Result := 1;
  Message.CharCode := 0;
end;

procedure TForm1.WMKeyUp(var Message: TWMKeyUp);
var
  InRec: TInputRecord;
  nWritten: integer;
begin
  InRec.EventType := KEY_EVENT;
  InRec.KeyEvent.bKeyDown := false;
  ParseKeyState(Message, InRec);
  if hConIn = 0 then WriteConsoleInput(hRead, InRec, 1, nWritten)
  else WriteConsoleInput(hConIn, InRec, 1, nWritten);
  inherited;
  Message.Result := 1;
  Message.CharCode := 0;
end;

procedure ParseMouseState(var InRec: TInputRecord; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  with InRec.MouseEvent do
  begin
    dwMousePosition.X := x;
    dwMousePosition.y := y;
    dwButtonState := 0;
    if mbLeft = Button then dwButtonState := dwButtonState or 1;
    if mbRight = Button then dwButtonState := dwButtonState or 2;
    //    if mbMiddle = Button then dwButtonState := dwButtonState or 4;
    dwControlKeyState := GetExtKeyFlags(0);
    dwEventFlags := 0;
  end;
end;

procedure TForm1.TermMouseUpDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  InRec: TInputRecord;
  nWritten: integer;
begin
  InRec.EventType := _MOUSE_EVENT;
  ParseMouseState(InRec, Button, Shift, X div TermCharW, Y div TermCharH);
  if hConIn = 0 then WriteConsoleInput(hRead, InRec, 1, nWritten)
  else WriteConsoleInput(hConIn, InRec, 1, nWritten);
end;

procedure TForm1.TermMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
{$IFDEF CAPTURE_MOUSE_MOVE}
var
  InRec: TInputRecord;
  nWritten: integer;
begin
  InRec.EventType := _MOUSE_EVENT;
  ParseMouseState(InRec, mbMiddle, Shift, X div TermCharW, Y div TermCharH);
  InRec.MouseEvent.dwEventFlags := MOUSE_MOVED;
  if hConIn = 0 then WriteConsoleInput(hRead, InRec, 1, nWritten)
  else WriteConsoleInput(hConIn, InRec, 1, nWritten);
end;
{$ELSE}
begin
  ;
end;
{$ENDIF}

procedure TForm1.FormShow(Sender: TObject);
begin
  TermCharW := TermPb.Canvas.TextWidth('A');
  TermCharH := TermPb.Canvas.TextHeight('A') - 1;
end;

procedure TConOutThread.Refresh;
begin
  Form1.PaintScreen;
end;

procedure TConOutThread.Execute;
var
  dwBufSize, dwBufCo: TCoord;
  lpReadReg: TSmallRect;
begin
  while not (Terminated or Application.Terminated) do
  begin
    if WaitForSingleObject(WHandle, 1000) = WAIT_OBJECT_0 then
    begin
      GetConsoleScreenBufferInfo(hConOut, scrBufInfo);
      dwBufSize.X := 80; dwBufSize.Y := 25;
      dwBufCo.X := 0; dwBufCo.Y := 0;
      lpReadReg.Left := 0; lpReadReg.Right := 79;
      lpReadReg.Top := 0; lpReadReg.Bottom := 24;
      ReadConsoleOutPut(hConOut, @scrBuf[0][0], dwBufSize, dwBufCo, lpReadReg);
      Synchronize(Refresh);
    end;
    Sleep(100);
  end;
end;

constructor TConOutThread.Create(AHandle: THandle);
begin
  inherited Create(false);
  FreeOnTerminate := true;
  WHandle := AHandle;
end;

procedure TForm1.FontSizeChange(Sender: TObject);
begin
  try
    TermPb.Canvas.Font.Size := FontSize.Value;
    TermCharW := TermPb.Canvas.TextWidth('A');
    TermCharH := TermPb.Canvas.TextHeight('A') - 1;
    PaintScreen;
  except
  end;
end;

end.
---- Consoler.pas, Ends ----------
---- Consoler.dfm, cut below ------
object Form1: TForm1
  Left = 259
  Top = 261
  Width = 670
  Height = 405
  Caption = 'Remote Console'
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object TermPb: TPaintBox
    Left = 0
    Top = 0
    Width = 560
    Height = 378
    Align = alClient
    Font.Charset = OEM_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = 'Terminal'
    Font.Style = [fsBold]
    ParentFont = False
    OnMouseDown = TermMouseUpDown
    OnMouseMove = TermMouseMove
    OnMouseUp = TermMouseUpDown
    OnPaint = TermPbPaint
  end
  object Panel1: TPanel
    Left = 560
    Top = 0
    Width = 102
    Height = 378
    Align = alRight
    TabOrder = 0
    object Label1: TLabel
      Left = 16
      Top = 48
      Width = 44
      Height = 13
      Caption = 'Font Size'
    end
    object Button2: TButton
      Left = 15
      Top = 8
      Width = 75
      Height = 25
      Caption = 'Start'
      TabOrder = 0
      OnClick = Button2Click
    end
    object FontSize: TSpinEdit
      Left = 16
      Top = 64
      Width = 73
      Height = 22
      EditorEnabled = False
      Enabled = False
      MaxLength = 2
      MaxValue = 20
      MinValue = 6
      TabOrder = 1
      Value = 9
      OnChange = FontSizeChange
    end
  end
end
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
campidCommented:
Igor,
What version of Delphi was your accepted answer for? as I have tried to compile it on D5 on a win98 box and it failed with over a page of errors.

Any ideas?

Cheers Ian
0
interCommented:
Hi there, over 2 years by now :) the compiler is D3 on NT4, i do not know if console related apis properly run on win98,

regards,
igor

-i am suprised that some one interested in this after years :)
0
campidCommented:
I'll have to give it a try on NT. Cheers
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Delphi

From novice to tech pro — start learning today.