Direct2D (41) : 文本命中测试 - IDWriteTextLayout.HitTestPoint()

uses Direct2D, D2D1;

var iTextLayout: IDWriteTextLayout;

{构建 DWRITE_TEXT_RANGE 结构的函数}
function DWriteTextRange(pos,len: Cardinal): TDwriteTextRange;
begin
  Result.startPosition := pos;
  Result.length := len;
end;

{建立 IDWriteTextLayout}
procedure TForm1.FormCreate(Sender: TObject);
var
  str: string;
  iTextFormat: IDWriteTextFormat;
begin
  str := 'Click on this text.';
  DWriteFactory.CreateTextFormat(
    'Verdana',
    nil,
    DWRITE_FONT_WEIGHT_REGULAR,
    DWRITE_FONT_STYLE_NORMAL,
    DWRITE_FONT_STRETCH_NORMAL,
    48.0,
    'en-us',
    iTextFormat
  );
  iTextFormat.SetTextAlignment(DWRITE_TEXT_ALIGNMENT_CENTER);
  iTextFormat.SetParagraphAlignment(DWRITE_PARAGRAPH_ALIGNMENT_CENTER);

  DWriteFactory.CreateTextLayout(
    PWideChar(str),
    Length(str),
    iTextFormat,
    ClientWidth,
    ClientHeight,
    iTextLayout
  );
end;

{命中测试}
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  bTrailingHit, bInside: BOOL;
  rTestMetrics: TDWriteHitTestMetrics;
begin
  iTextLayout.HitTestPoint(
    X, Y,         //给出位置
    bTrailingHit, //输出布尔值, 表示当前位置是在命中区域的前端还是后端
    bInside,      //输出布尔值, 表示当前位置是在命中区域的内部还是外部
    rTestMetrics  //命中区域的信息结构
  );
  iTextLayout.SetUnderline(False, DWriteTextRange(0, MaxInt));                   //全部取消下划线
  iTextLayout.SetUnderline(True, DWriteTextRange(rTestMetrics.textPosition, 1)); //给命中的区域添加下划线
//  Text := Format('TrailingHit: %d, Inside: %d', [Integer(bTrailingHit), Integer(bInside)]);
  Repaint;
end;

{使用 RenderTarget.DrawTextLayout() 方法绘制文本}
procedure TForm1.FormPaint(Sender: TObject);
var
  cvs: TDirect2DCanvas;
  iBrush: ID2D1SolidColorBrush;
begin
  cvs := TDirect2DCanvas.Create(Canvas, ClientRect);
  cvs.RenderTarget.BeginDraw;
  cvs.RenderTarget.Clear(D2D1ColorF(clWhite));
  cvs.RenderTarget.CreateSolidColorBrush(D2D1ColorF(clBlack), nil, iBrush);
  cvs.RenderTarget.DrawTextLayout(D2D1PointF(0,0), iTextLayout, iBrush);
  cvs.RenderTarget.EndDraw();
  cvs.Free;
end;

{刷新数据及重绘}
procedure TForm1.FormResize(Sender: TObject);
begin
  FormCreate(nil);
  Repaint;
end;

---

效果图：

---