rxhints.pas

灰鸽子1.23源码,,,,,,,

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 2001,2002 SGB Software          }
{         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
{                        Igor Pavluk and Serge Korolev  }
{                                                       }
{*******************************************************}

unit RxHints;

{$I RX.INC}

interface

uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} Messages,
  Graphics, Classes, Controls, Forms, Dialogs;

type
  THintStyle = (hsRectangle, hsRoundRect, hsEllipse);
  THintPos = (hpTopRight, hpTopLeft, hpBottomRight, hpBottomLeft);
  THintShadowSize = 0..15;

  TRxHintWindow = class(THintWindow)
  private
    FSrcImage: TBitmap;
    FImage: TBitmap;
    FPos: THintPos;
    FRect: TRect;
    FTextRect: TRect;
    FTileSize: TPoint;
    FRoundFactor: Integer;
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
{$IFDEF RX_D3}
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
{$ENDIF}
    function CreateRegion(Shade: Boolean): HRgn;
    procedure FillRegion(Rgn: HRgn; Shade: Boolean);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
{$IFDEF RX_D3}
    procedure ActivateHintData(Rect: TRect; const AHint: string;
      AData: Pointer); override;
{$ENDIF}
    function CalcHintRect(MaxWidth: Integer; const AHint: string;
      AData: Pointer): TRect; {$IFDEF RX_D3} override; {$ENDIF}
  end;

procedure SetHintStyle(Style: THintStyle; ShadowSize: THintShadowSize;
  Tail: Boolean; Alignment: TAlignment);
procedure SetStandardHints;
procedure RegisterHintWindow(AClass: THintWindowClass);
function GetHintControl: TControl;

implementation

uses SysUtils, VclUtils, AppUtils, MaxMin;

const
  HintStyle: THintStyle = hsRectangle;
  HintShadowSize: THintShadowSize = 0;
  HintTail: Boolean = False;
  HintAlignment: TAlignment = taLeftJustify;

{ Utility routines }

procedure RegisterHintWindow(AClass: THintWindowClass);
begin
  HintWindowClass := AClass;
  with Application do
    if ShowHint then begin
      ShowHint := False;
      ShowHint := True;
    end;
end;

procedure SetStandardHints;
begin
  RegisterHintWindow(THintWindow);
end;

procedure SetHintStyle(Style: THintStyle; ShadowSize: THintShadowSize;
  Tail: Boolean; Alignment: TAlignment);
begin
  HintStyle := Style;
  HintShadowSize := ShadowSize;
  HintTail := Tail;
  HintAlignment := Alignment;
  RegisterHintWindow(TRxHintWindow);
end;

function GetHintControl: TControl;
var
  CursorPos: TPoint;
begin
  GetCursorPos(CursorPos);
  Result := FindDragTarget(CursorPos, True);
  while (Result <> nil) and not Result.ShowHint do
    Result := Result.Parent;
  if (Result <> nil) and (csDesigning in Result.ComponentState) then
    Result := nil;
end;

procedure StandardHintFont(AFont: TFont);
{$IFDEF WIN32}
var
  NonClientMetrics: TNonClientMetrics;
{$ENDIF}
begin
{$IFDEF WIN32}
  NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    AFont.Handle := CreateFontIndirect(NonClientMetrics.lfStatusFont)
  else begin
    AFont.Name := 'MS Sans Serif';
    AFont.Size := 8;
  end;
  AFont.Color := clInfoText;
{$ELSE}
  AFont.Name := 'MS Sans Serif';
  AFont.Size := 8;
  AFont.Color := clWindowText;
{$ENDIF}
end;

{$IFDEF WIN32}
{$IFNDEF RX_D3}
function GetCursorHeightMargin: Integer;
{ Return number of scanlines between the scanline containing cursor hotspot
  and the last scanline included in the cursor mask. }
