formsetcodecolorunit.pas

duiwenjiandechuli fangbianguanli.

unit FormSetCodeColorUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, RichEdit, Clipbrd, ComCtrls;

type
  TFormSetCodeColor = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    ColorStyle: TComboBox;
    Label1: TLabel;
    btnSetColor: TButton;
    btnDoCancel: TButton;
    btnOk: TButton;
    btnCancel: TButton;
    OpMode: TComboBox;
    Label2: TLabel;
    btnPrint: TButton;
    richEdit: TRichEdit;
    FontName: TComboBox;
    backRichEdit: TRichEdit;
    procedure FormCreate(Sender: TObject);
    procedure btnPrintClick(Sender: TObject);
    procedure btnSetColorClick(Sender: TObject);
    procedure FontNameChange(Sender: TObject);
    procedure btnDoCancelClick(Sender: TObject);
    procedure btnOkClick(Sender: TObject);
    procedure FontNameKeyPress(Sender: TObject; var Key: Char);
  private
    procedure GetFontNames;
  public

  end;

var
  FormSetCodeColor  : TFormSetCodeColor;

implementation

uses FormMainUnit;

{$R *.dfm}

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; stdcall;
begin
  TStrings(Data).Add(LogFont.lfFaceName);
  Result := 1;
end;

procedure TFormSetCodeColor.GetFontNames;
var
  DC                : HDC;
begin
  DC := GetDC(0);
  EnumFonts(DC, nil, @EnumFontsProc, Pointer(FontName.Items));
  ReleaseDC(0, DC);
  FontName.Sorted := True;
end;

procedure CodeColors(Form: TForm; Style, fontName: string; RichE: TRichedit;
  InVisible:
  Boolean);
