remindpopup.pas

一个朋友写的delphi的漂亮时钟

{*******************************************************}
{*            Email: [e-mail]               *}
{*               QQ: 39262884                          *}
{*******************************************************}

unit RemindPopup;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type
  TScrollSpeed = 1..50;
  TOrientation = (mbHorizontal, mbVertical);

  TRemindLink = procedure(RemindID: Integer) of object;

  TRemindPop = class(TComponent)
  private
    FWidth: Integer;
    FHeight: Integer;
    FTimeOut: Integer;
    FScrollSpeed: TScrollSpeed;
    FGradientColorStart: TColor;
    FGradientColorEnd: TColor;
    FGradientOrientation: TOrientation;
    FTxtFont: TFont;
    FTxtOverFont: TFont;
    FTitleFont: TFont;
    FPopCount: Integer;
    FPopPosY: Integer;
    FOnURLClick: TRemindLink;

    procedure SetTxtFont(AValue: TFont);
    procedure SetTxtOverFont(AValue: TFont);
    procedure SetTitleFont(AValue: TFont);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure ShowPopUp(ARemindID: Integer; ATitle, AText: string);
    procedure DecPopCount;
  published
    property Width: Integer read FWidth write FWidth default 200;
    property Height: Integer read FHeight write FHeight default 100;
    property TimeOut: Integer read FTimeOut write FTimeOut default 30;
    property ScrollSpeed: TScrollSpeed read FScrollSpeed write FScrollSpeed default 9;
    property Orientation: TOrientation read FGradientOrientation write
      FGradientOrientation default mbHorizontal;
    property GradientColorStart: TColor read FGradientColorStart write FGradientColorStart;
    property GradientColorEnd: TColor read FGradientColorEnd write FGradientColorEnd;
    property TxtFont: TFont read FTxtFont write SetTxtFont;
    property TxtOverFont: TFont read FTxtOverFont write SetTxtOverFont;
    property TitleFont: TFont read FTitleFont write SetTitleFont;
    property PopPosY: Integer read FPopPosY write FPopPosY;
    property OnURLClick: TRemindLink read FOnURLClick write FOnURLClick;
  end;

  TFmRemindPop = class(TForm)
    lblTitle: TLabel;
    lblTxt: TLabel;
    tmrShow: TTimer;
    tmrHide: TTimer;
    tmrExit: TTimer;
    procedure lblTxtClick(Sender: TObject);
    procedure pnl1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure tmrHideTimer(Sender: TObject);
    procedure tmrExitTimer(Sender: TObject);
    procedure tmrShowTimer(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure lblTxtMouseLeave(Sender: TObject);
    procedure lblTxtMouseEnter(Sender: TObject);
  private
    FRemindPop: TRemindPop;
    FRemindID: Integer;
    FBmpGradient: TBitmap;
    FMsnBottom: TBitmap;
    FMaxHeigth: Integer;
    function CalcColorIndex(StartColor, endColor: TColor; Steps, ColorIndex: Integer): TColor;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(ARemindPop: TRemindPop);
    destructor Destroy; override;
    procedure ShowPopUp(ARemindID: Integer; ATitle, AText: string);
  end;

procedure Register;

implementation

uses Types;

{$R *.dfm}
{$R MSNBottom.RES}

{ TRemindPop }

procedure Register;
begin
  RegisterComponents('Fan', [TRemindPop]);
end;   

constructor TRemindPop.Create(AOwner: TComponent);
begin
  inherited;
  FTxtFont := TFont.Create;
  FTxtOverFont := TFont.Create;
  FTitleFont := TFont.Create;
  FTitleFont.Style := [fsBold];
  FTxtOverFont.Style := [fsUnderline];
  PopPosY := 0;
  FGradientColorStart := $00FFCC99;
  FGradientColorEnd := clWhite;
  FPopCount := 0;
  FPopPosY := 0;
  Width := 300;
  Height := 185;
  ScrollSpeed := 10;
  TimeOut := 30;
  Orientation := mbVertical;
end;

procedure TRemindPop.DecPopCount;
begin
  if FPopCount > 0 then
    Dec(FPopCount);
end;

destructor TRemindPop.Destroy;
begin
  FTxtFont.Free;
  FTxtOverFont.Free;
  FTitleFont.Free;
  inherited;
end;

procedure TRemindPop.SetTitleFont(AValue: TFont);
begin
  if FTitleFont <> AValue then
    FTitleFont.Assign(AValue);
end;

procedure TRemindPop.SetTxtFont(AValue: TFont);
begin
  if FTxtFont <> AValue then
    FTxtFont.Assign(AValue);
end;

procedure TRemindPop.SetTxtOverFont(AValue: TFont);
begin
  if FTxtOverFont <> AValue then
    FTxtOverFont.Assign(AValue);
end;

procedure TRemindPop.ShowPopUp(ARemindID: Integer; ATitle, AText: string);
var
  FmRemindPop: TFmRemindPop;
begin
  FmRemindPop := TFmRemindPop.Create(Self);
  FPopCount := FPopCount + 1;
  if FPopCount >= 1 then
    FPopPosY := (FPopCount - 1) * Height
  else
    FPopPosY := 0;
  FmRemindPop.ShowPopUp(ARemindID, ATitle, AText);
end;

{ TFmRemindPopTFmRemindPop }


function TFmRemindPop.CalcColorIndex(StartColor, endColor: TColor; Steps,
  ColorIndex: Integer): TColor;
var
  beginRGBValue: Array[0..2] of Byte;
  RGBDifference: Array[0..2] of Integer;
  Red, Green, Blue: Byte;
  NumColors: Integer;
begin
  NumColors := Steps;
  Dec(ColorIndex);
  beginRGBValue[0] := GetRValue(ColorToRGB(StartColor));
  beginRGBValue[1] := GetGValue(ColorToRGB(StartColor));
  beginRGBValue[2] := GetBValue(ColorToRGB(StartColor));
  RGBDifference[0] := GetRValue(ColorToRGB(endColor)) - beginRGBValue[0];
  RGBDifference[1] := GetGValue(ColorToRGB(endColor)) - beginRGBValue[1];
  RGBDifference[2] := GetBValue(ColorToRGB(endColor)) - beginRGBValue[2];
  Red := beginRGBValue[0] + MulDiv(ColorIndex, RGBDifference[0], NumColors - 1);
  Green := beginRGBValue[1] + MulDiv(ColorIndex, RGBDifference[1], NumColors - 1);
  Blue := beginRGBValue[2] + MulDiv(ColorIndex, RGBDifference[2], NumColors - 1);
  Result := RGB(Red, Green, Blue);
end;

constructor TFmRemindPop.Create(ARemindPop: TRemindPop);
begin
  inherited Create(nil);
  FRemindPop := ARemindPop;
  FBmpGradient := TBitmap.Create;
  FMsnBottom := TBitmap.Create;
  lblTitle.Font.Assign(ARemindPop.TitleFont);
  lblTxt.Font.Assign(ARemindPop.TxtFont);
end;

procedure TFmRemindPop.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.WndParent := GetDesktopWindow;
  Params.Style := Params.Style and not WS_CAPTION or WS_POPUP;
  Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW;
end;

destructor TFmRemindPop.Destroy;
begin
  FBmpGradient.Free;
  FMsnBottom.Free;
  inherited;
end;

procedure TFmRemindPop.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FRemindPop.DecPopCount;
  Action := caFree;
end;

procedure TFmRemindPop.FormPaint(Sender: TObject);
var
  Rect: TRect;
begin
  Rect.Top := Height - 4;
  Rect.Left := 2;
  Rect.Right := FRemindPop.Width - 2;
  Rect.Bottom := Height;
  Canvas.StretchDraw(Rect, FMsnBottom);

  Rect.Top := 2;
  Rect.Left := 2;
  Rect.Right := FRemindPop.Width - 2;
  Rect.Bottom := FRemindPop.Height - 4;
  Canvas.StretchDraw(Rect, FBmpGradient);
end;

procedure TFmRemindPop.lblTxtClick(Sender: TObject);
begin
  if Assigned(FRemindPop.OnURLClick) then
    FRemindPop.OnURLClick(FRemindID);
end;

procedure TFmRemindPop.lblTxtMouseEnter(Sender: TObject);
begin
  lblTxt.Font.Assign(FRemindPop.TxtOverFont);
end;

procedure TFmRemindPop.lblTxtMouseLeave(Sender: TObject);
begin
  lblTxt.Font.Assign(FRemindPop.TxtFont);
end;

procedure TFmRemindPop.pnl1Click(Sender: TObject);
begin
  tmrShow.Enabled := False;
  tmrHide.Enabled := True;
end;

procedure TFmRemindPop.ShowPopUp(ARemindID: Integer; ATitle, AText: string);
var
  i: Integer;
  WorkRect: TRect;
begin
  FRemindID := ARemindID;
  lblTitle.Caption := ATitle;
  lblTxt.Caption := AText;
  lblTxt.Width := FRemindPop.Width - lblTxt.Left*2;
  lblTxt.AutoSize := True;
  lblTxt.Top := (FRemindPop.Height - lblTxt.Height) div 2;
  lblTxt.Left := (FRemindPop.Width - lblTxt.Width) div 2;
  Width := FRemindPop.Width;
  FMaxHeigth := FRemindPop.Height;
  FBmpGradient.Width := FRemindPop.Width - 4;
  FBmpGradient.Height := FRemindPop.Height - 4;
  if FRemindPop.Orientation = mbVertical then
  begin
    for i := 0 To FBmpGradient.Height Do
    begin
      FBmpGradient.Canvas.Pen.Color := CalcColorIndex(FRemindPop.FGradientColorStart,
        FRemindPop.FGradientColorEnd, FBmpGradient.Height + 1, i + 1);
      FBmpGradient.Canvas.MoveTo(0,i);
      FBmpGradient.Canvas.LineTo(FBmpGradient.Width, i);
    end;
  end;
  if FRemindPop.Orientation = mbHorizontal then
  begin
    for i := 0 To FBmpGradient.Width Do
    begin
      FBmpGradient.Canvas.Pen.Color := CalcColorIndex(FRemindPop.FGradientColorStart,
        FRemindPop.FGradientColorEnd, FBmpGradient.Height + 1, i + 1);
      FBmpGradient.Canvas.MoveTo(i, 0);
      FBmpGradient.Canvas.LineTo(i, FBmpGradient.Height);
    end;
  end;
  FMsnBottom.LoadFromResourceName(HInstance, 'MSN');
  SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkRect, 0);
  Top := WorkRect.Bottom - (FRemindPop.PopPosY);
  Left := WorkRect.Right - FRemindPop.Width;
  Height := 0;
  tmrShow.Interval := 100;
  tmrHide.Interval := 100;
  tmrExit.Interval := FRemindPop.TimeOut * 1000;
  Show;
  tmrShow.Enabled := True;
end;

procedure TFmRemindPop.tmrExitTimer(Sender: TObject);
begin
  tmrShow.Enabled := False;
  tmrHide.Enabled := True;
end;

procedure TFmRemindPop.tmrHideTimer(Sender: TObject);
begin
  if Height - FRemindPop.ScrollSpeed > 0 then
  begin
    Height := Height - FRemindPop.ScrollSpeed;
    Top := Top + FRemindPop.ScrollSpeed;
  end
  else
    Close;
end;

procedure TFmRemindPop.tmrShowTimer(Sender: TObject);
begin
  if Height + FRemindPop.ScrollSpeed < FMaxHeigth then
  begin
    Top := Top - FRemindPop.ScrollSpeed;
    Height := Height + FRemindPop.ScrollSpeed;
  end
  else
  begin
    Top := Top - (FMaxHeigth - Height);
    Height := FMaxHeigth;
    tmrShow.Enabled := False;
    tmrExit.Enabled := True;
  end;
  //Invalidate;
end;

end.