lbmorphbutton.pas

天涯進銷存系統

unit LBMorphButton;

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

interface

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

const
  MorphOffset = 0.1;

type
  TBevelWidth = 1..MaxInt;
  TBorderWidth = 0..MaxInt;

  TSmType = 1..100;
  TLBRegulator = class(TCustomControl)
  private
    FTimeInt: Cardinal;
    FMinValue: Longint;
    FMaxValue: Longint;
    FValue: LongInt;
    FOnChange: TNotifyEvent;
    FBTnPosY: Integer;
    FOldBtnPosY: Integer;
    FMY: Integer;
    FBtnColor: TColor;
    FDown: Boolean;
    FRgn: HRgn;
    FRadius: Integer;
    FFrameWidth: TSmType;
    FMouseY: Integer;
    function PointinBtn(X,Y: Integer): Boolean;
    procedure SetValue(Value: LongInt);
    procedure SetBtnColor(Value: TColor);
    procedure SetFrameWidth(Value: TSmType);
    procedure SetMinValue(Value: Longint);
    procedure SetMaxValue(Value: Longint);
    procedure CalcValue;
    procedure CalcBtnPos;
    procedure WMTimer(var Message: TMessage); message WM_TIMER;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CreateR;
    procedure WMEraseBkGnd(var Msg: TWMEraseBkgnd); message WM_EraseBkgnd;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property TimeInt: Cardinal read FTimeInt write FTimeInt;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Value: Longint read FValue write SetValue;
    property MinValue: Longint read FMinValue write SetMinValue default 0;
    property MaxValue: Longint read FMaxValue write SetMaxValue default 100;
    property BtnColor: TColor read FBtnColor write SetBtnColor;
    property FrameWidth: TSmType read FFrameWidth write SetFrameWidth;
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
  protected
    procedure DrawBtn(FRullerPos: Integer);
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState;
        X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  end;

  TLBMorphButton = class(TEffectGControl)
  private
    MorphKf: Double;
    FTimer: TTimer;
    FDownGlyph: TBitMap;
    FUpGlyph: TBitMap;
    FActiveGlyph: TBitMap;
    FMouseIn: Boolean;
    FDown: Boolean;
    FOnClick: TNotifyEvent;
    FGlyphsTransparent: Boolean;
    procedure SetInterval(Value: Cardinal);
    function GetInterval: Cardinal;
    procedure SetGlyphsTransparent(Value: Boolean);
    procedure SetDownGlyph(Value: TBitMap);
    procedure SetUpGlyph(Value: TBitMap);
    procedure SetActiveGlyph(Value: TBitMap);
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure IncMorphkf(Sender: TObject);
    procedure DecMorphkf(Sender: TObject);
  protected
    { Protected declarations }
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
     X, Y: Integer);  override;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
     X, Y: Integer);  override;
     procedure MouseMove(Shift: TShiftState;
      X, Y: Integer); override;
     procedure PaintFace; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Notification(AComponent: TComponent;
                           Operation: TOperation); override;
  published
    property Action;
    property Align;
    property Color;
    property UpGlyph: TBitMap read FUpGlyph write SetUpGlyph;
    property DownGlyph: TBitMap read FDownGlyph write SetDownGlyph;
    property ActiveGlyph: TBitMap read FActiveGlyph write SetActiveGlyph;
    property Enabled;
    property Visible;
    property PopupMenu;
    property ParentFont;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property GlyphsTransparent: Boolean read FGlyphsTransparent
                                        write SetGlyphsTransparent;
    property Interval: Cardinal read GetInterval write SetInterval;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
  end;



implementation

const
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);

constructor TLBRegulator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width  := 30;
  Height := 150;
  FBtnColor := clBtnFace;
  FBtnPosY := 0;
  FMY := 0;
  FMinValue := 0;
  FMaxValue := 100;
  FValue := 0;
  FTimeInt := 100;
  FrameWidth := 1;
  FRgn := 0;
end;


procedure TLBRegulator.WMEraseBkGnd(var Msg: TWMEraseBkgnd);
begin
end;


