lxpopup.pas

专用于PC进销存软件

unit lxpopup;

interface

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

Const
  WS_EX_NOACTIVATE = $8000000;

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

  TMSNPopupOption = (msnSystemFont, msnCascadePopups, msnAllowScroll);

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

  TMSNPopupOptions = Set Of TMSNPopupOption;

  TMSNPopUp = Class(TComponent)
  private
    { Private declarations }
    FText: String;
    FTitle: String;
    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;

    FOnClick: TNotifyEvent;

    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 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;

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

Type
  TfrmMSNPopUp = Class(TCustomForm)
    pnlBorder: TPanel;
    lblText: TLabel;
    imgGradient: TImage;

    tmrExit: TTimer;
    tmrScroll: TTimer;
    // add by Ahmed Hamed 20-3-2002
    tmrScrollDown: TTimer;
    //
    lblTitle: TLabel;
    // Added by Anomy

    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 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 }
    Text, Title: String;
    TimeOut: Integer;
    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

procedure Register;
begin
  RegisterComponents('liuxiangvcl', [lxpopup]);
end;

{ TMSNPopUp }

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;

constructor TMSNPopUp.Create(AOwner: TComponent);
Begin
  Inherited;
  //FOptions := [msnAllowScroll, msnAllowHyperlink, msnAutoOpenURL, msnCascadePopups];
  FOptions := [msnAllowScroll,msnCascadePopups];

  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;
  FWidth  := 200;
  FHeight := 100;

  FTimeOut     := 10;
  FScrollSpeed := 9;

  FText  := 'text';
  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
  FFont.Free;
  FHoverFont.Free;
  FTitleFont.Free;

  //Jelmer
  FBackground.Free;

  Inherited;
End;

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;


function TMSNPopUp.GetEdge: Integer;
Var
  AppBar: TAppbarData;
Begin
  Result := -1;

  FillChar(AppBar, sizeof(AppBar), 0);
  AppBar.cbSize := Sizeof(AppBar);

  If ShAppBarMessage(ABM_GETTASKBARPOS, AppBar) <> 0 Then
   Begin
    If ((AppBar.rc.top = AppBar.rc.left) and (AppBar.rc.bottom > AppBar.rc.right)) Then
      Result := ABE_LEFT
    Else If ((AppBar.rc.top = AppBar.rc.left) and (AppBar.rc.bottom < AppBar.rc.right)) Then
      Result := ABE_TOP
    Else If (AppBar.rc.top > AppBar.rc.left) Then
      Result := ABE_BOTTOM
    Else
      Result := ABE_RIGHT;
   End;
End;

procedure TMSNPopUp.SetBackground(Value: TBitmap);
Begin
  If Value <> Self.FBackground Then
   Begin
    Self.FBackground.Assign(Value);
   End;
End;

procedure TMSNPopUp.SetFont(Value: TFont);
begin
  If not (FFont = Value) Then
    FFont.Assign(Value);
end;

procedure TMSNPopUp.SetHoverFont(Value: TFont);
Begin
  If not (FHoverFont = Value) Then
    FHoverFont.Assign(Value);
End;

procedure TMSNPopUp.SetTitleFont(Value: TFont);
Begin
  If not (FTitleFont = Value) Then
    FTitleFont.Assign(Value);
End;

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.Title   := FTitle;
  MSNPopUp.TimeOut := FTimeOut;

  MSNPopUp.bScroll     := msnAllowScroll 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;

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;

{ TfrmMSNPopUp }

function TfrmMSNPopUp.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
  // Initialize
  NumColors := Steps;
  Dec(ColorIndex);

  // Values are set
  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];

  // Calculate the bands color
  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);

  // The final color is returned
  Result := RGB(Red, Green, Blue);
End;


constructor TfrmMSNPopUp.CreateNew(AOwner: TComponent; Dummy: Integer);
Begin
  Inherited;
  BorderStyle := bsNone; //bsDialog;

  pnlBorder        := TPanel.Create(Self);
  pnlBorder.Parent := Self;
  pnlBorder.Align  := alClient;
  pnlBorder.BevelWidth := 1;
  pnlBorder.BevelInner := bvLowered;