imtextattribute.pas

Delphi中一直都没有能快速显示彩色文字信息的Memo控件而TRichEdit慢得无法在需要高速的场合使用

{*******************************************************}
{                 TAttributeLines v1.2                  }
{ Copyright (c) 2008 Zhang jin-song                     }
{ License : Free                                        }
{ www.ynu.edu.cn                                        }
{*******************************************************}

unit imTextAttribute;
{$R-,T-,H+,X+}

interface
uses
 Windows, Messages, SysUtils, Classes, Forms, Graphics, Controls, StdCtrls,
 CustomSimpleList;


type
PimAttributeData  = ^TimAttributeData;
TimAttributeData  = record
                      case Integer of
                       0 : (FirstLast,FontStylesBackForeColor : Int64);
                       1 : (Last,First: Integer; ForeColor,FontStylesBackColor: TColor);
                       2 : (Lt,Ft: Integer; FR,FG,FB,Alpha,BR,BG,BB: Byte; FontStyles: TFontStyles);
                     end;


type
// TimAttributeList -----------------------------------------------------------

 TimAttributeList = class(TCustomSimpleList)
 protected
   function  Get(Index: Integer): PimAttributeData;
   function  SortCompare(Item1,Item2: Pointer): Integer; override;
   procedure Insert(Index: Integer; const ExpAttrData: TimAttributeData); overload;
   procedure Insert(Index: Integer; ForeColor,BackColor: TColor; FontStyles: TFontStyles;
                                    First,Last: Integer); overload;
   procedure Delete(Index: Integer); override;
 public
   procedure Assign(ExpAttributeList : TimAttributeList);
   procedure Clear;
   procedure Sort;
   function  Add(const ExpAttrData: TimAttributeData): Integer; overload;
   function  Add(ForeColor,BackColor: TColor; FontStyles: TFontStyles;
                 First,Last: Integer): Integer; overload;
   procedure OrderAppend(const ExpAttrData: TimAttributeData); overload;
   procedure OrderAppend(ForeColor,BackColor: TColor; FontStyles: TFontStyles;
                         First,Last: Integer); overload;
   procedure OrderInsert(const ExpAttrData: TimAttributeData); overload;
   procedure OrderInsert(ForeColor,BackColor: TColor; FontStyles: TFontStyles;
                         First,Last: Integer); overload;
   procedure OrderDelete(First,Last: Integer);
   procedure SplitDelete(First: Integer; DelLeft: boolean);
   procedure InsertRange(First,Last: Integer);
   function GetAttributeData(First: Integer; var EAData: TimAttributeData): Boolean;
   property Items[Index: Integer]: PimAttributeData read Get;
   property IPList;
 end;

// TExpAttributeLines ----------------------------------------------------------

 TimAttributeLines = class(TCustomSimpleList)
 protected
   function  Get(Index: Integer): TimAttributeList;
   procedure Put(Index: Integer; Item: TimAttributeList = nil);
 public
   function  Add(ExpAttributeList: TimAttributeList = nil): Integer;
   procedure Insert(Index: Integer; ExpAttributeList: TimAttributeList = nil);
   procedure Delete(Index: Integer); override;
   procedure Assign(ExpAttributeLines : TimAttributeLines);
   procedure Clear;
   property  Items[Index: Integer]: TimAttributeList read Get write Put;
   property  IPList;
 end;

const
CimListMinGrow  = 10;
CimLinesMinGrow = 100;


implementation

// TimAttributeList -----------------------------------------------------------------

function  TimAttributeList.Get(Index: Integer): PimAttributeData;
begin
 if (Index < 0) or (Index >= Count) then Error(@csListIndexError, Index);
 Result := IPList^[Index];
end;

function TimAttributeList.Add(const ExpAttrData: TimAttributeData): Integer;
var
P : PimAttributeData;
begin
 P := AllocMem(SizeOf(TimAttributeData));
 Move(ExpAttrData,P^,SizeOf(TimAttributeData));
 Result := slAdd(P);
end;

function TimAttributeList.Add(ForeColor,BackColor: TColor; FontStyles: TFontStyles;
                            First,Last: Integer): Integer;
var
P : PimAttributeData;
begin
 P := AllocMem(SizeOf(TimAttributeData));
 P^.ForeColor := ForeColor;
 P^.FontStylesBackColor := BackColor;
 P^.FontStyles := FontStyles;
 P^.First := First;
 P^.Last := Last;
 Result := slAdd(P);
end;

procedure TimAttributeList.Insert(Index: Integer; const ExpAttrData: TimAttributeData);
var
P : PimAttributeData;
begin
 P := AllocMem(SizeOf(TimAttributeData));
 Move(ExpAttrData,P^,SizeOf(TimAttributeData));
 slInsert(Index,P);
end;

procedure TimAttributeList.Insert(Index: Integer; ForeColor,BackColor: TColor; FontStyles: TFontStyles;
                                First,Last: Integer);
var
P : PimAttributeData;
begin
 P := AllocMem(SizeOf(TimAttributeData));
 P^.ForeColor := ForeColor;
 P^.FontStylesBackColor := BackColor;
 P^.FontStyles := FontStyles;
 P^.First := First;
 P^.Last := Last;
 slInsert(Index,P);
end;

procedure TimAttributeList.Delete(Index: Integer);
var
P : PimAttributeData;
begin
 if (Index < 0) or (Index >= Count) then Error(@csListIndexError, Index);
 P := IPList^[Index];
 FreeMem(P,SizeOf(TimAttributeData));
 ICount := ICount - 1;
 if Index < ICount then
  System.Move(IPList^[Index + 1],IPList^[Index],(Count - Index) * SizeOf(Pointer));
end;

