usmilies.pas

Delphi快速开发Web Server

unit USmilies;

{$DEFINE FASTSTRINGS}

interface
uses
  SysUtils,
  Classes,
  Graphics,
  ImgList,
  ComCtrls,
  URxRichEd,
  {$IFDEF FASTSTRINGS}
  FastStrings,
  {$ELSE}
  HyperStr,
  {$ENDIF}
  URTF;

type
  // This class is needed to store the RichEdit style. The default
  // TRxTextAttributes will automatically assign the attributes to the RichEdit,
  // which we don't want...
  TStorageTextAttributes  = class(TObject)
  private
    FName:      String;
    FStyle:     TFontStyles;
    FPitch:     TFontPitch;
    FColor:     TColor;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent);
    procedure AssignTo(Dest: TPersistent);

    property Name:    String      read FName  write FName;
    property Style:   TFontStyles read FStyle write FStyle;
    property Pitch:   TFontPitch  read FPitch write FPitch;
    property Color:   TColor      read FColor write FColor;
  end;

  TRTFSmilies = class(TObject)
  private
    // Properties
    FImageList:           TCustomImageList;
    FRichEdit:            TRxRichEdit;
    FSmilies:             TStringList;
  public
    // Constructor / destructor
    constructor Create();
    destructor Destroy(); override;

    // Load smilies list (multiple functions for convenience)
    procedure LoadFromFile(const Filename: String);
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromStrings(Strings: TStrings);

    // Add text with smilies (all procedures call AddStyle)
    // - adds with current style
    procedure Add(const Text: String);

    // - adds with color
    procedure AddColor(const Text: String; Color: TColor);

    // - adds with style
    procedure AddStyle(const Text: String; Style: TRxTextAttributes);

    // Properties
    property ImageList:   TCustomImageList  read FImageList write FImageList;
    property RichEdit:    TRxRichEdit       read FRichEdit  write FRichEdit;
    property Smilies:     TStringList       read FSmilies   write FSmilies;
  end;

implementation
type
  // Holds the smilie index/position
  TSmilie = record
    Index:        Integer;
    Pos:          Integer;
  end;

  // Used in the Split() function
  TSplitArray = array of String;


const
  CNoRichEdit   = 'Tsk tsk, the programmer forgot to set the RichEdit property!';
  CNoImageList  = 'Tsk tsk, the programmer forgot to set the ImageList property!';



{****************************************
  Split function

    This one is a modified version of
    my original split function designed
    to use HyperStrings for optimal
    speed...

    Could be optimized further by
    minimizing memory allocation
    (SetLength calls)
****************************************}
function Split(const Source, Delimiter: String): TSplitArray;
var
  iCount:     Integer;
  iPos:       Integer;
  iSearch:    Integer;
  iLength:    Integer;
  sTemp:      String;
  aSplit:     TSplitArray;

begin
  sTemp   := Source;
  iCount  := 0;
  iLength := Length(Delimiter) - 1;

  iSearch := Length(Delimiter);

  repeat
    {$IFDEF FASTSTRINGS}
    iPos := FastPos(sTemp, Delimiter, Length(sTemp), iSearch, 1);
    {$ELSE}
    iPos := ScanFF(sTemp, Delimiter, 1);
    {$ENDIF}

    if iPos = 0 then
      break
    else begin
      Inc(iCount);
      SetLength(aSplit, iCount);
      aSplit[iCount - 1] := Copy(sTemp, 1, iPos - 1);
      Delete(sTemp, 1, iPos + iLength);
    end;
  until False;

  if Length(sTemp) > 0 then begin
    Inc(iCount);
    SetLength(aSplit, iCount);
    aSplit[iCount - 1] := sTemp;
  end;

  Result := aSplit;
end;


