如何增强Delphi中的默认备忘录控件,并能够为文本加下划线

下面是一些使用常规winapi的D2007代码示例,它将向您展示如何在可滚动的备忘录中找到绘制位置以及如何绘制简单的下划线.为简洁起见,它没有错误捕获/处理.还只允许一个下划线范围,因为作为组件的可用性不是样本的目的.尝试使用垂直滚动备忘录,但如果您愿意,如果出现问题,您应该能够微调细节.

在2K,XP和7上测试,XP上的外观如下：

memo with underlined text http://img687.imageshack.us/img687/8176/20101210061602.png

和代码：

type
  TMemo = class(stdctrls.TMemo)
  private
    FStartChar,FEndChar: Integer;
    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
  public
    procedure Underline(StartLine,StartChar,EndLine,EndChar: Integer);
  end;

  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TMemo }

procedure TMemo.Underline(StartLine,EndChar: Integer);
begin
  FStartChar := SendMessage(Handle,EM_LINEINDEX,StartLine,0) + StartChar;
  FEndChar := SendMessage(Handle,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;

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

    DC := GetDC(Handle);

    // clip to not to draw to non-text area (internal margins)
    SendMessage(Handle,EM_GETRECT,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));
    MoveToEx(DC,Pt1.x,Pt1.y + LineHeight,nil);
    LineTo(DC,Pt2.x,Pt2.y + LineHeight);

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

var
  StartChar,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 TForm1.Button1Click(Sender: TObject);
begin
  Memo1.Underline(7,14,8,17);
end;

编辑：忘记提及,在键入时你可能会删除下划线.我不知道它在键入时应该如何表现,并且可能很难实现所期望的行为.