msnpopup.pas

灰鸽子VIP1.2经典源代码

{
    MsnPopup - using MSN-style popup windows in your Delphi programs
    Copyright (C) 2001-2003 JWB Software

    Web:   http://people.zeelandnet.nl/famboek/delphi/
    Email: [e-mail]
}

Unit MSNPopUp;

Interface

Uses
  Windows, Classes, Graphics, StdCtrls, ExtCtrls, Controls, Forms,
  ShellApi, Dialogs, SysUtils, Messages;

// fix for Delphi-5 users
Const
  WS_EX_NOACTIVATE = $8000000;

Type
  TURLEvent = Procedure(Sender: TObject; URL: String) Of Object;

Type
  TMouseLabel = Class(TLabel)
  private
    { Private declarations }
    fMouseEnter: TNotifyEvent;
    fMouseLeave: TNotifyEvent;
    Procedure CMMouseEnter(Var Message: TMessage); message CM_MOUSEENTER;
    Procedure CMMouseLeave(Var Message: TMessage); message CM_MOUSELEAVE;
  published
    { Published declarations }
    Property OnMouseEnter: TNotifyEvent read fMouseEnter write fMouseEnter;
    Property OnMouseLeave: TNotifyEvent read fMouseLeave write fMouseLeave;
  End;

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

  TMSNPopupOption = (msnAutoOpenURL, msnSystemFont, msnCascadePopups,
    msnAllowScroll, msnAllowHyperlink);

  // Anomy
  TMSNImageDrawMethod = (dmActualSize, dmTile, dmFit);

  TMSNPopupOptions = Set Of TMSNPopupOption;

  TMSNPopUp = Class(TComponent)
  private
    { Private declarations }
    FURL: String;
    FText: String;
    FTitle: String;
    FIcon: TBitmap;
    FWidth: Integer;
    FHeight: Integer;
    FTimeOut: Integer;
    FScrollSpeed: TScrollSpeed;
    FColor1: TColor;
    FColor2: TColor;
    FGradientOrientation: TOrientation;
    FFont: TFont;
    FHoverFont: TFont;
    FTitleFont: TFont;
    FCursor: TCursor;
    FOptions: TMSNPopupOptions;

    // Anomy
    FTextAlignment: TAlignment;
    FBackgroundDrawMethod: TMSNImageDrawMethod;

    //Jelmer
    FPopupMarge, FPopupStartX, FPopupStartY: Integer;
    PopupCount, NextPopupPos: Integer;
    LastBorder: Integer;
    FDefaultMonitor: TDefaultMonitor;
    FBackground: TBitmap;

    FIconLeft, FIconTop: Integer;

    FOnClick: TNotifyEvent;
    FOnURLClick: TURLEvent;

    Procedure SetIcon(Value: TBitmap);
    Function GetEdge: Integer;
    Function GetCaptionFont: TFont;

    // Jiang Hong
    Procedure SetFont(Value: TFont);
    Procedure SetHoverFont(Value: TFont);
    Procedure SetTitleFont(Value: TFont);

    //Jelmer
    Procedure SetBackground(Value: TBitmap);
  public
    { Public declarations }
    Function ShowPopUp: Boolean;
    Procedure ClosePopUps;
  published
    { Published declarations }
    Property Text: String read FText write FText;
    Property URL: String read FURL write FURL;
    Property IconBitmap: TBitmap read FIcon write SetIcon stored True;
    Property IconLeft: Integer read FIconLeft write FIconLeft;
    Property IconTop: Integer read FIconTop write FIconTop;
    Property TimeOut: Integer read FTimeOut write FTimeOut default 10;
    Property Width: Integer read FWidth write FWidth default 175;
    Property Height: Integer read FHeight write FHeight default 175;
    Property GradientColor1: TColor read FColor1 write FColor1;
    Property GradientColor2: TColor read FColor2 write FColor2;
    Property GradientOrientation: TOrientation read FGradientOrientation write FGradientOrientation default mbVertical;
    Property ScrollSpeed: TScrollSpeed read FScrollSpeed write FScrollSpeed default 5;
    Property Font: TFont read FFont write SetFont;
    Property HoverFont: TFont read FHoverFont write SetHoverFont; //Jiang Hong
    Property Title: String read FTitle write FTitle;              //Jiang Hong
    Property TitleFont: TFont read FTitleFont write SetTitleFont; //Jiang Hong
    Property Options: TMSNPopupOptions read FOptions write FOptions;
    // Anomy
    Property TextAlignment: TAlignment read FTextAlignment write FTextAlignment default taLeftJustify;
    Property BackgroundDrawMethod: TMSNImageDrawMethod read FBackgroundDrawMethod write FBackgroundDrawMethod default dmActualSize;
    //Jelmer
    Property TextCursor: TCursor read FCursor write FCursor;
    Property PopupMarge: Integer read FPopupMarge write FPopupMarge;
    Property PopupStartX: Integer read FPopupStartX write FPopupStartX;
    Property PopupStartY: Integer read FPopupStartY write FPopupStartY;
    Property DefaultMonitor: TDefaultMonitor read FDefaultMonitor write FDefaultMonitor;
    Property BackgroundImage: TBitmap read FBackground write SetBackground;

    Property OnClick: TNotifyEvent read FOnClick write FOnClick;
    Property OnURLClick: TURLEvent read FOnURLClick write FOnURLClick;

    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
  End;