{****************************************
  QuickSort

    Modified from Borland Threads Demo
    for TSmilie sorting...
****************************************}
procedure QuickSort(var A: array of TSmilie);
  procedure DoSort(var A: array of TSmilie; iLo, iHi: Integer);
  var
    Lo, Hi, Mid: Integer;
    T: TSmilie;
  begin
    Lo := iLo;
    Hi := iHi;
    Mid := A[(Lo + Hi) div 2].Pos;
    repeat
      while A[Lo].Pos < Mid do Inc(Lo);
      while A[Hi].Pos > Mid do Dec(Hi);
      if Lo <= Hi then
      begin
        T := A[Lo];
        A[Lo] := A[Hi];
        A[Hi] := T;
        Inc(Lo);
        Dec(Hi);
      end;
    until Lo > Hi;
    if Hi > iLo then DoSort(A, iLo, Hi);
    if Lo < iHi then DoSort(A, Lo, iHi);
  end;

begin
  DoSort(A, Low(A), High(A));
end;


{****************************************
  TRTFSmilies
****************************************}
constructor TRTFSmilies.Create;
begin
  inherited Create();

  // Create smilies list
  FSmilies  := TStringList.Create();
end;

destructor TRTFSmilies.Destroy;
begin
  // Destroy smilies list
  FSmilies.Free;
  FSmilies:=nil;

  inherited Destroy();
end;


{****************************************
  Load smilies list
****************************************}
procedure TRTFSmilies.LoadFromFile;
begin
  FSmilies.LoadFromFile(Filename);
end;

procedure TRTFSmilies.LoadFromStream;
begin
  FSmilies.LoadFromStream(Stream);
end;

procedure TRTFSmilies.LoadFromStrings;
begin
  FSmilies.Assign(Strings);
end;


{****************************************
  Add text with smilies
****************************************}
procedure TRTFSmilies.Add;
begin
  AddStyle(Text, FRichEdit.SelAttributes);
end;

procedure TRTFSmilies.AddColor;
begin
  FRichEdit.SelAttributes.Color := Color;
  AddStyle(Text, FRichEdit.SelAttributes);
end;

procedure TRTFSmilies.AddStyle;
var
  iSmile:       Integer;
  iPos:         Integer;
  iLength:      Integer;
  {$IFDEF FASTSTRINGS}
  iSource:      Integer;
  {$ENDIF}
  sMsg:         String;
  sCode:        String;
  sIndex:       String;
  iSmileIndex:  Integer;
  aParts:       TSplitArray;
  aSmilies:     array of TSmilie;
  iSmilies:     Integer;
  iCount:       Integer;
  iIndex:       Integer;
  ssTemp:       TStringStream;
  bmpSmile:     TBitmap;
  pStyle:       TStorageTextAttributes;

