harmfade.pas

一款很漂亮的按钮组件Delphi,有源码哦。

unit HarmFade;

interface

{
          HarmFade Component, by Harm

     Copyright 1998-1999 Technoid Brain Trust
           [e-mail]

Version 2.4 - 10/99. Add two new events:
                     OnMouseDown and OnMouseUp.
                     Added one new property:
                     MSecPerFrame.
                     Many thanks to Jens Doll for the timing code!

Version 2.3 - 12/98. Add two new events:
                     OnMouseEnter and OnMouseLeave.
                     Added two new methods:
                     UnBlend and UnDissolve.
                     These excellent suggestions came from
                     [e-mail]

****  Documentation has been moved to ReadMe.htm
}

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, jpeg;

const
  Maxize = (1294967280 Div SizeOf(TPoint));
  MaxPixelCount   =  32768;
  Mask0101 = $00FF00FF; 
  Mask1010 = $FF00FF00; 

type
  EHarmFade = class(Exception);

  PRGBArray  =  ^TRGBArray;
  TRGBArray  =  array[0..MaxPixelCount-1] of TRGBTriple;

  TPnts = array[0..Maxize - 1] of TPoint;

  THarmFade = class(TGraphicControl)
  private
    {Private Declarations}
    bmF      : TBitmap;
    bmT      : TBitmap;
    bmZ      : TBitmap;
    FPicFrom : TPicture;
    FPicTo   : TPicture;
    FclFrom  : TColor;
    FclTo    : TColor;
    FPnts    : ^TPnts;
    FDRate   : integer;
    FBRate   : integer;
    FNumPix  : integer;
    FMSecPerFrame : Integer;                                                    // Variable Inserted
    FStretch : Boolean;
    FProcMsg : Boolean;
    FFinish  : Boolean;
    FOnBegin : TNotifyEvent;
    FOnEnd   : TNotifyEvent;
    FOnReset : TNotifyEvent;
    FAutoRev : Boolean;
    FRevSwap : Boolean;
    FReverst : Boolean;
    FStrTmp  : Boolean;
    FDelay   : integer;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    procedure CMMouseEnter(var Msg:TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg:TMessage); message CM_MOUSELEAVE;
    procedure chgPicF(Sender : TObject);
    procedure chgPicT(Sender : TObject);
    procedure WMEraseBkgnd(Var Msg : TMessage); message WM_ERASEBKGND;
    procedure SetpicFrom(Pic : TPicture);
    procedure SetpicTo(Pic : TPicture);
    procedure SetclFrom(Col : TColor);
    procedure SetclTo(Col : TColor);
    procedure SetDRate(Val : integer);
    procedure SetBRate(Val : integer);
    procedure SetStretch(Val : Boolean);
    procedure SetProcMsg(Val : Boolean);
    procedure SetPnts;
    procedure Blendit(bFr,bTo,bLn : Pointer ; Width,Height : Integer ; Dens : LongInt);
    procedure SetAutoRev(Val : Boolean);
    procedure SetRevSwap(Val : Boolean);
    procedure SetDelay(Val : integer);
  protected
    {Protected Declarations}
    procedure WMPosChg(var Msg : TMessage); message WM_WINDOWPOSCHANGED;
  public
    {Public Declarations}
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure Reset;
    procedure Dissolve;
    procedure FinishIt;
    procedure Blend;
    procedure UnBlend;
    procedure UnDissolve;
    property Finish : Boolean read FFinish write FFinish default FALSE;
  published
    {Published Declarations}
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter
        write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave
        write FOnMouseLeave;
    property PicFrom : TPicture read FPicFrom write SetpicFrom;
    property PicTo : TPicture read FPicTo write SetpicTo;
    property ColorFrom : TColor read FclFrom write SetclFrom default clBlack;
    property ColorTo : TColor read FclTo write SetclTo default clWhite;
    property DisolvRate : integer read FDRate write SetDRate default 125;
    property BlendRate : integer read FBRate write SetBRate default 32;
    property StretchToFit : Boolean read FStretch write SetStretch default TRUE;
    property ProcessMsgs : Boolean read FProcMsg write SetProcMsg default FALSE;
    property OnBegin : TNotifyEvent read FOnBegin write FOnBegin;
    property OnEnd : TNotifyEvent read FOnEnd write FOnEnd;
    property OnReset : TNotifyEvent read FOnReset write FOnReset;
    property AutoReverse : Boolean read FAutoRev write SetAutoRev default FALSE;
    property SwapOnReverse : Boolean read FRevSwap write SetRevSwap default TRUE;
    property SwapDelay : integer read FDelay write SetDelay default 1;
    property MsecPerFrame : Integer read FMsecPerFrame write FMsecPerFrame;     // Property inserted
    property Hint;
    property OnClick;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnMouseDown;
    property OnMouseUp;
  end;

