facepart.pas

著名的J2ME动作编辑器.<金刚>也是由这个编辑器制作动作的.

unit FacePart;

interface

uses Windows, Messages, Classes, Graphics, SysUtils, Math, ExtCtrls,
  Controls, GifImage, ManaList, MarkData, MGraphics, Encode, Forms;

type
  TPartList = class;
  TPartItem = class(TManaItem)
  private
    FOwner: TPartList;
    FPartX, FPartY, FPartW, FPartH: Integer;
    procedure SetPartX(const Value: Integer);
    procedure SetPartY(const Value: Integer);
    procedure SetPartW(const Value: Integer);
    procedure SetPartH(const Value: Integer);

    function GetData: String;
    procedure SetData(const Value: String);
  protected
    procedure DoChange; override;
  public
    property PartX: Integer read FPartX write SetPartX;
    property PartY: Integer read FPartY write SetPartY;
    property PartW: Integer read FPartW write SetPartW;
    property PartH: Integer read FPartH write SetPartH;
    property Data: String read GetData write SetData;
    procedure RefreshFace;
    constructor Create(AOwner: TPartList); reintroduce;
  end;

  TPartList = class(TManaList)
  private
    FOnPartsChange: TNotifyEvent;
    FOnPartsFree: TNotifyEvent;
    FPicture: TBitmap;
    FFaceData: String;

    function GetData: String;
    procedure SetData(const Value: String);
    function GetFace: String;
    procedure SetFace(const Value: String);
    function GetPart(Index: Integer): TPartItem;
    procedure SetPicture(const Value: TBitmap);
  protected
    procedure DoChange; override;
  public
    property Face: String read GetFace write SetFace;
    property Data: String read GetData write SetData;
    property Picture: TBitmap read FPicture write SetPicture;
    property Parts[Index: Integer]: TPartItem read GetPart;

    function NewPart: TPartItem;
    procedure DelPart;
    procedure LoadPicture(aFileName: String);

    procedure SetCount(const Value: Integer);

    constructor Create;
    destructor Destroy; override;
  end;

  TPartsControl = class(TCustomControl)
  private
    FFace: TBitmap;
    FPartList: TPartList;
    FOnChange: TNotifyEvent;
    FNumbVisible: Boolean;
    FPartVisible: Boolean;
    procedure PartsFree(Sender: TObject);
    procedure PartsChange(Sender: TObject);
    procedure SetNumbVisible(const Value: Boolean);
    procedure SetPartVisible(const Value: Boolean);
    procedure SetPartList(const Value: TPartList);
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; {* 用于去掉系统在花布上的填充过程 }
  protected
    procedure Paint; override;
    procedure Resize; override;
    procedure RefreshFace; 
  public
    property PartList: TPartList read FPartList write SetPartList;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property NumbVisible: Boolean read FNumbVisible write SetNumbVisible;
    property PartVisible: Boolean read FPartVisible write SetPartVisible;

    property OnDragOver;
    property OnDragDrop;

    constructor Create(AOwer: TComponent); override;
    destructor Destroy; override;
  end;

  TActionItem = class;
  TActionLst = class;
  TFrameItem = class;

  TFramePart = class
  private
    FOwner: TFrameItem;
    FIndex: Integer;
    FLinkX: Integer;
    FLinkY: Integer;
    FOnChange: TNotifyEvent;
    procedure SetIndex(const Value: Integer);
    procedure SetLinkX(const Value: Integer);
    procedure SetLinkY(const Value: Integer);
    function GetFace: TBitmap;
    function GetHave: Boolean;
    procedure DoChange;
  public
    property Face: TBitmap read GetFace;
    property Have: Boolean read GetHave;
    property Index: Integer read FIndex write SetIndex;
    property LinkX: Integer read FLinkX write SetLinkX;
    property LinkY: Integer read FLinkY write SetLinkY;
    constructor Create(AOwner: TFrameItem);
  end;

  TFrameItem = class(TManaItem)
  private
    FRectW: Integer;
    FRectT: Integer;
    FRectB: Integer;
    FFireX: Integer;
    FFireY: Integer;
    FFireW: Integer;
    FFireH: Integer;
    FOwner: TActionItem;
    FFrameParts: array of TFramePart;

    function GetFramePart(Index: Integer): TFramePart;
    procedure SetFramePart(Index: Integer; const Value: TFramePart);
    procedure FramePartChange(Sender: TObject);

    procedure RefreshFace;

    function GetData: String;
    procedure SetData(const Value: String);

    procedure SetRectT(const Value: Integer);
    procedure SetRectW(const Value: Integer);

    function GetPartList: TPartList;
    function GetFramePartCount: Integer;
    procedure SetFireH(const Value: Integer);
    procedure SetFireW(const Value: Integer);
    procedure SetFireX(const Value: Integer);
    procedure SetFireY(const Value: Integer);
  public
    property PartList: TPartList read GetPartList;
    property Data: String read GetData write SetData;
    property FramePartCount: Integer read GetFramePartCount;
    property FrameParts[Index: Integer]: TFramePart read GetFramePart write SetFramePart;
    property RectW: Integer read FRectW write SetRectW;
    property RectT: Integer read FRectT write SetRectT;
    property FireX: Integer read FFireX write SetFireX;
    property FireY: Integer read FFireY write SetFireY;
    property FireW: Integer read FFireW write SetFireW;
    property FireH: Integer read FFireH write SetFireH;
    property RectB: Integer read FRectB;
    constructor Create(AOwner: TActionItem); reintroduce;
  end;

  TActionItem = class(TManaList)
  private
    FOwner: TActionLst;
    FCaption: String;
    function GetData: String;
    procedure SetData(const Value: String);
    function GetFrame(Index: Integer): TFrameItem;
    function GetPartList: TPartList;
  public
    property PartList: TPartList read GetPartList;
    property Frames[Index: Integer]: TFrameItem read GetFrame;
    property Data: String read GetData write SetData;
    property Caption: String read FCaption write FCaption;
    function NewFrame: TFrameItem;
    constructor Create(AOwner: TActionLst); reintroduce;
  end;

  TActionLst = class
  private
    FFramePartCount: Integer;
    FPartList: TPartList;
    FActions: array of TActionItem;
    function GetCount: Integer;
    function GetAction(Index: Integer): TActionItem;
    function GetData: String;
    procedure SetData(const Value: String);
    procedure SetPlatList(const Value: TPartList);
    procedure SetFramePartCount(const Value: Integer);
  public
    property FramePartCount: Integer read FFramePartCount write SetFramePartCount;
    property PartList: TPartList read FPartList write SetPlatList;
    property Data: String read GetData write SetData;
    property Count: Integer read GetCount;
    property Actions[Index: Integer]: TActionItem read GetAction;

    procedure ExchangeAction(Index1, Index2: Integer);
    function NewAction: TActionItem; overload;
    function NewAction(aActionName: String): TActionItem; overload;
    procedure DelAction(Index: Integer);
    procedure Clear;

    constructor Create;
    destructor Destroy; override;
  end;

  TFrameControl = class;
  TLinkControl = class(TCustomControl)
  private
    FFace: TBitmap;
    FIndex: Integer;
    FOnChange: TNotifyEvent;
    procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; {* 用于去掉系统在花布上的填充过程 }
    function GetFramePart: TFramePart;
    procedure DoChange;

    procedure SetIndex(const Value: Integer);
    function GetPartIndex: Integer;
    function GetPartLinkX: Integer;
    function GetPartLinkY: Integer;
    procedure SetPartIndex(const Value: Integer);
    procedure SetPartLinkX(const Value: Integer);
    procedure SetPartLinkY(const Value: Integer);
  protected
    procedure Paint; override;
    procedure Resize; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

    property Index: Integer read FIndex write SetIndex;
    property FramePart: TFramePart read GetFramePart;
  public
    property PartIndex: Integer read GetPartIndex write SetPartIndex;
    property PartLinkX: Integer read GetPartLinkX write SetPartLinkX;
    property PartLinkY: Integer read GetPartLinkY write SetPartLinkY;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property OnDragOver;
    property OnDragDrop;
  end;

  TShowControl = class(TCustomControl)
  private
    FFace: TBitmap;
    FRectVisible: Boolean;
    procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; {* 用于去掉系统在花布上的填充过程 }
    function GetFrameItem: TFrameItem;
    procedure SetRectVisible(const Value: Boolean);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
    procedure Resize; override;
  public
    property RectVisible: Boolean read FRectVisible write SetRectVisible;
    property FrameItem: TFrameItem read GetFrameItem;
    procedure RefreshFace;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TFrameControl = class(TCustomControl)
  private
    FOnPartsDragOver: TDragOverEvent;
    FOnPartsDragDrop: TDragDropEvent;
    FLinkControls: array of TLinkControl;
    FShowControl: TShowControl;
    FBottomPanel: TPanel;
    FFrameItem: TFrameItem;
    procedure LinkChange(Sender: TObject);
    procedure ClearLinkControls;
    procedure SetFrameItem(const Value: TFrameItem);
    procedure SetOnPartsDragDrop(const Value: TDragDropEvent);
    procedure SetOnPartsDragOver(const Value: TDragOverEvent);
    function GetRectVisible: Boolean;
    procedure SetRectVisible(const Value: Boolean);
  protected
    procedure Resize; override;
  public
    property RectVisible: Boolean read GetRectVisible write SetRectVisible;
    property FrameItem: TFrameItem read FFrameitem write SetFrameItem;
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
    property OnPartsDragOver: TDragOverEvent read FOnPartsDragOver write SetOnPartsDragOver;
    property OnPartsDragDrop: TDragDropEvent read FOnPartsDragDrop write SetOnPartsDragDrop;
  end;


