unitpltortf.pas

用于制作和整理（文件搜索方式）编程技术文档和各类源代码, 可以如编程工具一样分色显示程序(C++, Delphi , java, Vb, SQL ……)(用算法实现), 主要用于查找相应的类和函数

procedure TPLToRtf.setFont(SelectStart,SelectLength: integer;TokenState:TTokenState);
begin

  Frichedit.SelStart :=SelectStart;
  Frichedit.SelLength :=SelectLength;
   if TokenState<>tsUnknown then
   Frichedit.SelAttributes.Assign(FTokenStateFont[TokenState]);
end;

procedure TPLToRtf.setKeyList(Keys: string);
begin
   self.setlist(Keys,KeyList);
end;

procedure TPLToRtf.setlist(text: string; list: TstringList);
var i, TextLength:integer;
var word:string;

begin
  list.Clear ;
  word:='';
  text:=text+' ';
  TextLength:=length(text);
  if not FUpLow then  //如果大小写不敏感 则都转为大写
     Text:=AnsiUpperCase(Text);
  list.Clear ;
  list.Sorted :=false;

  for i:=1 to TextLength do
  begin
    if text[i]=' 'then
    begin
      if word<>'' then
      begin
        list.Add(word);
        word:='';
      end;
    end
    else
       word:=word+text[i];
  end;
  list.Sorted :=true;//排序
end;

procedure TPLToRtf.SetSymbolList(Symbols: string);
begin
  self.setlist(Symbols,SymbolList);
end;

function TPLToRtf.SetTokenStateFont(TokenState: TTokenState;
  newFont: TFont): boolean;
begin
  if newfont<>nil then
  begin
    FTokenStateFont[TokenState].Assign(newFont);
    result:=true;
  end
  else
    result:=false;
end;

function TPLToRtf.stringDeal( var i: integer): boolean;
var selectStart:integer;
begin
   
   if Frichedit.Text [i]=Fstring then
   begin
     selectStart:=i;
     inc(i);
     while  not (Frichedit.Text [i] in [Fstring ,#13])  do
         inc(i);
     self.setFont(selectStart-1,i-selectstart+1,tsString);
     result:=true;
     inc(i);
   end
   else
     result:=false;
end;

{ TPLConversion }

function TPLConversion.ColorToRTF(aColor: TColor): String;
begin
  aColor:=ColorToRGB(aColor);
  Result:='\red'+IntToStr(GetRValue(aColor))+
          '\green'+IntToStr(GetGValue(aColor))+
          '\blue'+IntToStr(GetBValue(aColor))+';';
end;

function TPLConversion.CommentDeal(word: string; var i: integer): boolean;
var index:integer;
var findindex:integer;
var EndFlag:string;
    selectStart:integer;
    findPos:integer;
    lastpos:integer;
begin
   Findindex:=-1;
   lastpos:=Length(word) ;
   for index :=0 to self.FcommentList[COMMENTBEGIN].Count -1 do
   begin
      FindPos:=pos( FcommentList[COMMENTBEGIN].Strings[index],word);
      if (findpos<>0)and (findpos<=lastpos) then //找到注释符号
      begin
         Findindex:=index;
         lastpos:=findpos;
      end;
   end;

   if Findindex<> -1 then  //存在注释符号
   begin
     findpos:=lastpos;
     EndFlag:=self.FcommentList[COMMENTEND].Strings[Findindex];
     selectStart:=i-Length(word)+findpos-1;//接下去找的开始: 如',../{/}'中指向'/'

     self.writeNext(tsUnknown,copy(Ftext,selectStart-findpos+1,findpos-1));

     if EndFlag='NULL' then    //行注释
     begin
       i:=selectStart;
       while  (i<=FtextLen) and (Ftext[i]<>#10) do inc(i);
     end
     else
     begin
        i:=pos(EndFlag,copy(Ftext,selectStart,FtextLen-selectStart+1));
        if i=-1 then i:=  FtextLen
        else i:=selectStart+i+length(endFlag)-2;
     end;
     inc(i);

     // 写入流中
     self.writeNext(tscomment,copy(Ftext, selectStart,i-selectStart));


     result:=true;
   end
   else
     result:=false;

end;

constructor TPLConversion.Create;
begin
   inherited create;
   ftext:='';
   FtextLen:=0;
   FResultMs:= TMemoryStream.Create ;
   FKeyList :=TstringList.Create ;
   Fkeylist.CaseSensitive := true; //查找设置:大小写不敏感
   FCommentList[COMMENTBEGIN]:=Tstringlist.Create ;
   FCommentList[COMMENTEND]:=Tstringlist.Create ;
   Fstring:=#0;
   FColorString:='';
   FUpLow:=false;
   self.PLName :='';
   self.KeyIsBold :=true;
   self.commentIsItalisc :=true;
   self.setDefultFix ;

end;

destructor TPLConversion.Destroy;
begin
     FResultMs.Free ;
     FKeyList.Free;
     FCommentList[COMMENTBEGIN].Free;
     FCommentList[COMMENTEND].Free;
  inherited;
end;

procedure TPLConversion.WriteRtfHeader;
var s:string;
begin
   self.Clear ;
   fBuffer:='{\rtf1\ansi\ansicpg936\deff0\deflang1033\deflangfe2052'
           +'{\fonttbl{\f0\fnil\fcharset134 \''cb\''ce\''cc\''e5;}'
           +'{\f1\fmodern\fprq1\fcharset134 \''d0\''c2\''cb\''ce\''cc\''e5;}}'
           +#13+#10;
   self.Write(fBuffer,lengthchars(fbuffer));

   strtochars(Fcolorstring,Fbuffer);
   self.Write(FBuffer,lengthchars(Fbuffer));

   s:='\viewkind4\uc1\pard\lang2052\f0\fs'+inttostr(self.FontSize )+' ';
   strtochars(s,Fbuffer);
   self.Write(FBuffer,lengthchars(Fbuffer));//