procedure Register;

implementation

Var
  EBX, ESI, EDI, ESP, EBP,
  FinA,
  Dens1, Dens2 : Longint;

constructor THarmFade.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FclFrom := clBlack;
  FclTo := clWhite;
  FDRate := 125;
  FBRate := 32;
  FMsecPerFrame := 40;                                                          // Init eingef黦t
  FStretch := TRUE;
  FStrTmp := TRUE;
  FProcMsg := FALSE;
  FFinish := FALSE;
  FAutoRev := FALSE;
  FRevSwap := TRUE;
  FReverst := FALSE;
  FDelay := 1;
  ControlStyle := ControlStyle + [csOpaque]; // + [csNoStdEvents];
  FPicFrom := TPicture.Create;
  FPicTo := TPicture.Create;
  bmF := TBitmap.Create;
  bmT := TBitmap.Create;
  bmZ := TBitmap.Create;
  bmZ.PixelFormat := pf24bit;
  bmF.Canvas.Brush.Color := clBlack;
  FPicFrom.OnChange := chgPicF;
  FPicTo.OnChange := chgPicT;
  Width := 75;
  Height := 75;
  bmF.Width := Width;
  bmF.Height := Height;
end;

procedure DoIco(I : TGraphic; B : TBitmap; C : TColor; W : integer; H : integer);
var
  bmIco : TBitmap;
begin
  bmIco := TBitmap.Create;
  bmIco.Width := I.Width;
  bmIco.Height := I.Height;
  bmIco.Canvas.Brush.Color := C;
  bmIco.Canvas.FillRect(RECT(0,0,bmIco.Width,bmIco.Height));
  bmIco.Canvas.Draw(0,0,I);
  B.Canvas.StretchDraw(RECT(0,0,W,H),bmIco);
  bmIco.Free;
end;

procedure THarmFade.Reset;
var
  pTmp : TPicture;
  cTmp : TColor;
begin

  bmF.PixelFormat := pf24bit;
  bmT.PixelFormat := pf24bit;
  bmZ.PixelFormat := pf24bit;

  if FReverst = TRUE then begin
    cTmp := FclFrom;
    FclFrom := FclTo;
    FclTo := cTmp;
    pTmp := TPicture.Create;
    pTmp.Assign(FPicFrom);
    FPicFrom.Assign(FPicTo);
    FPicTo.Assign(pTmp);
    bmF.Canvas.Brush.Color := FclFrom;
    bmT.Canvas.Brush.Color := FclTo;
    FReverst := FALSE;
    pTmp.Free;
    FStretch := FStrTmp;
  end;

  if FStretch = TRUE then begin
    bmF.Width := Width;
    bmF.Height := Height;
    if FPicFrom.Graphic = nil then
      bmF.Canvas.FillRect(RECT(0,0,Width,Height))
    else begin
      if FPicFrom.Graphic is TMetaFile then
        bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      if FPicFrom.Graphic is TIcon then begin
        DoIco(FPicFrom.Graphic, bmF, FclFrom, Width, Height);
      end
      else
      bmF.Canvas.StretchDraw(RECT(0,0,Width,Height),FPicFrom.Graphic);
    end;
    bmT.Width := Width;
    bmT.Height := Height;
    if FPicTo.Graphic = nil then
      bmT.Canvas.FillRect(RECT(0,0,Width,Height))
    else begin
      if FPicTo.Graphic is TMetaFile then
        bmT.Canvas.FillRect(RECT(0,0,Width,Height));
      if FPicTo.Graphic is TIcon then
        DoIco(FPicTo.Graphic, bmT, FclTo, Width, Height)
      else
      bmT.Canvas.StretchDraw(RECT(0,0,Width,Height),FPicTo.Graphic);
    end;
  end;

  if FStretch = FALSE then begin
    if (FPicTo.Graphic <> nil) and (FPicFrom.Graphic = nil) then begin
      Width := FPicTo.Width;
      Height := FPicTo.Height;
      bmT.Width := Width;
      bmT.Height := Height;
      if (FPicTo.Graphic is TMetaFile) or (FPicTo.Graphic is TIcon) then
        bmT.Canvas.FillRect(RECT(0,0,Width,Height));
      bmT.Canvas.Draw(0,0,FPicTo.Graphic);
      bmF.Width := Width;
      bmF.Height := Height;
      bmF.Canvas.FillRect(RECT(0,0,Width,Height));
    end;
    if (FPicFrom.Graphic <> nil) and (FPicTo.Graphic = nil) then begin
      Width := FPicFrom.Width;
      Height := FPicFrom.Height;
      bmF.Width := Width;
      bmF.Height := Height;
      if (FPicFrom.Graphic is TMetaFile) or (FPicFrom.Graphic is TIcon) then
        bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      bmF.Canvas.Draw(0,0,FPicFrom.Graphic);
      bmT.Width := Width;
      bmT.Height := Height;
      bmT.Canvas.FillRect(RECT(0,0,Width,Height));
    end;
    if (FPicFrom.Graphic = nil) and (FPicTo.Graphic = nil) then begin
      bmF.Width := Width;
      bmF.Height := Height;
      bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      bmT.Width := Width;
      bmT.Height := Height;
      bmT.Canvas.FillRect(RECT(0,0,Width,Height));
    end;
    if (FPicFrom.Graphic <> nil) and (FPicTo.Graphic <> nil) then begin
      Width := FPicFrom.Width;
      Height := FPicFrom.Height;
      bmF.Width := Width;
      bmF.Height := Height;
      if (FPicFrom.Graphic is TMetaFile) or (FPicFrom.Graphic is TIcon) then
        bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      bmF.Canvas.Draw(0,0,FPicFrom.Graphic);
      bmT.Width := Width;
      bmT.Height := Height;
      if FPicTo.Graphic is TMetaFile then
        bmT.Canvas.FillRect(RECT(0,0,Width,Height));
      if FPicTo.Graphic is TIcon then begin
        DoIco(FPicTo.Graphic, bmT, FclTo, Width, Height);
      end
      else
      bmT.Canvas.StretchDraw(RECT(0,0,Width,Height),FPicTo.Graphic);
    end;
  end;

  bmZ.Width := bmF.Width;
  bmZ.Height := bmF.Height;

  Invalidate;

  if Assigned (FOnReset) then FOnReset(Self);

