msgfrm.~pas

类似于MSN登陆消息提示窗口！比较不错

unit MsgFrm;

interface

uses
  Windows, Messages, SysUtils, Classes,  Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, MsgUnit, jpeg, se_controls, KsSkinPanels,
  KsSkinEngine;

type
{ TMsgForm }

  TMsgForm = class(TForm)
    Panel1: TPanel;
    L_Msg: TLabel;
    imgWarning: TImage;
    imgInfo: TImage;
    imgError: TImage;
    L_Caption: TLabel;
    L_AppName: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure tmFadeInTimer(Sender: TObject);
    procedure tmDelayTimer(Sender: TObject);
    procedure tmFadeOutTimer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure L_MsgMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure L_MsgMouseLeave(Sender: TObject);
    procedure SeSkinPanel1Resize(Sender: TObject);
    procedure SeSkinPanel1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    FMsg: string;
    Bmp: TBitmap;
    FMsgKind: TMsgKind;
    StartColor, EndColor: TColor;
    FMsgPos: TShowPos;
    InTimer: Integer;
    InValue: Integer;
    InDraw: Boolean;
    tmFadeIn: TTimer;
    tmFadeOut: TTimer;
    tmDelay: TTimer;
    FormClicked: Boolean;
    
    procedure SetMsg(const Value: string);
    procedure SetMsgKind(const Value: TMsgKind);
    procedure SetMsgPos(const Value: TShowPos);
    procedure CreateTimers;
  protected
    function CalcRect(MaxWidth: Integer; const ACap: string; AData: Pointer): TRect;

  public
    lAutoClose: Boolean;
    property Msg: string read FMsg write SetMsg;
    property MsgKind: TMsgKind read FMsgKind write SetMsgKind;
    property MsgPos: TShowPos read FMsgPos write SetMsgPos;
  end;

  procedure ShowMsg(const Info: string; Kind: TMsgKind; lCaptionFont, lInfoFont: TFont;Lclick:TNotifyEvent); overload;
  procedure ShowInfo(const Info: string);
  procedure ShowWarning(const Info: string);
  procedure ShowError(const Info: string);

var
  MsgForm : TMsgForm;

  AppCaption: String;
  {* 窗口标题}
  ShowCaption: String ;
  {* 消息标题}
  ShowPos: TShowPos;
  {* 默认显示位置}
  ShowMsgStyle: TMsgStyle;
  {* 窗口风格}
  ShowDelay: Integer;
  {* 延时 }
  AutoClose: Boolean ;
  {* 是否自动关闭}
  CaptionFont, InfoFont: TFont ;
  {* 标题，内容字体}

implementation

{$R *.DFM}

var
  ThisList: TThreadList;

function GetWorkRect: TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0)
end;

procedure ShowMsg(const Info: string; Kind: TMsgKind; lCaptionFont, lInfoFont: TFont;Lclick:TNotifyEvent) ;
var
  H: Integer;
begin
  CaptionFont := TFont.Create ;
  InfoFont := TFont.Create ;
  CaptionFont.Assign(lCaptionFont) ;
  InfoFont.Assign(lInfoFont) ;
  MsgForm := TMsgForm.Create(nil) ;
  with MsgForm do begin
    Msg := Info;
    MsgKind := Kind;
    MsgPos := ShowPos;
    lAutoClose := AutoClose;
    if ShowMsgStyle = msXpBlue then begin
     //  M_Image2.SendToBack ;
       L_AppName.Top := 7;
       L_AppName.Font.Color := clWhite;
    end;
    if ShowMsgStyle = msContracted then begin
      // M_Image1.SendToBack ;
       L_AppName.Top := 3;
       L_AppName.Font.Color := clBlack;
    end;
    H := CalcRect(L_Msg.Width, Info, nil).Bottom - L_Msg.Height;
    if H > 0 then
    begin
      L_Msg.Height := L_Msg.Height + H;
      Height := Height + H;
    end;
    L_Caption.Caption:=ShowCaption;
    L_MSG.OnClick:=Lclick;
    ShowWindow(Handle, SW_SHOWNOACTIVATE);
    SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOOWNERZORDER);
    SetCurrentRoundWindow(Handle, Width + 1, Height + 1);
    FormShow(nil);
  end;
