Results 1 to 2 of 2

Thread: Eindelijk de TOM Richedit

  1. #1
    Senior Member Thaddy's Avatar
    Join Date
    Dec 2004
    Location
    Amsterdam
    Posts
    2,211

    Eindelijk de TOM Richedit

    Hoi,

    Naar aanleiding van een discussie in de newsgroups kwam ik er toe eindelijk eens een Q&D demo van de Text Object Model interfaces te maken.
    Hier is een Q&D component, het is de bedoeling dat je het meeneemt in een betere eigen component, je kunt de code zo plakken in elke bekende OleRichEdit of het gewoon hierbij laten. Dit is niet bedoeld als weeeer een OleRichedit, maar alleen voor de TOM interfaces :
    Code:
    unit TOMRichEdit;
    {
    
      Quick and dirty example of how to surface the Text Object Model interfaces
      from RichEd20.dll. See MSDN under TOM or ITextDocument for documentation and
      how to use.
      This is merly a sketch, not a full-blown component.
      You obtain tom_TLB by opening riched20.dll with the typelibrary editor.
      With the TOM interfaces you can for example clone a range, do processing on it
      and assign it back to the Richedit.
    
      Use as you like.
    
      (C) 2001,2005, Thaddy de Koning
    }
    
    interface
    
    uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
      StdCtrls, ComCtrls,
      richedit, activeX, comobj, tom_TLB;{imported from riched20.dll}
    
    type
    
    
      TTOMRichEdit = class(TRichEdit)
      private
         IOle: IUnknown;//IRichEditOle;
         ITextDoc:ITextDocument;
        function GetTextDocument: ITextDocument;
      public
        destructor destroy;override;
        property Document:ITextDocument read GetTextDocument;
      end;
    
    procedure Register;
    
    implementation
    
    procedure Register;
    begin
      RegisterComponents('Samples', [TTOMRichEdit]);
    end;
    
    { TTOMRichEdit }
    destructor TTOMRichEdit.destroy;
    begin
      IOle:=nil;
      ITextDoc:=nil;
      inherited;
    end;
    
    function TTOMRichEdit.GetTextDocument: ITextDocument;
    begin
      // can't do this from the constructor,
      // so I q&d it here
      if IOle = nil then
      begin
        perform(EM_GETOLEINTERFACE, 0, integer(@IOle));
        If IOle <> nil then
        begin
          Iole.QueryInterface(ITextDocument,ITextDoc);
        end;
      end;
      Result:=ITextDoc;
    end;
    
    initialization
      coInitialize(nil);
    finalization
      coUninitialize;
    end.
    En hier is wat Q&D demo code om te laten zien dat het een stuk handiger werkt dan de standaard Richedit als je de text wilt processen. Dit is een - langzame - syntaxhighlighter in heel weinig code.

    Code:
    unit Unit1;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, Menus, StdCtrls, ComCtrls, TOMRichEdit, tom_TLB, contnrs;
    
    const
      PascalKeywords : array [0..105] of widestring = (
        {reserved words}
        'and', 'array', 'as', 'asm', 'begin', 'case', 'class', 'const',
        'constructor', 'destructor', 'dispinterface', 'div', 'do',
        'downto', 'else', 'end', 'except', 'exports', 'file',
        'finalization', 'finally', 'for', 'function', 'goto', 'if',
        'implementation', 'in', 'inherited', 'initialization', 'inline',
        'interface', 'is', 'label', 'library', 'mod', 'nil', 'not',
        'object', 'of', 'or', 'out', 'packed', 'procedure', 'program',
        'property', 'raise', 'record', 'repeat', 'resourcestring', 'set',
        'shl', 'shr', 'string', 'then', 'threadvar', 'to', 'try', 'type',
        'unit', 'until', 'uses', 'var', 'while', 'with', 'xor',
        {directives}
        'absolute', 'abstract', 'assembler', 'automated', 'cdecl',
        'contains', 'default', 'dispid', 'dynamic', 'export', 'external',
        'far', 'forward', 'implements', 'index', 'message', 'name',
        'near', 'nodefault', 'overload', 'override', 'package', 'pascal',
        'private', 'protected', 'public', 'published', 'read', 'readonly',
        'register', 'reintroduce', 'requires', 'resident', 'safecall',
        'stdcall', 'stored', 'virtual', 'write', 'writeonly',
        {others}
        'at', 'on'
        );
    
    type
    
      TParseRecord = record
        ML1Start:widestring;  //Multiline comment
        ML1End:widestring;
        ML2Start:widestring;  //Multiline comment alternative
        ML2End:widestring;
        DvStart:widestring;   //Directive
        DvEnd:widestring;
        SL:widestring;        //Single line color
        SD:String;
        DefaultColor,
        CommentColor,
        DirectiveColor,
        KeywordColor:TColor;
      end;
    
    type
      // simple hashed stringlist. Uses a fast elfhash (in BASM)
      // and linear probing to find a string element.
      // Fast but not finished (Objects property needs to be guarded from use)
      THashedStringlist = class(Tstringlist)
      public
         constructor create;virtual;
         function IndexOf(const S: string): Integer;override;
         procedure Insert(Index: Integer; const S: string);override;
         function Add(const S:string):integer;override;
      end;
    
    type
      TForm1 = class(TForm)
        MainMenu1: TMainMenu;
        TOMRichEdit1: TTOMRichEdit;
        File1: TMenuItem;
        Exit1: TMenuItem;
        N1: TMenuItem;
        Open1: TMenuItem;
        Options1: TMenuItem;
        Highlight1: TMenuItem;
        OpenDialog1: TOpenDialog;
        procedure Exit1Click(Sender: TObject);
        procedure Open1Click(Sender: TObject);
        procedure Highlight1Click(Sender: TObject);
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
      private
        KeyWords:THashedStringlist;
        PascalRecord:TParseRecord;
      public
        { Public declarations }
        procedure HighLight;
      end;
    
    var
      Form1: TForm1;
    
    implementation
    
    {$R *.dfm}
    
    // Fast: only 7 cycles per round....
    function ElfHash(const s: string): Tobject;
    asm
         mov   edx, eax
         xor   eax, eax
         test  edx, edx
         jz    @Ret
         sub   eax, [edx-4]
         jz    @Ret
         mov   ecx, eax
         sub   edx, eax
         xor   eax, eax
         push  ebx
    @Loop:
         movzx ebx, [edx+ecx]
         add   ebx, eax
         lea   eax, [ebx+ebx]
         shr   ebx, 20
         lea   eax, [8*eax]
         and   ebx, $0F00
         xor   eax, ebx
         add   ecx, 1
         jnz   @Loop
         shr   eax, 4
         pop   ebx
    @Ret:
    end;
    
    procedure TForm1.Exit1Click(Sender: TObject);
    begin
      Application.Terminate;
    end;
    
    procedure TForm1.Open1Click(Sender: TObject);
    var
      fn:OleVariant;
    begin
      if Opendialog1.execute then
      begin
        fn:=OpenDialog1.FileName;
        TomRichedit1.document.Open(fn,0,0);
      end;
    end;
    
    procedure TForm1.Highlight1Click(Sender: TObject);
    begin
      HighLight;
    end;
    
    procedure Tform1.highlight;
    var
     Token:Widestring;
     I:Integer;
     Clone:ITextRange;
    begin
     Clone:=TomRichEdit1.Document.Selection.Duplicate;
     i:=Clone.start;
     Clone.font.Style:=-2;
     while 1=1  do
     with Clone, PascalRecord do
     begin
       if Boolean(MoveEnd(tomWord,1))=false then break;
       Token:=trim(lowercase(text));
       // single line comment, if applicable
       // Note that the order in which the text is parsed is very important!
       if ( length(SL)>0 )and (system.copy(Token,1,length(SL)) = SL) then
       begin
         FindTextEnd(#13,tomForward,0);
         Font.ForeColor:=CommentColor;
         setrange(end_,end_);
       end
       else
       // Directive, if applicable
       if ( length(DVStart)>0 ) and (system.copy(Token,1,Length(DvStart)) =DvStart) then
       begin
         if DvEnd <> '' then
            FindTextEnd(DvEnd,tomForward,0)
         else
            MoveEnd(tomWord,1);
         Clone.font.ForeColor:=DirectiveColor;
         setrange(end_,end_);
       end
       // multiline comment type 1, if applicable
       else
       if( length(ML1Start)>0 )  and (system.copy(Token,1,Length(ML1start)) = ML1Start) then
       begin
         SetRange(start,start);
         FindTextEnd(ML1End,tomForward,0);
         Font.ForeColor:=CommentColor;
         SetRange(end_,end_);
       end
       // multiline comment type 2, if applicable
       else
       if ( length(ML2Start)>0 ) and (system.copy(Token,1,Length(ML2start)) = ML2Start) then
       begin
         SetRange(start,start);
         FindTextEnd(ML2End,tomForward,0);
         Font.ForeColor:=CommentColor;
         SetRange(end_,end_);
       end
       else
       // keywords
       begin
         // poor man's hashmap using linear probing to find the key.
         if Keywords.IndexOf(Token) >= 0 then
         begin
           Clone.font.forecolor:=KeywordColor;
           Clone.Font.Bold:=integer(tomTrue);
         end else
           Clone.font.forecolor:=DefaultColor;
           movestart(tomword,1);
       end;
       Application.ProcessMessages;
      end;
     Clone.Setrange(i,i);
    end;
    
    
    
    procedure TForm1.FormCreate(Sender: TObject);
    var
     i:integer;
    begin
      Keywords:=THashedStringlist.Create;
      for i:= Low(PascalKeyWords) to High(PascalKeyWords) do
        begin
         KeyWords.Add(PascalKeywords[i]);
        end;
    
      with PascalRecord do
      begin
       ML1Start := '{';
       ML1End := '}';
       ML2Start := '(*';
       ML2End := '*)';
       DVStart := '{$';
       DVEnd := '}';
       SL := '//';
       SD := #39;
       DefaultColor  := ClBlack;
       CommentColor  := clNavy;
       DirectiveColor:= clGreen;
       KeywordColor  := clBlack
      end;
    end;
    
    procedure TForm1.FormDestroy(Sender: TObject);
    begin
      Keywords.Free;
    end;
    
    { THashedStringlist }
    
    function THashedStringlist.Add(const S: string): integer;
    begin
      Result := GetCount;
      Insert(Result, S);
    end;
    
    constructor THashedStringlist.create;
    begin
     inherited create;
     Duplicates:=dupError;
    end;
    
    function THashedStringlist.IndexOf(const S: string): Integer;
    begin
      result:=IndexOfObject(ElfHash(Lowercase(s)));
    end;
    
    procedure THashedStringlist.Insert(Index: Integer; const S: string);
    begin
      inherited;
      Objects[index]:=ElfHash(Lowercase(S));
    end;
    
    end.
    Form:

    Code:
    object Form1: TForm1
      Left = 232
      Top = 199
      Width = 696
      Height = 480
      Caption = 'Form1'
      Color = clBtnFace
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      Menu = MainMenu1
      OldCreateOrder = False
      OnCreate = FormCreate
      OnDestroy = FormDestroy
      PixelsPerInch = 96
      TextHeight = 13
      object TOMRichEdit1: TTOMRichEdit
        Left = 0
        Top = 0
        Width = 688
        Height = 426
        Align = alClient
        Font.Charset = DEFAULT_CHARSET
        Font.Color = clWindowText
        Font.Height = 15
        Font.Name = 'Courier New'
        Font.Pitch = fpFixed
        Font.Style = []
        Lines.Strings = (
          'TOMRichEdit1')
        ParentFont = False
        ScrollBars = ssVertical
        TabOrder = 0
      end
      object MainMenu1: TMainMenu
        Left = 32
        Top = 32
        object File1: TMenuItem
          Caption = '&File'
          object Open1: TMenuItem
            Caption = '&Open...'
            OnClick = Open1Click
          end
          object N1: TMenuItem
            Caption = '-'
          end
          object Exit1: TMenuItem
            Caption = 'E&xit'
            OnClick = Exit1Click
          end
        end
        object Options1: TMenuItem
          Caption = '&Options'
          object Highlight1: TMenuItem
            Caption = '&Highlight'
            OnClick = Highlight1Click
          end
        end
      end
      object OpenDialog1: TOpenDialog
        Filter = 'Pascal files|*.dpr;*.pas'
        Left = 64
        Top = 32
      end
    end
    Last edited by Thaddy; 20-Oct-05 at 16:20. Reason: Demo aangepast
    Werken aan Ansi support voor Windows is verspilde tijd, behalve voor historici.

  2. #2
    Senior Member PsychoMark's Avatar
    Join Date
    Nov 2001
    Location
    Raamsdonksveer
    Posts
    10,269
    • Verplaatst van Algemeen naar Artikelen & tips


    ...ziet er interessant uit!
    Qui custodiet ipsos custodes

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •