Solved

.PAS ----> .DOC

Posted on 1998-12-14
8
530 Views
Last Modified: 2010-04-04
I want to be able to copy/export my Color Syntax Highlighted .PAS files to a Microsoft Word Document and keep the same colors and formatting that I see when I'm in Delphi. Reason: I am converting some files into .PDF files and I need a .DOC file.  If I highlight all the text in a .PAS file and paste it into Microsoft Word I loose all the color and formatting and all the text ends up being aligned to the left edge. I'm so frustrated....
0
Comment
Question by:iNDiGLo
8 Comments
 
LVL 12

Expert Comment

by:rwilson032697
Comment Utility
You need to convert it to RTF. Doing that will preserve all the syntax highlighting and colours. There are some pascal to rtf converters on DSP (http://sunsite.icm.edu.pl/delphi/)  (though the DSP search pageb is down at the moment 'cause it is being updated. I'll dig out a URL for you when it comes back.

Cheers,

Raymond.
0
 
LVL 12

Expert Comment

by:rwilson032697
Comment Utility
Heres a URL to a .PAS to RTF converter which will preserve syntax highlighting etc. Word will then read the RTF directly...

http://home.sol.no/~stenvart/delphi/makehtml.html

Cheers,

Raymond.

0
 
LVL 12

Expert Comment

by:rwilson032697
Comment Utility
Here's another related one:

http://www1.omnitel.net/proga/cm20.zip

Cheers,

Raymond.
0
 

Author Comment

by:iNDiGLo
Comment Utility
Thanks for the two links but they don't exactly do it. The first one doesn't work on the entire file. It only works on about 80% of the file. Its buggy. The second file is great for creating rules to highlight your text in delphi but again you can't get the information COLOR SYNTAX HIGHLIGHTED into an RTF file.
0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 
LVL 4

Expert Comment

by:dwwang
Comment Utility
Maybe you can view this article, if you can get the code on the webpage to work, you may get what you want.
http://216.22.198.171/Articles/981027d.html
0
 
LVL 2

Accepted Solution

by:
gallaghe earned 150 total points
Comment Utility
First off, I hope all the text makes it into the answer.
Secondly, I have no short solution so the answer
had to be this long. Hope that is OKay with the Expert
Web-Master!

Begin my solution
I had a similar need to take PAS to DOC and after looking around
for something already done decided to create my own.

First create an executable, then add it to Windows Explorer's file
association View->Folder Options->File Type,"Delphi Pascal
unit", edit then "Add action" i.e. "C:\Pas Viewer\PasView" "%1"

The utility needs on the main (only) form:
1 RichText control  (for displaying the PAS file)
   Name it "TheEditor"

2 Command Button (to select the PAS file to read)
(next button is optional, you could simple select the text using
the mouse and press Ctrl+C)

3 Command Button (to select text and copy to clipboard)

4 Add the unit listed below called " mwPasToRtf". This unit
   was created by Martin Waldenburg, was changed by
  Jon Hogan-Doran and Kevin S. Gallagher (myself).
  * Add mwPasToRtf to the forms uses clause.

5 Add a OpenDialog control

Add the following code for the Command Button listed in
step 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  PC: TPasConversion ;
  cFile : String ;
begin

  if OpenDialog1.Execute then begin
    TheEditor.Clear ;
    cFile := OpenDialog1.FileName ;
    Caption := cFile ;
    PC := TPasConversion.Create ;

    try
      with PC do begin
        UseDelphiHighlighting(3) ;
        LoadFromFile(cFile) ;
        ConvertReadStream ;
      end;
      with TheEditor do begin
        Lines.BeginUpdate ;
        Lines.LoadFromStream(PC) ;
        Lines.EndUpdate ;
      end;
    finally
      PC.Free ;
    end ;
  end ;
end;


Here is the code that does the conversion from plain
text to Delphi IDE formatted text.

BEGIN CODE (Ends with END CODE)


{+--------------------------------------------------------------------------+
 | jhdPas2Rtf - by Jon Hogan-Doran (jonhd@hotmail.com)
 |
 | adapated from:
 |
 | Unit:        mwPasToRtf
 | Created:     09.97
 | Author:      Martin Waldenburg
 | Copyright    1997, all rights reserved.
 | Description: Pas to Rtf converter for syntax highlighting etc.
 | Version:     0.7 beta
 | Status:       FreeWare
 | DISCLAIMER:  This is provided as is, expressly without a
 |                          warranty of any kind.
 |              You use it at your own risc.
 |
 | NOTE: Delphi will complain if you open this file about the
 |             Unit names not matching. This is designed to be
 |             copied verbatim over the
 |       shipping mwPasToRtf that comes with YourPasEdit.
 +--------------------------------------------------------------------------+}

unit mwPasToRtf;

interface

uses
  Windows,
  SysUtils,
  Messages,
  Classes,
  ComCtrls,
  Graphics,
  Dialogs,
  Registry;

type
  TTokenState = (tsAssembler, tsComment, tsCRLF, tsDirective, tsIdentifier,
                 tsKeyWord, tsNumber, tsSpace, tsString, tsSymbol, tsUnknown);

  TCommentState = (csAnsi, csBor, csNo, csSlashes);


//JHD
const
  ColorsInList = 15;
  ColorValues: array [0..ColorsInList] of TColor = (
    clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray,
    clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
//JHD

type
  TPasConversion = class(TMemoryStream)
  private
    FDiffer: Boolean;
    FUseWordFont: Boolean;    { KSG }
    FPreFixList, FPostFixList: array[tsAssembler..tsUnknown] of String;
    FComment: TCommentState;
    Prefix, TokenStr, Postfix: String;
    FBuffPos, TokenLen, FOutBuffSize, FStrBuffSize: Integer;
    FReadBuff, FOutBuff, FStrBuff, FStrBuffEnd, Run, RunStr, TokenPtr: PChar;
    FTokenState : TTokenState;
    FAssemblerFo: TFont;
    FCommentFo: TFont;
    FDirectiveFo: TFont;
    FIdentifierFo: TFont;
    FNumberFo: TFont;
    FKeyWordFo: TFont;
    FSpaceFo: TFont;
    FStringFo: TFont;
    FSymbolFo: TFont;
    //JHD
    FFontTable: TStringList;
    //JHD
    function IsKeyWord(aToken: String):Boolean;
    function IsDirective(aToken: String):Boolean;
    function IsDiffKey(aToken: String):Boolean;
    procedure SetAssemblerFo(newValue: TFont);
    procedure SetCommentFo(newValue: TFont);
    procedure SetDirectiveFo(newValue: TFont);
    procedure SetIdentifierFo(newValue: TFont);
    procedure SetKeyWordFo(newValue: TFont);
    procedure SetNumberFo(newValue: TFont);
    procedure SetSpaceFo(newValue: TFont);
    procedure SetStringFo(newValue: TFont);
    procedure SetSymbolFo(newValue: TFont);
    procedure SetRTF;
    procedure WriteToBuffer(aString: String);
    //JHD
    //procedure HandleAnsiC;
    //procedure HandleBorC;
    //procedure HandleCRLF;
    //procedure HandleSlashesC;
    //procedure HandleString;
    //JHD
    procedure ScanForRtf;
    procedure AllocStrBuff;
    procedure SetPreAndPosFix(aFont: TFont; aTokenState: TTokenState);
    //JHD
    function FontToRTFFontNr(aFont: TFont):Integer;
    function ColorToTable(aColor: TColor): String;
    procedure WriteColorTable;
    procedure WriteFontTable;
    //JHD
  protected
  public
    //JHD
    FParseFont: array[tsAssembler..tsUnknown] of TFont;
    //JHD
    constructor Create;
    destructor Destroy; override;
    procedure Init;
    procedure UseDelphiHighlighting(Ver: Integer);
    function ColorToRTF(aColor: TColor): String;
    function ConvertReadStream: Integer;
    property UseWordFont: boolean read FUseWordFont write FUseWordFont;
    //function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer):Integer;
    property AssemblerFo: TFont read FAssemblerFo write SetAssemblerFo;
    property CommentFo: TFont read FCommentFo write SetCommentFo;
    property DirectiveFo: TFont read FDirectiveFo write SetDirectiveFo;
    property IdentifierFo: TFont read FIdentifierFo write SetIdentifierFo;
    property KeyWordFo: TFont read FKeyWordFo write SetKeyWordFo;
    property NumberFo: TFont read FNumberFo write SetNumberFo;
    property SpaceFo: TFont read FSpaceFo write SetSpaceFo;
    property StringFo: TFont read FStringFo write SetStringFo;
    property SymbolFo: TFont read FSymbolFo write SetSymbolFo;
    //JHD
    function GetToken(Run: PChar; var aTokenState: TTokenState; var aTokenStr: string):PChar;
    //JHD
  published
  end;

const
  Keywords : array[0..98] of string =
            ('ABSOLUTE', 'ABSTRACT', 'AND', 'ARRAY', 'AS', 'ASM', 'ASSEMBLER',
             'AUTOMATED', 'BEGIN', 'CASE', 'CDECL', 'CLASS', 'CONST', 'CONSTRUCTOR',
             'DEFAULT', 'DESTRUCTOR', 'DISPID', 'DISPINTERFACE', 'DIV', 'DO',
             'DOWNTO', 'DYNAMIC', 'ELSE', 'END', 'EXCEPT', 'EXPORT', 'EXPORTS',
             'EXTERNAL', 'FAR', 'FILE', 'FINALIZATION', 'FINALLY', 'FOR', 'FORWARD',
             'FUNCTION', 'GOTO', 'IF', 'IMPLEMENTATION', 'IN', 'INDEX', 'INHERITED',
             'INITIALIZATION', 'INLINE', 'INTERFACE', 'IS', 'LABEL', 'LIBRARY',
             'MESSAGE', 'MOD', 'NAME', 'NEAR', 'NIL', 'NODEFAULT', 'NOT', 'OBJECT',
             'OF', 'OR', 'OUT', 'OVERRIDE', 'PACKED', 'PASCAL', 'PRIVATE', 'PROCEDURE',
             'PROGRAM', 'PROPERTY', 'PROTECTED', 'PUBLIC', 'PUBLISHED', 'RAISE',
             'READ', 'READONLY', 'RECORD', 'REGISTER', 'REPEAT', 'RESIDENT',
             'RESOURCESTRING', 'SAFECALL', 'SET', 'SHL', 'SHR', 'STDCALL', 'STORED',
             'STRING', 'STRINGRESOURCE', 'THEN', 'THREADVAR', 'TO', 'TRY', 'TYPE',
             'UNIT', 'UNTIL', 'USES', 'VAR', 'VIRTUAL', 'WHILE', 'WITH', 'WRITE',
             'WRITEONLY', 'XOR');

  Directives : array[0..10] of string =
              ('AUTOMATED', 'INDEX', 'NAME', 'NODEFAULT', 'READ', 'READONLY',
               'RESIDENT', 'STORED', 'STRINGRECOURCE', 'WRITE', 'WRITEONLY');

  DiffKeys: array[0..6] of string =
           ('END', 'FUNCTION', 'PRIVATE', 'PROCEDURE', 'PRODECTED', 'PUBLIC', 'PUBLISHED');


implementation

destructor TPasConversion.Destroy;
var
  State: TTokenState;
begin
  for State := Low(FParseFont) to High(FParseFont) do
  FParseFont[State].Free;

  FAssemblerFo.Free;
  FCommentFo.Free;
  FDirectiveFo.Free;
  FIdentifierFo.Free;
  FKeyWordFo.Free;
  FNumberFo.Free;
  FSpaceFo.Free;
  FStringFo.Free;
  FSymbolFo.Free;
  ReAllocMem(FStrBuff, 0);

  //JHD
  FFontTable.Free;
  //JHD

  inherited Destroy;
end;  { Destroy }

constructor TPasConversion.Create;
var
  State: TTokenState;
begin
  inherited Create;

  for State := Low(FParseFont) to High(FParseFont) do
  FParseFont[State] := TFont.Create;

  FAssemblerFo := TFont.Create;
  FCommentFo := TFont.Create;
  FDirectiveFo := TFont.Create;
  FIdentifierFo := TFont.Create;
  FKeyWordFo := TFont.Create;
  FNumberFo := TFont.Create;
  FSpaceFo := TFont.Create;
  FStringFo := TFont.Create;
  FSymbolFo := TFont.Create;
  Prefix:='';
  PostFix:='';
  FStrBuffSize:= 0;
  AllocStrBuff;

  //JHD
  FFontTable    := TStringList.Create;
  //JHD

    Init;
  FDiffer:= False;
  FUseWordFont := False;

end;  { Create }

procedure TPasConversion.AllocStrBuff;
begin
  FStrBuffSize:= FStrBuffSize + 1024;
  ReAllocMem(FStrBuff, FStrBuffSize);
  FStrBuffEnd:= FStrBuff + 1023;
end;  { AllocStrBuff }

procedure TPasConversion.SetAssemblerFo(newValue: TFont);
begin
  FAssemblerFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsAssembler);
end;  { SetAssemblerFo }

procedure TPasConversion.SetCommentFo(newValue: TFont);
begin
  FCommentFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsComment);
