unitpltortf.pas

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

 {       Support: [e-mail]                       }
 // xcwen 2005-7~~~2005-8           delphi7
 // 2005-12
unit UnitPLToRtf;

interface
uses
  Windows, Messages, SysUtils,  Classes, Controls, Graphics,
  Dialogs, StdCtrls, ComCtrls,
  {///}inifiles;
const
   COMMENTBEGIN=0;  //注释开始
   COMMENTEND=1;    //注释结束

type
  TTokenState = ( tsComment,tsKeyword, tsNumber,  tsString, tsUnknown);
  TPLMessage = class
  private
    Finifilename:string;
    FPLname:string;
    FisUpLow:boolean;
    FKeys:string;
    FKeyIsBold:boolean;
    FcommentIsItalisc:boolean;
    Fcomments:string;
    FstringSymbol:char;
    FSymbols:string;
    FTsColors:array [TsComment..TsString] of TColor;
    Flinktypes:string;
    FFontSize:integer;
    procedure setPLname(newPLname: string);
    procedure setKeys(newKeys:string);
  public

    constructor Create(Newinifilename,NewPLname:string);
    function isok:boolean;
    function setTokenColor(Ts:TTokenState;NewColor:Tcolor):boolean;
    procedure clear;
    function loadfromInifile:boolean;
    procedure savetoInifile;
    function getTokenColor(Ts:TTokenState):Tcolor;
    function LoadPLname(PLnamelist:TStrings):boolean;
  published
    property isUpLow:boolean read FisUpLow write FisUpLow;
    property KeyIsBold:boolean read FKeyIsBold write FKeyIsBold;
    property commentIsItalisc:boolean read FcommentIsItalisc write FcommentIsItalisc;
    property Keys:string read FKeys write setKeys;
    property comments:string read Fcomments write Fcomments;
    property stringSymbol:char read FstringSymbol write FstringSymbol;
    property Symbols:string read FSymbols write FSymbols;
    property inifilename:string read Finifilename write Finifilename;
    property PLname:string read FPLname write setPLname;
    property linktypes:string read Flinktypes write Flinktypes;
    property FontSize:integer read FFontSize write FFontSize;
  end;

  TPLToRtf = class(TMemoryStream)
  private
    FrichEdit:TrichEdit;
    FKeyList:TstringList;    //保留字
    FSymbolList:TstringList; //分隔符号
    FcommentList:array [COMMENTBEGIN..COMMENTEND] of TstringList;
        //相应字体
    FTokenStateFont:array [tsComment..tsUnknown] of TFont;
    Fstring:char;//字符串符号
    FUpLow:boolean;          //大小写是否敏感
    procedure setFont(SelectStart,SelectLength:integer;TokenState:TTokenState);
    function  getTokenState(word:string):TTokenState;
    function  CommentDeal(word:string;var i:integer):boolean;
    function  stringDeal(var i:integer):boolean;
  protected
    procedure setlist(text:string;list:TstringList);
  public
    constructor Create(richedit:TrichEdit);
    destructor Destroy; override;
    procedure  SetKeyList(Keys :string);  //以' '(空格)分隔  如
    procedure  SetSymbolList(Symbols :string);
    procedure  SetCommentList(comments:string); //行注释 后一个用0 表示
    function   SetTokenStateFont(TokenState:TTokenState;newFont:TFont):boolean;
    procedure   ReretRtf;
    property   KeyList:TstringList read FKeyList;
    property   SymbolList:TstringList read FSymbolList ;
    property   UpLow:boolean read FUpLow write FUpLow;
    property   stringSymbol:char read Fstring write Fstring;
  published

  end;
  TPLConversion = class(TMemoryStream)
  private
    FResultMs:TMemoryStream;
    FKeyList:TstringList;    //保留字
    FSymbols:array[0..127] of boolean; //分隔符号
    FcommentList:array [COMMENTBEGIN..COMMENTEND] of TstringList;
    FPreFixList, FPostFixList: array[tsComment..tsUnknown] of String;

    FTokenStateColor:array [tsComment..tsUnknown] of TColor; //相应字体颜色
    Fstring:char;//字符串符号
    FUpLow:boolean;          //大小写是否敏感
    Ftext:string;
    FTextLen:integer;
    FColorString:string; //格式rtf的头部颜色标识
    FKeyIsBold:boolean;
    FcommentIsItalisc:boolean;
    FFontSize:integer;
    Fbuffer:array [0..1023] of char;
    FPLname:string;
    function  CommentDeal(word:string;var i:integer):boolean;
    function  stringDeal(word:string;var i:integer):boolean;
    function  KeyDeal(word:string):boolean;
    procedure WriteRtfHeader;
    procedure WriteRtfTail;
    procedure ScanForRtf(var word :string);
    procedure setDefultFix;
    procedure getMemoryString;
    procedure writeNext(TokenState:TTokenState;word:string);
    function  findINSymbols(ch :char ):boolean;
    procedure resetColorString;
  protected
    procedure setlist(text:string;list:TstringList);
  public
    constructor Create;
    destructor  Destroy; override;
    procedure   SetKeyList(Keys :string);  //以' '(空格)分隔
    procedure   SetSymbolList(Symbols :string);
    procedure   SetCommentList(comments:string); //行注释 后一个用0 表示
    procedure   SetTokenStateColor(TokenState: TTokenState;NewColor:TColor);
    procedure   ReretRtf;
    procedure   loadfromInifile(inifilename, PLname: string);
    function    ColorToRTF(aColor: TColor): String;
    function    ReallyGo:boolean;
    procedure   reset;
  published
    property KeyList:TstringList read FKeyList;
    property stringSymbol:char read Fstring write Fstring;
    property isUpLow:boolean read FUpLow  write FUplow ;        //大小写是否敏感
    property KeyIsBold:boolean read FKeyIsBold write FKeyIsBold;
    property FontSize:integer read FFontSize write FFontSize;
    property PLName:string read FPLname Write FPLname;
    property commentIsItalisc:boolean read FcommentIsItalisc write FcommentIsItalisc;
  end;
//////////////////////////////////////////////////////////////////////////////
  function strtochars(s:string;var chars :array of char) :boolean;
  function LengthChars(chars :array of char):integer;   //保证 #0 的存在
  function GetPascalKeys:string;
  function  GetPascalSymbols:string;
  function GetCPPSymbols:string;
  function GetCPPKeys:string;
  function find(substr,s:string):integer;
implementation
function find(substr,s:string):integer;
var temp,i,j:integer;
    sLen:integer;
    subLen:integer;
begin
  i:=1;
  result:=0;
  SubLen:=length(Substr);
  sLen:=length(s)-SubLen+1;

  while i<=  sLen do
  begin
    j:=1;
    temp:=i;
    while s[temp]=substr[j] do
    begin
      if SubLen=j then
      begin
        result:=i;
        exit;
      end;
      inc(temp);
      inc(j);
    end;
    inc(i);
  end;
end;
function strtochars(s:string;var chars :array of char) :boolean;
var i:integer;
var lenStr:integer;
begin
  lenStr:=length(s);
  if lenStr<length(chars) then
  begin
    for i :=1 to lenStr do
      chars[i-1]:=s[i];
    chars[lenStr]:=#0;
    result:=true;
  end
  else
    result:=false;
end;
function GetCPPSymbols:string;
begin
  result:='!{}[];:<>,.?/\%&*()-+=|';
end;
function GetCPPKeys:string;
begin
  result:='#define #elseif #endif #if #ifdef #ifndef #include';
  result:=result+' bool case char class const';
  result:=result+' default delete do double else elseif enum extern';
  result:=result+' false float for friend if goto inline int long namespace new';
  result:=result+' operator private protected public return static struct switch';
  result:=result+' this true union unsigned using virtual void while';
end;
function LengthChars(chars :array of char):integer;   //保证 #0 的存在
var i:integer;
begin
   i:=0;
   while chars[i]<>#0 do inc(i);
   result:=i;
end;
function GetPascalKeys:string;
var Keys:string;
begin
  Keys:='ABSOLUTE ABSTRACT AND ARRAY AS ASM ASSEMBLER ';
  Keys:=Keys+'AUTOMATED BEGIN CASE CDECL CLASS CONST CONSTRUCTOR ';
  Keys:=Keys+'DEFAULT DESTRUCTOR DISPID DISPINTERFACE DIV DO ';
  Keys:=Keys+'DOWNTO DYNAMIC  ELSE END END. EXCEPT EXPORT EXPORTS ';
  Keys:=Keys+'EXTERNAL FAR FILE FINALIZATION FINALLY FOR FORWARD ';
  Keys:=Keys+'FUNCTION GOTO IF IMPLEMENTATION IN INDEX INHERITED ';
  Keys:=Keys+'INITIALIZATION INLINE INTERFACE IS LABEL LIBRARY ';
  Keys:=Keys+'MESSAGE MOD NAME NEAR NIL NODEFAULT NOT OBJECT ';
  Keys:=Keys+'OF OR OUT OVERRIDE PACKED PASCAL PRIVATE PROCEDURE ';
  Keys:=Keys+'PROGRAM PROPERTY PROTECTED PUBLIC PUBLISHED RAISE ';
  Keys:=Keys+'READ READONLY RECORD REGISTER REPEAT RESIDENT ';
  Keys:=Keys+'RESOURCESTRING SAFECALL SET SHL SHR STDCALL STORED ';
  Keys:=Keys+'STRING STRING RESOURCE THEN THREADVAR TO TRY TYPE ';
  Keys:=Keys+'UNIT UNTIL USES VAR VIRTUAL WHILE WITH WRITE ';
  Keys:=Keys+'WRITEONLY XOR ';
  result:= Keys;
end;
function  GetPascalSymbols:string;
begin
  result:='=+-*/\(){}[]:<>,;';
end;
{ TPLToRtf }

function TPLToRtf.CommentDeal(word: string; var i: integer): boolean;
var index:integer;
var findindex:integer;
var EndFlag:string;
    selectStart:integer;
    findPos:integer;
begin
   Findindex:=-1;
   findpos:=0;
   for index :=0 to self.FcommentList[COMMENTBEGIN].Count -1 do
   begin
      FindPos:=pos( FcommentList[COMMENTBEGIN].Strings[index],word);
      if findpos<>0 then
      begin
         Findindex:=index;
         break;
      end;
   end;

   if Findindex<> -1 then
   begin
     EndFlag:=self.FcommentList[COMMENTEND].Strings[Findindex];
     selectStart:=i;
     if endFlag='0' then    //
     begin
        while (i<length(FrichEdit.Text[i]))and (FrichEdit.Text[i]<>#13 ) do inc(i);
     end
     else
     begin
        i:=FrichEdit.FindText(endFlag,i,length(Frichedit.Text)-selectstart+1,[stMatchCase]);
        if i=-1 then i:=  length(Frichedit.Text)
        else i:=i+length(endFlag);
     end;

     self.FrichEdit.SelStart :=selectStart-(length(word)-findPos+1)-2;
     self.FrichEdit.SelLength :=i-selectStart+1;
     self.FrichEdit.SelAttributes.Assign(FTokenStateFont[tscomment]);
     inc(i);
     result:=true;
   end
   else
     result:=false;

end;

constructor TPLToRtf.Create(richedit: TrichEdit);
var TokenState:TTokenState;
begin

  if (richedit<>nil ) then
  begin
     FrichEdit:=richEdit;
     FKeyList :=TstringList.Create ;
     FsymbolList :=TstringList.Create ;
     FCommentList[COMMENTBEGIN]:=Tstringlist.Create ;
     FCommentList[COMMENTEND]:=Tstringlist.Create ;
     Fstring:=' ';
     for TokenState:= tsComment to  tsUnknown do
         FTokenStateFont[TokenState]:=TFont.Create ;
     FUpLow:=false;
     inherited create;
  end;

end;

destructor TPLToRtf.Destroy;
var TokenState:TTokenState;
begin
     FKeyList.Free;
     FsymbolList .Free;
     FCommentList[COMMENTBEGIN].Free;
     FCommentList[COMMENTEND].Free;
     for TokenState:= tsComment to  tsUnknown do
         FTokenStateFont[TokenState].Free ;
  inherited;
end;



function TPLToRtf.getTokenState(word: string): TTokenState;
var i:integer;
begin
  if not FUpLow then
     Word:=AnsiUpperCase(word);
  if word<>'' then
  begin
   // if word[1]=Fstring then     result:= tsString     else
   if word[1] in['0'..'9'] then  result:=tsnumber
    else if FKeyList.Find(word,i) then result:=tsKeyword
   // else if FCommentlist[COMMENTBEGIN].Find(word,i) then result:=tsComment
    else result:=tsUnknown;

  end
  else result:=tsUnknown;
end;



procedure TPLToRtf.ReretRtf;
var SelectStart:integer;
    i:integer;
    findID:integer;
    textLength:integer;
var word:string;
begin
  i:=1 ;
  FrichEdit.Font .Assign ( FTokenStateFont[tsUnknown]);
  textLength:=length(frichedit.text);
  while(i<=Textlength) do
  begin
    word:='' ;

    while (Frichedit.Text[i]in[' ',#13,#10,#9 {vk_tab} ]) or
        self.FSymbolList.Find(string(Frichedit.Text[i]),FindID) do
    begin
      if Frichedit.Text[i]<>' ' then
         word:=word+Frichedit.Text[i];
      inc(i);
    end;



    if  self.CommentDeal(word,i) then  //注释处理
    else if self.stringDeal(i) then  //字符串处理
    else
    begin
      selectstart:=i;
      while not(Frichedit.Text[i]in[' ',#13,#10,#9 {vk_tab}]) and
           not self.FSymbolList.Find(string(Frichedit.Text[i]),FindID) do
      begin
        inc(i);
      end;
      self.setFont(selectstart-1,i-selectstart,getTokenState(copy(Frichedit.Text ,selectstart,i-selectstart)));
      inc(i);
    end;

  end;
end;

procedure TPLToRtf.SetCommentList(comments: string);
var i:integer;
    word:string;
begin
  word:='';
  comments:=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;