funit.pas

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

unit FUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, HarmFade, ExtDlgs, jpeg, ExtCtrls, Menus;

const
  MY_MSG = WM_USER + 5;

type
  TForm1 = class(TForm)
    bDslv: TButton;
    bBlnd: TButton;
    bRest: TButton;
    bExit: TButton;
    bLFr: TButton;
    bLTo: TButton;
    bCFr: TButton;
    bCTo: TButton;
    bStrch: TButton;
    Label1: TLabel;
    eDislv: TEdit;
    eBlnd: TEdit;
    OP1: TOpenPictureDialog;
    Label3: TLabel;
    Bevel1: TBevel;
    l1: TLabel;
    l2: TLabel;
    l3: TLabel;
    PopupMenu1: TPopupMenu;
    SavePicFrom1: TMenuItem;
    SavePicTo1: TMenuItem;
    N2: TMenuItem;
    Blend1: TMenuItem;
    Dissolve1: TMenuItem;
    N3: TMenuItem;
    Exit1: TMenuItem;
    spDlg: TSavePictureDialog;
    HarmFade1: THarmFade;
    HarmFade2: THarmFade;
    HarmFade3: THarmFade;
    HarmFade4: THarmFade;
    HarmFade5: THarmFade;
    N1: TMenuItem;
    About1: TMenuItem;
    cbAR: TCheckBox;
    cbSOR: TCheckBox;
    Dt: TEdit;
    Label2: TLabel;
    ColorDialog1: TColorDialog;
    Button1: TButton;
    Button2: TButton;
    HarmFade6: THarmFade;
    procedure bDslvClick(Sender: TObject);
    procedure bBlndClick(Sender: TObject);
    procedure bRestClick(Sender: TObject);
    procedure bExitClick(Sender: TObject);
    procedure bLFrClick(Sender: TObject);
    procedure bLToClick(Sender: TObject);
    procedure bCFrClick(Sender: TObject);
    procedure bCToClick(Sender: TObject);
    procedure bStrchClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure SavePicFrom1Click(Sender: TObject);
    procedure SavePicTo1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure HarmFade2End(Sender: TObject);
    procedure HarmFade3End(Sender: TObject);
    procedure HarmFade4End(Sender: TObject);
    procedure HarmFade5End(Sender: TObject);
    procedure cbARClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure HarmFade6Click(Sender: TObject);
    procedure HarmFade6MouseEnter(Sender: TObject);
    procedure HarmFade6MouseLeave(Sender: TObject);
  private
    { Private declarations }
    HF6Clicked : Boolean;
    procedure DisolvOnShow(var Msg : TMessage); message MY_MSG;
    procedure SavePic(Pic : TPicture);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  //At form creation, set the OpenPicture dialog filter.  Must
  // add jpeg to the uses clause for it to recognize *.jpg as
  // a valid format.
  Op1.Filter := GraphicFilter(TGraphic);
  HF6Clicked := FALSE; //Set a flag for the button effect
end;

procedure TForm1.SavePic(Pic : TPicture);
begin
  //A generic save picture routine.  It modifies the save picture
  // dialog filter depending on the type of graphic passed to it.
  if Pic.Graphic is TBitmap then begin
    spDlg.Filter := '*.bmp';
    spDlg.DefaultExt := GraphicExtension(TBitmap);
  end;
  if Pic.Graphic is TMetaFile then begin
    spDlg.Filter := '*.wmf';
    spDlg.DefaultExt := GraphicExtension(TMetaFile);
  end;
  if Pic.Graphic is TJPEGImage then begin
    spDlg.Filter := '*.jpg';
    spDlg.DefaultExt := GraphicExtension(TJPegImage);
  end;
  if Pic.Graphic is TIcon then begin
    spDlg.Filter := '*.ico';
    spDlg.DefaultExt := GraphicExtension(TIcon);
  end;
  if Pic = nil then begin
    ShowMessage('No picture assigned');
    Exit;
  end;
  if spDlg.Execute then
    Pic.SaveToFile(spDlg.Filename);
end;

procedure TForm1.SavePicFrom1Click(Sender: TObject);
begin
  //This is the popup menu item for Save PicFrom.  It passes
  // PicFrom to the generic Save Pictue routine above.
  SavePic(HarmFade1.PicFrom);
