shintmanager.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

unit sHintManager;
{$I sDefs.inc}
{.$DEFINE LOGGED}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  sGraphUtils, sConst, acntUtils, ExtCtrls, IniFiles, sHtmlParse;

{$IFNDEF NOTFORHELP}
const
  DefStyle = hsEllipse;
  DefAnimationTime = 250;
{$ENDIF} // NOTFORHELP

type
{$IFNDEF NOTFORHELP}
  TsMousePosition = (mpLeftTop, mpLeftBottom, mpRightTop, mpRightBottom);
  TsHintsEffectsMode = (hmNone, hmSystem, hmCustom);
  TsHintManager = class;
  TsCustomHintWindow = class;

  TsHintKind = class(TPersistent)
  private
    FOwner : TsHintManager;
    FShadowEnabled: boolean;
    FMarginV: integer;
    FTexturePercent: integer;
    FShadowBlur: integer;
    FTransparency: integer;
    FGradientPercent: integer;
    FMarginH: integer;
    FExOffset: integer;
    FShadowTransparency: integer;
    FShadowOffset: integer;
    FBevelWidth: integer;
    FMaxWidth: integer;
    FRadius: integer;
    FBevel: integer;
    FGradientData: string;
    FTextureFile: string;
    FColorBorderTop: TColor;
    FColorBorderBottom: TColor;
    FColor: TColor;
    FShadowColor: TColor;
    FFont: TFont;
    FTexture: TPicture;
    FStyle: TsHintStyle;
    FBlur: integer;
    procedure SetFont(const Value: TFont);
    procedure SetStyle(const Value: TsHintStyle);
    procedure SetTexture(const Value: TPicture);
    function GetShadowEnabled: boolean;
    function GetShadowBlur: integer;
    function GetShadowOffset: integer;
    function GetShadowTransparency: integer;
    procedure SetBlur(const Value: integer);
    procedure SetShadowColor(const Value: TColor);
  public
    constructor Create (AOwner: TsHintManager);
    destructor Destroy; override;
  published
    property Style: TsHintStyle read FStyle write SetStyle default DefStyle;
    property Radius : integer read FRadius write FRadius default 20;
    property BevelWidth : integer read FBevelWidth write FBevelWidth default 1;
    property Blur : integer read FBlur write SetBlur Default 0; // Leaved for compatibility, should be removed later
    property ExOffset : integer read FExOffset write FExOffset default 32;
    property GradientData : string read FGradientData write FGradientData;
    property Texture : TPicture read FTexture write SetTexture;
    property TextureFile : string read FTextureFile write FTextureFile;
    property GradientPercent : integer read FGradientPercent write FGradientPercent default 0;
    property TexturePercent : integer read FTexturePercent write FTexturePercent default 0;
    property Bevel : integer read FBevel write FBevel;
    property Color : TColor read FColor write FColor;
    property ColorBorderTop : TColor read FColorBorderTop write FColorBorderTop;
    property ColorBorderBottom : TColor read FColorBorderBottom write FColorBorderBottom;
    property Transparency : integer read FTransparency write FTransparency;

    property ShadowBlur : integer read GetShadowBlur write FShadowBlur;
    property ShadowColor : TColor read FShadowColor write SetShadowColor default clBlack; // Leaved for compatibility, should be removed later
    property ShadowEnabled : boolean read GetShadowEnabled write FShadowEnabled;
    property ShadowOffset : integer read GetShadowOffset write FShadowOffset;
    property ShadowTransparency : integer read GetShadowTransparency write FShadowTransparency;
    property MarginH : integer read FMarginH write FMarginH default 15;
    property MarginV : integer read FMarginV write FMarginV default 10;
    property MaxWidth : integer read FMaxWidth write FMaxWidth default 200;
    property Font: TFont read FFont write SetFont;
  end;

