字符串处理问题高难度。。。。。。。。。。。。。。。

[wangfei1812]

一个字符串处理问题。用什么控件也说下。。
如：s：='一个人[最好在|不再|不知]家，二个人[发热|不发热|不知发热]中';
说明下[发热|不发热|不知发热]内容部分是随机的，有多个长度也是不固定的。数量内容不固定。（[发热|不发热|不知发热|23|44|22|55]）这个可以多个。都是不固定的。
我想让他显示在一个控件里为：一个人最好在家 ，二个人发热中。

重点来了。。。就是鼠标放在最好在时候右键，在右键弹出框中可以选择到：
格式如下：右键弹出框中：最好在
不再
不知
可以选择其中一个，替换之前的最好在。
当鼠标放在：发热上点右键弹出的菜单就是：发热
不发热
不知发热
可以选择其中一个，替换之前的发热。

当还有标示红字的：弹出的页，也显示相应的字符。

重点，就是鼠标放在每个标示过的红色字 上。右键弹出的菜单都要和字符串中对应。。。

最好能给个列子，谢了，有描述不清楚的地方还请，见谅!!!!!

[wangfei1812]

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

[mdejtod]

无聊给你写了一个

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

[mdejtod]

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

[hhhfff2010]

不错，楼上正确，，，

[缘中人]

只是语法分析？e

[wzca]

[wzca]

while Length(stemp) > 1 do 1 要改成 0 否则最后那个“中”写出不来

[sololie]

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

[reverzeng]

向 mdejtod 兄致敬!

[mdejtod]

引用 11 楼 wzca 的回复:

while Length(stemp) > 1 do 1 要改成 0 否则最后那个“中”写出不来

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

[mdejtod]

引用 12 楼 sololie 的回复:

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

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

[hsfzxjy]

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

[fox600123]

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

[hsfzxjy]

弹框用popupmenu啊

[wangfei1812]

哈哈，这两天忙，都没来看，谢谢大家，看到有位都出列子了。能发我个看看不。。 [e-mail] 还得 等两天才能继续研究这个。希望大家继续跟帖！！！

[wangfei1812]

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

[wangfei1812]

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

[wangfei1812]

不能用，白高兴

[hsfzxjy]

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

[wangfei1812]

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