end;  { SetCommentFo }

procedure TPasConversion.SetDirectiveFo(newValue: TFont);
begin
  FDirectiveFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsDirective);
end;  { SetDirectiveFo }

procedure TPasConversion.SetIdentifierFo(newValue: TFont);
begin
  FIdentifierFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsIdentifier);
end;  { SetIdentifierFo }

procedure TPasConversion.SetKeyWordFo(newValue: TFont);
begin
  FKeyWordFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsKeyWord);
end;  { SetKeyWordFo }

procedure TPasConversion.SetNumberFo(newValue: TFont);
begin
  FNumberFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsNumber);
end;  { SetNumberFo }

procedure TPasConversion.SetSpaceFo(newValue: TFont);
begin
  FSpaceFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsSpace);
end;  { SetSpaceFo }

procedure TPasConversion.SetStringFo(newValue: TFont);
begin
  FStringFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsString);
end;  { SetStringFo }

procedure TPasConversion.SetSymbolFo(newValue: TFont);
begin
  FSymbolFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsSymbol);
end;  { SetSymbolFo }

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

procedure TPasConversion.UseDelphiHighlighting(Ver: Integer);

  {Delphi Editor settings are a comma delimited list of seven
   values as follows:

   0 - Foreground color
   1 - Background color
   2 - font style
   3 - Foreground Default
   4 - Background Default
   6 - Unknown
   7 - Unknown

   Currently this routine only handles setting the Bold, Italic, Underline}

  procedure SetDelphiRTF(S: String; aTokenState: TTokenState);
  var
    Ed_List: TStringList;
    Font: TFont;
  Begin
    Font:=TFont.Create;
    Font.Name := 'Courier';
    Ed_List:=TStringList.Create;
    Try
      Ed_List.CommaText:=S;
      if pos('B',Ed_List[2])>0 then
        Font.Style:=Font.Style+[fsBold];
      if pos('I',Ed_List[2])>0 then
        Font.Style:=Font.Style+[fsItalic];
      if pos('U',Ed_List[2])>0 then
        Font.Style:=Font.Style+[fsUnderLine];

      //JHD
      Font.Color := StrToInt(Ed_List[0]);
      //JHD

      SetPreAndPosFix(Font,aTokenState);
    finally
    Ed_List.Free;
    Font.Free;
    End;
  End;

const Delphi_Editor: array[0..10] of string=('Assembler','Comment','IGNORE',
           'IGNORE','Identifier','Reserved_Word','Number','Whitespace','String',
           'Symbol','Plain_Text');
var
  RegIni: TRegIniFile;
  Ed_Setting: String;
  i: Integer;
Begin
  if Ver=2 then
    RegIni:=TRegIniFile.Create('Software\Borland\Delphi\2.0')
  else if Ver=3 then
    RegIni:=TRegIniFile.Create('Software\Borland\Delphi\3.0')
  else
    Raise Exception.Create('Only syntax highlighting from Delphi 2 and 3 are supported');

  Try
    for i:=0 to 10 do
      if Delphi_Editor[i]<>'IGNORE' then
        Begin
        Ed_Setting:=RegIni.ReadString('HighLight',Delphi_Editor[i],'0,0,,0,0,0,0');
        SetDelphiRTF(Ed_Setting,TTokenState(i));
        End;
  finally
  RegIni.Free;
  End;
End;

procedure TPasConversion.SetPreAndPosFix(aFont: TFont; aTokenState: TTokenState);
begin
   { Here you need to set the Pre - and PostFix
     accordingly to the aFont value }

  FParseFont[aTokenState].Assign(aFont);

  FPreFixList[aTokenState]:= '';
  FPostFixList[aTokenState]:= '';


  //JHD

  FPreFixList[aTokenState] := '\f' + IntToStr(FontToRTFFontNr(aFont));
  FPreFixList[aTokenState] := FPreFixList[aTokenState] + '\fs' + IntToStr(aFont.Size*2);
  FPreFixList[aTokenState] := FPreFixList[aTokenState] + '\cf' +
                                 ColorToTable(aFont.Color) + ' ';
  //JHD

  if (fsBold in aFont.Style) then
    FPreFixList[aTokenState]:=FPreFixList[aTokenState]+'\b ';
  if (fsItalic in aFont.Style) then
    FPreFixList[aTokenState]:=FPreFixList[aTokenState]+'\i ';
  if (fsUnderline in aFont.Style) then
    FPreFixList[aTokenState]:=FPreFixList[aTokenState]+'\u ';

  if FPreFixList[aTokenState]<>'' then
    FPreFixList[aTokenState]:='{'+FPreFixList[aTokenState];

  if FPreFixList[aTokenState]<>'' then
    FPostFixList[aTokenState]:='}'