const
  Ln = #13#10;
var
  PartList: TPartList;

implementation


{ TPartItem }

constructor TPartItem.Create(AOwner: TPartList);
begin
  inherited Create;
  FOwner:= AOwner;
end;

procedure TPartItem.DoChange;
begin
  inherited;
  RefreshFace;
end;

function TPartItem.GetData: String;
begin
  Result:= '  <Part>' +
           '  ' + PickSInt(PartX, 'PartX') +
           '  ' + PickSInt(PartY, 'PartY') +
           '  ' + PickSInt(PartW, 'PartW') +
           '  ' + PickSInt(PartH, 'PartH') +
           '  </Part>' + Ln;
end;

procedure TPartItem.SetData(const Value: String);
begin
  try FPartX:= ReadSInt(Value, 'PartX'); except end;
  try FPartY:= ReadSInt(Value, 'PartY'); except end;
  try FPartW:= ReadSInt(Value, 'PartW'); except end;
  try FPartH:= ReadSInt(Value, 'PartH'); except end;
  DoChange;
end;

procedure TPartItem.RefreshFace;
begin
  if FOwner.Picture.Empty then
  begin
    Picture.Width:= 1;
    Picture.Height:= 1;
  end else begin
    Picture.Width:= PartW;
    Picture.Height:= PartH;
    Picture.Canvas.Brush.Color:= $FFFFFF;
    Picture.Canvas.FillRect(Rect(0, 0, PartW, PartH));
    Picture.Canvas.Draw(-PartX, -PartY, FOwner.Picture);
  end;
