Telnet WriteConsoleInput

API Chat for Delphi
Admin
Site Admin
Posts: 955
Joined: Thu Aug 23, 2007 10:35 am

Telnet WriteConsoleInput

Postby Admin » Wed Nov 26, 2008 12:29 am

Code: Select all

---- 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

Return to “API”

Who is online

Users browsing this forum: No registered users and 1 guest