end;

procedure TPLConversion.ReretRtf;
 VAR
    i:integer;
    word:string;
begin
  self.getMemoryString;

  self.WriteRtfHeader ;

  i:=1;
  //分解分隔符  到 word
  while(i<=FTextlen) do
  begin
    word:='' ;
    while self.findINSymbols (ftext[i]) and (i<=FTextlen)do
    begin
        word:=word+FText[i];
        inc(i);
    end;

    if   self.CommentDeal(word,i) then begin end//注释处理
    else if  self.stringDeal(word, i) then begin end//字符串处理
    else
    begin
      self.writeNext(tsUnknown,word);

      word:='';
      while not self.findINSymbols (ftext[i])and (i<=FTextlen) do
      begin
        word:=word+Ftext[i];
        inc(i);
      end;

     if  self.KeyDeal(word) then  begin end //关键字
      else if (word<>'' )and (word[1] in ['0'..'9']) then
           self.writeNext(Tsnumber,word) //数字
      else
           self.writeNext(TsUnknown ,word);
    end;
  end;
  self.WriteRtfTail ;
  self.Position :=0;//回到起点
 
end;

procedure TPLConversion.SetCommentList(comments: string);
var i:integer;
    word:string;
begin
  word:='';
  comments:=comments+' ';
  self.ScanForRtf(comments);
  FCommentList[COMMENTBEGIN].Clear ;
  FCommentList[COMMENTEND].Clear ;
  for i:=1 to length(comments) do
  begin
    if comments[i]=' 'then
    begin
      if word<>'' then
      begin
        if  FCommentList[COMMENTBEGIN].Count =FCommentList[COMMENTEND].Count then
             FCommentList[COMMENTBEGIN].Add(word)
        else
             FCommentList[COMMENTEND].Add(word);
        word:='';
      end;
    end
    else
       word:=word+comments[i];
  end;