end;

procedure ShowInfo(const Info: string);
begin
 // ShowMsg(Info, mkInfo, CaptionFont, InfoFont,MsgForm.myclick);
end;

procedure ShowWarning(const Info: string);
begin
 // ShowMsg(Info, mkWarning, CaptionFont, InfoFont,MsgForm.myclick);
end;

procedure ShowError(const Info: string);
begin
//  ShowMsg(Info, mkError, CaptionFont, InfoFont,myclick);
end;

{ TMsgForm }

procedure TMsgForm.FormCreate(Sender: TObject);
begin
  L_Msg.Font.Assign(InfoFont) ;
  L_Caption.Font.Assign(CaptionFont);
  Left := -300;
  Top := Screen.Height + 300;
 // L_AppName.Caption := Application.Title ;
  with ThisList.LockList do
  try
    Add(Self);
  finally
    ThisList.UnlockList;
  end;
  Bmp := TBitmap.Create;
  Bmp.PixelFormat := pf24Bit;
  CreateTimers;
  tmFadeIn.Enabled := True;
  FormClicked := False;
 // myclick:=l_msg.OnClick ;
end;

procedure TMsgForm.FormShow(Sender: TObject);
begin
  case MsgPos of
    spLeft:
      begin
        Top := (GetWorkRect.Bottom - Height) div 2;
        Left := GetWorkRect.Left + 1 - Width;
      end;
    spRight:
      begin
        Top := (GetWorkRect.Bottom - Height) div 2;
        Left := GetWorkRect.Right - 1;
      end;
    spRightTop:
      begin
        Top := GetWorkRect.Top + 1 - Height;
        Left := GetWorkRect.Right - Width;
      end;
  else
    begin
      Top := GetWorkRect.Bottom - 1;
      Left := GetWorkRect.Right - Width;
    end;
  end;
  tmDelay.Interval := ShowDelay * 1000;
end;

procedure TMsgForm.FormDestroy(Sender: TObject);
begin
  Bmp.Free;
  CaptionFont.Free ;
  InfoFont.Free ;
  with ThisList.LockList do
  try
    Delete(IndexOf(Self));
  finally
    ThisList.UnlockList;
  end;
end;

procedure TMsgForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  tmFadeIn.Enabled := False;
  tmDelay.Enabled := False;
  tmFadeOut.Enabled := False;
end;

procedure TMsgForm.FormClick(Sender: TObject);
begin
  FormClicked := True ;
  tmDelayTimer(Self);
end;

procedure TMsgForm.tmFadeInTimer(Sender: TObject);
begin
  Inc(InTimer);
  InValue := 1 + InTimer * 3 div 11;
  case MsgPos of
    spLeft:
      begin
        if Left >= GetWorkRect.Left then
        begin
          tmFadeIn.Enabled := False;
          tmDelay.Enabled := True;
        end
        else if Left - InValue >= GetWorkRect.Left then
          Left := GetWorkRect.Left
        else
          Left := Left + InValue;
      end;
    spRight:
      begin
        if Left <= GetWorkRect.Right - Width then
        begin
          tmFadeIn.Enabled := False;
          tmDelay.Enabled := True;
        end
        else if Left + InValue <= GetWorkRect.Right - Width then
          Left := GetWorkRect.Right - Width
        else
          Left := Left - InValue;
      end;
    spRightTop:
      begin
        if Top >= GetWorkRect.Top then
        begin
          tmFadeIn.Enabled := False;
          tmDelay.Enabled := True;
        end
        else if Top - InValue >= GetWorkRect.Top then
          Top := GetWorkRect.Top
        else
          Top := Top + InValue;
      end;
  else
    begin
      if Top + Height <= GetWorkRect.Bottom then
      begin
        tmFadeIn.Enabled := False;
        tmDelay.Enabled := True;
      end
      else if Top + Height + InValue <= GetWorkRect.Bottom then
        Top := GetWorkRect.Bottom - Height
      else
        Top := Top - InValue;
    end;
  end;
