Tips (1541)

Tip Bewertung (27):

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}
{$R Smiley.res}

uses
  RichEdit;

type
  TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;
    cb: Longint; var pcb: Longint): DWORD;
  stdcall;

  TEditStream = record
    dwCookie: Longint;
    dwError: Longint;
    pfnCallback: TEditStreamCallBack;
  end;

type
  TMyRichEdit = TRxRichEdit;

// EditStreamInCallback callback function

function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;
  cb: Longint; var pcb: Longint): DWORD; stdcall;
var
  theStream: TStream;
  dataAvail: LongInt;
begin
  theStream := TStream(dwCookie);
  with theStream do
  begin
    dataAvail := Size - Position;
    Result := 0;
    if dataAvail <= cb then
    begin
      pcb := read(pbBuff^, dataAvail);
      if pcb <> dataAvail then
        Result := UINT(E_FAIL);
    end
    else
    begin
      pcb := read(pbBuff^, cb);
      if pcb <> cb then
        Result := UINT(E_FAIL);
    end;
  end;
end;

// Insert Stream into RichEdit

procedure PutRTFSelection(RichEdit: TMyRichEdit; SourceStream: TStream);
var
  EditStream: TEditStream;
begin
  with EditStream do
  begin
    dwCookie := Longint(SourceStream);
    dwError := 0;
    pfnCallback := EditStreamInCallBack;
  end;
  RichEdit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, Longint(@EditStream));
end;

// Load a smiley image from resource

function GetSmileyCode(ASimily: string): string;
var
  dHandle: THandle;
  pData, pTemp: PChar;
  Size: Longint;
begin
  pData := nil;
  dHandle := FindResource(hInstance, PChar(ASimily), RT_RCDATA);
  if dHandle <> 0 then
  begin
    Size := SizeofResource(hInstance, dHandle);
    dhandle := LoadResource(hInstance, dHandle);
    if dHandle <> 0 then
      try
        pData := LockResource(dHandle);
        if pData <> nil then
          try
            if pData[Size - 1] = #0 then
            begin
              Result := StrPas(pTemp);
            end
            else
            begin
              pTemp := StrAlloc(Size + 1);
              try
                StrMove(pTemp, pData, Size);
                pTemp[Size] := #0;
                Result := StrPas(pTemp);
              finally
                StrDispose(pTemp);
              end;
            end;
          finally
            UnlockResource(dHandle);
          end;
      finally
        FreeResource(dHandle);
      end;
  end;
end;

procedure InsertSmiley(ASmiley: string);
var
  ms: TMemoryStream;
  s: string;
begin
  ms := TMemoryStream.Create;
  try
    s := GetSmileyCode(ASmiley);
    if s <> '' then
    begin
      ms.Seek(0, soFromEnd);
      ms.Write(PChar(s)^, Length(s));
      ms.Position := 0;
      PutRTFSelection(frmMain.RXRichedit1, ms);
    end;
  finally
    ms.Free;
  end;
end;

procedure TfrmMain.SpeedButton1Click(Sender: TObject);
begin
  InsertSmiley('Smiley1');
end;

procedure TfrmMain.SpeedButton2Click(Sender: TObject);
begin
  InsertSmiley('Smiley2');
end;

// Replace a :-) or :-( with a corresponding smiley

procedure TfrmMain.RxRichEdit1KeyPress(Sender: TObject; var Key: Char);
var
 sCode, SmileyName: string;

  procedure RemoveText(RichEdit: TMyRichEdit);
  begin
    with RichEdit do
    begin
      SelStart := SelStart - 2;
      SelLength := 2;
      SelText :=  '';
    end;
  end;

begin
 If (Key = ')') or (Key = '(')  then
 begin
   sCode := Copy(RxRichEdit1.Text, RxRichEdit1.SelStart-1, 2) + Key;
   SmileyName := '';
   if sCode = ':-)'  then SmileyName := 'Smiley1';
   if sCode = ':-('  then SmileyName := 'Smiley2';
   if SmileyName <> '' then
   begin
     Key := #0;
     RemoveText(RxRichEdit1);
     InsertSmiley('Smiley1');
   end;
 end;
end;