cpmdi.pas

生物信息学中的遗传数据分析的delphi源码。

{*******************************************************************
*                                                                  *
*  COMPONENT for MS DOS and Windows source code.                   *
*                                                                  *
*  (c) 1992, Roderic D. M. Page                                    *
*                                                                  *
*  Language: Turbo Pascal (Pascal with object-oriented extensions) *
*  Compiler: Turbo Pascal 6.0 (MS DOS)                             *
*            Turbo Pascal for Windows 1.0 (WINDOWS)                *
*                                                                  *
*  Notes:    Program interface is currently Windows specific.      *
*                                                                  *
*******************************************************************}


(*{$DEFINE RIBBONS}*)

{*

   Basic MDI application window with support for
   status bar and ribbon dialogs. Will derive MDI
   applications (such as COMPONENT) from the objects
   in this unit.


   Based on code in MDITEST, but without the ribbon dialog.

   User Messages defined in this module:

   fw_StatusBarUpDate
   ---------------------------------------------------------
   Sent by MDIChild to inform Frame window of new status
   bar string.

   Parameters: wParam:
               lParam: Pointer to status bar string (typecast)
                       to a longint.

   fw_ChildStatusBar
   ---------------------------------------------------------
   Tells MDIChild to place a child specific message on the
   status bar.

   Parameters: wParam:
               lParam:

   um_NewChild
   ---------------------------------------------------------
   Sent by MDIChild to inform Frame window that a child
   window has been activated. (Used here just to toggle
   ribbons).

   Parameters: wParam: vale (e.g., 1, 2, 3 ) depending on child window type.
               lParam:


   History
   =======



    5 Feb 1992 fw_ChildStatusBar message added so frame window
               can support editor children with caret position
               on the status bar.

   21 Apr 1992 Status bar drawing method changed (BlastStatusBar
               introduced) so that bar can be updated without
               having to invalidate the frame window. (This caused
               all kinds of display problems. )

   22 Jul 1992 Status bar now uses bitmap background for nicer appearance.
*}

{$DEFINE SMALLFONT}
{$I CPDIR.INC}

unit cpmdi;

interface

uses
	{$IFDEF BWCC}  { use Borland-style dialogs }
   {$IFDEF VER10} { TPW 1.0 }
   WObjectB,
   BWCC,
	{$ELSE}        { TPW 1.5 } 
   WObjects,
   {$ENDIF}
	{$ELSE}         
   WObjects,
	{$ENDIF}		   {use standard dialogs }
	WinTypes,
   WinProcs,
   Strings,
   cpmdico;

{$IFNDEF BINDRESOURCES}
{$R CPMDI.RES}
{$ENDIF}

const
   { Ribbon commands }
   cm_RibbonShow = 300;
   cm_RibbonHide = 301;

   { User messages }
   fw_StatusBarUpDate = wm_User + 10;
   fw_ChildStatusBar  = wm_user + 11; { new }
   fw_LogClosed       = wm_User + 14;
   um_NewChild        = wm_User + 20;
   um_Ready           = wm_User + 21;
   um_Working         = wm_User + 22;

   { Child window types }
   FirstChild  = 0;
   SecondChild = 1;

   { Length of status bar message }
   MsgLength = 128;

type
   { Status bar message }
   MsgStr = array[0..MsgLength] of char;

const
   { Standard status bar messages }
   ReadyStr  :MsgStr = ' Ready';
   WorkingStr:MsgStr = ' Working...';
   ChildStr  :MsgStr = ' MDIChild';
   MenuStr   :MsgStr = ' Menu item selected';