end;

procedure TForm1.SavePicTo1Click(Sender: TObject);
begin
  //This is the popup menu item for Save PicTo.  It passes
  // PicTo to the generic Save picture routine above.
  SavePic(HarmFade1.PicTo);
end;

procedure TForm1.bDslvClick(Sender: TObject);
begin
  //Dissolve button clicked - set dissolve rate to match the edit box value
  HarmFade1.DisolvRate := StrToInt(eDislv.Text);
  //Set properties to match check box indicators.
  if cbAR.Checked then begin
    HarmFade1.AutoReverse := TRUE;
    HarmFade1.SwapDelay := StrToInt(Dt.Text);
  end
  else
    HarmFade1.AutoReverse := FALSE;
  if cbSOR.Checked then
    HarmFade1.SwapOnReverse := TRUE
  else
    HarmFade1.SwapOnReverse := FALSE;
  //Properties are set, do the effect (Dissolve).  If auto reverse is
  // true, the effect will revert the picture back to PicFrom.
  // If auto reverse is true, it will show PicTo for the Delay time
  // before reverting back to PicFrom.  I would recommend keeping SwapDelay
  // in single digits, since the application hangs while it's sleeping.
  // If AutoReverse is true and SwapOnReverse is True, it will Blend
  // back to PicFrom.
  HarmFade1.Dissolve;
  //This same routine is used for the popup menu item Dissolve.
end;

procedure TForm1.bBlndClick(Sender: TObject);
begin
  //Blend button clicked - set Blend rate to match the edit box value
  HarmFade1.BlendRate := StrToInt(eBlnd.Text);
  //Set properties to match check box indicators.
  if cbAR.Checked then begin
    HarmFade1.AutoReverse := TRUE;
    HarmFade1.SwapDelay := StrToInt(Dt.Text);
  end
  else
    HarmFade1.AutoReverse := FALSE;
  if cbSOR.Checked then
    HarmFade1.SwapOnReverse := TRUE
  else
    HarmFade1.SwapOnReverse := FALSE;
  //Properties are set, do the effect (Blend).  If auto reverse is
  // true, the effect will revert the picture back to PicFrom.
  // If auto reverse is true, it will show PicTo for the Delay time
  // before reverting back to PicFrom.  I would recommend keeping SwapDelay
  // in single digits, since the application hangs while it's sleeping.
  // If AutoReverse is true and SwapOnReverse is True, it will Dissolve
  // back to PicFrom.
  HarmFade1.Blend;
  //This same routine is used for the popup menu item Blend.
end;

procedure TForm1.bRestClick(Sender: TObject);
begin
  //A reset shows PicFrom again.
  HarmFade1.Reset;
end;

procedure TForm1.bLFrClick(Sender: TObject);
begin
  //This just loads in a new picture to PicFrom.  It can be
  // *.bmp, *.jpg, *.ico, *.wmf, or *.emf.  You must include jpeg
  // in the uses clause of the unit to make that format available.
  if OP1.Execute then
    HarmFade1.PicFrom.LoadFromFile(OP1.FileName);
end;

procedure TForm1.bLToClick(Sender: TObject);
begin
  //This just loads in a new picture to PicTo.  It can be
  // *.bmp, *.jpg, *.ico, *.wmf, or *.emf.  You must include jpeg
  // in the uses clause of the unit to make that format available.
  if OP1.Execute then
    HarmFade1.PicTo.LoadFromFile(OP1.FileName);
end;

procedure TForm1.bCFrClick(Sender: TObject);
begin
  //This will clear the PicFrom, which means it will use the
  // ColorFrom color to fill the rectangle for a solid color
  // PicFrom.
  HarmFade1.PicFrom := nil;
end;

procedure TForm1.bCToClick(Sender: TObject);
begin
  //This will clear the PicTo, which means it will use the
  // ColorTo color to fill the rectangle for a solid color
  // PicFrom.
  HarmFade1.PicTo := nil;
end;

