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;

---

效果图：

---