{$ENDIF}
  TacShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo; var Frame : TFrame) of object;

  TsHintManager = class(TComponent)
{$IFNDEF NOTFORHELP}
  private
    FPauseHide: integer;
    FHTMLMode : boolean;
    FTempHint: TsCustomHintWindow;
    FPredefinitions: TsHintsPredefinitions;
    FOnShowHint: TacShowHintEvent;
    FHintKind: TsHintKind;
    FDefaultMousePos: TsMousePosition;
    FAnimated: boolean;
    FHintPos: TPoint;
{$IFNDEF ACHINTS}
    FSkinSection: TsSkinSection;
    FUseSkinData: boolean;
{$ENDIF}
    procedure SetNewStyle(hs: TsHintStyle);
    procedure SetPredefinitions(const Value: TsHintsPredefinitions);
    function GetAnimated: boolean;
{$IFNDEF ACHINTS}
    procedure SetSkinData(const Value: boolean);
    procedure SetPauseHide(const Value: integer);
{$ENDIF}
  public
    FForm : TCustomForm;
    FCacheBmp : TBitmap;
    procedure OnShowHintApp(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure AfterConstruction; override;
    procedure Invalidate;
    procedure PaintBG(BGBmp : TBitmap; R : TRect; ci : TCacheInfo);
    procedure ShowHint(TheControl: TControl; HintText: String);
    procedure HideHint;
    procedure UpdateProperties;
    function Skinned : boolean;
  published
{$ENDIF} // NOTFORHELP
    property OnShowHint: TacShowHintEvent read FOnShowHint write FOnShowHint;
    property Animated : boolean read GetAnimated write FAnimated default True;
    property DefaultMousePos : TsMousePosition read FDefaultMousePos write FDefaultMousePos default mpLeftTop;
    property HintKind: TsHintKind read FHintKind write FHintKind;
    property HTMLMode : boolean read FHTMLMode write FHTMLMode default False;
    property PauseHide : integer read FPauseHide write SetPauseHide default 5000;
    property Predefinitions : TsHintsPredefinitions read FPredefinitions write SetPredefinitions default shEllipse;
{$IFNDEF ACHINTS}
    property SkinSection : TsSkinSection read FSkinSection write FSkinSection;
    property UseSkinData : boolean read FUseSkinData write SetSkinData default False;
{$ENDIF}
  end;

{$IFNDEF NOTFORHELP}
  TsCustomHintWindow = class(THintWindow)
  private
    FHintLocation: TPoint;
    procedure WMEraseBkGND (var Message: TWMPaint); message WM_ERASEBKGND;
    procedure WMNCPaint (var Message: TWMPaint); message WM_NCPaint;
    procedure PrepareMask;
  protected
    SkinIndex, BorderIndex, BGIndex : integer;
    rgn : hrgn;
    dx, dy : integer;
    FMousePos : TsMousePosition;
    procedure CreateParams(var Params: TCreateParams); override;
    function GetMousePosition : TPoint; virtual;
    function MainRect: TRect; dynamic;
    function ShadowTransparency : integer;
    procedure WndProc(var Message: TMessage); override;
    function SkinMargin(Border : byte): integer;
  public
    BodyBmp: TBitmap;
    MaskBmp : TBitmap; // for debug
    ScreenBmp : TBitmap; // for debug
    AlphaBmp : TBitmap;
    function GetMask : TBitmap; dynamic;
    function GetBody : TBitmap; dynamic;
    procedure PaintShadow(Bmp : TBitmap = nil); virtual;
    property HintLocation: TPoint read FHintLocation write FHintLocation;
    procedure Paint; override;
    procedure PaintBG(Bmp: TBitmap; aRect: TRect); dynamic;
    procedure PaintBorder(Bmp: TBitmap); dynamic;
    procedure TextOut(Bmp: TBitmap); dynamic;
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
  end;

  { Hint window type for style hsSimply}
  TsSimplyHintWindow = class(TsCustomHintWindow)
  public
    procedure PaintShadow(Bmp : TBitmap = nil); override;
    function GetMask : TBitmap; override;
    function GetBody : TBitmap; override;
    function GetMousePosition : TPoint; override;
    procedure PaintBorder(Bmp: TBitmap); override;
  end;

  { Hint window type for style hsComics}
  TsComicsHintWindow = class(TsCustomHintWindow)
  public
    function MainRect: TRect; override;
    procedure PaintShadow(Bmp : TBitmap = nil); override;
    function GetMask : TBitmap; override;
    function GetArrowPosition : TPoint;
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
    function GetBody : TBitmap; override;
    procedure PaintBorder(Bmp: TBitmap); override;
  end;

  { Hint window type for style hsEllipse}
  TsEllipseHintWindow = class(TsCustomHintWindow)
  public
    function GetArrowPosition : TPoint;
    function GetBody : TBitmap; override;
    function GetMask : TBitmap; override;
    function MainRect: TRect; override;
    procedure PaintShadow(Bmp : TBitmap = nil); override;
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
    procedure PaintBorder(Bmp: TBitmap); override;
  end;

  { Hint window type for style hsBalloon}
  TsBalloonHintWindow = class(TsCustomHintWindow)
  public
    BalloonCount : integer;
    Divid : integer;
    procedure PaintShadow(Bmp : TBitmap = nil); override;
    function GetMask : TBitmap; override;
    function GetCustMask(Shadow : boolean) : TBitmap;
    function GetBody : TBitmap; override;
    function GetArrowPosition : TPoint;
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
    constructor Create(AOwner:TComponent); override;
    function MainRect: TRect; override;
    procedure PaintBorder(Bmp: TBitmap); override;
  end;

var
  Manager : TsHintManager;
  acHintsInEditor : boolean = False;

{$IFDEF ACHINTS}
procedure Register;
{$ENDIF}
{$ENDIF} // NOTFORHELP

implementation

uses {$IFNDEF ACHINTS}sVclUtils, sMessages, sSkinProps, sSkinManager, {$ENDIF}
  sGradient, math, sStyleSimply, sAlphaGraph{$IFDEF LOGGED}, sDebugMsgs{$ENDIF};

{$IFDEF DELPHI5}
const
  WS_EX_LAYERED = $00080000;
  LWA_ALPHA = $00000002;
  ULW_ALPHA = $00000002;
  AC_SRC_ALPHA = $01;
{$ENDIF}

const
  NCS_DROPSHADOW = $20000;
  DelayValue = 8;
  SkinBorderWidth = 4;

var
  FBlend: TBlendFunction;
  HintFrame : TFrame = nil;

function Layered: Boolean;
begin
  Result := @UpdateLayeredWindow <> nil;
end;

{$IFDEF ACHINTS}
procedure Register;
begin
  RegisterComponents('AlphaTools', [TsHintManager]);
end;
{$ENDIF}

{ TsHintManager }

procedure BorderByMask(SrcBmp, MskBmp: TBitmap; ColorTop, ColorBottom: TsColor);
var
  S1, S2, S2t, S2b : PRGBArray;
  t, b : boolean;
  X, Y, sw, sh: Integer;
  function BlackPoint(c: TsRGB) : boolean;
  begin
    Result := c.R + c.G + c.B < 765;
  end;
begin
  S2t := nil;
  S2b := nil;
  sh := SrcBmp.Height - 1;
  sw := SrcBmp.Width - 1;
  if SrcBmp.Height <> MskBmp.Height then Exit;
  if SrcBmp.Width <> MskBmp.Width then Exit;
  if SrcBmp.Height < 1 then Exit;
  if SrcBmp.Width < 1 then Exit;
  for Y := 0 to sh do begin
    S1 := SrcBmp.ScanLine[Y];
    S2 := MskBmp.ScanLine[Y];
    if Y > 0 then begin
      S2t := MskBmp.ScanLine[Y - 1];
      t := True;
    end
    else t := False;
    if Y < SrcBmp.Height - 1 then begin
      S2B := MskBmp.ScanLine[Y + 1];
      b := True;
    end
    else b := False;

    for X := 0 to sw do begin
      if BlackPoint(S2[X]) then begin
        if ((X > 0) and not BlackPoint(S2[X - 1])) or (X = 0) or (t and not BlackPoint(S2t[X])) or not t then begin
          S1[X].R := ColorTop.R;
          S1[X].G := ColorTop.G;
          S1[X].B := ColorTop.B;
        end
        else
        if ((X < SrcBmp.Width - 1) and not BlackPoint(S2[X + 1])) or (X = SrcBmp.Width - 1) or (b and not BlackPoint(S2b[X])) or not b then begin
          S1[X].R := ColorBottom.R;
          S1[X].G := ColorBottom.G;
          S1[X].B := ColorBottom.B;
        end;
      end;
    end
  end;
END;

constructor TsHintManager.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FForm := GetParentForm(TControl(AOwner));
  FHintKind := TsHintKind.Create(Self);

  FCacheBmp := CreateBmp24(0, 0);

  FHTMLMode := False;
  FPauseHide := 5000;
  FDefaultMousePos := mpLeftTop;
  FHintPos := Point(-1, -1);

  Application.HintPause := 500;
  Application.HintShortPause := 200;

  FPreDefinitions := shEllipse;
  FAnimated := True;
{$IFNDEF ACHINTS}
  FUseSkinData := False;
{$ENDIF}
  if not (csDesigning in ComponentState) then Application.OnShowHint := OnShowHintApp;
end;

destructor TsHintManager.Destroy;
begin
  FreeAndNil(FCacheBmp);
  FreeAndNil(FHintKind);
  inherited;
end;

procedure TsHintManager.Invalidate;
begin
  PreDefinitions := FPreDefinitions;
  HintKind.Style := HintKind.Style;
end;

procedure TsHintManager.Loaded;
begin
  inherited;
  Application.HintHidePause := FPauseHide;
{$IFNDEF ACHINTS}
  if FSkinSection = '' then FSkinSection := s_Hint;
{$ENDIF}
  SetNewStyle(HintKind.Style);
  if not (csDesigning in ComponentState) then UpdateProperties;
end;

procedure TsHintManager.OnShowHintApp(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
begin
  FHintPos := HintInfo.HintPos;
  if Assigned(FOnShowHint) then FOnShowHint(HintStr, CanShow, HintInfo, HintFrame) else inherited;
  if (FHintPos.x <> HintInfo.HintPos.x) and (FHintPos.y <> HintInfo.HintPos.y) then FHintPos := HintInfo.HintPos else begin
  end;
end;

procedure TsHintManager.PaintBG(BGBmp: TBitmap; R: TRect; ci: TCacheInfo);
var
  aRect: TRect;
  TransColor : TsColor;
  Transparency : integer;
  iDrawed : boolean;
  TempBmp : TBitmap;