var
  IconInfo: TIconInfo;
  BitmapInfoSize: Integer;
  BitmapBitsSize: Integer;
  Bitmap: PBitmapInfoHeader;
  Bits: Pointer;
  BytesPerScanline, ImageSize: Integer;

    function FindScanline(Source: Pointer; MaxLen: Cardinal;
      Value: Cardinal): Cardinal; assembler;
    asm
            PUSH    ECX
            MOV     ECX,EDX
            MOV     EDX,EDI
            MOV     EDI,EAX
            POP     EAX
            REPE    SCASB
            MOV     EAX,ECX
            MOV     EDI,EDX
    end;

begin
  { Default value is entire icon height }
  Result := GetSystemMetrics(SM_CYCURSOR);
  if GetIconInfo(GetCursor, IconInfo) then
  try
    GetDIBSizes(IconInfo.hbmMask, BitmapInfoSize, BitmapBitsSize);
    Bitmap := AllocMem(BitmapInfoSize + BitmapBitsSize);
    try
      Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
      if GetDIB(IconInfo.hbmMask, 0, Bitmap^, Bits^) and
        (Bitmap^.biBitCount = 1) then
      begin
        { Point Bits to the end of this bottom-up bitmap }
        with Bitmap^ do
        begin
          BytesPerScanline := ((biWidth * biBitCount + 31) and not 31) div 8;
          ImageSize := biWidth * BytesPerScanline;
          Bits := Pointer(Integer(Bits) + BitmapBitsSize - ImageSize);
          { Use the width to determine the height since another mask bitmap
            may immediately follow }
          Result := FindScanline(Bits, ImageSize, $FF);
          { In case the and mask is blank, look for an empty scanline in the
            xor mask. }
          if (Result = 0) and (biHeight >= 2 * biWidth) then
            Result := FindScanline(Pointer(Integer(Bits) - ImageSize),
              ImageSize, $00);
          Result := Result div BytesPerScanline;
        end;
        Dec(Result, IconInfo.yHotSpot);
      end;
    finally
      FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
    end;
  finally
    if IconInfo.hbmColor <> 0 then DeleteObject(IconInfo.hbmColor);
    if IconInfo.hbmMask <> 0 then DeleteObject(IconInfo.hbmMask);
  end;
end;
{$ENDIF}
{$ENDIF}

{ TRxHintWindow }

constructor TRxHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  StandardHintFont(Canvas.Font);
  FImage := TBitmap.Create;
  FSrcImage := TBitmap.Create;
end;

destructor TRxHintWindow.Destroy;
begin
  FSrcImage.Free;
  FImage.Free;
  inherited Destroy;
end;

procedure TRxHintWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and not WS_BORDER;
end;

{$IFDEF RX_D3}
procedure TRxHintWindow.WMNCPaint(var Message: TMessage);
begin
end;
{$ENDIF}

procedure TRxHintWindow.WMEraseBkgnd(var Message: TMessage);
begin
  Message.Result := 1;
end;

function TRxHintWindow.CreateRegion(Shade: Boolean): HRgn;
var
  R: TRect;
  W, TileOffs: Integer;
  Tail, Dest: HRgn;
  P: TPoint;

  function CreatePolyRgn(const Points: array of TPoint): HRgn;
  type
    PPoints = ^TPoints;
    TPoints = array[0..0] of TPoint;
  begin
    Result := CreatePolygonRgn(PPoints(@Points)^, High(Points) + 1, WINDING);
  end;

begin
  R := FRect;
  Result := 0;
  if Shade then OffsetRect(R, HintShadowSize, HintShadowSize);
  case HintStyle of
    hsRoundRect: Result := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom,
      FRoundFactor, FRoundFactor);
    hsEllipse: Result := CreateEllipticRgnIndirect(R);
    hsRectangle: Result := CreateRectRgnIndirect(R);
  end;
  if HintTail then begin
    R := FTextRect;
    GetCursorPos(P);
    TileOffs := 0;
    if FPos in [hpTopLeft, hpBottomLeft] then TileOffs := Width;
    if Shade then begin
      OffsetRect(R, HintShadowSize, HintShadowSize);
      Inc(TileOffs, HintShadowSize);