end;  { SetPreAndPosFix }

//procedure TPasConversion.ScanForRtf;
//var
//  i: Integer;
//begin
//  RunStr:= FStrBuff;
//  FStrBuffEnd:= FStrBuff + 1023;
//  for i:=1 to TokenLen do
//  begin
//    Case TokenStr[i] of
//      '\', '{', '}':
//        begin
//          RunStr^:= '\';
//          inc(RunStr);
//        end
//    end;
//    if RunStr >= FStrBuffEnd then AllocStrBuff;
//    RunStr^:= TokenStr[i];
//    inc(RunStr);
//  end;
//  RunStr^:= #0;
//  TokenStr:= FStrBuff;
//end;  { ScanForRtf }
//
//procedure TPasConversion.HandleAnsiC;
//begin
//  while Run^ <> #0 do
//  begin
//    Case Run^ of
//      #13:
//        begin
//          if TokenPtr <> Run then
//          begin
//            FTokenState:= tsComment;
//            TokenLen:= Run - TokenPtr;
//            SetString(TokenStr, TokenPtr, TokenLen);
//            ScanForRtf;
//            SetRTF;
//            WriteToBuffer(Prefix + TokenStr + Postfix);
//            TokenPtr:= Run;
//          end;
//          HandleCRLF;
//          dec(Run);
//        end;
//
//      '*': if (Run +1 )^ = ')' then begin  inc(Run, 2); break; end;
//    end;
//    inc(Run);
//  end;
//  FTokenState:= tsComment;
//  TokenLen:= Run - TokenPtr;
//  SetString(TokenStr, TokenPtr, TokenLen);
//  ScanForRtf;
//  SetRTF;
//  WriteToBuffer(Prefix + TokenStr + Postfix);
//  TokenPtr:= Run;
//  FComment:= csNo;
//end;  { HandleAnsiC }
//
//procedure TPasConversion.HandleBorC;
//begin
//  while Run^ <> #0 do
//  begin
//    Case Run^ of
//      #13:
//        begin
//          if TokenPtr <> Run then
//          begin
//            FTokenState:= tsComment;
//            TokenLen:= Run - TokenPtr;
//            SetString(TokenStr, TokenPtr, TokenLen);
//            ScanForRtf;
//            SetRTF;
//            WriteToBuffer(Prefix + TokenStr + Postfix);
//            TokenPtr:= Run;
//          end;
//          HandleCRLF;
//          dec(Run);
//        end;
//
//      '}': begin  inc(Run); break; end;
//
//    end;
//    inc(Run);
//  end;
//  FTokenState:= tsComment;
//  TokenLen:= Run - TokenPtr;
//  SetString(TokenStr, TokenPtr, TokenLen);
//  ScanForRtf;
//  SetRTF;
//  WriteToBuffer(Prefix + TokenStr + Postfix);
//  TokenPtr:= Run;
//  FComment:= csNo;
//end;  { HandleBorC }
//
//procedure TPasConversion.HandleCRLF;
//begin
//  if Run^ = #0 then exit;
//  inc(Run, 2);
//  FTokenState:= tsCRLF;
//  TokenLen:= Run - TokenPtr;
//  SetString(TokenStr, TokenPtr, TokenLen);
//  SetRTF;
//  WriteToBuffer(Prefix + TokenStr + Postfix);
//  TokenPtr:= Run;
//  fComment:= csNo;
//  FTokenState:= tsUnKnown;
//  if Run^ = #13 then HandleCRLF;
//  end;  { HandleCRLF }
//
//procedure TPasConversion.HandleSlashesC;
//begin
//  FTokenState:= tsComment;
//  while (Run^ <> #13) and (Run^ <> #0) do inc(Run);
//  TokenLen:= Run - TokenPtr;
//  SetString(TokenStr, TokenPtr, TokenLen);
//  ScanForRtf;
//  SetRTF;
//  WriteToBuffer(Prefix + TokenStr + Postfix);
//  TokenPtr:= Run;
//  FComment:= csNo;
//end;  { HandleSlashesC }
//
//procedure TPasConversion.HandleString;
//begin
//  FTokenState:= tsSTring;
//  FComment:= csNo;
//  repeat
//    Case Run^ of
//      #0, #10, #13: raise exception.Create('Invalid string');
//    end;
//    inc(Run);
//  until Run^ = #39;
//          inc(Run);
//          TokenLen:= Run - TokenPtr;
//          SetString(TokenStr, TokenPtr, TokenLen);
//          ScanForRtf;
//          SetRTF;
//
//          WriteToBuffer(Prefix + TokenStr + Postfix);
//          TokenPtr:= Run;
//end;  { HandleString }


