有点像Word的自动拼写检查并替换的功能吧

给下基本思路：
 首先，每个红色字串都有与他一一对应的几个选项（像选中“发热”就能关联到“不发热|不知发热”，选中“不发热”就能关联到“发热|不知发热”）。这个关联的生成机制需要你自己完成。

其次，推荐使用RichEdit。当单击右键时，自动检测光标周围有没有红色字体，若有则取出该字符串，并由此关联到可选项，将可选项加入菜单即可

颜色区别和颜色右键可以实现。，，问题就是右键取值和弹出框，，怎么实现，，一直想不出办法，

还有[发热|不发热|不知发热]这个显示出来要隐藏还是，怎么处理。。

弹框用popupmenu啊

无聊给你写了一个

unit Unit1;



interface



uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs,Gdiplus,GdipUtil, ExtCtrls, Menus;



type

  TReplaceText = record

    TIdx           : Integer;

    TStart         : Integer;

    TEnd           : Integer;

    DrawRect       : TRect;

    StartText      : array[0..255] of Char;

    RepalceText    : array[0..255] of Char;

  end;

  TReplaceTextArray = array of TReplaceText;

  TForm1 = class(TForm)

    pb1: TPaintBox;

    pmText: TPopupMenu;

    procedure FormCreate(Sender: TObject);

    procedure pb1Paint(Sender: TObject);

    procedure pb1MouseDown(Sender: TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

    procedure pb1MouseMove(Sender: TObject; Shift: TShiftState; X,

      Y: Integer);

    procedure FormDestroy(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

    FReplaceText : TReplaceTextArray;

    procedure GetReplaceText(str : string;var ReplaceText : TReplaceTextArray);

    function  GetReplaceIndex(x : Integer) : Integer;

    function  GetReplaceStr(ReplaceText : TReplaceText) : string;

    procedure OnMenuClick(Sender : TObject);

  end;



var

  Form1: TForm1;

  GString : string = '一个人[最好在|不再|不知]家，二个人[发热|不发热|不知发热]中';

implementation



{$R *.dfm}

function DrawString(gp : TGpGraphics; str : string; FontName : TFontName; Size : Integer ; x,y : Single;color : TColor) : Single;

  var gFamily : TGpFontFamily;

      format: TGpStringFormat;

      path: TGPGraphicsPath;

      gBrush : TGpSolidBrush;

      origin: TGpPointF;

      rc : TGpRectF;

begin

  gp.SmoothingMode := smAntiAlias;

  try

    gFamily := TGpFontFamily.Create(FontName);

  except

    gFamily := TGpFontFamily.Create('Arial');

  end;

  path := TGpGraphicsPath.Create();

  format := TGpStringFormat.Create();

  format.Alignment := saCenter;

  format.LineAlignment := saCenter;

  gBrush := TGpSolidBrush.Create(ARGBFromTColor(color));

  origin.X := x;

  origin.Y := y;

  path.AddString(str,gFamily,[fsBold],Size,origin,format);

  gp.FillPath(gBrush,path);

  FreeAndNil(format);

  FreeAndNil(gFamily);

  FreeAndNil(gBrush);

  FreeAndNil(path);

end;



procedure TForm1.GetReplaceText(str: string;  var ReplaceText: TReplaceTextArray);

  var stemp,stext : string;

      istart,iend ,icount, cstart,cend: Integer;

begin

  if str = '' then Exit;

  stemp := str;

  istart := 1;

  cend := 0;

  cstart := 0;

  icount := 0;

  iend := 0;

  istart := Pos('[',stemp);

  while  Length(stemp) > 1  do

  begin

    Inc(icount);

    SetLength(ReplaceText,icount);

    FillChar(ReplaceText[icount - 1],SizeOf(ReplaceText[icount - 1]),0);

    ReplaceText[icount - 1].TIdx := 0;

    if istart > 0 then

      stext := Copy(stemp,1,istart - 1)

    else

    begin

      stext := Copy(stemp,1,Length(stemp));

      istart := Length(stemp);

    end;

    lstrcpy(ReplaceText[icount - 1].StartText,PChar(stext));



    Delete(stemp,1,istart );

    inc(cstart,istart + iend);

    iend := Pos(']',stemp);

    inc(cend,istart + iend);

    stext := Copy(stemp,1,iend - 1);



    ReplaceText[icount - 1].TStart := cstart;

    ReplaceText[icount - 1].TEnd := cend;

    lstrcpy(ReplaceText[icount - 1].RepalceText,PChar(stext));

    Delete(stemp,1,iend );

    istart := Pos('[',stemp);

  end;

end;



procedure TForm1.FormCreate(Sender: TObject);

begin

  GetReplaceText(GString,FReplaceText);

  if Length(FReplaceText) = 0 then Exit;

end;



procedure TForm1.pb1Paint(Sender: TObject);

  var str ,drawstr: string;

      idx ,iwidth: Integer;

      gp : TGpGraphics;

      ileft,iheight : Integer;



begin

  SetBkMode(pb1.Canvas.Handle,TRANSPARENT);

  ileft := 0;

  with pb1.Canvas do

  begin

    Font.Size := 15;

    Font.Color := clBlack;

    font.Name := 'Tahoma';

  end;

  for idx := Low(FReplaceText) to High(FReplaceText) do

  begin

    str := FReplaceText[idx].StartText;

    iwidth := pb1.Canvas.TextWidth(str);

    pb1.Canvas.Font.Color := clBlack;

    pb1.Canvas.TextOut(ileft,0,FReplaceText[idx].StartText);

    str := GetReplaceStr(FReplaceText[idx]);

    inc(ileft,iwidth);

    if str = '' then Continue;

    pb1.Canvas.Font.Color := clRed;

    pb1.Canvas.TextOut(ileft,0,str);

    iwidth := pb1.Canvas.TextWidth(str);

    iheight := pb1.Canvas.TextHeight(str);

    FReplaceText[idx].DrawRect := Rect(ileft,0,ileft + iwidth,iheight);

    inc(ileft,iwidth);

  end;

end;



procedure TForm1.pb1MouseDown(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

  var idx : Integer;

      mi: TMenuItem;

      slist : TStringList;

      ReplaceText : TReplaceText;

      str : string;

      FPoint : TPoint;

begin

  if not (ssRight in shift) then Exit;

  idx := GetReplaceIndex(x);

  if idx = -1 then Exit;

  ReplaceText := FReplaceText[idx];

  slist := TStringList.Create;

  str := ReplaceText.RepalceText;

  str := StringReplace(str,'|',',',[rfReplaceAll]);

  slist.Delimiter := ',';

  slist.DelimitedText := str;

  pmText.Tag := idx;

  pmText.Items.Clear;

  for idx := 0 to slist.Count - 1 do

  begin

    mi := TMenuItem.Create(self);

    mi.Caption := slist[idx];

    pmText.Items.Add(mi);

    mi.Tag := idx;

    mi.OnClick := OnMenuClick;

  end;

  ScreenToClient(Point(x,y)) ;

  FPoint := Point(pb1.Left + x,pb1.Top + y + 10);

  FPoint := ClientToScreen(FPoint);

  pmText.Popup(FPoint.X,FPoint.Y);

  slist.Free;

end;



function TForm1.GetReplaceIndex(x: Integer): Integer;

  var idx : Integer;

      rc : TRect;

begin

  Result := -1;

  for idx := Low(FReplaceText) to High(FReplaceText) do

  begin

    if PtInRect(FReplaceText[idx].DrawRect,Point(x,0)) then

    begin

      Result := idx;

      Break;

    end;  

  end;

end;



procedure TForm1.pb1MouseMove(Sender: TObject; Shift: TShiftState; X,

  Y: Integer);

  var idx : Integer;

begin

  idx := GetReplaceIndex(x);

  if idx = -1 then

    pb1.Cursor := crDefault

  else

    pb1.Cursor := crHandPoint;

end;



function TForm1.GetReplaceStr(ReplaceText: TReplaceText): string;

  var slist : TStringList;

      str : string;

begin

  Result := '';

  slist := TStringList.Create;

  str := ReplaceText.RepalceText;

  str := StringReplace(str,'|',',',[rfReplaceAll]);

  slist.Delimiter := ',';

  slist.DelimitedText := str;

  if slist.Count > 0 then

    Result := slist[ReplaceText.TIdx];

  slist.Free;

end;



procedure TForm1.OnMenuClick(Sender: TObject);

begin

  if pmText.Tag = -1 then Exit;

  FReplaceText[pmText.Tag].TIdx := TMenuItem(Sender).Tag;

  pb1.Repaint;

end;



procedure TForm1.FormDestroy(Sender: TObject);

begin

  FReplaceText := nil;

  pmText.Items.Clear;

end;



end.

窗体:
object Form1: TForm1
  Left = 581
  Top = 419
  Width = 667
  Height = 431
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object pb1: TPaintBox
    Left = 32
    Top = 32
    Width = 585
    Height = 185
    OnMouseDown = pb1MouseDown
    OnMouseMove = pb1MouseMove
    OnPaint = pb1Paint
  end
  object pmText: TPopupMenu
    Tag = -1
    Left = 336
    Top = 248
  end
end

木有注释， drawstring函数可以去掉，另外可以将结构体放到tlist中，容易处理一些

不错，楼上正确，，，

只是语法分析？e

while  Length(stemp) > 1  do

1 要改成 0

否则最后那个“中”写出不来

俺也用richedit写了个，既然上面已经有示例了，就不继续弄了
需要注意的问题比较多
要能处理多行文本、
如果不处理高亮热字热词时需要考虑右键菜单的复制粘贴等功能、
文本中的汉字和英文要区分处理，还要考虑编码问题、
热字可能不止两组，需要更多时能动态增删
......
虽然都没啥技术含量，但是比较繁琐。

向 mdejtod  兄致敬!

引用 11 楼 wzca 的回复:

while  Length(stemp) > 1  do

1 要改成 0

否则最后那个“中”写出不来

真细心啊，我 倒没怎么测试

引用 12 楼 sololie 的回复:

俺也用richedit写了个，既然上面已经有示例了，就不继续弄了
需要注意的问题比较多
要能处理多行文本、
如果不处理高亮热字热词时需要考虑右键菜单的复制粘贴等功能、
文本中的汉字和英文要区分处理，还要考虑编码问题、
热字可能不止两组，需要更多时能动态增删
......
虽然都没啥技术含量，但是比较繁琐。

扩展的功能，就留给楼主慢慢完善了呗

这贴不加推荐对不起人民对不起党。。

现在做电子病历的很多就是用这种方法，在病历模版里设置N多的关键字和N多的选项，写病历就象做选择题一样。

哈哈，这两天忙，都没来看，谢谢大家，看到有位都出列子了。能发我个看看不。。
24282510@qq.com  还得 等两天才能继续研究这个。希望大家继续跟帖！！！

不错，方法有了，谢谢mdejtod 
和大家的热情，，，

这个是好。怎么显示在 richedit里边。。  “专业撸过”  有没有写出来。方法一样么？？？

不能用，白高兴

最近用了个RichView，感觉挺好，应该能实现这方面功能，推荐一下。。http://www.delphifans.com/dl.asp?no=8&id=2783&size=552

RichView 这个控件怎么用。有没DEMO