procedure TLBRegulator.SetFrameWidth;
begin
  FFrameWidth := Value;
  Invalidate;
end;


procedure TLBRegulator.SetBtnColor;
begin
  FBtnColor := Value;
  Invalidate;
end;

procedure TLBRegulator.CalcBtnPos;
var
  kf: Double;
  L: Integer;
begin
  kf := (FValue - FMinValue) / (FMaxValue - FMinValue);
  L := Height - 2 * FRadius;
  L := Trunc(L * Kf);
  FBtnPosY := Height - FRadius - L;
end;

procedure TLBRegulator.CalcValue;
var
  kf: Double;
begin
  kf := (FBtnPosY - FRadius) / (Height - 2 * FRadius);
  kf := 1 - kf;
  FValue := FMinValue + Trunc((FMaxValue - FMinValue) * Kf);
end;

procedure TLBRegulator.WMTimer(var Message: TMessage);
var
  FOldValue: LongInt;
begin
  if FMouseY - FMY <= 0 then Dec(FBtnPosY,(FMY - FMouseY));
  if FMouseY - FMY > 0 then Inc(FBtnPosY,(FMouseY - FMY));
  if FBtnPosY < FRadius then FBtnPosY := FRadius;
  if FBtnPosY > Height - FRadius then FBtnPosY := Height - FRadius;
  if FOldBtnPosY <> FBtnPosY
  then
    begin
      DrawBtn(FBtnPosY);
      FOldValue := Value;
      CalcValue;
      FMY := FMouseY;
      FOldBtnPosY := FBtnPosY;
      if FOldValue <> FValue then
        if Assigned(FOnChange) then FOnChange(Self);
    end;
end;

procedure TLBRegulator.SetMinValue;
begin
  if Value <> FMinValue then
  begin
    FMinValue := Value;
    if FValue < Value then FValue := Value;
    RePaint;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

procedure TLBRegulator.SetValue;
begin
  if Value < FMinValue then Value := FMinValue else
  if Value > FMaxValue then Value := FMaxValue;

  if Value <> FValue then
  begin
    FValue := Value;
    if FValue = FMinValue then FBtnPosY := Height - FRadius else
    if FValue = FMaxValue then FBtnPosY := FRadius
    else CalcBtnPos;
    RePaint;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

procedure TLBRegulator.SetMaxValue;
begin
  if Value <> FMaxValue then
  begin
    FMaxValue := Value;
    if FValue > Value then FValue := Value;
    RePaint;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

function TLBRegulator.Pointinbtn;
var
  cx,cy: Integer;
  nx ,ny: Integer;
  Rd: Integer;
  R: TRect;
begin

  R := Rect( Width div 2 - FRadius + FFrameWidth div 2 + 4,
             FBTnPosY - FRadius + FFrameWidth div 2 + 4,
             Width div 2 + FRadius - FFrameWidth div 2 - 4,
             FBTnPosY + FRadius - FFrameWidth div 2 - 4);

  Rd := (R.Right - R.Left) div 2;
  cx := R.Left + Rd;
  cy := R.Top + Rd;
  nx := X - CX;
  ny := Y - CY;
  if Sqr(nx)+Sqr(ny)<=Sqr(Rd) then Result := True else Result := False;
end;


procedure TLBRegulator.MouseMove;
begin
  if FDown then FMouseY := Y;
  inherited MouseMove(Shift, X, Y);
end;

destructor TLBRegulator.Destroy;
var
  r: HRgn;
begin
  r := FRgn;
  inherited Destroy;
  if r <> 0 then DeleteObject(r);
end;

procedure TLBRegulator.DrawBtn(FRullerPos: Integer);
var
  C1,C2: TColor;
  R: Trect;
  FColor: TColor;
  B: TBitMap;
  FB: TEffectBmp;