function TPasConversion.IsKeyWord(aToken: String):Boolean;
var
  First, Last, I, Compare: Integer;
  Token: String;
begin
  First := 0;
  Last := 98;
  Result := False;
  Token:= UpperCase(aToken);
  while First <= Last do
  begin
    I := (First + Last) shr 1;
    Compare := CompareStr(Keywords[i],Token);
    if Compare = 0 then
      begin
        Result:=True;
        break;
      end
    else
    if Compare < 0  then First := I + 1 else Last := I - 1;
  end;
end;  { IsKeyWord }

function TPasConversion.IsDiffKey(aToken: String):Boolean;
var
  First, Last, I, Compare: Integer;
  Token: String;
begin
  First := 0;
  Last := 6;
  Result := False;
  Token:= UpperCase(aToken);
  while First <= Last do
  begin
    I := (First + Last) shr 1;
    Compare := CompareStr(DiffKeys[i],Token);
    if Compare = 0 then
      begin
        Result:=True;
        break;
      end
    else
    if Compare < 0  then First := I + 1 else Last := I - 1;
  end;
end;  { IsDiffKey }

function TPasConversion.IsDirective(aToken: String):Boolean;
var
  First, Last, I, Compare: Integer;
  Token: String;
begin
  First := 0;
  Last := 10;
  Result := False;
  Token:= UpperCase(aToken);
  if CompareStr('PROPERTY', Token) = 0 then FDiffer:= True;
  if IsDiffKey(Token) then FDiffer:= False;
  while First <= Last do
  begin
    I := (First + Last) shr 1;
    Compare := CompareStr(Directives[i],Token);
    if Compare = 0 then
      begin
        Result:= True;
        if FDiffer then
        begin
          Result:= False;
          if CompareStr('NAME', Token) = 0 then Result:= True;
          if CompareStr('RESIDENT', Token) = 0 then Result:= True;
          if CompareStr('STRINGRESOURCE', Token) = 0 then Result:= True;
        end;
        break;
      end
    else
    if Compare < 0  then First := I + 1 else Last := I - 1;
  end;
end;  { IsDirective }

procedure TPasConversion.SetRTF;
begin
  prefix:=FPreFixList[FTokenState];
  postfix:=FPostFixList[FTokenState];
  Case FTokenState of
    tsAssembler: FTokenState:= tsUnknown;

    tsComment: FTokenState:= tsUnknown;

    tsCRLF:
      begin
        //JHD
        //PostFix:= '\par ';
        //JHD
        FTokenState:= tsUnknown;
        FComment:= csNo;
      end;

    tsDirective: FTokenState:= tsUnknown;

    tsIdentifier: FTokenState:= tsUnknown;

    tsNumber: FTokenState:= tsUnknown;

    tsKeyWord: FTokenState:= tsUnknown;

    tsSpace: FTokenState:= tsUnknown;

    tsString: FTokenState:= tsUnknown;

    tsSymbol: FTokenState:= tsUnknown;

  end;
end;  { SetRTF }

procedure TPasConversion.WriteToBuffer(aString: String);
var
  Count, Pos: Longint;
begin
  Count:= Length(aString);
  if (FBuffPos >= 0) and (Count >= 0) then
  begin
    Pos := FBuffPos + Count;
    if Pos > 0 then
    begin
      if Pos >= FOutBuffSize then
        begin
           Try
             FOutBuffSize:= FOutBuffSize + 16384;
             ReAllocMem(FOutBuff, FOutBuffSize);
           except
             raise exception.Create('conversions buffer to small');
           end;
        end;
        {System.Write(aString);}
      StrECopy((FOutBuff + FBuffPos), PChar(aString));
      FBuffPos:= FBuffPos + Count;
      FOutBuff[FBuffPos]:= #0;
    end;
  end;
end;  { WriteToBuffer }