end;


procedure TPLConversion.SetKeyList(Keys: string);
begin
   self.setlist(Keys,KeyList);
end;

procedure TPLConversion.setlist(text: string; list: TstringList);
var i, TextLength:integer;
var word:string;

begin
  list.Clear ;
  word:='';
  text:=text+' ';
  TextLength:=length(text);
  if not FUpLow then  //如果大小写不敏感 则都转为大写
     Text:=AnsiUpperCase(Text);
  list.Clear ;
  list.Sorted :=false;

  for i:=1 to TextLength do
  begin
    if text[i]=' 'then
    begin
      if word<>'' then
      begin
        list.Add(word);
        word:='';
      end;
    end
    else
       word:=word+text[i];
  end;
  list.Sorted :=true;//排序
end;

procedure TPLConversion.SetSymbolList(Symbols: string);
var i: integer;
begin
  for  i:=1 to length(symbols) do
        Fsymbols[ord(symbols[i])]:=true;
  // ' ' #13 #10,tab
  Fsymbols[ord(' ')]:=true;
  Fsymbols[10]:=true;
  Fsymbols[13]:=true;
  Fsymbols[9]:=true;

end;

procedure TPLConversion.SetTokenStateColor(TokenState: TTokenState;
  NewColor:TColor);
var Ts: TTokenState;
begin
   if TokenState <>TsUnknown then
   begin
     FTokenStateColor[TokenState]:=NewColor;
     FColorString := '{\colortbl ;';
     for Ts:= tsComment to  tsString do
     begin
       FColorString := FColorString+self.ColorToRTF(FTokenStateColor[Ts]);
     end;
       FColorString := FColorString+'}'+#13+#10;
   end;
end;

function TPLConversion.stringDeal(word:string;var i: integer): boolean;
var selectStart:integer;
begin
  if i<=FTextLen then
  begin
     if Ftext[i]=Fstring then
     begin
         self.writeNext(tsUnknown,word);
         selectstart:=i;
         inc(i);
         while  (i<=FTextLen )and not (Ftext[i] in[#10,Fstring]) do
           inc(i);
        inc(i);
        self.writeNext(tsstring,copy(Ftext, selectStart,i-selectStart));
        result:=true;
     end
     else
        result:=false;
  end
  else
    result:=false;
end;

procedure TPLConversion.ScanForRtf(var word: string);
var len:integer;
    i:integer;
    s:string;
begin
   s:=word;
   len:=length(s);
   word:='';
  for i:=1 to len do
  begin
    if s[i] in[ '\', '{', '}' ] then
    begin
      word:=word+'\';
    end;
    word:=word+s[i];
    if s[i]=#10 then
      word:=word+'\par ';
  end;

end;

procedure TPLConversion.setDefultFix;
begin
   if self.commentIsItalisc then
     self.FPreFixList[tscomment]:='\cf1\i\f1 '
   else
     self.FPreFixList[tscomment]:='\cf1\f1 ';
   self.FPostFixList [tscomment]:='\cf0\i0\f0 ';

   if self.KeyIsBold then
     self.FPreFixList[tsKeyword]:='\cf2\b\f1 '
   else
     self.FPreFixList[tsKeyword]:='\cf2\f1 ' ;
   self.FPostFixList [tsKeyword]:='\cf0\b0\f0 ';

   self.FPreFixList[tsNumber]:='\cf3 ';
   self.FPostFixList [tsNumber]:='\cf0 ';
   self.FPreFixList[tsstring]:='\cf4 ';
   self.FPostFixList [tsstring]:='\cf0 ';
end;

procedure TPLConversion.getMemoryString;
var slist:Tstringlist;
begin
  slist:=Tstringlist.Create ;
  try
    self.Position :=0;
    slist.LoadFromStream(self);
    Ftext:=slist.Text ;
    self.ScanForRtf(Ftext);
    FTextLen:=length(ftext);
    self.Clear ;
  finally