begin
  B := TBitMap.Create;
  B.Width := Width + 10;
  B.Height := Height + 10;
  FColor := Self.Color;
  with B.Canvas do
  begin
    Font := Self.Font;
    Brush.Style := bsSolid;
    Brush.Color := FColor;
    Pen.Color := Self.Color;
    RoundRect(0,0,Width,Height,FRadius,FRadius);
    c2 := RGBChange(ColorToRGB(FColor), -65, -65, -65);
    c1 := RGBChange(ColorToRGB(FColor), 65, 65, 65);

    RndRectFrm3D(B.Canvas,Rect(0,1, Width - 1,Height - 1),
                 C1,C2,
                 2 * (FRadius - 4), FFrameWidth + 1);

    Frm3D(B.Canvas,
          Rect(Width div 2 - 2,Fradius, Width div 2 + 3,Height - FRadius),
          C2,C1,2);

    Brush.Color := FBtnColor;
    R := Rect(Width div 2 - FRadius + FFrameWidth div 2 + 4,
              FRullerPos - FRadius + FFrameWidth div 2 + 4,
              Width div 2 + FRadius - FFrameWidth div 2 - 4,
              FRullerPos + FRadius - FFrameWidth div 2 - 4);
    Ellipse(R.Left, R.Top, R.Right, R.Bottom);
    c2 := RGBChange(ColorToRGB(FBtnColor), -65, -65, -65);
    c1 := RGBChange(ColorToRGB(FBtnColor), 65, 65, 65);
    RndFRm3D(B.Canvas,c1,c2,R,2);
  end;
  FB := TEffectBmp.CreateFromhWnd(B.Handle);
  FB.SplitBlur(1);
  FB.Draw(B.Canvas.Handle, 0, 0);
  Dec(R.Top);
  RndFRm3D(B.Canvas,c1,c2,R,1);
  Canvas.Draw(0,0,B);
  FB.Free;
  B.Free;
end;

procedure TLBRegulator.CreateR;

procedure CreateRndRectRgn;
var
  r: HRgn;
begin
  if Width mod 2 <> 0 then Width := Width - 1;
  FRadius := Width div 2;
  r := FRgn;
  FRgn := CreateRoundRectRgn(0,0,Width,Height,FRadius * 2,FRadius * 2);
  SetWindowRgn(Self.Handle,FRgn,True);
  if r <> 0 then DeleteObject(r);
end;

begin
  CreateRndRectRgn;
  CalcBtnPos;
end;

procedure TLBRegulator.Paint;
begin
  DrawBtn(FBtnPosY);
end;

procedure TLBRegulator.MouseUp;
begin
  FDown := False;
  KillTimer(Handle, 1);
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TLBRegulator.MouseDown;
begin
  if (PointInBtn(X,Y))and(Button = mbLeft) then
  begin
    FDown := True;
    FMY := Y;
    FMouseY := Y;
    SetTimer(Handle, 1, FTimeInt, nil);
    inherited MouseDown(Button, Shift, X, Y);
  end;
end;

procedure TLBRegulator.WMSize(var Message: TWMSize);
begin
  Creater;
  inherited;
end;
  
constructor TLBMorphButton.Create;
begin
  inherited Create(AOwner);
  Width := 100;
  Height := 100;
  FUpGlyph := TBitMap.Create;
  FDownGlyph := TBitMap.Create;
  FActiveGlyph := TBitMap.Create;
  FTimer := TTimer.Create(Self);
  FTimer.Interval := 100;
  FTimer.Enabled := False;
  MorphKf := 0;
end;

destructor TLBMorphButton.Destroy;
begin
  FUpGlyph. Free;
  FDownGlyph. Free;
  FActiveGlyph. Free;
  FTimer.Free;
  inherited Destroy;
end;

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

procedure TLBMorphButton.SetGlyphsTransparent(Value: Boolean);
begin
  FGlyphsTransparent := Value;
  XPaint;
end;

procedure TLBMorphButton.SetInterval(Value: Cardinal);
begin
  FTimer.Interval := Value;
end;

function TLBMorphButton.GetInterval: Cardinal;
begin
  Result := FTimer.Interval;
end;

procedure TLBMorphButton.PaintFace;
var
  Face, AFace: TBitMap;
  EfFace: TEffectBMP;
  EfAFace: TEffectBMP;