Type
  TfrmMSNPopUp = Class(TCustomForm)
    pnlBorder: TPanel;
    imgIcon: TImage;
    lblText: TMouseLabel;
    imgGradient: TImage;
    // add by Ahmed Hamed 21-3-2002
    imgMsn: TImage;
    //
    tmrExit: TTimer;
    tmrScroll: TTimer;
    // add by Ahmed Hamed 20-3-2002
    tmrScrollDown: TTimer;
    //
    lblTitle: TMouseLabel;
    // Added by Anomy

    Procedure lblTextMouseEnter(Sender: TObject);
    Procedure lblTextMouseLeave(Sender: TObject);
    Procedure lblTextClick(Sender: TObject);
    Procedure tmrExitTimer(Sender: TObject);
    // add by Ahmed Hamed 20-3-2002
    Procedure tmrscrollDownTimer(Sender: TObject);
    //
    Procedure lblTextMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    Procedure lblTitleMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    Procedure tmrScrollTimer(Sender: TObject);
    Procedure imgIconMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    Procedure imgGradientMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  protected
    Procedure CreateParams(Var Params: TCreateParams); override;
    Procedure DoClose(Var Action: TCloseAction); override;
  private
    //Jelmer
    PopupPos: Integer;
    ParentMSNPopup: TMSNPopup;
    CanClose: Boolean;

    // Anomy
    BGDrawMethod: TMSNImageDrawMethod;

    Function CalcColorIndex(StartColor, EndColor: TColor; Steps, ColorIndex: Integer): TColor;
    Procedure PositionText;
    Function IsWinXP: Boolean;
  public
    { Public declarations }
    URL, Text, Title: String;
    TimeOut: Integer;
    Icon: TBitmap;
    sWidth: Integer;
    sHeight: Integer;
    bScroll, bHyperlink: Boolean;
    Color1, Color2: TColor;
    Orientation: TOrientation;
    ScrollSpeed: TScrollSpeed;
    Font, HoverFont, TitleFont: TFont;
    StoredBorder: Integer;
    Cursor: TCursor;

    Constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
    Procedure PopUp;
  End;

Procedure Register;
Function IsNT4: Boolean;

Implementation

{$R *.res}

Function IsNT4: Boolean;
Var
  VersionInfo: _OSVERSIONINFOA;
Begin
  Result := False;

  VersionInfo.dwOSVersionInfoSize := sizeof(VersionInfo);
  GetVersionEx(VersionInfo);

  If VersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT Then
   Begin
    If (VersionInfo.dwMajorVersion <= 4) and ((VersionInfo.dwMinorVersion = 0) or
      (VersionInfo.dwMinorVersion = 51)) Then
      Result := True;
   End;
End;

Procedure Register;
Begin
  RegisterComponents('Custom', [TMSNPopUp]);
End;

// mouselabel-stuff

Procedure TMouseLabel.CMMouseEnter(Var Message: TMessage);
Begin
  If assigned(fMouseEnter) Then
    fMouseEnter(self);
End;

Procedure TMouseLabel.CMMouseLeave(Var Message: TMessage);
Begin
  If assigned(fMouseLeave) Then
    fMouseLeave(self);
End;

// component stuff

Function TMSNPopUp.ShowPopUp: Boolean;
Var
  r: TRect;
  MSNPopUp: TfrmMSNPopUp;