begin
  // Check if properties are assigned
  Assert(Assigned(FRichEdit), CNoRichEdit);
  Assert(Assigned(FImageList), CNoImageList);

  // Store style locally
  pStyle  := TStorageTextAttributes.Create();
  pStyle.Assign(Style);

  // Set richedit properties to allow inline streaming
  FRichEdit.StreamMode  := [smSelection, smPlainRTF];

  iCount    := -1;
  iSmilies  := 50;
  SetLength(aSmilies, iSmilies);
  SetLength(aParts, 0);

  // Remove #0 characters from string (to prevent Split from messing up later on)
  {$IFDEF FASTSTRINGS}
  sMsg  := FastReplace(Text, #0, '', True);
  {$ELSE}
  sMsg  := Text;
  ReplaceSC(sMsg, #0, '', False);
  {$ENDIF}

  // Replace smilies with #0 and store their indices...
  for iSmile := 0 to FSmilies.Count - 1 do begin
    iPos        := 1;
    sCode       := FSmilies.Names[iSmile];
    {$IFDEF FASTSTRINGS}
    iSource     := Length(sCode);
    {$ENDIF}
    iLength     := iSource - 1;
    sIndex      := FSmilies.Strings[iSmile];
    Delete(sIndex, 1, Length(sCode) + 1);
    iSmileIndex := StrToIntDef(sIndex, -1);

    repeat
      {$IFDEF FASTSTRINGS}
      iPos  := FastPos(sMsg, sCode, Length(sMsg), iSource, iPos);
      {$ELSE}
      // Smilies with ? must be filtered, ScanF will use ? as a delimiter otherwise
      // This also means that smilies with an ? are NOT case insensitive!
      if ScanFF(sCode, '?', 1) > 0 then
        iPos  := ScanFF(sMsg, sCode, iPos)
      else
        iPos  := ScanF(sMsg, sCode, -iPos);
      {$ENDIF}

      if iPos > 0 then begin
        // Check buffer size
        Inc(iCount);
        if iCount = iSmilies then begin
          Inc(iSmilies, 50);
          SetLength(aSmilies, iSmilies);
        end;

        Delete(sMsg, iPos, iLength);
        sMsg[iPos]  := #0;

        // Store index/position/length
        with aSmilies[iCount] do begin
          Index   := iSmileIndex;
          Pos     := iPos;
        end;

        // Update smilies which appear after this one...
        for iIndex := 0 to iCount - 1 do
          if aSmilies[iIndex].Pos > iPos then begin
            Dec(aSmilies[iIndex].Pos, iLength);
          end;
      end;
    until iPos = 0;
  end;

  if iCount > -1 then begin
    Inc(iCount);
    SetLength(aSmilies, iCount);
    QuickSort(aSmilies);

    // Split string, write each part, add smilies between them...
    {$IFDEF FASTSTRINGS}
    FastReplace(sMsg, '\', '\\', True);
    FastReplace(sMsg, #13#10, '\par ', True);
    {$ELSE}
    ReplaceSC(sMsg, '\', '\\', False);
    ReplaceSC(sMsg, #13#10, '\par ', False);
    {$ENDIF}
    aParts    := Split(sMsg, #0);
    bmpSmile  := TBitmap.Create();
    ssTemp    := TStringStream.Create('');

    bmpSmile.Canvas.Brush.Color := FRichEdit.Color;
    bmpSmile.Width              := FImageList.Width;
    bmpSmile.Height             := FImageList.Height;

    for iSmile := 0 to High(aParts) do begin
      // Add text
      ssTemp.Size := 0;
      ssTemp.WriteString('{\rtf1 ' + aParts[iSmile] + '}');
      ssTemp.Seek(0, soFromBeginning);

      FRichEdit.SelStart  := Length(FRichEdit.Text);

      // Fix: use TStorageTextAttributes's AssignTo method, otherwise: AV!
      pStyle.AssignTo(FRichEdit.SelAttributes);

      FRichEdit.Lines.LoadFromStream(ssTemp);

      if iSmile < iCount then begin
        // Add smilie
        FRichEdit.SelStart  := Length(FRichEdit.Text);

        bmpSmile.Canvas.FillRect(Rect(0, 0, FImageList.Width, FImageList.Height));

        FImageList.GetBitmap(aSmilies[iSmile].Index, bmpSmile);
        ssTemp.Size := 0;
        ssTemp.WriteString(BitmapToRTF(bmpSmile));
        ssTemp.Seek(0, soFromBeginning);

        FRichEdit.SelStart  := Length(FRichEdit.Text);
        FRichEdit.Lines.LoadFromStream(ssTemp);
      end;
    end;

    FRichEdit.Lines.Add('');

    bmpSmile.Free();
    ssTemp.Free();
  end else begin
    // Just add it...
    FRichEdit.SelAttributes.Assign(Style);
    FRichEdit.Lines.Add(Text);
  end;
  pStyle.Free;
end;

{****************************************
  TStorageRxTextAttributes
****************************************}
procedure TStorageTextAttributes.Assign;
begin
  if Source is TRxTextAttributes then begin
    Name    := TRxTextAttributes(Source).Name;
    Style   := TRxTextAttributes(Source).Style;
    Pitch   := TRxTextAttributes(Source).Pitch;
    Color   := TRxTextAttributes(Source).Color;
  end;
end;

procedure TStorageTextAttributes.AssignTo;
begin
  if Dest is TRxTextAttributes then begin
    TRxTextAttributes(Dest).Name  := Name;
    TRxTextAttributes(Dest).Style := Style;
    TRxTextAttributes(Dest).Pitch := Pitch;
    TRxTextAttributes(Dest).Color := Color;
  end;
end;

constructor TStorageTextAttributes.Create;
  begin
  inherited;
  FName:='';
  end;

destructor TStorageTextAttributes.Destroy;
  begin
  FName:='';
  inherited;
  end;

end.