end;

procedure TPartItem.SetPartH(const Value: Integer);
begin
  if FPartH = Value then Exit;
  FPartH := Value;
  DoChange;
end;

procedure TPartItem.SetPartW(const Value: Integer);
begin
  if FPartW = Value then Exit;
  FPartW := Value;
  DoChange;
end;

procedure TPartItem.SetPartX(const Value: Integer);
begin
  if FPartX = Value then Exit;
  FPartX := Value;
  DoChange;
end;

procedure TPartItem.SetPartY(const Value: Integer);
begin
  if FPartY = Value then Exit;
  FPartY := Value;
  DoChange;
end;


{ TPartList }

constructor TPartList.Create;
begin
  inherited;
  FPicture:= TBitmap.Create;
end;

destructor TPartList.Destroy;
begin
  if Assigned(FOnPartsFree) then FOnPartsFree(Self);
  Clear;
  FPicture.Free;
  inherited;
end;

procedure TPartList.SetCount(const Value: Integer);
var
  i: Integer;
begin
  if Value = Count then Exit;
  if Value > Count then
    for i:= 1 to Value - Count do NewPart
  else
    for i:= 1 to Count - Value do DelPart;
end;

function TPartList.GetData: String;
var
  i: Integer;
begin
  Result:= Result + '<Parts>' + Ln;
  for i:= 0 to Count - 1 do Result:= Result + Parts[i].Data;
  Result:= Result + '</Parts>' + Ln;
end;

procedure TPartList.SetData(const Value: String);
var
  i: Integer;
  StrList: TStrList;
begin
  Clear;
  StrList:= ReadList(Value, 'Part');
  for i:= 0 to Length(StrList) - 1 do NewPart.Data:= StrList[i];
end;

function TPartList.GetFace: String;
begin
  Result:= FFaceData;
end;

procedure TPartList.SetFace(const Value: String);
var
  FStrStream: TStringStream;
  GifPicture: TGifImage;
  i: Integer;
begin
  if Value = '' then
  begin
    FPicture.Width:= 1;
    FPicture.Height:= 1;
    FPicture.FreeImage;
    FFaceData:= '';
    DoChange;
  end else begin
    FStrStream:= TStringStream.Create(DecodeData(Value));
    GifPicture:= TGifImage.Create;
    try
      FStrStream.Seek(0,0);
      GifPicture.LoadFromStream(FStrStream);
      FPicture.Width:= GifPicture.Width;
      FPicture.Height:= GifPicture.Height;
      FPicture.Canvas.Draw(0,0, GifPicture);
      FFaceData:= Value;
    finally
      GifPicture.Free;
      FStrStream.Free;
    end;
    for i:= 0 to Count - 1 do
      Parts[i].RefreshFace;
    DoChange;
  end;
end;

function TPartList.GetPart(Index: Integer): TPartItem;
begin
  Result:= TPartItem(Items[Index]);
end;

procedure TPartList.DelPart;
begin
  if Count = 0 then Exit;
  DelItem(Count - 1);
end;

function TPartList.NewPart: TPartItem;
begin
  Result:= TPartItem.Create(Self);
  AddItem(Result);
  Result.Caption:= IntToStr(Count - 1);
end;

procedure TPartList.DoChange;
begin
  inherited;