procedure TimAttributeList.Assign(ExpAttributeList : TimAttributeList);
var
i : Integer;
P : PimAttributeData;
begin
 slClear;
 ICapacity := ExpAttributeList.Count;
 for i := 0 to ExpAttributeList.Count - 1 do
 begin
  P := AllocMem(SizeOf(TimAttributeData));
  Move(ExpAttributeList.Get(i)^,P^,SizeOf(TimAttributeData));
  slAdd(P);
 end;
end;

procedure TimAttributeList.Clear;
begin
 slClear;
end;

procedure TimAttributeList.Sort;
begin
 if (IPList <> nil) and (Count > 1) then QuickSort(0,Count - 1);
end;

function  TimAttributeList.SortCompare(Item1,Item2: Pointer): Integer;
begin
 with PimAttributeData(Item1)^ do
 begin
  if First < PimAttributeData(Item2)^.First then Result := -1 else
  if First > PimAttributeData(Item2)^.First then Result := 1 else Result := 0;
 end;
end;

// Append 时保证空间不重叠
procedure TimAttributeList.OrderAppend(const ExpAttrData: TimAttributeData);
var
i,ii : Integer;
LenA : Integer;
SameKind : Boolean;
PEADataA : PimAttributeData;
PEADataB : PimAttributeData;
FEADTmp : TimAttributeData;
AModify : Boolean;
IsChange : Boolean;
begin
 PEADataA := @ExpAttrData;
 i := 0;
 AModify := True;
 IsChange := False;
 while i < Count do begin
  PEADataB := IPList^[i];
  if PEADataB^.First >= PEADataA^.First then
  begin
   if PEADataB^.First <= PEADataA^.Last then
   begin
    IsChange := True;
    if PEADataB^.Last <= PEADataA^.Last then
    begin
     if AModify then
     begin
      AModify := False;
      PEADataB^ := PEADataA^;
      inc(i);
     end else Delete(i);
    end else begin
     SameKind := PEADataB^.FontStylesBackForeColor = PEADataA^.FontStylesBackForeColor;
     if SameKind then
      PEADataB^.First := PEADataA^.First
     else begin
      PEADataB^.First := PEADataA^.Last + 1;
      Insert(i,PEADataA^);
     end;
     Break;
    end;
   end else begin
    if not IsChange then
    begin
     Insert(i,PEADataA^);
     IsChange := True;
    end;
    Break;
   end;
  end else begin
   if PEADataB^.Last >= PEADataA^.First then
   begin
    IsChange := True;
    SameKind := PEADataB^.FontStylesBackForeColor = PEADataA^.FontStylesBackForeColor;
    if PEADataB^.Last <= PEADataA^.Last then
    begin
     if SameKind then
      PEADataB^.Last := PEADataA^.Last
     else begin
      PEADataB^.Last := PEADataA^.First - 1;
      Insert(i + 1,PEADataA^);
     end;
    end else begin
     if not SameKind then
     begin
      Insert(i + 1,PEADataA^);
      inc(i,2); // inc(i) and jump over Insert item
      FEADTmp.FontStylesBackForeColor := PEADataB^.FontStylesBackForeColor;
      FEADTmp.First := PEADataA^.Last + 1;
      FEADTmp.Last := PEADataB^.Last;
      PEADataB^.Last := PEADataA^.First - 1;
      Insert(i,FEADTmp);
     end;
    end;
    Break;
   end else begin
    if PEADataA^.First - PEADataB^.Last < 2 then
    begin
     SameKind := PEADataB^.FontStylesBackForeColor = PEADataA^.FontStylesBackForeColor;
     if SameKind then
     begin
      LenA := PEADataA^.Last - PEADataA^.First + 1;
      PEADataB^.Last := PEADataA^.Last;
      IsChange := True;
      ii := i + 1;
      while ii < Count do
      begin
       PEADataB := IPList^[ii];
       inc(PEADataB^.First,LenA);
       inc(PEADataB^.Last,LenA);
       inc(ii);
      end;
      Break;
     end;
    end;
    inc(i);
   end;
  end;
 end;
 if not IsChange then Add(PEADataA^);
end;

procedure TimAttributeList.OrderAppend(ForeColor,BackColor: TColor; FontStyles: TFontStyles;
                                        First,Last: Integer);
var
ExpAttrData: TimAttributeData;
begin
 ExpAttrData.ForeColor := ForeColor;
 ExpAttrData.FontStylesBackColor := BackColor;
 ExpAttrData.FontStyles := FontStyles;
 ExpAttrData.First := First;
 ExpAttrData.Last := Last;
 OrderAppend(ExpAttrData);
end;

// Insert 时保证空间不重叠
procedure TimAttributeList.OrderInsert(const ExpAttrData: TimAttributeData);
var
i,ii : Integer;
SameKind : Boolean;
LenA : Integer;
PEADataA : PimAttributeData;
PEADataB : PimAttributeData;
FEADTmp : TimAttributeData;
IsChange : Boolean;
begin
 PEADataA := @ExpAttrData;
 i := 0;
 IsChange := False;
 LenA := PEADataA^.Last - PEADataA^.First + 1;
 while i < Count do begin
  PEADataB := IPList^[i];
  if PEADataB^.First = PEADataA^.First then
  begin
   IsChange := True;
   SameKind := PEADataB^.FontStylesBackForeColor = PEADataA^.FontStylesBackForeColor;
   if SameKind then inc(PEADataB^.Last,LenA)
               else Insert(i,PEADataA^);
   ii := i + 1;
   while ii < Count do
   begin
    PEADataB := IPList^[ii];
    inc(PEADataB^.First,LenA);
    inc(PEADataB^.Last,LenA);
    inc(ii);
   end;
   Break;
  end else