procedure TForm1.bStrchClick(Sender: TObject);
begin
  //StretchToFit indicates how the PicFrom will be displayed.
  // If this value is true, the picture will be 'stretched',
  // (either shrunk or expanded) to fit the current size of
  // HarmFade.  If False, Harmfade size is adjusted to match
  // the dimensions of the Picture.
  HarmFade1.StretchToFit := not HarmFade1.StretchToFit;
  if HarmFade1.StretchToFit = TRUE then begin
    bStrch.Caption := 'Stretch Off';
    Label1.Caption := 'Stretch is ON';
  end
  else begin
    bStrch.Caption := 'Stretch On';
    Label1.Caption := 'Stretch is OFF';
  end;
end;

procedure TForm1.DisolvOnShow(var Msg : TMessage);
begin
  //This procedure is used in conjunction with the next one
  // to make sure the form is fully painted before doing the
  // effect.  We post our own user message to indicate that
  // the form is now visible, and it's time to do our effect.
  // Otherwise, the effect gets done before the form is
  // painted, and you can't see it happen.
  Application.ProcessMessages;
  HarmFade1.Dissolve;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  PostMessage(Handle, MY_MSG, 0, 0);
end;

procedure TForm1.HarmFade2End(Sender: TObject);
begin
  //This procedure executes when HarmFade2 completes the effect.
  // It does a short delay (1/2 second), then makes the hidden
  // controls visible again.  It makes HarmFade3 visible, and
  // starts that effect.
  Sleep(500);
  Bevel1.Visible := TRUE;
  l1.Visible := TRUE;
  l2.Visible := TRUE;
  l3.Visible := TRUE;
  HarmFade2.Visible := FALSE;
  Application.ProcessMessages;  //Need this or HarmFade3 takes off
  HarmFade3.Visible := TRUE;    // before HarmFade2 becomes invisible.
  HarmFade3.Blend;
end;

procedure TForm1.HarmFade3End(Sender: TObject);
begin
  //This procedure executes when HarmFade3 effect completes.
  // It makes HarmFade3 invisible, then shows HarmFade4 and
  // starts that effect.  HarmFade3 has AutoReverse true and
  // SwapOnReverse False.
  HarmFade3.Visible := FALSE;
  Application.ProcessMessages;
  HarmFade4.Visible := TRUE;
  HarmFade4.Blend;
end;

procedure TForm1.HarmFade4End(Sender: TObject);
var
  ADC : HDC;
  sx, sy : integer;
  bm1 : TBitmap;
begin
  //When HarmFade4 ends, it sets up HarmFade5.  This is a bit different.
  // HarmFade5 sits on top of HarmFade1.  We first get a screen
  // capture of the area that HarmFade5 covers, in bm1 bitmap.  It will
  // be assigned to PicFrom, then some text is drawn
  // onto it, and it is assigned to PicTo.  So, PicFrom and PicTo are
  // identical except for the text. This must be done each time, since
  // the underlying HarmFade1 may change, have different pictures, etc.
  // This gives the appearance of the text blending and dissolving into
  // the background, when actually it's a copy of the background, much
  // like the splash screen trick.
  HarmFade4.Visible := FALSE;
  Application.ProcessMessages;
  bm1 := TBitmap.Create;          //Instantiate bitmap.
  ADC := GetDC(0);                //Get a device context.
  bm1.Width := HarmFade5.Width;   //Set bitmap dimensions to match.
  bm1.Height := Harmfade5.Height;
  sx := HarmFade5.ClientOrigin.x;   //Locate screen coordinates
  sy := HarmFade5.ClientOrigin.y;
  Bitblt(bm1.Canvas.Handle, 0, 0,    //Copy screen to bm1 bitmap.
         bm1.Width, bm1.Height,
         ADC, sx, sy, SRCCOPY);
  HarmFade5.PicFrom.Assign(bm1);     //Assign bm1 to picfrom
  bm1.Canvas.Font.Size := 24;        //Setup same bmp with our text
  bm1.Canvas.Font.Color := clWhite;
  bm1.Canvas.Font.Name := 'Times New Roman';
  bm1.Canvas.Font.Style := [fsBold];
  bm1.Canvas.Brush.Style := bsClear;  //For transparency around text, so
  // it doesn't erase the screen capture that's already drawn. Then,
  // use textout to draw some text.
  bm1.Canvas.TextOut((bm1.Width - bm1.Canvas.TextWidth('HarmFade')) div 2,
                    (bm1.Height - bm1.Canvas.TextHeight('HarmFade')) div 2,
                     'HarmFade');
  //OK, we wrote 'HarmFade' in white, let's write 'by Harm' in Aqua
  bm1.Canvas.Font.Color := clAqua;
  bm1.Canvas.TextOut((bm1.Width - bm1.Canvas.TextWidth('by Harm')) div 2,
                    (bm1.Height + bm1.Canvas.TextHeight('HarmFade')) div 2,
                     'by Harm');
  HarmFade5.PicTo.Assign(bm1);        //All drawn, assign to PicTo.
  bm1.Free;                           //Release temp bitmap.
  HarmFade5.Reset;                    //HarmFade5 has AutoReverse true
  HarmFade5.Visible := TRUE;          // and SwapOnReverse true. The text
  HarmFade5.Blend;                    // Blends in then dissolves out.
  //This same procedure is used for the popup menu item About. 
