[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    {
    I have just extended some PD sources (in this month's SWAG - HOOKCRT.PAS) to
    convert it to a unit, with supporting Pascal Object and Delphi Class. This
    hooks into the WinCRT unit (BPW and Delphi 1.x) to add menus, etc. A sample
    program is included. You might wish to add this to the SWAG archives.
    Thanks.

    ------------------------------ cut ------------------------------ }
    Unit HookCrt2;

    { ----- ORIGINAL MESSAGE ---
      The intent of this program is to provide the ability to add additional functionality
      to WinCRT.  Like the ablity to add and use a menubar and to be able to respond to
      mouse clicks.

      WinCRT does NOT need to be modified to run this app.

      This program is Public Domain by Cedar Island Software. Use it as you see fit.
      All the usual disclaimers apply.

      Thanks to Neil Rubenking and his book 'Turbo Pascal for Windows Techniques and Utilities'.
      Thanks to Kurt Barthlemess of BPASCAL (TeamB).
      Thanks also to Paul A. LeBlanc of BCPPWIN (TeamB).

      Good Luck and Have Fun.
      Mike Caughran
      Cedar Island Software
      [71034,2371]

      ---- ADDED MESSAGE by Dr A Olowofoyeku ------
      September 1996
      Amended and Extended by Dr A Olowofoyeku (The African Chief);
       [a] converted to a unit
       [b] a Pascal object (and Delphi Class) to encapsulate the
           unit's functionality.
       [c] some default procedural types and functions
       [d] MyInitWinCRT changed to: HookedInitWinCRT - and now
           takes some parameters
       [e] MyDoneWinCRT changed to: HookedDoneWinCrt;
       [f] supports Delphi 1.x

      Enjoy!

      THIS UNIT IS PUBLIC DOMAIN -
      NOTHING IS WARRANTEED. USE AT YOUR OWN RISK!

      Dr A. Olowofoyeku (The African Chief)
      Email: laa12@cc.keele.ac.uk
      http://ourworld.compuserve.com/homepages/African_Chief/
    }

    Interface
    {$ifdef Ver80}     {Delphi 1.x}
       {$Define Delphi}
    {$endif Ver80}

    uses {$ifndef Delphi}Objects {$else}Messages{$endif},WinCRT, WinTypes, WinProcs;

    {/////////////////////////////////////////////////////////////}
    {////////////// exported data and functions //////////////////}
    {/////////////////////////////////////////////////////////////}
    {custom icon for CRT window}
      Var
      CrtappIcon : hIcon;

    {  User menu command tags (identifiers)
       start from 1 to 64 for CRT menu tags
    }
      Const
      cm_User1   = 1;
      cm_UserMax = 64;

    {Crt Window function type}
    Type
    aWindowFunc = Function(Window : HWnd; Message : Word;
                           wParam : Word; lParam : LongInt) : LongInt;

    {menu command procedural type}
    aMenuFunc   = Procedure(Const aTag:integer);

    {create a CRT window}
    Function  HookedInitWinCRT(
    Const
    Left,                 {left side of the window}
    Top,                  {top of the window}
    width,                {width of the window}
    height:integer;       {height of the window}
    Title :pChar ;        {window title}
    aWinProc:aWindowFunc; {new window function, or Nil for default}
    MenuFunc:aMenuFunc    {new window procedure, or Nil for default}
    ):HWnd;                 {returns the handle to the CRT window}

    {destroy a CRT window}
    Function HookedDoneWinCRT : Boolean;

    {/////////////////////////////////////////////////////////////}
    {///////////////////// CRT object ////////////////////////////}
    {// This object encapsulates the functionality of this unit //}
    {/////////////////////////////////////////////////////////////}
    {/////////////////////////////////////////////////////////////}
    Type
    TNewCrtClass = {$ifdef Delphi}Class{$else}Object(TObject){$endif}
       HWindow : HWnd; {handle of the CRT window}

       Constructor {$ifdef Delphi}Create{$else}Init{$endif}
       {init constructor - calls HookedInitWinCRT with all these
       parameters, to create the CRT window}
       (Const
       Left,                 {left side of the window}
       Top,                  {top of the window}
       width,                {width of the window}
       height:integer;       {height of the window}
       Title :pChar ;        {window title}
       aWinProc:aWindowFunc; {new window function, or Nil for default}
       MenuFunc:aMenuFunc    {new window procedure, or Nil for default}
       );

       Destructor {$ifDef Delphi}Destroy;override{$else}Done; virtual{$endif};

       Procedure   MakeMainMenu(Caption:pChar;Tag:integer);virtual;
       {create a main menu item = e.g., File Menu, Edit, etc.
       Caption = the title of the menu
       Tag     = the command tag
       }

       Procedure   MakeSubMenu(ParentNum:Byte;Caption:pChar;Tag:integer);virtual;
       {create a submenu under the main menu "parentnum"
       ParentNum = the numeric ID of the parent main menu
       Caption = the title of the menu
       Tag     = the command tag
       }
       Procedure   MakeSeparator(ParentNum:Byte);virtual;
       {create a menu separator under the main menu "parentnum"
       ParentNum = the numeric ID of the parent main menu
       }

       Procedure   AssignCRTMenu;virtual;
       {assign the menu to the CRT window and repaint the menu;
       MUST be called at some stage - normall AFTER all the menu
       items have been create.}

       Private
         MainMenus : Array[0..32] of HMenu; {max 32 main MainMenus}
         MenuCount : Word; {number of main MainMenus created}
    end;{end of CRT object}
    {////////////////////////////////////////////////}
    Var
      OldCRTProc   : TFarProc;{pointer to old window function}
      NewCRTHandle : HWND;  {handle to CRT window}

    implementation

    var
      NewCRTProc : TFarProc; {pointer to new window function}

    Var
    DefMenuFunc:aMenuFunc;{menu command function}

    {////////////////////////////////////////////////}
    function NewDefaultMsgHandler(Window : HWnd; Message : Word;
    {default message handler - if none is specified in call to
    HookedInitWinCRT}
    wParam : Word; lParam : LongInt) : LongInt; export;
    begin
      case Message of
        wm_Command  : begin
          case WParam of
            cm_User1 .. cm_UserMax:
            If @DefMenuFunc<> Nil then DefMenuFunc(WParam);
          end;
        end;
      end;
      NewDefaultMsgHandler := CallWindowProc(OldCRTProc, Window, Message, wParam, lParam);
    end;
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    Constructor TNewCrtClass.{$ifdef Delphi}Create{$else}Init{$endif};
    Begin
       Inherited {$ifdef Delphi}Create;{$else}Init;{$endif}
       HWindow := HookedInitWinCrt
       (Left,Top,width,height,Title,aWinProc,MenuFunc);

       FillChar(MainMenus, Sizeof(MainMenus), #0);
       MainMenus[0] := CreateMenu;
       MenuCount := 0;
    End;
    {////////////////////////////////////////////////}
    Destructor TNewCrtClass.{$ifDef Delphi}Destroy{$else}Done{$endif};
    Begin
        FillChar(MainMenus, Sizeof(MainMenus), #0);
        MenuCount := 0;
        HWindow   := 0;
        HookedDoneWinCRT;
       {$ifdef Delphi}
        Inherited Destroy;
       {$else}
        Inherited Done;
       {$endif}
    End;
    {////////////////////////////////////////////////}
    Procedure TNewCrtClass.MakeMainMenu;
    Begin
       If MenuCount>=32 then Exit;
       If Tag > 0 then AppendMenu(MainMenus[0], mf_Enabled, Tag, Caption)
       else begin
         Inc(MenuCount);
         MainMenus[MenuCount] := CreateMenu;
         AppendMenu(MainMenus[0], mf_PopUp or mf_Enabled, MainMenus[MenuCount], Caption);
       end;
    End;
    {////////////////////////////////////////////////}
    Procedure TNewCrtClass.MakeSubMenu;
    Begin
      If (ParentNum<1) or (ParentNum>32) then exit;
      AppendMenu(MainMenus[ParentNum], mf_Enabled, Tag, Caption);
    End;
    {////////////////////////////////////////////////}
    Procedure TNewCrtClass.MakeSeparator;
    Begin
      If (ParentNum<1) or (ParentNum>32) then exit;
      AppendMenu(MainMenus[ParentNum], mf_Separator,0, '');
    End;
    {////////////////////////////////////////////////}
    Procedure TNewCrtClass.AssignCRTMenu;
    Begin
      SetMenu(HWindow,MainMenus[0]);
    End;
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    function  GetCRTWindowHandle: HWnd;
    {return handle to the CRT window}
    begin
      ClrScr;   {force active window}
      GetCRTWindowHandle := GetActiveWindow;
    end;
    {////////////////////////////////////////////////}
    Procedure GetScreenResolution(Var aTPoint : TPoint);
    {get the current screen resolution and return it in "T"}
    Var
    HD : HDC;
    Wn : HWnd;
    Begin
       Wn := GetDesktopWindow;
       Hd := GetDC(Wn);
       With aTPoint do begin
         X := GetDeviceCaps(Hd, HorzRes);
         Y := GetDeviceCaps(Hd, VertRes);
       End;
       ReleaseDC(Wn, Hd);
    End;
    {////////////////////////////////////////////////}
    Procedure SetWindowCoordinates;
    {set up CRT window for possible scrolling}
    Var
    aPoint : tpoint;
    aReal  : real;
    anInt  : integer;

    Begin
       GetScreenResolution(aPoint);

       With aPoint do
       begin
          aReal := Y /25;
          If y >  768 then aReal := (aReal*13.2) else
          If Y >= 600 then aReal := (aReal*15.8) else
          aReal := (aReal*18.4);

          anInt := round(aReal + 25);
          WindowSize.Y := anInt;

          If X > 800 then anInt := 11 else anInt := 10;
          WindowSize.X := (ScreenSize.X * anInt);
       end;
    End;
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}

    Function  HookedInitWinCRT;
    {initialise the new crt stuff}
    Begin
      {window location coordinates}
      With WindowOrg do begin
         x := Left;
         y := Top;
      end;

     {the size of the CRT window buffer}
      With ScreenSize do begin
         x := Width;
         y := Height;
      end;

      {setup the window properly}
      SetWindowCoordinates;

      {set window title}
      lStrCpy(WindowTitle, Title);

      {call WinCRT.InitWinCRT}
      InitWinCrt;

     {get the CRT window handle}
      NewCRTHandle := GetCRTWindowHandle;
      {SetWindowText(NewCRTHandle, Title);}

      {save old window proc}
      OldCRTProc := TFarProc(GetWindowLong(NewCRTHandle, gwl_WndProc));

      {assign new window proc}
      If @aWinProc<>Nil then
      NewCrtProc := MakeProcInstance(@aWinProc, hInstance)
      else
      NewCrtProc := MakeProcInstance(@NewDefaultMsgHandler, hInstance);

      {make it happen!}
      SetWindowLong(NewCRTHandle, gwl_WndProc, LongInt(NewCrtProc));

      {assign CRT menu proc}
      If @MenuFunc <> Nil then DefMenuFunc := MenuFunc;

      {if custom icon used, assign it}
      If CrtappIcon<>0 then
      SetClassWord(NewCRTHandle, gcw_hIcon, CrtappIcon);

     {return handle of CRT window}
      HookedInitWinCRT := NewCRTHandle;
    End;
    {////////////////////////////////////////////////}
    Function  HookedDoneWinCRT;
    {dispose of the new crt window}
    begin
      DoneWinCrt; {call WinCRT.DoneWinCrt}
      HookedDoneWinCRT:=True;

      {do other stuff}
      CrtappIcon := 0;
      NewCRTHandle:=0;
      FreeProcInstance(NewCrtProc);
      DefMenuFunc := Nil;
    end;
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    {///////// initialisation block /////////////////}
    {////////////////////////////////////////////////}
    begin
       CrtappIcon   := 0;
       NewCRTHandle := 0;
       DefMenuFunc  := Nil;
    end.
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    {// TEST PROGRAM: shows usage of HOOKCRT2.PAS ///}
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    Program TestCRT;
    {$ifdef Ver80}
       {$Define Delphi}
    {$endif Ver80}

    uses {$ifdef Delphi}Messages,{$endif}WinTypes,
    WinProcs, HookCrt2, WinCrt;

      {menu constants: start from 1 - to infinity}
      Const
      cm_Exit    = 1;
      cm_About   = 2;
      cm_Clear   = 3;

    Var
    TestCrtObj : TNewCrtClass;

    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    Procedure ExecMenus(Const Tag:Integer);forward;
    {a sample procedure to process menu choices}

    function  ShellAbout(hwnd:HWND; Title,Text:PChar; icon:HICON):integer; external 'SHELL' index 22;
    {an "About" function}
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    function TestProc(Window : HWnd; Message : Word;
    wParam : Word; lParam : LongInt) : LongInt; export;
    {sample new menu handler}
    begin
      case Message of
        wm_char        : begin {MessageBeep(0);} end;
        wm_LButtonDown : MessageBox(NewCrtHandle,'Left button','Mouse',MB_OK);
        wm_Command     : begin
          case WParam of
            cm_User1 .. cm_UserMax: ExecMenus(WParam);
          end;
        end;
      end;

      {call the old window proc = essential!}
      TestProc := CallWindowProc(OldCRTProc, Window, Message, wParam, lParam);
    end;
    {////////////////////////////////////////////////}
    Procedure ExecMenus(Const Tag:Integer);
    Begin
      Case Tag of
         cm_About:
         ShellAbout(NewCrtHandle,'Hooked CRT#Cedar Island Software & The Chief','Hello World, from the Chief!',
                      CrtappIcon);
         cm_Exit:
               TestCrtObj.{$ifDef Delphi}Free{$else}Done{$endif};
         {HookedDoneWinCRT;}
         cm_Clear: begin clrscr; gotoxy(1,1); end;
      End;
    End;
    {////////////////////////////////////////////////}
    procedure DoTest;
    var
      Name    : String;
    begin
      LoadString(GetModuleHandle('USER'),514,@Name[1],79);
      Name[0]:=Char(LStrLen(@Name[1]));
      Writeln('Hello ',Name);
      Writeln('Welcome to a Subclassed WinCRT World!');
      readln;
    end;
    {////////////////////////////////////////////////}
    {////////////////////////////////////////////////}
    {//////////// program block  ////////////////////}
    begin
       TestCrtObj{$ifdef Delphi}:= TNewCrtClass.Create{$else}.Init{$endif}
       (1,1,80,25,'Chief''s Hooked CRT Window',TestProc,ExecMenus);

        With TestCrtObj do begin
         MakeMainMenu('&File ', 0);
           MakeSubMenu(1, '&New', 0);
           MakeSubMenu(1, '&Open...', 0);
           MakeSubMenu(1, '&Save', 0);
           MakeSubMenu(1, 'Save &As ...', 0);
           MakeSeparator(1);
           MakeSubMenu(1,'E&xit', cm_Exit);

         MakeMainMenu('&Edit ', 0);
           MakeSubMenu(2,'Cu&t    Shift+Del', 0);
           MakeSubMenu(2,'&Copy   Ctrl+Ins', 0);
           MakeSubMenu(2, '&Paste Shift+Ins', 0);
           MakeSubMenu(2, 'C&lear Ctrl+Del', cm_Clear);
           MakeSeparator(2);
           MakeSubMenu(2,'E&xit', cm_Exit);

         MakeMainMenu('&Help ', 0);
           MakeSubMenu(3,'&Contents  Shift+F1', 0);
           MakeSubMenu(3,'&Topic Search', 0);
           MakeSubMenu(3,'&Using Help', 0);
           MakeSeparator(3);
           MakeSubMenu(3,'&About ...', cm_About);
           MakeSeparator(3);
           MakeSubMenu(3,'E&xit', cm_Exit);

           AssignCrtMenu; {this MUST be called after creating all menus!!}

           DoTest;  {call a test procedure}

           {dispose of object and CRT window}
           {$ifDef Delphi}Free{$else}Done{$endif};
       end;
    end.

    [----------------------- end cut ------------------------]
    Warmest regards,
    The Chief
    ---------
    Dr. Abimbola A. Olowofoyeku  (The African Chief)
    Keele University, England    (and, The Great Elephant)
    Email: laa12@keele.ac.uk      or,  chief@mep.com
    http://ourworld.compuserve.com/homepages/African_Chief/chief.htm

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]