end;

procedure THarmFade.SetPnts;
var
  x, y, n, r : integer;
  tmpPt : TPoint;
begin
  FNumPix := Width * Height;
  n := 0;
  FPnts := AllocMem(FNumPix * SizeOf(TPoint));
  for x := 0 to Height-1 do begin
    for y := 0 to Width-1 do begin
      Fpnts^[n] := Point(x,y);
      n := n + 1;
    end;
  end;
  Randomize;
  for n := 0 to ((Width * Height)-1) do begin
    r := Random(FNumPix);
    tmpPt := Fpnts^[r];
    Fpnts^[r] := Fpnts^[n];
    Fpnts^[n] := tmpPt;
  end;
end;

procedure THarmFade.WMEraseBkgnd(var Msg:TMessage);
begin
  Msg.Result := 1;
end;

procedure THarmFade.Paint;
begin
  Canvas.Draw(0,0,bmF);
end;

procedure THarmFade.Dissolve;
var
  x, y, n, r, l : integer;
  Block : integer;
  ba, bb : pByteArray;
  lasttime : TDateTime;
  waittime : Integer;
begin
  Reset;
  SetPnts;
  Block := FNumPix Div FDRate;
  if Block < 1 then
    raise EHarmFade.Create('DisolvRate cannot be > Width * Height!');

  if Assigned (FOnBegin) then FOnBegin(Self);

  lasttime := now;                                                              // Point A - for constant Time at all ( FrameCount * MSecPerFrame )
  for r := 0 to ((FNumPix Div Block)-1) do begin
//    lasttime := now;                                                          // Point B - for constant Time-Intervall ( don't get a "running"-Effect after long "Hangups" in Process-Message )
    for n := (r * Block) to ((r * Block) + Block - 1) do begin
      x := Fpnts^[n].x;
      y := Fpnts^[n].y;
      ba := bmT.ScanLine[x];
      bb := bmF.ScanLine[x];
      for l := 0 to 2 do
        bb[(y*3) + l] := ba[(y*3) + l];
    end;
    Repaint;
    lasttime := lasttime+MsecperFrame/(24*60*60*1000);                          // Next Step at Time ...
    waittime := round( 24*60*60*1000*( lasttime-now ) );                        // Waittime calculation
    if waittime<0 then waittime := 0;                                           // Safty

    if FProcMsg = TRUE then begin                                               // begin end
      repeat
        Application.ProcessMessages;
      until now>lasttime;                                                       // another kind of Sleep !!!

      if FFinish = TRUE then begin
        FinishIt;
        FreeMem(FPnts, FNumPix * SizeOf(TPoint));
        Exit;
      end;
    end else Sleep( Waittime )                                                  // begin end
  end;

  for n := ((FNumPix div Block) * Block) to (FNumPix-1) do begin
    x := Fpnts^[n].x;
    y := Fpnts^[n].y;
    ba := bmT.ScanLine[x];
    bb := bmF.ScanLine[x];
    for l := 0 to 2 do
      bb[(y*3) + l] := ba[(y*3) + l];