dwinctl.pas.svn-base

Asphyre的传奇WIL,可以用Asphyre来写传奇了

unit DWinCtl;

interface

uses
  Windows, Classes, Graphics, SysUtils, Controls,
  Forms, Grids, wmUtil, HUtil32, WIL,
  AsphyreDef, AsphyreCanvas, AsphyreImages;

const
   WINLEFT = 60;
   WINTOP  = 60;
   WINRIGHT = 800-60;
   BOTTOMEDGE = 600-30;  //扩档狼 Bottom捞 WINBOTTOM阑 逞阑 荐 绝澜.

type
   TClickSound = (csNone, csStone, csGlass, csNorm);
   TDControl = class;
   TOnDirectPaint = procedure(Sender: TObject; dsurface: TAsphyreCanvas) of object;
   TOnKeyPress = procedure(Sender: TObject; var Key: Char) of object;
   TOnKeyDown = procedure(Sender: TObject; var Key: word; Shift: TShiftState) of object;
   TOnMouseMove = procedure(Sender: TObject; Shift: TShiftState; X, Y: integer) of object;
   TOnMouseDown = procedure(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer) of object;
   TOnMouseUp = procedure(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object;
   TOnClick = procedure(Sender: TObject) of object;
   TOnClickEx = procedure(Sender: TObject; X, Y: integer) of object;
   TOnInRealArea = procedure(Sender: TObject; X, Y: integer; var IsRealArea: Boolean) of object;
   TOnGridSelect = procedure(Sender: TObject; ACol, ARow: integer; Shift: TShiftState) of object;
   TOnGridPaint = procedure(Sender: TObject; ACol, ARow: integer; Rect: TRect; State: TGridDrawState; dsurface: TAsphyreCanvas) of object;
   TOnClickSound = procedure(Sender: TObject; Clicksound: TClickSound) of object;

   TDControl = class (TCustomControl)
   private
      FDrawFx: Cardinal;
      FCaption: string;
      FDParent: TDControl;
      FEnableFocus: Boolean;
      FOnDirectPaint: TOnDirectPaint;
      FOnKeyPress: TOnKeyPress;
      FOnKeyDown: TOnKeyDown;
      FOnMouseMove: TOnMouseMove;
      FOnMouseDown: TOnMouseDown;
      FOnMouseUp: TOnMouseUp;
      FOnDblClick: TNotifyEvent;
      FOnClick: TOnClickEx;
      FOnInRealArea: TOnInRealArea;
      FOnBackgroundClick: TOnClick;
      procedure SetCaption (str: string);
   protected
      FVisible: Boolean;
   public
      Background: Boolean;
      DControls: TList;
      //FaceSurface: TAsphyreImage;
      WLib: TWMImages;
      FaceIndex: integer;
      WantReturn: Boolean; //Background老锭, Click狼 荤侩 咯何..

      constructor Create (AOwner: TComponent); override;
      destructor Destroy; override;
      procedure Paint; override;
      procedure Loaded; override;
      function  SurfaceX (x: integer): integer;
      function  SurfaceY (y: integer): integer;
      function  LocalX (x: integer): integer;
      function  LocalY (y: integer): integer;
      procedure AddChild (dcon: TDControl);
      procedure ChangeChildOrder (dcon: TDControl);
      function  InRange (x, y: integer): Boolean;
      function  KeyPress (var Key: Char): Boolean; dynamic;
      function  KeyDown (var Key: Word; Shift: TShiftState): Boolean; dynamic;
      function  MouseMove (Shift: TShiftState; X, Y: Integer): Boolean; dynamic;
      function  MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; dynamic;
      function  MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; dynamic;
      function  DblClick (X, Y: integer): Boolean; dynamic;
      function  Click (X, Y: integer): Boolean; dynamic;
      function  CanFocusMsg: Boolean;

      procedure SetImgIndex (Lib: TWMImages; index: integer);
      procedure DirectPaint (dsurface: TAsphyreCanvas); dynamic;

   published
      property OnDirectPaint: TOnDirectPaint read FOnDirectPaint write FOnDirectPaint;
      property OnKeyPress: TOnKeyPress read FOnKeyPress write FOnKeyPress;
      property OnKeyDown: TOnKeyDown read FOnKeyDown write FOnKeyDown;
      property OnMouseMove: TOnMouseMove read FOnMouseMove write FOnMouseMove;
      property OnMouseDown: TOnMouseDown read FOnMouseDown write FOnMouseDown;
      property OnMouseUp: TOnMouseUp read FOnMouseUp write FOnMouseUp;
      property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
      property OnClick: TOnClickEx read FOnClick write FOnClick;
      property OnInRealArea: TOnInRealArea read FOnInRealArea write FOnInRealArea;
      property OnBackgroundClick: TOnClick read FOnBackgroundClick write FOnBackgroundClick;
      property Caption: string read FCaption write SetCaption;
      property DParent: TDControl read FDParent write FDParent;
      property Visible: Boolean read FVisible write FVisible;
      property EnableFocus: Boolean read FEnableFocus write FEnableFocus;
      property DrawFx: Cardinal read FDrawFx write FDrawFx;
      property Color;
      property Font;
      property Hint;
      property ShowHint;
      property Align;
   end;

   TDButton = class (TDControl)
   private
      FClickSound: TClickSound;
      FOnClick: TOnClickEx;
      FOnClickSound: TOnClickSound;
   public
      Downed: Boolean;
      constructor Create (AOwner: TComponent); override;
      function  MouseMove (Shift: TShiftState; X, Y: Integer): Boolean; override;
      function  MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override;
      function  MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override;
   published
      property ClickCount: TClickSound read FClickSound write FClickSound;
      property OnClick: TOnClickEx read FOnClick write FOnClick;
      property OnClickSound: TOnClickSound read FOnClickSound write FOnClickSound;
   end;

   TDGrid = class (TDControl)
   private
      FColCount, FRowCount: integer;
      FColWidth, FRowHeight: integer;
      FViewTopLine: integer;
      SelectCell: TPoint;
      DownPos: TPoint;
      FOnGridSelect: TOnGridSelect;
      FOnGridMouseMove: TOnGridSelect;
      FOnGridPaint: TOnGridPaint;
      function  GetColRow (x, y: integer; var acol, arow: integer): Boolean;
   public
      CX, CY: integer;
      Col, Row: integer;
      constructor Create (AOwner: TComponent); override;
      function  MouseMove (Shift: TShiftState; X, Y: Integer): Boolean; override;
      function  MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override;
      function  MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override;
      function  Click (X, Y: integer): Boolean; override;
      procedure DirectPaint (dsurface: TAsphyreCanvas); override;
   published
      property ColCount: integer read FColCount write FColCount;
      property RowCount: integer read FRowCount write FRowCount;
      property ColWidth: integer read FColWidth write FColWidth;
      property RowHeight: integer read FRowHeight write FRowHeight;
      property ViewTopLine: integer read FViewTopLine write FViewTopLine;
      property OnGridSelect: TOnGridSelect read FOnGridSelect write FOnGridSelect;
      property OnGridMouseMove: TOnGridSelect read FOnGridMouseMove write FOnGridMouseMove;
      property OnGridPaint: TOnGridPaint read FOnGridPaint write FOnGridPaint;
   end;

   TDWindow = class (TDButton)
   private
      FFloating: Boolean;
   protected
      procedure SetVisible (flag: Boolean);
   public
      SpotX, SpotY: integer;
      DialogResult: TModalResult;
      constructor Create (AOwner: TComponent); override;
      function  MouseMove (Shift: TShiftState; X, Y: Integer): Boolean; override;
      function  MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override;
      function  MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; override;
      procedure Show;
      function  ShowModal: integer;
   published
      property Visible: Boolean read FVisible write SetVisible;
      property Floating: Boolean read FFloating write FFloating;
   end;


   TDWinManager = class (TComponent)
   private
   public
      DWinList: TList; //list of TDControl;
      constructor Create (AOwner: TComponent); override;
      destructor Destroy; override;
      procedure AddDControl (dcon: TDControl; visible: Boolean);
      procedure DelDControl (dcon: TDControl);
      procedure ClearAll;

      function  KeyPress (var Key: Char): Boolean;
      function  KeyDown (var Key: Word; Shift: TShiftState): Boolean;
      function  MouseMove (Shift: TShiftState; X, Y: Integer): Boolean;
      function  MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean;
      function  MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean;
      function  DblClick (X, Y: integer): Boolean;
      function  Click (X, Y: integer): Boolean;
      procedure DirectPaint (dsurface: TAsphyreCanvas);
   end;

procedure Register;
procedure SetDFocus (dcon: TDControl);
procedure ReleaseDFocus;
procedure SetDCapture (dcon: TDControl);
procedure ReleaseDCapture;

var
   MouseCaptureControl: TDControl; //mouse message
   FocusedControl: TDControl; //Key message
   MainWinHandle: integer;
   ModalDWindow: TDControl;


implementation


procedure Register;
begin
   RegisterComponents('Zura', [TDWinManager, TDControl, TDButton, TDGrid, TDWindow]);
end;


procedure SetDFocus (dcon: TDControl);
begin
   FocusedControl := dcon;
end;

procedure ReleaseDFocus;
begin
   FocusedControl := nil;
end;

procedure SetDCapture (dcon: TDControl);
begin
   SetCapture (MainWinHandle);
   MouseCaptureControl := dcon;
end;

procedure ReleaseDCapture;
begin
   ReleaseCapture;
   MouseCaptureControl := nil;
end;

{----------------------------- TDControl -------------------------------}

constructor TDControl.Create (AOwner: TComponent);
begin
   inherited Create (AOwner);
   inherited Visible := FALSE;
   FEnableFocus := FALSE;
   Background := FALSE;

   FOnDirectPaint := nil;
   FOnKeyPress := nil;
   FOnKeyDown := nil;
   FOnMouseMove := nil;
   FOnMouseDown := nil;
   FOnMouseUp := nil;
   FOnInRealArea := nil;
   DControls := TList.Create;
   FDParent := nil;

   FDrawFx := fxNone;

   Width := 80;
   Height:= 24;
   FCaption := '';
   FVisible := TRUE;
   //FaceSurface := nil;
   WLib := nil;
   FaceIndex := 0;
end;

destructor TDControl.Destroy;
begin
   DControls.Free;
   inherited Destroy;
end;

procedure TDControl.SetCaption (str: string);
begin
   FCaption := str;
   if csDesigning in ComponentState then begin
      Refresh;
   end;
end;

procedure TDControl.Paint;
begin
   if csDesigning in ComponentState then begin
      if self is TDWindow then begin
         with Canvas do begin
            Pen.Color := clBlack;
            MoveTo (0, 0);
            LineTo (Width-1, 0);
            LineTo (Width-1, Height-1);
            LineTo (0, Height-1);
            LineTo (0, 0);
            LineTo (Width-1, Height-1);
            MoveTo (Width-1, 0);
            LineTo (0, Height-1);
            TextOut ((Width-TextWidth(Caption)) div 2, (Height-TextHeight(Caption)) div 2, Caption);
         end;
      end else begin
         with Canvas do begin
            Pen.Color := clBlack;
            MoveTo (0, 0);
            LineTo (Width-1, 0);
            LineTo (Width-1, Height-1);
            LineTo (0, Height-1);
            LineTo (0, 0);
            TextOut ((Width-TextWidth(Caption)) div 2, (Height-TextHeight(Caption)) div 2, Caption);
         end;
      end;
   end;
end;

procedure TDControl.Loaded;
var
   i: integer;
   dcon: TDControl;
begin
   if not (csDesigning in ComponentState) then begin
      if Parent <> nil then
         for i:=0 to TControl(Parent).ComponentCount-1 do begin
            if TControl(Parent).Components[i] is TDControl then begin
               dcon := TDControl(TControl(Parent).Components[i]);
               if dcon.DParent = self then begin
                  AddChild (dcon);
               end;
            end;
         end;
   end;
end;

//瘤开 谅钎甫 傈眉 谅钎肺 官厕
function  TDControl.SurfaceX (x: integer): integer;
var
   d: TDControl;
begin
   d := self;
   while TRUE do begin
      if d.DParent = nil then break;
      x := x + d.DParent.Left;
      d := d.DParent;
   end;
   Result := x;
end;

function  TDControl.SurfaceY (y: integer): integer;
var
   d: TDControl;
begin
   d := self;
   while TRUE do begin
      if d.DParent = nil then break;
      y := y + d.DParent.Top;
      d := d.DParent;
   end;
   Result := y;
end;

//傈眉谅钎甫 按眉狼 谅钎肺 官厕
function  TDControl.LocalX (x: integer): integer;
var
   d: TDControl;
begin
   d := self;
   while TRUE do begin
      if d.DParent = nil then break;
      x := x - d.DParent.Left;
      d := d.DParent;
   end;
   Result := x;
end;

function  TDControl.LocalY (y: integer): integer;
var
   d: TDControl;
begin
   d := self;
   while TRUE do begin
      if d.DParent = nil then break;
      y := y - d.DParent.Top;