begin
  if FUpGlyph.Empty or FActiveGlyph.Empty then Exit;
  if not (FMouseIn and FDown) or FDownGlyph.Empty
  then
    begin
      Face := TBitMap.Create;
      Face.Width := FUpGlyph.Width;
      Face.Height := FUpGlyph.Height;
      Face.Canvas.Draw(0,0, FUpGlyph);
      AFace := TBitMap.Create;
      AFace.Width := FUpGlyph.Width;
      AFace.Height := FUpGlyph.Height;
      AFace.Canvas.Draw(0,0, FActiveGlyph);
      EfFace := TEffectBmp.CreateFromhWnd(Face.Handle);
      EfAFace := TEffectBmp.CreateFromhWnd(AFace.Handle);
      EfFace.Morph(efAFace, MorphKf);
      if FGlyphsTransparent
      then
        begin
          EfFace.Draw(Face.Canvas.Handle, 0, 0);
          DrawBitmapTransparent(DG.Canvas, 0, 0, Face,
                                GetTransparentColor(Face));
        end
      else
        EfFace.Draw(DG.Canvas.Handle, 0, 0);
      EfFace.Free;
      Face.Free;
      EfAFace.Free;
      AFace.Free;
    end
  else
    if not FDownGlyph.Empty then
      if FGlyphsTransparent then
        DrawBitmapTransparent(DG.Canvas, 0, 0, FDownGlyph,
                             GetTransparentColor(FDownGlyph))
      else
        DG.Canvas.Draw(0,0, FDownGlyph);
end;

procedure TLBMorphButton.SetDownGlyph;
begin
  FDownGlyph.Assign(Value);
  XPaint;
end;

procedure TLBMorphButton.SetUpGlyph;
begin
  FUpGlyph.Assign(Value);
  XPaint;
end;

procedure TLBMorphButton.SetActiveGlyph;
begin
  FActiveGlyph.Assign(Value);
  XPaint;
end;

procedure TLBMorphButton.MouseDown;
begin
  if (Button = mbLeft) and not FDown 
  then
    begin
      FDown := True;
      FMouseIn := True;
      if not FDownGlyph.Empty
      then
        begin
          FTimer.Enabled := False;
          XPaint;
        end;
    end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TLBMorphButton.MouseUp;
begin
  if (Button = mbLeft) and FDown
  then
    begin
      FDown := False;
      if not FDownGlyph.Empty and not FTimer.Enabled
      then
        begin
          if FMouseIn then MorphKf := 1 else MorphKf := 0;
          XPaint;
        end;
      if FMouseIn
      then
        begin
          if Assigned(FOnClick) then FOnClick(Self);
        end;
    end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TLBMorphButton.MouseMove;
begin
  inherited MouseMove(Shift, X, Y);
end;

procedure TLBMorphButton.CMMouseEnter(var Message: TMessage);
begin
  FMouseIn := True;
  if not FDown or FDownGlyph.Empty
  then
    begin
      FTimer.OnTimer := IncMorphKf;
      FTimer.Enabled := True;
    end
  else
    begin
      MorphKf := 1;
      XPaint;
    end;
  inherited;
end;

procedure TLBMorphButton.CMMouseLeave(var Message: TMessage);
begin
  FMouseIn := False;
  if (not FDown) or FDownGlyph.Empty
  then
    begin
      FTimer.OnTimer := DecMorphKf;
      FTimer.Enabled := True;
    end
  else
    begin
      MorphKf := 1;
      XPaint;
      FTimer.OnTimer := DecMorphKf;
      FTimer.Enabled := True;
    end;
  inherited;
end;

procedure TLBMorphButton.IncMorphkf(Sender: TObject);
begin
  if MorphKf < 1
  then
    begin
      MorphKf := MorphKf + MorphOffset;
      XPaint;
    end
  else
    begin
      FTimer.Enabled := False;
      MorphKf := 1;
    end;
end;

procedure TLBMorphButton.DecMorphkf(Sender: TObject);
begin
  if MorphKf > 0
  then
    begin
      MorphKf := MorphKf - MorphOffset;
      XPaint;
    end
  else
    begin
      FTimer.Enabled := False;
      MorphKf := 0;
    end;
end;

end.