type

   { Ribbon dialog }
   PRibbonDialog = ^RibbonDialog;
   RibbonDialog = object(TDlgWindow)
      procedure WMEraseBkgnd (var Msg:TMessage);virtual wm_First + wm_EraseBkgnd;
      procedure WMPaint (var Msg:TMessage);virtual wm_First + wm_Paint;
      procedure Button (var Msg:TMessage);virtual id_First + 100;
      function GetClassName:PChar;virtual;
      procedure GetWindowClass (var AWndClass: TWndClass);virtual;
      end;


  { MDI Frame window with status bar and ribbon }
  PNewMDIWindow = ^NewMDIWindow;
  NewMDIWindow = object (TMDIWindow)
     StatusBarOn     : Boolean;         { status bar toggle }
     StatusBarText   : MsgStr;          { status bar text }
     RibbonBarOn     : Boolean;         { ribbon toggle }
     TheRibbon       : PRibbonDialog;   { current ribbon bar }

     Ribbon1,
     Ribbon2         : PRibbonDialog;   { ribbon bars}


     hMDIActiveChild : HWnd;            { active child }
     fMDIChildIsMax  : Boolean;         { true if active child is maximized }
     FirstChildWnd   : PWindow;         { first child window }

     LogClosed : Boolean;
     StatusLineBitmap : HBitmap;

     constructor Init (ATitle: PChar; AMenu: HMenu);

     procedure CreateRibbons;virtual;

     procedure RecreateFirstChild;virtual;
     procedure CMCloseChildren (var Msg:TMessage);virtual cm_First + cm_CloseChildren;
     procedure AppMenuHelpText (TextID:word);virtual;
     procedure AppPopupMenuHelpText (ItemID:word);virtual;
     procedure StatusBarUpDate (s:PChar);
     procedure FWStatusBarUpDate (var Msg:TMessage);virtual wm_First + FW_StatusBarUpDate;
     procedure SetUpWindow;virtual;
     procedure WMSize (var Msg:TMessage);virtual wm_First + wm_Size;
     procedure WMMenuSelect (var Msg:TMessage);virtual wm_First + wm_MenuSelect;
     procedure Paint (PaintDC: HDC; var PaintInfo: TPaintStruct);virtual;
     function InitChild:PWindowsObject;virtual;
     procedure DefWndProc (var Msg:TMessage);virtual;
     procedure umNewChild (var Msg:TMessage);virtual wm_First + um_NewChild;
     procedure umReady (var Msg:TMessage);virtual wm_First + um_Ready;
     procedure umWorking (var Msg:TMessage);virtual wm_First + um_Working;
     procedure ShowNewRibbon (NewRibbon:PRibbonDialog);
     procedure CMRibbonShow (var Msg:TMessage);virtual cm_First + cm_RibbonShow;
     procedure CMRibbonHide (var Msg:TMessage);virtual cm_First + cm_RibbonHide;
     procedure ChildStatusBar;
     procedure FWLogClosed (var msg:TMessage);virtual wm_First + fw_LogClosed;

     private
     procedure BlastStatusLine(PaintDC: HDC);
     procedure MenuHelpText (Textid:word);
     procedure PopupMenuHelpText (ItemID:word);
     function FirstItemInPopup (PopupHandle:word):word;
     procedure GetStatusBarRect (var r:TRect);
     procedure ResizeClientWindow;
     procedure DrawStatusBar (DC: HDC);
(*     procedure DrawStatusDivide (DC: HDC; var R: TRect);*)
     end;

   { MDI child window }
   PMDIChild = ^MDIChild;
   MDIChild = object(TWindow)
      StatusStr : MsgStr;
      constructor Init (AParent: PWindowsObject; ATitle:PChar);
      procedure WMMenuSelect (var Msg:TMessage);virtual wm_First + wm_MenuSelect;
      procedure WMMDIActivate (var Msg:TMessage);virtual wm_First + wm_MDIActivate;
      function GetClassName:PChar;virtual;
      procedure GetWindowClass (var AWndClass:TWndClass);virtual;
      procedure FWChildStatusBar (var Msg:TMessage);virtual wm_First + FW_ChildStatusBar;
      end;

   PMDIFirstChild = ^MDIFirstChild;
   MDIFirstChild = object(MDIChild)
      procedure WMMDIActivate (var Msg:TMessage);virtual wm_First + wm_MDIActivate;
      end;


implementation


procedure Create3DEffect (DC :HDC; var Rect : TRect; thickness : integer);
var
	i, x1, y1, x2, y2 : integer;
	NewBrush, OldBrush : HBrush;
	NewPen, OldPen : HPen;
