RAD Studio HTML Hint

[Горячий шоколад]

При создании приложений очень часто используются всплывающие текстовые подсказки (hint). В своей работе столкнулся с проблемой: мне (да и другим пользователям) бывает трудно понять / вспомнить через какое-то время смысл того или иного элемента управления (поля ввода). Для решения данной задачи в качестве ЭКСПЕРИМЕНТа был написан модуль HTMLHint. Подключается к проекту и заменяет стандартный класс подсказок. Можно использовать все поддерживаемые теги HtmlViewer. Картинки отображаются через data:image.

Версия Delphi: XE 10.4.2 (в других не проверялось)
Зависимости: HtmlViewer (Для просмотра ссылки Войди или Зарегистрируйся)

Спойлер: Source

unit HTMLHint;

interface

uses
  Winapi.Windows,
  Winapi.Messages,

  System.SysUtils,
  System.Classes,
  System.UITypes,

  Vcl.Controls,
  Vcl.Graphics,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.StdCtrls,
  Vcl.Themes,
  Vcl.GraphUtil,

  HtmlGlobals,
  HTMLUn2,
  HtmlView,
  HTMLSubs;

type
  TNTHTMLHint = class(THintWindow)
  strict private
    FViewer: THtmlViewer;
    FBufferBit: TBitmap;
  protected
    procedure InheritedPaint;
    procedure Paint; override;
    procedure DoParseEnd(Sender: TObject);
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: TCustomData): TRect; override;
  end;

implementation

procedure InitAlpha(B: TBitmap);
type
  PRGBA = ^TRGBA;
  TRGBA = packed record
    case Cardinal of
      0: (Color: Cardinal);
      2: (HiWord, LoWord: Word);
      3: (B, G, R, A: Byte);
    end;
  PRGBAArray = ^TRGBAArray;
  TRGBAArray = array[0..0] of TRGBA;
var
  I: Integer;
begin
  {$RANGECHECKS OFF}
  for I := 0 to B.Width * B.Height - 1 do
    PRGBAArray(B.Scanline[B.Height - 1])[I].Color := $FFFFFFFF;
  {$RANGECHECKS ON}
end;

{ TNTHTMLHint }

function TNTHTMLHint.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: TCustomData): TRect;
var
  CopyList: ThtDocument;
  Dummy: Integer;
  Curs: Integer;
begin
  FViewer.Text := '<nobr>' + AHint + '</nobr>';
        {
  for var I := 0 to FViewer.SectionList.PositionList.Count - 1 do
  begin
    if FViewer.SectionList.PositionList[I] is THtmlTable then
    begin
      (FViewer.SectionList.PositionList[I] as THtmlTable).CellPadding := 0;
      (FViewer.SectionList.PositionList[I] as THtmlTable).CellSpacingHorz := 0;
      (FViewer.SectionList.PositionList[I] as THtmlTable).CellSpacingVert := 0;
    end;
  end;
  FViewer.Reformat;    }

  CopyList := ThtDocument.CreateCopy(FViewer.SectionList);
  try
    Curs := 0;
    CopyList.DoLogic(FBufferBit.Canvas, 0, 2, 2, 300, Dummy, Curs);

    FViewer.Width := Dummy;
    FViewer.Height := FViewer.MaxVertical;

    FBufferBit.Width := Dummy;
    FBufferBit.Height := FViewer.MaxVertical;
    InitAlpha(FBufferBit);

    CopyList.DoLogic(FBufferBit.Canvas, 0, FBufferBit.Width, FBufferBit.Height, 300, Dummy, Curs);

    CopyList.SetYOffset(0);
    CopyList.Draw(FBufferBit.Canvas, Rect(0, 0, FBufferBit.Width, FBufferBit.Height), FViewer.Width, 0, 0, 0, 0);
  finally
    CopyList.Free;
  end;

  Result := Rect(0, 0, FBufferBit.Width, FBufferBit.Height);
  Inc(Result.Right, 4);
  // Inc(Result.Bottom, 2);
end;

constructor TNTHTMLHint.Create(AOwner: TComponent);
begin
  inherited;

  FBufferBit := TBitmap.Create;
  FBufferBit.PixelFormat := TPixelFormat.pf32bit;

  FViewer := THtmlViewer.Create(Self);
  FViewer.BorderStyle := htNone;
  FViewer.Visible := False;

  FViewer.Parent := Self;
  FViewer.Top := 0;
  FViewer.Left := 0;
  FViewer.Width := 10;
  FViewer.Height := 10;
  FViewer.MarginHeight := 2;
  FViewer.MarginWidth := 2;
  FViewer.LoadCursor := crDefault;
  FViewer.Cursor := crDefault;
  FViewer.DefBackground := clInfoBk;
  FViewer.DefFontColor := clInfoText;
  FViewer.DefFontName := Screen.HintFont.Name;
  FViewer.DefFontSize := Screen.HintFont.Size;
  FViewer.ScrollBars := System.UITypes.TScrollStyle.ssNone;
  FViewer.NoSelect := True;

  FViewer.OnParseEnd := DoParseEnd;
end;

destructor TNTHTMLHint.Destroy;
begin
  FreeAndNil(FViewer);
  FreeAndNil(FBufferBit);

  inherited;
end;

procedure TNTHTMLHint.DoParseEnd(Sender: TObject);
begin
end;

procedure TNTHTMLHint.InheritedPaint;
var
  R, ClipRect: TRect;
  LColor: TColor;
  LStyle: TCustomStyleServices;
  LDetails: TThemedElementDetails;
  LGradientStart, LGradientEnd, LTextColor: TColor;
begin
  R := ClientRect;
  LStyle := StyleServices(Screen.ActiveForm);
  LTextColor := Screen.HintFont.Color;
  if LStyle.Enabled then
  begin
    ClipRect := R;
    InflateRect(R, 4, 4);
    if TOSVersion.Check(6) and LStyle.IsSystemStyle then
    begin
      // Paint Windows gradient background
      LStyle.DrawElement(Canvas.Handle, LStyle.GetElementDetails(tttStandardNormal), R, ClipRect);
    end
    else
    begin
      LDetails := LStyle.GetElementDetails(thHintNormal);
      if LStyle.GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then
        LGradientStart := LColor
      else
        LGradientStart := clInfoBk;
      if LStyle.GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then
        LGradientEnd := LColor
      else
        LGradientEnd := clInfoBk;

      if LStyle.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then
        LTextColor := LColor
      else
        LTextColor := Screen.HintFont.Color;

      GradientFillCanvas(Canvas, LGradientStart, LGradientEnd, R, gdVertical);
    end;
    R := ClipRect;
  end;
{  Inc(R.Left, 2);
  Inc(R.Top, 2);
  Canvas.Font.Color := LTextColor;

  DrawText(Canvas.Handle, Caption, -1, R, DT_LEFT or DT_NOPREFIX or
    DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); }
end;

type
  THackHtmlViewer = class(THtmlViewer);

procedure TNTHTMLHint.Paint;
begin
{  Canvas.Lock;
  try
    InheritedPaint;

    Canvas.Draw(0, 0, FBufferBit);
  finally
    Canvas.Unlock;
  end;}
end;

procedure TNTHTMLHint.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
  Canvas.Lock;
  try
    InheritedPaint;

    Canvas.Draw(0, 0, FBufferBit);
  finally
    Canvas.Unlock;
  end;

  Message.Result := 1;
end;

initialization
  HintWindowClass := TNTHTMLHint;

end.