const
  // 符号...
  CodeC1            : array[0..20] of string = ('#', '$', '(', ')', '*', ',',
    '.', '/', ':', ';', '[', ']', '{', '}', '<', '>',
    '-', '=', '+', '''', '@');
  // 保留字...
  CodeC2            : array[0..44] of string = ('and', 'as', 'begin',
    'case', 'char', 'class', 'const', 'downto',
    'else', 'end', 'except', 'finally', 'for',
    'forward', 'function', 'if', 'implementation', 'interface',
    'is', 'nil', 'or', 'private', 'procedure', 'public', 'raise',
    'repeat', 'string', 'to', 'try', 'type', 'unit', 'uses', 'var',
    'while', 'external', 'stdcall', 'do', 'until', 'array', 'of',
    'in', 'shr', 'shl', 'cos', 'div');
var
  FoundAt           : LongInt;
  StartPos, ToEnd, i: integer;
  OldCap, T         : string;
  FontC, BackC, C1, C2, C3, strC, strC1: TColor;
begin
  OldCap := Form.Caption;
  with RichE do
  begin
    Font.Name := fontName;
    Font.Size := 9;
    if WordWrap then
      WordWrap := false;
    SelectAll;
    SelAttributes.color := clBlack;
    SelAttributes.Style := [];
    SelStart := 0;
    if InVisible then
    begin
      Visible := False;
      Form.Caption := '执行代码加色...';
    end;
  end;

  BackC := clWhite;
  FontC := clBlack;
  C1 := clBlack;
  C2 := clBlack;
  C3 := clBlack;
  strC := clBlue;
  strC1 := clSilver;

  if Style = 'Twilight' then
  begin
    BackC := clBlack;
    FontC := clWhite;
    C1 := clLime;
    C2 := clSilver;
    C3 := clAqua;
    strC := clYellow;
    strC1 := clRed;
  end
  else if Style = 'Default' then
  begin
    BackC := clWhite;
    FontC := clBlack;
    C1 := clTeal;
    C2 := clMaroon;
    C3 := clBlue;
    strC := clMaroon;
    strC1 := clSilver;
  end
  else if Style = 'Ocean' then
  begin
    BackC := $00FFFF80;
    FontC := clBlack;
    C1 := clMaroon;
    C2 := clBlack;
    C3 := clBlue;
    strC := clTeal;
    strC1 := clBlack;
  end
  else if Style = 'Classic' then
  begin
    BackC := clNavy;
    FontC := clYellow;
    C1 := clLime;
    C2 := clSilver;
    C3 := clWhite;
    strC := clAqua;
    strC1 := clSilver;
  end
  else
  begin
    with RichE do
    begin
      T := '{' + Style +
        ' = 无效式样,只能选择 [Default,Classic,Twilight,Ocean] 其中一种! }';
      Lines.Insert(0, T);
      StartPos := 0;
      ToEnd := Length(Text) - StartPos;
      FoundAt := FindText(T, StartPos, ToEnd, [stWholeWord]);
      SelStart := FoundAt;
      SelLength := Length(T);
      SelAttributes.Color := clRed;
      SelAttributes.Style := [fsBold];
      StartPos := 0;
      ToEnd := Length(Text) - StartPos;
      FoundAt := FindText('唯一!', StartPos, ToEnd, [stWholeWord]);
      SelStart := FoundAt;
      SelLength := 4;
      SelAttributes.Color := clRed;
      SelAttributes.Style := [fsBold, fsUnderLine];
    end;
  end;

  RichE.SelectAll;
  RichE.color := BackC;
  RichE.SelAttributes.color := FontC;

  for i := 0 to 100 do
  begin
    with RichE do
    begin
      StartPos := 0;
      ToEnd := Length(Text) - StartPos;
      FoundAt := FindText(IntToStr(i), StartPos, ToEnd, [stWholeWord]);
      while (FoundAt <> -1) do
      begin
        SelStart := FoundAt;
        SelLength := Length(IntToStr(i));
        SelAttributes.Color := C1;
        SelAttributes.Style := [];
        StartPos := FoundAt + Length(IntToStr(i));
        FoundAt := FindText(IntToStr(i), StartPos, ToEnd, [stWholeWord]);
      end;
    end;
  end;
  for i := 0 to 20 do
  begin
    with RichE do
    begin
      StartPos := 0;
      ToEnd := Length(Text) - StartPos;
      FoundAt := FindText(CodeC1[i], StartPos, ToEnd, []);
      while (FoundAt <> -1) do
      begin
        SelStart := FoundAt;
        SelLength := Length(CodeC1[i]);
        SelAttributes.Color := C2;
        StartPos := FoundAt + Length(CodeC1[i]);
        FoundAt := FindText(CodeC1[i], StartPos, ToEnd, []);
      end;
    end;
  end;
  for i := 0 to 44 do
  begin
    with RichE do
    begin
      StartPos := 0;
      ToEnd := Length(Text) - StartPos;
      FoundAt := FindText(CodeC2[i], StartPos, ToEnd, [stWholeWord]);
      while (FoundAt <> -1) do
      begin
        SelStart := FoundAt;
        SelLength := Length(CodeC2[i]);
        SelAttributes.Color := C3;
        SelAttributes.Style := [fsBold];
        StartPos := FoundAt + Length(CodeC2[i]);
        FoundAt := FindText(CodeC2[i], StartPos, ToEnd, [stWholeWord]);
      end;
    end;
  end;
  Startpos := 0;
  with RichE do
  begin
    FoundAt := FindText('''', StartPos, Length(Text), []);
    while FoundAt <> -1 do
    begin
      SelStart := FoundAt;
      Startpos := FoundAt + 1;
      FoundAt := FindText('''', StartPos, Length(Text), []);
      if FoundAt <> -1 then
      begin
        SelLength := (FoundAt - selstart) + 1;
        SelAttributes.Style := [];
        SelAttributes.Color := strC;
        StartPos := FoundAt + 1;
        FoundAt := FindText('''', StartPos, Length(Text), []);
      end;
    end;
  end;

  Startpos := 0;
  with RichE do
  begin
    FoundAt := FindText('{', StartPos, Length(Text), []);
    while FoundAt <> -1 do
    begin
      SelStart := FoundAt;
      Startpos := FoundAt + 1;
      FoundAt := FindText('}', StartPos, Length(Text), []);
      if FoundAt <> -1 then
      begin
        SelLength := (FoundAt - selstart) + 1;
        SelAttributes.Style := [];
        SelAttributes.Color := strC1;
        StartPos := FoundAt + 1;
        FoundAt := FindText('{', StartPos, Length(Text), []);
      end;
    end;
  end;

  if InVisible then
  begin
    RichE.Visible := True;
    Form.Caption := OldCap;
  end;
  RichE.SelStart := 0;
end;

procedure TFormSetCodeColor.FormCreate(Sender: TObject);
begin
  ColorStyle.ITems.Clear;
  ColorStyle.Items.Add('Default');
  ColorStyle.Items.Add('Classic');
  ColorStyle.Items.Add('Twilight');
  ColorStyle.Items.Add('Ocean');
  OpMode.Items.Clear;
  OpMode.Items.Add('替换/插入到原文本');
  OpMode.Items.Add('保存到剪贴板');

  ColorStyle.ItemIndex := 0;
  OpMode.ItemIndex := 0;
  GetFontNames;
  FontName.Text := Richedit.Font.Name;
  backRichEdit.Visible := false;
  backrichEdit.Clear;
  richEdit.Clear;

  richEdit.PasteFromClipboard;
  backRichEdit.PasteFromClipboard;

  self.richEdit.SelAttributes.Color :=
    formMainUnit.FormMain.RichEdit.SelAttributes.Color;
  self.richEdit.SelAttributes.Style :=
    formMainUnit.FormMain.RichEdit.SelAttributes.Style;
  self.richEdit.Color := formMainUnit.FormMain.RichEdit.color;

  self.backrichEdit.SelAttributes.Color :=
    formMainUnit.FormMain.RichEdit.SelAttributes.Color;
  self.backrichEdit.SelAttributes.Style :=
    formMainUnit.FormMain.RichEdit.SelAttributes.Style;
  self.backrichEdit.Color := formMainUnit.FormMain.RichEdit.color;
end;

procedure TFormSetCodeColor.btnPrintClick(Sender: TObject);
begin
  richedit.Print(datetimeToStr(now));
end;

procedure TFormSetCodeColor.btnSetColorClick(Sender: TObject);
begin
  CodeColors(formsetCodeColor, colorStyle.Text, FontName.Text, richEdit, false);
end;

procedure TFormSetCodeColor.FontNameChange(Sender: TObject);
begin
  if RichEdit.SelLength > 0 then
  begin
    RichEdit.SelAttributes.Name := FontName.Items[FontName.ItemIndex];
  end
  else
  begin
    RichEdit.DefAttributes.Name := FontName.Items[FontName.ItemIndex];
  end;
end;

procedure TFormSetCodeColor.btnDoCancelClick(Sender: TObject);
begin
  RichEdit.DefAttributes.Color := backRichEdit.DefAttributes.Color;
  RichEdit.SelAttributes.Color := backRichEdit.SelAttributes.Color;
  RichEdit.DefAttributes.Style := backRichEdit.DefAttributes.Style;
  RichEdit.SelAttributes.Style := backRichEdit.SelAttributes.Style;
  RichEdit.color := backRichEdit.Color;
  backrichEdit.SelectAll;
  backrichEdit.CopyToClipboard;
  richedit.Clear;
  richEdit.PasteFromClipboard;
end;

procedure TFormSetCodeColor.btnOkClick(Sender: TObject);
begin
  richedit.SelectAll;
  richedit.CopyToClipboard;
  if OpMode.ItemIndex = 0 then
  begin
    formMainUnit.FormMain.richEdit.PasteFromClipboard;
    formMainUnit.FormMain.RichEdit.SelAttributes.Color :=
      self.richEdit.SelAttributes.Color;
    formMainUnit.FormMain.RichEdit.SelAttributes.Style :=
      self.richEdit.SelAttributes.Style;
    formMainUnit.FormMain.RichEdit.color := self.richEdit.Color;
  end;
end;

procedure TFormSetCodeColor.FontNameKeyPress(Sender: TObject;
  var Key: Char);
begin
  key := #0;
end;

end.