pascalhigh.pas

wptools5 pro 完整源代码 Msword界面的文本编辑器源代码

unit PascalHigh;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, WPRTEDefs, WPCTRMemo, WPCTRRich, ExtCtrls, StdCtrls;

type
  TWPHighlightPascal = class(TForm)
    Panel1: TPanel;
    WPRichText1: TWPRichText;
    Load: TButton;
    aSyntaxHiglightExecute: TButton;
    Label1: TLabel;
    procedure LoadClick(Sender: TObject);
    procedure aSyntaxHiglightExecuteClick(Sender: TObject);
      private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  WPHighlightPascal: TWPHighlightPascal;

implementation

{$R *.dfm}

procedure TWPHighlightPascal.LoadClick(Sender: TObject);
begin
  WPRichText1.Load('','Pascal Code|*.PAS')
end;

{ The following procedure highlights the selected text
  like Pascal Source in the Delphi Editor.
  It handles, comments, strings and reserved words.

  The procedure was initially written for WPTools 4 - we have modified it to
  work with WPTools 5.

  This changes were required:
    "CPAttr^." changed to "CPAttr."
    "CPChar^"  changed to "CPChar"

    The old code used a char pointer p which was initialized with CPChar. This is
    not possible in V5. It is posssible to simulate this pointer using the array
    CPChars[offset] : WideChar but then StrlIcomp would not work with that.

    We implemented the function par.Compare which can be used instead.
}

procedure TWPHighlightPascal.aSyntaxHiglightExecuteClick(Sender: TObject);
var
  pos, l, rl, i, j, comcolor, strcolor: Integer;
  last, last2, c: Char;
  p: PChar;
  comment1, comment2, string1, ignore: Boolean;
const
  ReservedWords: array[1..27] of string = // not complete list
  ('var', 'end', 'begin', 'then', 'or', 'and', 'else', 'nil', 'property',
    'if', 'while', 'procedure', 'function', 'repeat', 'until',
    'unit', 'interface', 'uses', 'type', 'class', 'private', 'public', 'implementation',
    'try', 'except', 'finally', 'case');
  procedure SetTheColor;
  begin
    if comment2 or comment1 then
      WPRichText1.CPAttr.Color := comcolor
    else if string1 then
      WPRichText1.CPAttr.Color := strcolor;
  end;
begin
  if WPRichText1 <> nil then
  begin
    if WPRichText1.SelLength=0 then WPRichText1.SelectAll;

    pos := WPRichText1.SelStart;
    l := WPRichText1.SelLength;
    if l = 0 then
       ShowMessage('Please select text!');
    WPRichText1.BeginUpdate;
    try
      // Step 1: Set everything to black, 'Courier New', Size '10'
      WPRichText1.CurrAttr.BeginUpdate;
      WPRichText1.CurrAttr.Size := 10;
      WPRichText1.CurrAttr.FontName := 'Courier New';
      WPRichText1.CurrAttr.Color := 0; // black
      WPRichText1.CurrAttr.DeleteStyle([afsBold, afsItalic]);
      WPRichText1.CurrAttr.EndUpdate;
      // Step 2: Mark all comments
      comcolor := WPRichText1.CurrAttr.ColorToNr(clGreen, true); // Comments
      strcolor := WPRichText1.CurrAttr.ColorToNr(clRed, true); // Strings
      WPRichText1.CPPosition := pos;
      i := 0;
      ignore := FALSE;
      comment1 := FALSE; {}
      comment2 := FALSE; //
      string1 := FALSE;
      last := #0;
      last2 := #0;
      while i < l do
      begin
        c := WPRichText1.CPChar;
        if string1 and
          (((c = #39) and
          ((last <> #39) or (last2 = #39)) or (c = #13))) then
        begin
          SetTheColor;
          string1 := FALSE;
          ignore := TRUE;
        end
        else if comment1 and (c = '}') then
        begin
          SetTheColor;
          comment1 := FALSE;
          ignore := TRUE;
        end
        else if comment2 and (c = #13) then
          comment2 := FALSE
        else if not (comment1 or comment2) and (c = #39) then
          string1 := TRUE
        else if not (comment1 or string1) and (c = '/') and (last = '/') then
        begin
          comment2 := TRUE;
          WPRichText1.CPMoveBack;
          SetTheColor;
          WPRichText1.CPMoveNext;
        end
        else if not (comment2 or string1) and (c = '{') then
          comment1 := TRUE;
        last2 := last;
        last := c;
        if not ignore then SetTheColor;
        ignore := FALSE;
        inc(i);
        WPRichText1.CPMoveNext;
      end;
      // Step 3: Highlight reserved words
      WPRichText1.CPPosition := pos;
      i := 0;
      while i < l do
      begin
      { old V4 code: cannot be converted
        p := WPRichText1.CPChar;
        if WPRichText1.CPAttr^.Color = 0 then // No comment, no string !
          if (p^ in ['a'..'z']) or (p^ in ['A'..'Z']) then
          begin
            ignore := FALSE;
            for j := 1 to High(ReservedWords) do
            begin
              rl := Length(ReservedWords[j]);
              if (StrlIcomp(p, PChar(ReservedWords[j]), rl) = 0) and
                (((p + rl)^ <= #32) or ((p + rl)^ in [';', '(', ')', '/', '[', ']'])) then
              begin
                while rl > 0 do
                begin
                  include(WPRichText1.CPAttr^.Style, afsBold);
                  WPRichText1.CPMoveNext;
                  dec(rl);
                  inc(i);
                end;
                ignore := TRUE;
                break;
              end;
            end;   }
        // New V5 code:
        if (WPRichText1.CPChar in ['a'..'z']) or (WPRichText1.CPChar in ['A'..'Z']) then
        begin
          for j := 1 to High(ReservedWords) do
          begin
              rl := Length(ReservedWords[j]);
              if WPRichText1.ActiveParagraph.IsWordDelimiter(
                   WPRichText1.ActivePosInPar + rl) and
                 WPRichText1.ActiveParagraph.Compare(
                     WPRichText1.ActivePosInPar,
                     ReservedWords[j], FALSE) then
              begin
                while rl > 0 do
                begin
                  WPRichText1.CPAttr.IncludeStyle(afsBold);
                  // WPRichText1.CPAttr.Color := WPRichText1.CurrAttr.ColorToNr(clBlue);
                  WPRichText1.CPMoveNext;
                  dec(rl);
                  inc(i);
                end;
                ignore := TRUE;
                break;
              end;
          end;
          if not ignore then // We didn't find anything ....
              while (WPRichText1.CPChar in ['a'..'z']) or (WPRichText1.CPChar in ['A'..'Z']) do
              begin
                WPRichText1.CPMoveNext;
                inc(i);
              end;

          end;
        WPRichText1.CPMoveNext;
        inc(i);
      end;
      WPRichText1.CPPosition := pos;
    finally
      WPRichText1.EndUpdate;
    end;
  end;
  WPRichText1.HideSelection;
end;

end.