//function TPasConversion.ConvertReadStream: Integer;
//begin
//  FTokenState:= tsUnknown;
//  FOutBuffSize:= size+3;
//  ReAllocMem(FOutBuff, FOutBuffSize);
//  FComment:= csNo;
//  FBuffPos:= 0;
//  FReadBuff:= Memory;
//  {Write leading RTF}
//  WriteToBuffer('{\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS SansSerif;}{\f1\froman\fcharset2 Symbol;}{\f2\fmodern Courier New;}}'+#13+#10);
//  WriteToBuffer('{\colortbl\red0\green0\blue0;}'+#13+#10);
//  WriteToBuffer('\deflang1033\pard\plain\f2\fs20 ');
//
//  Result:= Read(FReadBuff^, Size);
//  FReadBuff[Result]:= #0;
//  if Result > 0 then
//  begin
//  Run:= FReadBuff;
//  TokenPtr:= Run;
//  while Run^ <> #0 do
//  begin
//    Case Run^ of
//
//      #13:
//        begin
//          FComment:= csNo;
//          HandleCRLF;
//        end;
//
//      #1..#9, #11, #12, #14..#32:
//        begin
//          while Run^ in [#1..#9, #11, #12, #14..#32] do inc(Run);
//              FTokenState:= tsSpace;
//              TokenLen:= Run - TokenPtr;
//              SetString(TokenStr, TokenPtr, TokenLen);
//              SetRTF;
//              WriteToBuffer(Prefix + TokenStr + Postfix);
//              TokenPtr:= Run;
//        end;
//
//      'A'..'Z', 'a'..'z', '_':
//        begin
//          FTokenState:= tsIdentifier;
//          inc(Run);
//          while Run^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do inc(Run);
//          TokenLen:= Run - TokenPtr;
//          SetString(TokenStr, TokenPtr, TokenLen);
//          if IsKeyWord(TokenStr) then
//          begin
//            if IsDirective(TokenStr) then FTokenState:= tsDirective
//              else FTokenState:= tsKeyWord;
//          end;
//          SetRTF;
//          WriteToBuffer(Prefix + TokenStr + Postfix);
//          TokenPtr:= Run;
//        end;
//
//      '0'..'9':
//        begin
//          inc(Run);
//          FTokenState:= tsNumber;
//          while Run^ in ['0'..'9', '.', 'e', 'E'] do inc(Run);
//          TokenLen:= Run - TokenPtr;
//          SetString(TokenStr, TokenPtr, TokenLen);
//          SetRTF;
//          WriteToBuffer(Prefix + TokenStr + Postfix);
//          TokenPtr:= Run;
//        end;
//
//      '{':
//        begin
//          FComment:= csBor;
//          HandleBorC;
//        end;
//      
//      '!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~' :
//        begin
//          FTokenState:= tsSymbol;
//          while Run^ in ['!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~'] do
//          begin
//            Case Run^ of
//              '/': if (Run + 1)^ = '/' then
//                   begin
//                     TokenLen:= Run - TokenPtr;
//                     SetString(TokenStr, TokenPtr, TokenLen);
//                     SetRTF;
//                     WriteToBuffer(Prefix + TokenStr + Postfix);
//                     TokenPtr:= Run;
//                     FComment:= csSlashes;
//                     HandleSlashesC;
//                     break;
//                   end;
//
//              '(': if (Run + 1)^ = '*' then
//                   begin
//                     TokenLen:= Run - TokenPtr;
//                     SetString(TokenStr, TokenPtr, TokenLen);
//                     SetRTF;
//                     WriteToBuffer(Prefix + TokenStr + Postfix);
//                     TokenPtr:= Run;
//                     FComment:= csAnsi;
//                     HandleAnsiC;
//                     break;
//                   end;
//            end;
//            inc(Run);
//          end;
//          TokenLen:= Run - TokenPtr;
//          SetString(TokenStr, TokenPtr, TokenLen);
//          SetRTF;
//          WriteToBuffer(Prefix + TokenStr + Postfix);
//          TokenPtr:= Run;
//        end;
//
//      #39: HandleString;
//
//      '#':
//        begin
//          FTokenState:= tsString;
//          while Run^ in ['#', '0'..'9'] do inc(Run);
//          TokenLen:= Run - TokenPtr;
//          SetString(TokenStr, TokenPtr, TokenLen);
//          SetRTF;
//          WriteToBuffer(Prefix + TokenStr + Postfix);
//          TokenPtr:= Run;
//        end;
//
//      '$':
//        begin
//          FTokenState:= tsNumber;
//          while Run^ in ['$','0'..'9', 'A'..'F', 'a'..'f'] do inc(Run);
//          TokenLen:= Run - TokenPtr;
//          SetString(TokenStr, TokenPtr, TokenLen);
//          SetRTF;
//          WriteToBuffer(Prefix + TokenStr + Postfix);
//          TokenPtr:= Run;
//        end;
//
//    else
//      begin
//        if Run^ <> #0 then
//        begin
//          inc(Run);
//          TokenLen:= Run - TokenPtr;
//          SetString(TokenStr, TokenPtr, TokenLen);
//          SetRTF;
//          WriteToBuffer(Prefix + TokenStr + Postfix);
//          TokenPtr:= Run;
//        end else break;
//      end;
//    end;
//  end;
//
//
//  WriteToBuffer(#13+#10+'\par }{'+#13+#10);
//end;
//  Clear;
//  SetPointer(FOutBuff, fBuffPos-1) ;
//end;  { ConvertReadStream }
//
//function TPasConversion.ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize:
//Integer): Integer;
//begin
//  {FBuffPos:= 0;
//  FOutBuffSize:= BufSize;
//  FOutBuff:= StrAlloc(FOutBuffSize);
//  Run:= Buffer;
//  while Run^ <> #0 do
//  begin
//
//  end;
//  Result := Stream.Write(FOutBuff^, BufSize);
//  StrDispose(FOutBuff);}
//end;  { ConvertWriteStream }


procedure TPasConversion.Init;
begin

//JHD

   Clear;

   FStrBuffSize:= 0;
   AllocStrBuff;
   FFontTable.Clear;

   UseDelphiHighLighting(3);