end;

procedure TForm1.HarmFade5End(Sender: TObject);
begin
  //This is the end of the series started with the click of
  // the Show More button.  It makes HarmFade5 invisible.
  HarmFade5.Visible := FALSE;
end;

procedure TForm1.cbARClick(Sender: TObject);
begin
  //This does some manipulation when the AutoReverse Checkbox
  // is clicked.  Since SwapOnReverse is ignored if AutoReverse
  // is false, I disable the other checkbox and hide the SwapDelay
  // controls.  The SwapOnReverse and SwapDelay properties are only
  // pertinent if AutoReverse is in effect.
  if cbAR.Checked = FALSE then begin
    cbSOR.Enabled := FALSE;
    Dt.Visible := FALSE;
    label2.Visible := FALSE;
  end
  else begin
    cbSOR.Enabled := TRUE;
    Dt.Visible := TRUE;
    label2.Visible := TRUE;
  end;
end;

procedure TForm1.bExitClick(Sender: TObject);
begin
  //This same routine is used by the popup menu item Exit
  Application.Terminate;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ColorDialog1.Color := HarmFade1.ColorFrom;
  if ColorDialog1.Execute then
    HarmFade1.ColorFrom := ColorDialog1.Color;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ColorDialog1.Color := HarmFade1.ColorTo;
  if ColorDialog1.Execute then
    HarmFade1.ColorTo := ColorDialog1.Color;
end;

procedure TForm1.HarmFade6Click(Sender: TObject);
var
  ADC : HDC;
  sx, sy : integer;
  bm : TBitmap;
begin
  //Clicking this sets off a series of events.  First,
  // HarmFade2 is set up to do a screen capture of the controls
  // directly beneath it.  It then does a Blend into a Delphi
  // jpeg picture.  When it completes, it fires the HarmFade2.OnEnd
  // event.
  HF6Clicked := TRUE;
  HarmFade6.Reset;
  Application.ProcessMessages;
  ADC := GetDC(0);                //Get screen device context.
  bm := TBitmap.Create;           //Instantiate temp bitmap.
  bm.Width := HarmFade2.Width;    //Make size same as Harmfade
  bm.Height := Harmfade2.Height;
  sx := HarmFade2.ClientOrigin.x; //Find screen coordinates.
  sy := HarmFade2.ClientOrigin.y;
  Bitblt(bm.Canvas.Handle, 0, 0,  //Copy what is showing on the screen
         bm.Width, bm.Height,     // to the temp bitmap.
         ADC, sx, sy, SRCCOPY);
  HarmFade2.PicFrom.Assign(bm);   //Copy it to PicFrom.
  bm.Free;                        //Free memory.
  HarmFade2.Visible := TRUE;      //HarmFade2 PicFrom now looks identical
  l1.Visible := FALSE;            // to whatever was beneath it.  Hide
  l2.Visible := FALSE;            // the labels and the bevel to avoid
  l3.Visible := FALSE;            // flicker. Then, do the effect.
  Bevel1.Visible := FALSE;        // HarmFade2 has AutoReverse true
  HarmFade2.Blend;                // and SwapOnReverse true.
end;

procedure TForm1.HarmFade6MouseEnter(Sender: TObject);
begin
  HarmFade6.Blend;
end;

procedure TForm1.HarmFade6MouseLeave(Sender: TObject);
begin
  if HF6Clicked = TRUE then begin
    HF6Clicked := FALSE;
    Exit;
  end;
  HarmFade6.UnBlend;
end;

end.