Begin
  //Jelmer
  If GetEdge <> LastBorder Then
   Begin
    LastBorder := GetEdge;
    PopupCount := 0;
   End;
  Result := True;
  SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
  If PopupCount > 0 Then
   Begin
    Case LastBorder Of
      ABE_BOTTOM:
        If (r.Bottom - (NextPopupPos + FHeight + PopupStartY)) < 0 Then
         Begin
          Result := False;
          Exit;
         End;
      ABE_LEFT:
        If (NextPopupPos + FWidth + PopupStartX) > r.Right Then
         Begin
          Result := False;
          Exit;
         End;
      ABE_RIGHT:
        If (r.Right - (NextPopupPos + FHeight + PopupStartY)) < 0 Then
         Begin
          Result := False;
          Exit;
         End;
      ABE_TOP:
        If ((NextPopupPos + FHeight + PopupStartY)) > r.Bottom Then
         Begin
          Result := False;
          Exit;
         End;
     End;
   End
  Else
    NextPopupPos := 0;
  Inc(PopupCount);

  MSNPopUp := TfrmMSNPopUp.CreateNew(Self.Owner);
  MSNPopUp.Hide;

  //Jelmer
  MSNPopUp.ParentMSNPopup := Self;
  MSNPopUp.DefaultMonitor := FDefaultMonitor;

  MSNPopUp.sWidth  := FWidth;
  MSNPopUp.sHeight := FHeight;

  MSNPopUp.Text    := FText;
  MSNPopUp.URL     := FURL;
  MSNPopUp.Title   := FTitle;
  MSNPopUp.TimeOut := FTimeOut;

  MSNPopUp.Icon := FIcon;

  MSNPopUp.bScroll     := msnAllowScroll in FOptions;
  MSNPopUp.bHyperlink  := msnAllowHyperlink in FOptions;
  MSNPopUp.ScrollSpeed := FScrollSpeed;

  MSNPopUp.Font      := FFont;
  MSNPopUp.HoverFont := FHoverFont;
  MSNPopUp.TitleFont := FTitleFont;
  MSNPopUp.Cursor    := FCursor;

  MSNPopUp.Color1      := FColor1;
  MSNPopUp.Color2      := FColor2;
  MSNPopUp.Orientation := FGradientOrientation;

  // Anomy
  MSNPopUp.lblText.Alignment := FTextAlignment;
  MSNPopUp.pnlBorder.Align   := alClient;
  MSNPopUp.BGDrawMethod      := FBackgroundDrawMethod;

  MSNPopUp.PopUp;
End;

// JWB
Procedure TMSNPopUp.ClosePopUps;
Var
  hTfrmMSNPopUp: Cardinal;
  i: Integer;
Begin
  For i := 0 To PopUpCount Do
   Begin
    hTfrmMSNPopUp := FindWindow(PChar('TfrmMSNPopUP'), nil);
    If hTfrmMSNPopUp <> 0 Then
     Begin
      SendMessage(hTfrmMSNPopUp, WM_CLOSE, 0,0);
      Application.ProcessMessages;
     End;
   End;
End;

//Jiang Hong
Procedure TMSNPopup.SetFont(Value: TFont);
Begin
  If not (FFont = Value) Then
    FFont.Assign(Value);
End;

//Jiang Hong
Procedure TMSNPopup.SetHoverFont(Value: TFont);
Begin
  If not (FHoverFont = Value) Then
    FHoverFont.Assign(Value);
End;

//Jiang Hong
Procedure TMSNPopup.SetTitleFont(Value: TFont);
Begin
  If not (FTitleFont = Value) Then
    FTitleFont.Assign(Value);
End;

Procedure TMSNPopUp.SetIcon(Value: TBitmap);
Begin
  If Value <> Self.FIcon Then
   Begin
    Self.FIcon.Assign(Value);
   End;
End;

// function to find out system's default font
Function TMSNPopUp.GetCaptionFont: TFont;
Var
  ncMetrics: TNonClientMetrics;
Begin
  ncMetrics.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(TNonClientMetrics), @ncMetrics, 0);

  Result        := TFont.Create;
  Result.Handle := CreateFontIndirect(ncMetrics.lfMenuFont);
End;