//JHD

end;  { Initialize }


////////////////// SUBSTANTIALLY CHANGED CODE ////////////////////////////

procedure TPasConversion.ScanForRtf;
   // VERY MODIFIED TO REMOVE BUG!!! //
var
  i: Integer;
  j: Integer;
begin
  FStrBuffEnd:= FStrBuff + FStrBuffSize;
  j:=0;

  for i:=1 to TokenLen do
  begin
    Case TokenStr[i] of
      '\', '{', '}':
        begin
          FStrBuff[j]:= '\';
          inc(j);
        end;
      #13:
        begin
          if j >= (FStrBuffSize - 5) then AllocStrBuff;
          FStrBuff[j] := '\';
          FStrBuff[j+1] := 'p';
          FStrBuff[j+2] := 'a';
          FStrBuff[j+3] := 'r';
          FStrBuff[j+4] := ' ';
          inc(j,5);
        end;
    end;

    if j >= FStrBuffSize then AllocStrBuff;
    FStrBuff[j] := TokenStr[i];
    inc(j);
  end;
  FStrBuff[j] := #0;
  TokenStr:= FStrBuff;
end;  { ScanForRtf }


function TPasConversion.ConvertReadStream: Integer;
begin

  FOutBuffSize  := size+3;
  ReAllocMem(FOutBuff, FOutBuffSize);

  FTokenState   := tsUnknown;
  FComment      := csNo;
  FBuffPos      := 0;
  FReadBuff     := Memory;

  {Write leading RTF}

  WriteToBuffer('{\rtf1\ansi\deff0\deftab720');
  WriteFontTable;
  WriteColorTable;
  WriteToBuffer('\deflang1033\pard\plain\f0\fs20 ');


  Result:= Read(FReadBuff^, Size);
  if Result > 0 then
  begin

    FReadBuff[Result] := #0;
    Run               := FReadBuff;

    while Run^ <> #0 do
    begin

            Run                := GetToken(Run,FTokenState,TokenStr);

        ScanForRTF;
        SetRTF;

            WriteToBuffer(PreFix + TokenStr + PostFix);

        end;

    {Write ending RTF}

    WriteToBuffer(#13+#10+'\par }{'+#13+#10);
 end;

 Clear;
 SetPointer(FOutBuff, fBuffPos-1) ;

end;  { ConvertReadStream }

//
// MY Get Token routine
//

function TPasConversion.GetToken(Run: PChar; var aTokenState: TTokenState; var aTokenStr: string):PChar;
begin

  aTokenState    := tsUnknown;
  aTokenStr      := '';
  TokenPtr       := Run;


  Case Run^ of


      #13:
        begin
          aTokenState := tsCRLF;
          inc(Run, 2);
        end;

      #1..#9, #11, #12, #14..#32:
        begin
          while Run^ in [#1..#9, #11, #12, #14..#32] do inc(Run);
              aTokenState:= tsSpace;
        end;

      'A'..'Z', 'a'..'z', '_':
        begin

          aTokenState:= tsIdentifier;
          inc(Run);
          while Run^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do inc(Run);
          TokenLen:= Run - TokenPtr;
          SetString(aTokenStr, TokenPtr, TokenLen);
          if IsKeyWord(aTokenStr) then
          begin
            if IsDirective(aTokenStr) then aTokenState:= tsDirective
              else aTokenState:= tsKeyWord;
          end;
        end;

      '0'..'9':
        begin
          inc(Run);
          aTokenState:= tsNumber;
          while Run^ in ['0'..'9', '.', 'e', 'E'] do inc(Run);
        end;

      '{':
        begin
          FComment   := csBor;
              aTokenState := tsComment;
          while not (Run^ = '}') and not (Run^ = #0) do inc(Run);
          if (Run^ = '}') then inc(Run);
        end;

      '!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~' :
        begin
          aTokenState:= tsUnknown;
          while Run^ in ['!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~'] do
          begin
          Case Run^ of

              '/': if (Run + 1)^ = '/' then
                   begin
                    if (aTokenState = tsUnknown) then
                                begin
                                  while (Run^ <> #13) and (Run^ <> #0) do inc(Run);
                      FComment:= csSlashes;
                                  aTokenState := tsComment;
                                  break;
                    end
                    else
                                begin
                                  aTokenState := tsSymbol;
                                  break;
                                end;
                   end;

              '(': if (Run + 1)^ = '*' then
                   begin
                                if (aTokenState = tsUnknown) then
                                begin
                                 while (Run^ <> #0) and not
                     ((Run^ = ')') and ((Run - 1)^ = '*')) do inc(Run);
                     inc(Run);
                                     FComment:= csAnsi;
                                 aTokenState := tsComment;
                                     break;
                     end
                   else
                                begin
                                aTokenState := tsSymbol;
                                break;
                   end;
              end;
            end;
            aTokenState := tsSymbol;
            inc(Run);
          end;

              if (aTokenState = tsUnknown) then aTokenState := tsSymbol;
        end;


      #39:
      begin
          aTokenState:= tsSTring;
          FComment:= csNo;
          repeat
            Case Run^ of
              #0, #10, #13: raise exception.Create('Invalid string');
            end;
            inc(Run);
          until Run^ = #39;
          inc(Run);
      end;


      '#':
        begin
          aTokenState:= tsString;
          while Run^ in ['#', '0'..'9'] do inc(Run);
        end;

      '$':
        begin
          FTokenState:= tsNumber;
          while Run^ in ['$','0'..'9', 'A'..'F', 'a'..'f'] do inc(Run);
        end;

    else
      if Run^ <> #0 then inc(Run);

  end;

  TokenLen  := Run - TokenPtr;
  SetString(aTokenStr, TokenPtr, TokenLen);
  Result    := Run
end; { GetToken }

function TPasConversion.FontToRTFFontNr(aFont: TFont):Integer;
begin
    Result := FFontTable.IndexOf(aFont.Name);
    if (Result < 0) then        Result := FFontTable.Add(aFont.Name);
end;

function TPasConversion.ColorToTable(aColor: TColor): String;
var index: Integer;
begin
  Result := ''; // If not match... we don't Change things...//
  for Index := Low(ColorValues) to High(ColorValues) do
       if ColorValues[index] = aColor then Result := IntToStr(Index);

end; { ColorToTable }

procedure TPasConversion.WriteColorTable;
var    Index: Integer;
begin
     WriteToBuffer('{\colortbl');
     for Index := Low(ColorValues) to High(ColorValues) do
     begin
          WriteToBuffer(ColorToRTF(ColorValues[Index]));
     end;
     WriteToBuffer('}'+#13+#10);
end;

procedure TPasConversion.WriteFontTable;
var
  Index: Integer;
begin
  WriteToBuffer('{\fonttbl');
  { KSG tweak to allow the use of Arial, see code below}
  if UseWordFont then begin
    WriteToBuffer('{\f0 Arial};');
  end else begin
    for Index := 0  to FFontTable.Count-1 do begin
      WriteToBuffer('{\f' + IntToStr(Index) + ' ' + FFontTable.Strings[Index]);
      WriteToBuffer(';}');
    end;
  end ;

  WriteToBuffer('}'+#13+#10);
end;
end.

END CODE

Caveat: Since the above unit uses Delphi fonts from the
IDE you can't override it directly. I added the following
code to allow me to accomplish a font change.
Note: It is not the most elegant, but does the job. Since
it is a utility for me, why bother prettying it up?

procedure TfrmMain.mnuUsingArialClick(Sender: TObject);
var
  TS: TMemoryStream ;
  PC: TPasConversion ;
  x,
  iPos:Integer ;
begin
  TS := TMemoryStream.Create ;
  PC := TPasConversion.Create ;

  GetEditorCursorPos ;
  iPos := xPos.y ;
 
  try
    TheEditor.PlainText := True ;
    TheEditor.Lines.SaveToStream(TS) ;
    TheEditor.PlainText := False ;

    TS.Seek(0,0) ;
    with PC do begin
      if TComponent(Sender).Tag = 100 then
        UseWordFont := True;

      UseDelphiHighlighting(3) ;
      LoadFromStream(TS) ;
      ConvertReadStream ;
    end;

    with TheEditor do begin
      Clear;
      Lines.BeginUpdate ;
      Lines.LoadFromStream(PC) ;
      Lines.EndUpdate ;
    end;
   
    if iPos >0 then begin
      TheEditor.SetFocus ;
      for x := 1 to iPos -1 do begin
        keybd_Event(VK_DOWN, 0, 0, 0) ;
        keybd_Event(VK_DOWN, 0, KEYEVENTF_KEYUP, 0) ;
      end ;
    end;

  finally
    PC.Free ;
    TS.Free ;
  end;
end;

procedure TForm1.GetEditorCursorPos ;
var
  x:Integer ;
begin
  x := TheEditor.SelStart ;

  xPos.Y := SendMessage(TheEditor.Handle,EM_EXLINEFROMCHAR,0,x) ;
  xPos.X := (x - SendMessage(TheEditor.Handle,EM_LINEINDEX,xPos.Y,0)) ;

  Inc(xPos.Y) ;   // xPos is a global Tpoint as shown below.
  Inc(xPos.X) ;   // xPos: TPoint;
end ;


Once you import the unit, either highlight the text manually and
paste into MS-Word, or add the following using buttons or
menu items

TheEditor.SelectAll ;  // selects all text in the editor
TheEditor.CutToClipboard ;  // copies text from editor
I chose cut since I don't need the text anymore, you
could use CopyToClipboard instead.

If you need the code I can email you the complete source
kevin.s.gallagher@state.or.us
0
 
LVL 1

Expert Comment

by:slautin
Comment Utility
Ohh, I'm previos answers too long.
It's make by different way.
Lookig by lexical analizators!!! It's very easy... in any cases.

Specification example:

NQUOTE    [^']

%%

[a-zA-Z]([a-zA-Z0-9])*  begin
                      //test yytext value for keyword
                      //else it's identifier
                      //prepare output file like RTF
                       end;

'({NQUOTE}|'')+'        return(STRING);
"{"                     begin
                        //it is coment
                        c := get_char;
                        while c <> '}' do
                               c := get_char;
                        end;
                       begin
                        //put characters to output stream
                        end;

mail in difficults: slautin@yahoo.com
0
 
LVL 1

Expert Comment

by:slautin
Comment Utility
I think that write lexical analizer manually -  not best way.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
This video gives you a great overview about bandwidth monitoring with SNMP and WMI with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're looking for how to monitor bandwidth using netflow or packet s…
You have products, that come in variants and want to set different prices for them? Watch this micro tutorial that describes how to configure prices for Magento super attributes. Assigning simple products to configurable: We assigned simple products…

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now