end;

procedure TMsgForm.tmDelayTimer(Sender: TObject);
begin
  tmFadeIn.Enabled := False;
  tmDelay.Enabled := False;
  if FormClicked then
     tmFadeOut.Enabled := True
  else begin
     if lAutoClose then
        tmFadeOut.Enabled := True
     else
        tmFadeOut.Enabled := False;
  end;
end;

procedure TMsgForm.tmFadeOutTimer(Sender: TObject);
begin
  if InTimer > 0 then
    Dec(InTimer);
  InValue := 1 + InTimer * 3 div 11;
  case MsgPos of
    spLeft:
      begin
        Left := Left - InValue;
        if Left <= GetWorkRect.Left + 2 - Width then
        begin
          tmFadeOut.Enabled := False;
          Self.Close;
        end;
      end;
    spRight:
      begin
        Left := Left + InValue;
        if Left >= GetWorkRect.Right - 2 then
        begin
          tmFadeOut.Enabled := False;
          Self.Close;
        end;
      end;
    spRightTop:
      begin
        Top := Top - InValue;
        if Top <= GetWorkRect.Top + 1 - Height then
        begin
          tmFadeOut.Enabled := False;
          Self.Close;
        end;
      end;
  else
    begin
      Top := Top + InValue;
      if Top >= GetWorkRect.Bottom - 2 then
      begin
        tmFadeOut.Enabled := False;
        Self.Close;
      end;
    end;
  end;
end;

procedure TMsgForm.SetMsg(const Value: string);
begin
  FMsg := Value;
  L_Msg.Caption := FMsg;
end;

procedure TMsgForm.SetMsgKind(const Value: TMsgKind);
begin
  FMsgKind := Value;
  case FMsgKind of
    mkError:
      begin
        imgError.Visible := True;
        imgWarning.Visible := False ;
        imgInfo.Visible := False ;
        L_Caption.Caption := ShowCaption;
      end;
    mkWarning:
      begin
        imgError.Visible := False;
        imgWarning.Visible := True;
        imgInfo.Visible := False ;
        L_Caption.Caption := ShowCaption;
      end;
  else
    begin
      imgError.Visible := False;
      imgWarning.Visible := False;
      imgInfo.Visible := True;
      L_Caption.Caption := ShowCaption;
    end;
  end;
end;

procedure TMsgForm.SetMsgPos(const Value: TShowPos);
begin
  FMsgPos := Value;
end;

procedure TMsgForm.CreateTimers;
begin
  tmFadeIn := TTimer.Create(Self);
  with tmFadeIn do
  begin
    Enabled := False;
    Interval := 15;
    OnTimer := tmFadeInTimer;
  end;
  tmFadeOut := TTimer.Create(Self);
  with tmFadeOut do
  begin
    Enabled := False;
    Interval := 15;
    OnTimer := tmFadeOutTimer;
  end;
  tmDelay := TTimer.Create(Self);
  with tmDelay do
  begin
    Enabled := False;
    Interval := 5000;
    OnTimer := tmDelayTimer;
  end;
end;

function TMsgForm.CalcRect(MaxWidth: Integer; const ACap: string;
  AData: Pointer): TRect;
begin
  Result := Rect(0, 0, MaxWidth, 0);
//  DrawText(L_Msg.Canvas.Handle, PChar(ACap),Result, -1);
end;

procedure TMsgForm.L_MsgMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if pos('http',l_MSG.Caption)<>0 then
    L_MSG.Font.Color:=Clred;
end;

procedure TMsgForm.L_MsgMouseLeave(Sender: TObject);
begin
 if pos('http',l_MSG.Caption)<>0 then
    L_MSG.Font.Color:=Clblack;
end;

procedure TMsgForm.SeSkinPanel1Resize(Sender: TObject);
begin
Panel1.Refresh;
end;

procedure TMsgForm.SeSkinPanel1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
SendMessage(MsgForm.handle,wm_SysCommand,$f012,0);
end;

initialization
  ThisList := TThreadList.Create;

finalization
  FreeAndNil(ThisList);

end.