type
  TMemo = class(vcl.stdctrls.TMemo)
  private
    FStartChar, FEndChar: Integer;
    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
  public
    procedure Underline(StartLine, StartChar, EndLine, EndChar: Integer);
  end;
{ TMemo }////////////////////////
procedure TMemo.Underline(StartLine, StartChar, EndLine, EndChar: Integer);
begin
  FStartChar := SendMessage(Handle, EM_LINEINDEX, StartLine, 0) + StartChar;
  FEndChar := SendMessage(Handle, EM_LINEINDEX, EndLine, 0) + EndChar;
  Invalidate;
end;

procedure TMemo.WMPaint(var Msg: TWMPaint);

  function GetLine(CharPos: Integer): Integer;
  begin
    Result := SendMessage(Handle, EM_LINEFROMCHAR, CharPos, 0);
  end;

  procedure DrawLine(First, Last: Integer);
  var
    LineHeight: Integer;
    Pt1, Pt2: TSmallPoint;
    DC: HDC;
    Rect: TRect;
    ClipRgn: HRGN;
  begin
    // font height approximation (compensate 1px for internal leading)
    LineHeight := Abs(Font.Height) - Abs(Font.Height) div Font.Height+3;  //3为 下划线的高度

    // get logical top-left coordinates for line bound characters
    Integer(Pt1) := SendMessage(Handle, EM_POSFROMCHAR, First, 0);
    Integer(Pt2) := SendMessage(Handle, EM_POSFROMCHAR, Last, 0);

    DC := GetDC(Handle);

    // clip to not to draw to non-text area (internal margins)
    SendMessage(Handle, EM_GETRECT, 0, Integer(@Rect));
    ClipRgn := CreateRectRgn(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    SelectClipRgn(DC, ClipRgn);
    DeleteObject(ClipRgn); // done with region

    // set pen color to red and draw line
    SelectObject(DC, GetStockObject(DC_PEN));
   // SetDCPenColor(DC, RGB(255, 0 ,0));
    SelectObject(DC, CreatePen(PS_SOLID, 3, RGB(255, 0, 0)) );  //3 为厚度，255为红色

    MoveToEx(DC, Pt1.x, Pt1.y + LineHeight, nil);
    LineTo(DC, Pt2.x, Pt2.y + LineHeight);

    ReleaseDC(Handle, DC); // done with dc
  end;

var
  StartChar, CharPos, LinePos: Integer;
begin
  inherited;
  if FEndChar > FStartChar then begin

    // Find out where to draw.
    // Can probably optimized a bit by using EM_LINELENGTH
    StartChar := FStartChar;
    CharPos := StartChar;
    LinePos := GetLine(CharPos);
    while True do begin
      Inc(CharPos);
      if GetLine(CharPos) > LinePos then begin
        DrawLine(StartChar, CharPos - 1);
        StartChar := CharPos;
        Dec(CharPos);
        Inc(LinePos);
        Continue;
      end else
        if CharPos >= FEndChar then begin
          DrawLine(StartChar, FEndChar);
          Break;
        end;
    end;
  end;
end;
{  --end TMemo-- } 
procedure TForm2.Button1Click(Sender: TObject);
begin
 Memo1.Underline(7, 14, 8, 17);
end;

image