imtextattribute.pas

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

  if PEADataB^.First > PEADataA^.First then
  begin
   IsChange := True;
   ii := i;
   while ii < Count do
   begin
    PEADataB := IPList^[ii];
    inc(PEADataB^.First,LenA);
    inc(PEADataB^.Last,LenA);
    inc(ii);
   end;
   Insert(i,PEADataA^);
   Break;
  end else begin
   if PEADataB^.Last >= PEADataA^.First then
   begin
    IsChange := True;
    SameKind := PEADataB^.FontStylesBackForeColor = PEADataA^.FontStylesBackForeColor;
    if SameKind then
    begin
     inc(PEADataB^.Last,LenA);
     ii := i + 1;
    end else begin
     FEADTmp := PEADataB^;
     FEADTmp.First := PEADataA^.First;
     PEADataB^.Last := PEADataA^.First - 1;
     insert(i + 1,PEADataA^);
     insert(i + 2,FEADTmp);
     ii := i + 2;
    end;
    while ii < Count do
    begin
     PEADataB := IPList^[ii];
     inc(PEADataB^.First,LenA);
     inc(PEADataB^.Last,LenA);
     inc(ii);
    end;
    Break;
   end else begin
    if PEADataA^.First - PEADataB^.Last < 2 then
    begin
     SameKind := PEADataB^.FontStylesBackForeColor = PEADataA^.FontStylesBackForeColor;
     if SameKind then
     begin
      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.OrderInsert(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;
 OrderInsert(ExpAttrData);
end;

procedure TimAttributeList.InsertRange(First,Last: Integer);
var
i,ii : Integer;
LenA : Integer;
PEAData : PimAttributeData;
begin
 i := 0;
 LenA := Last - First + 1;
 while i < Count do
 begin
  PEAData := IPList^[i];
  if PEAData^.First = First then
  begin
   inc(PEAData^.Last,LenA);
   ii := i + 1;
   while ii < Count do
   begin
    PEAData := IPList^[ii];
    inc(PEAData^.First,LenA);
    inc(PEAData^.Last,LenA);
    inc(ii);
   end;
   Break;
  end else
  if PEAData^.First > First then
  begin
   ii := i;
   while ii < Count do
   begin
    PEAData := IPList^[ii];
    inc(PEAData^.First,LenA);
    inc(PEAData^.Last,LenA);
    inc(ii);
   end;
   Break;
  end else begin
   if PEAData^.Last >= First then
   begin
    inc(PEAData^.Last,LenA);
    ii := i + 1;
    while ii < Count do
    begin
     PEAData := IPList^[ii];
     inc(PEAData^.First,LenA);
     inc(PEAData^.Last,LenA);
     inc(ii);
    end;
    Break;
   end else inc(i);
  end;
 end;
end;

procedure TimAttributeList.OrderDelete(First,Last: Integer);
var
i,ii : Integer;
LenA : Integer;
IsMove : Boolean;
MovePos : Integer;
PEADataA : PimAttributeData;
PEADataB : PimAttributeData;
FEADTmp : TimAttributeData;
begin
 i := 0;
 MovePos := 0;
 IsMove := True;
 while i < Count do begin
  PEADataA := IPList^[i];
  if PEADataA^.First >= First then
  begin
   if PEADataA^.First <= Last then
   begin
    if PEADataA^.Last <= Last then
    begin
     Delete(i);
     MovePos := i;
    end else begin
     PEADataA^.First := Last + 1;
     MovePos := i;
     Break;
    end;
   end else begin
    MovePos := i;
    Break;
   end;
  end else begin
   if PEADataA^.Last >= First then
   begin
    if PEADataA^.Last <= Last then
    begin
     PEADataA^.Last := First - 1;
     MovePos := i + 1;
    end else begin
     FEADTmp.FontStylesBackForeColor := PEADataA^.FontStylesBackForeColor;
     FEADTmp.First := Last + 1;
     FEADTmp.Last := PEADataA^.Last;
     PEADataA^.Last := First - 1;
     Insert(i + 1,FEADTmp);
     MovePos := i + 1;
    end;
    Break;
   end else begin
    inc(i);
    if i >= Count then IsMove := False;
   end;
  end;
 end;
 if IsMove and (Count > 0) and (MovePos < Count) then
 begin
  LenA := Last - First + 1;
  ii := MovePos;
  while ii < Count do
  begin
   PEADataB := IPList^[ii];
   dec(PEADataB^.First,LenA);
   dec(PEADataB^.Last,LenA);
   inc(ii);
  end;
 end;
end;

procedure TimAttributeList.SplitDelete(First: Integer; DelLeft: boolean);
var
i,DP : integer;
PEAData : PimAttributeData;
begin
 DP := Count;
 if DelLeft then begin
  for i := Count - 1 downto 0 do
  begin
   PEAData := IPList^[i];
   if (PEAData^.First > First) and (PEAData^.Last > First) then Continue;
   if (First >= PEAData^.First) and (First <= PEAData^.Last) then
   begin
    PEAData^.First := First;
    DP := i - 1;
    Break;
   end else begin
    DP := i;
    Break;
   end;
  end;
  for i := 0 to DP do Delete(0);
  for i := 0 to Count - 1 do
  begin
   PEAData := IPList^[i];
   dec(PEAData.First,First);
   dec(PEAData.Last,First);
  end;
 end else begin
  for i := 0 to Count - 1 do
  begin
   PEAData := IPList^[i];
   if (PEAData^.First < First) and (PEAData^.Last < First) then Continue;
   if (First >= PEAData^.First) and (First <= PEAData^.Last) then
   begin
    PEAData^.Last := First;
    DP := i + 1;
    Break;
   end else begin
    DP := i;
    Break;
   end;
  end;
  for i := DP to Count - 1 do Delete(DP);
 end;
end;

function TimAttributeList.GetAttributeData(First: Integer;
                                           var EAData: TimAttributeData): Boolean;
var
i : Integer;
PEAData : PimAttributeData;
begin
 Result := False;
 for i := 0 to Count - 1 do
 begin
  PEAData := IPList^[i];
  if (First >= PEAData^.First) and (First <= PEAData^.Last) then
  begin
   EAData := PEAData^;
   Result := True;
   Break;
  end;
 end;
end;

// TimAttributeLines ----------------------------------------------------------

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

procedure TimAttributeLines.Put(Index: Integer; Item: TimAttributeList = nil);
begin
 if (Index < 0) or (Index >= Count) then Error(@csListIndexError, Index);
 if IPList^[Index] <> nil then TimAttributeList(IPList^[Index]).Free;
 slPut(Index,Item);
end;

function  TimAttributeLines.Add(ExpAttributeList: TimAttributeList = nil): Integer;
begin
 Result := slAdd(ExpAttributeList);
end;

procedure TimAttributeLines.Insert(Index: Integer; ExpAttributeList: TimAttributeList = nil);
begin
 slInsert(Index,ExpAttributeList);
end;

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

procedure TimAttributeLines.Assign(ExpAttributeLines : TimAttributeLines);
var
i : Integer;
P,T : TimAttributeList;
begin
 slClear;
 ICapacity := ExpAttributeLines.Count;
 for i := 0 to ExpAttributeLines.Count - 1 do
 begin
  T := ExpAttributeLines.IPList^[i];
  if T <> nil then
  begin
   P := TimAttributeList.Create(CimListMinGrow,Self);
   P.Assign(T);
   slAdd(P);
  end else slAdd(T);
 end;
end;

procedure TimAttributeLines.Clear;
begin
 slClear;
end;


end.