begin
	x1 := Rect.left;
	y1 := rect.top;
	x2 := rect.right;
	y2 := rect.bottom;
	SelectObject(DC, GetStockObject(BLACK_PEN));
	NewBrush := CreateSolidBrush(RGB(192, 192, 192));
	OldBrush := SelectObject(DC, NewBrush);
	Rectangle(DC, x1, y1, x2, y2);
	SelectObject(DC, GetStockObject(WHITE_PEN));

   for i := 1 to thickness do begin
		MoveTo(DC, x1 + i, y1 + i);    LineTo(DC, x1 + i, y2 - 1);
		MoveTo(DC, x1 + i, y1 + i);    LineTo(DC, x2 - 1, y1 + i);
      end;
	NewPen := CreatePen(PS_SOLID, 1, RGB(128,128,128));
	OldPen := SelectObject(DC, NewPen);

	for i := 1 to thickness do begin
		MoveTo(DC, x1 + i, y2 - 1 - i);
		LineTo(DC, x2 - 1, y2 - 1 - i);
		MoveTo(DC, x2 - 1 - i, y2 - 2);
		LineTo(DC, x2 - 1 - i, y1 + i);
      end;
	NewBrush := SelectObject(DC, OldBrush);
	DeleteObject(NewBrush);
	NewPen := SelectObject(DC, OldPen);
	DeleteObject(NewPen);
end;


{**********************}
{                      }
{  RibbonDialog object }
{                      }
{**********************}

{-----------------------------WMPaint--------------------------------------}

{ Intercept wm_Paint message to paint line separating
  ribbon from MDIClient window. }
procedure RibbonDialog.WMPaint (var Msg:TMessage);
var
   Pen: hPen;
   R: TRect;
   PaintDC: HDC;
   PaintInfo: TPaintStruct;
begin
   PaintDC := BeginPaint (HWindow, PaintInfo);
   Pen     := CreatePen (ps_solid, GetSystemMetrics(sm_CYBorder), RGB(0,0,0));
   SelectObject (PaintDC, Pen);
   GetClientRect (HWindow, R);
   MoveTo(PaintDC, r.left, R.bottom - GetSystemMetrics(sm_CYborder));
   LineTo(PaintDC, R.right, r.bottom - GetSystemMetrics(sm_CYBorder));
   DeleteObject (Pen);
   EndPaint (HWindow, PaintInfo);
end;

procedure RibbonDialog.GetWindowClass (var AWndClass: TWndClass);
begin
   TDlgWindow.GetWindowClass (AWndClass);
   AWndClass.hbrBackground := GetStockObject(LtGray_Brush);
end;

{-----------------------------GetClassName---------------------------------}

function RibbonDialog.GetClassName:PChar;
begin
   GetClassName := 'ribbon';
end;

procedure RibbonDialog.WMEraseBkgnd (var Msg:TMessage);
var
   OldBrush, newBrush: HBrush;
   DC : HDC;
   R : TRect;
begin
   MessageBeep(0);
   GetClientRect (HWindow, R);
   FillRect (HDC(Msg.wParam), R, GetStockObject(LtGray_Brush));
   Msg.result := 1;
{   TDlgWindow.DefWndProc (Msg);}
end;

{-----------------------------Button---------------------------------------}

{ Responds to "Ribbon" button, use as an e.g. of processing
  ribbon messages by passing them on to Frame window.
  Returns focus to parent window. Use this as a model
  for descendants of RibbonDialog. }
procedure RibbonDialog.Button (var Msg:TMessage);
var
   A: array[0.. 60] of char;
   s : Pchar;
begin
   StrCopy (A, 'Ribbon');
   s := A;
   SendMessage (Parent^.HWindow, fw_StatusBarUpDate, 0, longint(s));
   SetFocus (Parent^.HWindow);
end;

{**********************}
{                      }
{  MDIChild object     }
{                      }
{**********************}


constructor MDIChild.Init (AParent: PWindowsObject; ATitle:PChar);
begin
   TWindow.Init (AParent, ATitle);
   StrCopy (StatusStr, ' Ready');
end;

{-----------------------------GetWindowClass-------------------------------}

procedure MDIChild.GetWindowClass (var AWndClass:TWndClass);
begin
   TWindow.GetWindowClass (AWndClass);
end;

{-----------------------------GetClassName---------------------------------}

function MDIChild.GetClassName:PChar;
begin
   GetClassName := 'MDIChild';
end;

{-----------------------------WMMDIActivate--------------------------------}

{ Notify parent that child is active. Override in descendants.
  Ensure status bar shows child appropriate message. }
procedure MDIChild.WMMDIActivate (var Msg:TMessage);
begin
   if (Msg.wParam <> 0) then begin
      SendMessage (Parent^.HWindow, um_NewChild, SecondChild, 0);
      SendMessage (HWindow, fw_ChildStatusBar, 0, 0);
      end;
   with Msg do
      DefMDIChildProc (HWindow, Message, wParam, lParam);