Constructor TMSNPopUp.Create(AOwner: TComponent);
Begin
  Inherited;

  FOptions := [msnAllowScroll, msnAllowHyperlink, msnAutoOpenURL, msnCascadePopups];

  FIcon      := TBitmap.Create;
  FFont      := TFont.Create;
  FHoverFont := TFont.Create;
  FTitleFont := TFont.Create;

  //Jelmer
  FBackground := TBitmap.Create();

  If msnSystemFont in FOptions Then
   Begin
    FFont.Name      := GetCaptionFont.Name;
    FHoverFont.Name := GetCaptionFont.Name;
    FTitleFont.Name := GetCaptionFont.Name;
   End;

  FWidth  := 148;
  FHeight := 121;

  FTimeOut     := 10;
  FScrollSpeed := 9;

  FIconLeft := 8;
  FIconTop  := 8;

  FText  := 'text';
  FURL   := 'http://www.url.com/';
  FTitle := 'title';

  FCursor := crDefault;

  FColor1 := $00FFCC99;
  FColor2 := $00FFFFFF;
  FGradientOrientation := mbVertical;

  FHoverFont.Style := [fsUnderline];
  FHoverFont.Color := clBlue;

  FTitleFont.Style := [fsBold];

  // Anomy
  FBackgroundDrawMethod := dmActualSize;
  FTextAlignment        := taCenter;

  //Jelmer
  PopupCount   := 0;
  LastBorder   := 0;
  FPopupMarge  := 2;
  FPopupStartX := 16;
  FPopupStartY := 2;
  //---
End;

Destructor TMSNPopUp.Destroy;
Begin
  FIcon.Free;
  FFont.Free;
  FHoverFont.Free;
  FTitleFont.Free;

  //Jelmer
  FBackground.Free;

  Inherited;
End;

// form's functions

Procedure TfrmMSNPopUp.CreateParams(Var Params: TCreateParams);
Const
  CS_DROPSHADOW = $00020000;   // MS 12/01/2002
Begin
  Inherited;
  Params.Style := Params.Style and not WS_CAPTION or WS_POPUP;

  If IsNT4 Then
    Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW
  Else
    Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW or WS_EX_NOACTIVATE;

  If (IsWinXP) Then
    Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;

  Params.WndParent := GetDesktopWindow;
End;

Constructor TfrmMSNPopUp.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
Begin
  Inherited;
  BorderStyle := bsDialog;

  pnlBorder        := TPanel.Create(Self);
  pnlBorder.Parent := Self;
  pnlBorder.Align  := alClient;
  pnlBorder.BevelWidth := 2;
  pnlBorder.BevelOuter := bvLowered;

  imgGradient           := TImage.Create(Self);
  imgGradient.Parent    := pnlBorder;
  imgGradient.Align     := alClient;
  imgGradient.Anchors   := [akTop, akLeft, akRight, akBottom];
  imgGradient.OnMouseUp := Self.imgGradientMouseUp;

  imgIcon           := TImage.Create(Self);
  imgIcon.Parent    := pnlBorder;
  imgIcon.Left      := 3;
  imgIcon.Top       := 8;
  imgIcon.OnMouseUp := Self.imgIconMouseUp;

  lblText           := TMouseLabel.Create(Self);
  lblText.ShowAccelChar := False;
  lblText.Layout    := tlCenter;
  lblText.AutoSize  := True;
  lblText.WordWrap  := True;
  lblText.Parent    := pnlBorder;
  lblText.Transparent := True;
  lblText.OnMouseEnter := Self.lblTextMouseEnter;
  lblText.OnMouseLeave := Self.lblTextMouseLeave;
  lblText.OnClick   := Self.lblTextClick;
  lblText.OnMouseUp := Self.lblTextMouseUp;
  lblText.Left      := 9;
  lblText.Top       := 49;
  lblText.Width     := 3;
  lblText.Height    := 13;

  lblTitle           := TMouseLabel.Create(Self);
  lblTitle.ShowAccelChar := False;
  lblTitle.Parent    := pnlBorder;
  lblTitle.Transparent := True;
  lblTitle.Top       := 8;
  lblTitle.Left      := 48;
  lblTitle.OnMouseUp := Self.lblTitleMouseUp;

  tmrExit          := TTimer.Create(Self);
  tmrExit.Enabled  := False;
  tmrExit.OnTimer  := tmrExitTimer;
  tmrExit.Interval := 10000;

  tmrScroll          := TTimer.Create(Self);
  tmrScroll.Enabled  := False;
  tmrScroll.OnTimer  := tmrScrollTimer;
  tmrScroll.Interval := 25;
  // add by Ahmed Hamed 20-3-2002
  tmrScrollDown          := TTimer.Create(Self);
  tmrScrollDown.Enabled  := False;
  tmrScrollDown.OnTimer  := tmrScrollDownTimer;
  tmrScrollDown.Interval := 25;
  //
End;