lbmorphvclbase.pas

天涯進銷存系統

unit LBMorphVCLBase;

{$P+,S-,W-,R-}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  LBMorphUtils, LBBMPUtils, LBMorphBmp, ExtCtrls;

type
  TLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
  TMargin = -1..MaxInt;
  TSpacing = 0..MaxInt;
  TNumGlyphs = 1..4;

  TEffectGControl = class(TGraphicControl)
  private
    FTransparent: Boolean;
    procedure SetTransparent(Value: Boolean);
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
  protected
    DG: TBitMap;
    FB: TEffectBmp;
    procedure PaintFace; virtual;
    procedure PaintEffects; virtual;
    procedure PaintTransparent;
    procedure PaintEf;
  public
    procedure XPaint;
    procedure Paint; override;
    constructor Create(AOwner: TComponent); override;
  published
    property Transparent: Boolean read FTransparent write SetTransparent;
  end;

  TEffectCControl = class(TCustomControl)
  private
    FTransparent: Boolean;
    procedure SetTransparent(Value: Boolean);
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure WMEraseBkGnd(var Msg: TWMEraseBkgnd); message WM_EraseBkgnd;
  protected
    DG: TBitMap;
    FB: TEffectBmp;
    procedure PaintFace; virtual;
    procedure PaintEffects; virtual;
    procedure PaintTransparent;
    procedure PaintEf;
  public
    procedure Paint; override;
    constructor Create(AOwner: TComponent); override;
  published
    property Transparent: Boolean read FTransparent write SetTransparent;
  end;

  TButtonGControl = class(TEffectGControl)
  private
    procedure SetSpacing(Value: Integer);
    procedure SetMargin(Value: Integer);
    procedure SetLayout(Value : TLayout);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetGlyph(Value: TBitMap);
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  protected
    tx, ty, gx, gy: Integer;

    FGlyph: TBitMap;
    FNumGlyphs: TNumGlyphs;
    FActiveTextColor: TColor;
    FSpacing: Integer;
    FMargin: Integer;
    FLayout: TLayout;

    FOnClick: TNotifyEvent;
    FMouseIn: Boolean;
    FDown: Boolean;

    function IsMouseIn(X,Y: Integer): boolean; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;

    property Margin: Integer read FMargin write SetMargin default -1;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property Layout: TLayout read FLayout write SetLayout default blGlyphLeft;

    procedure DrawButtonGlyph;
    {$IFDEF EPD4 OR CBUILDER4}
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    {$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Notification(AComponent: TComponent;
                           Operation: TOperation); override;
  published
    {$IFDEF EPD4  OR CBUILDER4}
    property Action;
    {$ENDIF}
    property ActiveTextColor: TColor read FActiveTextColor write FActiveTextColor;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;
    property Glyph: TBitMap read FGlyph write SetGlyph;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;


  TButtonGTControl = class(TEffectGControl)
  private
    FTimer: TTimer;
    FOnClick: TNotifyEvent;
    procedure CreateTimer;
    procedure FreeTimer;
    procedure TimerExpired(Sender: TObject);
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure SetSpacing(Value: Integer);
    procedure SetMargin(Value: Integer);
    procedure SetLayout(Value : TLayout);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetGlyph(Value: TBitMap);
  protected
    FGlyph: TBitMap;
    FNumGlyphs: TNumGlyphs;
    FActiveTextColor: TColor;
    FSpacing: Integer;
    FMargin: Integer;
    FLayout: TLayout;

    FMouseIn: Boolean;
    FDown: Boolean;

    tx, ty, gx, gy: Integer;

    function IsMouseIn(X,Y: Integer): boolean; virtual;
    procedure MouseMove(Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;

    procedure DrawButtonGlyph;

    {$IFDEF EPD4  OR CBUILDER4}
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    {$ENDIF}
  public
    procedure Notification(AComponent: TComponent;
                           Operation: TOperation); override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    {$IFDEF EPD4  OR CBUILDER4}
    property Action;
    {$ENDIF}
    property ActiveTextColor: TColor read FActiveTextColor write FActiveTextColor;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;
    property Glyph: TBitMap read FGlyph write SetGlyph;
    property Margin: Integer read FMargin write SetMargin default -1;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property Layout: TLayout read FLayout write SetLayout default blGlyphLeft;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

  TButtonCControl = class(TEffectCControl)
  private
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure WMEraseBkGnd(var Msg: TWMEraseBkgnd); message WM_EraseBkgnd;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure SetSpacing(Value: Integer);
    procedure SetMargin(Value: Integer);
    procedure SetLayout(Value : TLayout);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetGlyph(Value: TBitMap);
  protected
    FGlyph: TBitMap;
    FNumGlyphs: TNumGlyphs;
    FActiveTextColor: TColor;
    FSpacing: Integer;
    FMargin: Integer;
    FLayout: TLayout;

    FOnClick: TNotifyEvent;
    FMouseIn: Boolean;
    FDown: Boolean;

    tx, ty, gx, gy: Integer;

    function IsMouseIn(X,Y: Integer): boolean; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;

    procedure DrawButtonGlyph;

    property Margin: Integer read FMargin write SetMargin default -1;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property Layout: TLayout read FLayout write SetLayout default blGlyphLeft;
    {$IFDEF EPD4 OR CBUILDER4}
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    {$ENDIF}
  public
    procedure Notification(AComponent: TComponent;
                           Operation: TOperation); override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    {$IFDEF EPD4 OR CBUILDER4}
    property Action;
    {$ENDIF}
    property ActiveTextColor: TColor read FActiveTextColor write FActiveTextColor;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;
    property Glyph: TBitMap read FGlyph write SetGlyph;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

  procedure CalcLCoord(Layout: TLayout;
                       R: TRect; gw, gh, tw, th: Integer;
                       spacing: TSpacing; margin: TMargin;
                       var tx, ty, gx, gy: Integer);



  const
    TInt = 300;

implementation

{$IFDEF EPD4 OR CBUILDER4}
   Uses ImgList, ActnList;
{$ENDIF}

type
  TParentControl = class(TWinControl);


constructor TButtonGTControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FGlyph := TBitMap.Create;
  FNumGlyphs := 1;
  FSpacing := 0;
  FMargin := -1;
end;

destructor TButtonGTControl.Destroy;
begin
  FGlyph.Free;
  inherited Destroy;
end;

{$IFDEF EPD4 OR CBUILDER4}
procedure TButtonGTControl.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
  begin
    with FGlyph do
    begin
      Width := ImageList.Width;
      Height := ImageList.Height;
      Canvas.Brush.Color := clFuchsia;
      Canvas.FillRect(Rect(0,0, Width, Height));
      ImageList.Draw(Canvas, 0, 0, Index);
    end;
  end;

begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if (FGlyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
        (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
      begin
        CopyImage(ActionList.Images, ImageIndex);
        XPaint;
      end;
    end;
end;
{$ENDIF}

procedure TButtonGTControl.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  XPaint;
end;


procedure TButtonGTControl.DrawButtonGlyph;
begin
  if FGlyph.Empty then Exit;
  if FMouseIn and FDown and (FNumGlyphs > 3)
  then
    PaintGlyph(DG.Canvas, gx, gy, FGlyph, 3, FNumGlyphs)
  else
    if FMouseIn and (FNumGlyphs > 2)
    then
      PaintGlyph(DG.Canvas, gx, gy, FGlyph, 2, FNumGlyphs)
    else
      if Enabled
      then
        PaintGlyph(DG.Canvas, gx, gy, FGlyph, 1, FNumGlyphs)
      else
        PaintGlyph(DG.Canvas, gx, gy, FGlyph, FNumGlyphs, FNumGlyphs);
end;


procedure TButtonGTControl.SetNumGlyphs(Value: TNumGlyphs);
begin
  FNumGlyphs := Value;
  XPaint;
end;

procedure TButtonGTControl.SetLayout(Value: TLayout);
begin
  FLayout := Value;
  XPaint;
end;

procedure TButtonGTControl.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    XPaint;
  end;
end;

procedure TButtonGTControl.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    XPaint;
  end;
end;

procedure TButtonGTControl.Notification(AComponent: TComponent;
      Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
end;


procedure TButtonGTControl.CreateTimer;
begin
  FTimer := TTimer.Create(Self);
  FTimer.OnTimer := TimerExpired;
  FTimer.Interval := TInt;
  FTimer.Enabled := True;
end;

procedure TButtonGTControl.FreeTimer;
begin
  FTimer.Enabled := False;
  FTimer.OnTimer := nil;
  FTimer.Free;
  FTimer := nil;
end;

function TButtonGTControl.IsMouseIn(X,Y: Integer): boolean;
begin
  if (X > 0) and (Y > 0) and (X < Width) and (Y < Height)
  then
    Result := True
  else
    Result := False;
end;

procedure TButtonGTControl.MouseMove;
var
  MInB: Boolean;
begin
  MinB := FMouseIn;
  FMouseIn := IsMouseIn(X,Y);
  if MinB <> FMouseIn then XPaint;

  if FMouseIn and not MinB
  then
    if FTimer = nil
    then
      begin
        CreateTimer;
      end;

  if FMouseIn then inherited MouseMove(Shift, X, Y);
end;


procedure TButtonGTControl.MouseDown;
begin
  if (Button = mbLeft)and(FMouseIn) then
  begin
    fDown := True;
    XPaint;
    inherited MouseDown(Button, Shift, X, Y);
  end;
end;

procedure TButtonGTControl.MouseUp;
begin
  if Button = mbLeft then
  begin
    fDown := False;
    if FMouseIn then
    begin
      XPaint;
      inherited MouseUp(Button, Shift, X, Y);
      if Assigned(FOnClick) then FOnClick(Self);
    end;
  end;
end;

procedure TButtonGTControl.CMMouseLeave(var Message: TMessage);
begin
  if FMouseIn then
  begin
    FMouseIn := False;
    XPaint;
  end;
end;

procedure TButtonGTControl.CMTextChanged(var Message: TMessage);
begin
  XPaint;
end;


procedure TButtonGTControl.TimerExpired(Sender: TObject);
var
  P,P1: TPoint;
begin
  GetCursorPos(P);
  P1 := Self.ClientOrigin;
  if not((P.X >= P1.X)and(P.X <= P1.X + Width)and
         (P.Y >= P1.Y)and(P.Y <= P1.Y + Height)) and FMouseIn
  then
    begin
      FMouseIn := False;
      XPaint;
    end;
  FreeTimer;
end;


constructor TButtonGControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FGlyph := TBitMap.Create;
  FNumGlyphs := 1;
  FSpacing := 0;
  FMargin := -1;
end;

destructor TButtonGControl.Destroy;
begin
  FGlyph.Free;
  inherited Destroy;
end;

{$IFDEF EPD4 OR CBUILDER4}
procedure TButtonGControl.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
  begin
    with FGlyph do
    begin
      Width := ImageList.Width;
      Height := ImageList.Height;
      Canvas.Brush.Color := clFuchsia;
      Canvas.FillRect(Rect(0,0, Width, Height));
      ImageList.Draw(Canvas, 0, 0, Index);
    end;
  end;

begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if (FGlyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
        (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
      begin
        CopyImage(ActionList.Images, ImageIndex);
        XPaint;
      end;
    end;
end;
{$ENDIF}


procedure TButtonGControl.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  XPaint;
end;

procedure TButtonGControl.SetNumGlyphs(Value: TNumGlyphs);
begin
  FNumGlyphs := Value;
  XPaint;
end;


procedure TButtonGControl.DrawButtonGlyph;