Tuesday, September 28, 2010

How to save a report as PDF to a stream with FastReport

Recently I needed to save a report to a stream as PDF, I'm using FastReport for my reports.
I've searched a lot for a way to do this, but unfortunately I only found comments like „you can't export a report to a stream in PDF format with FastReport¯ and similar comments... so I started browsing the source code of the PDF exporter and 2 minutes later I saw that the exporter checks if property „Stream¯ is assigned, otherwise it will create a TFileStream instance using the report's „FileName¯ property — therefore assigning a TStream descendant to PDFExporter.Stream will make the exporter write the PDF data to THAT stream in stead of the file, without further chit-chat, let's see some code:
I took „PrintStringList¯ example from the Demo folder and modified it to show you how it's done, I've added a new button on the form and a save dialog, in the OnClick event of the button I've added the following code:
procedure TForm1.Button2Click(Sender: TObject);
var
  // we use a file stream for example, but you can replace this
  // with a memory stream or any type of stream which is a
  // descendant of abstract class TStream
  LFileStream: TFileStream;
begin
  // allow the user to choose a file name
  if SaveDialog1.Execute then begin
    // create the file stream object
    LFileStream := TFileStream.Create(SaveDialog1.FileName, fmCreate or fmShareDenyNone);
    try
      // set the range properties
      StringDS.RangeEnd := reCount;
      StringDS.RangeEndCount := sl.Count;
      // THIS IS THE MAGIC
      // assign the stream for the TfrxPDFExport component
      frxPDFExport1.Stream := LFileStream;
      // prepare the report
      frxReport1.PrepareReport(True);
      // export calls the PDFExport component in this case
      frxReport1.Export(frxPDFExport1);
    finally
      // free the file stream object
      FreeAndNil(LFileStream);
      // NIL reference to the stream
      frxPDFExport1.Stream := NIL;
    end; // tryf
  end; // if SaveDialog1.Execute then begin
end;
NOTE: you need FastReport installed!!
You can download the entire project source code by clicking on this text.

Sunday, September 19, 2010

File/Stream compression/decompression class

Tired of searching for zip libraries just to compress/decompress a file/stream?!
Why not use zlib shipped with Delphi?! it's lightweight, super fast, very good compression and above all it's very easy to use!!
( uDGCompressor.pas )
unit uDGCompressor;

interface

//  Author: Dorin Duminica
//
//  Scope: file/stream compression/decompression and encryption/decryption
//
//  License: free for commercial or private use

uses
  SysUtils,
  Windows,
  Classes,
  zlib;

const
  CKILO_BYTE = 1024;
  //  default buffer //
  CBUFFER_SIZE = 35 * CKILO_BYTE;

//  cipher base class //
//  the child classes will HAVE to implement the Encrypt/Decrypt  //
//  methods based on the parameters defined bellow  //
type
  TDGCipherBase = class(TObject)
  public
    procedure EncryptData(const InData: Pointer; const InSize: Integer;
      out OutData: Pointer; out OutSize: Integer); virtual; abstract;
    procedure DecryptData(const InData: Pointer; const InSize: Integer;
      out OutData: Pointer; out OutSize: Integer); virtual; abstract;
  end;

//  before each compressed block the following structure will be written  //
type
  TDGBlockDesc = record
    //  initial size of the block, before compresstion  //
    InitialSize: Integer;
    //  size of the compressed block in stream  //
    Size: Integer;
  end; // TDGBlockDesc = record

const
  szDGBlockDesc = SizeOf(TDGBlockDesc);

type
  //  each time a block of data is processed  //
  TDGProgressEvent = procedure (const Progress, ProgressMax: Integer) of Object;

  //  before/after compress/decompress events //
  TDGCompressorEvent = procedure (const InFileName, OutFileName: string;
    const InSize, OutSize: Int64) of Object;

  //  when a block's decompressed size is different than initial size //
  //  this type of event will be fired if assigned  //
  TDGDecompressFailEvent = procedure (const BlockDesc: TDGBlockDesc;
    const InBuffer, OutBuffer: Pointer; const InSize, OutSize: Integer) of Object;

//  the compress/decompress class //s
type
  TDGCompressor = class(TObject)
  private
    FInStreamSize: Int64;
    FOutStreamSize: Int64;
    FBufferSize: Integer;
    FCipher: TDGCipherBase;
    FOnProgress: TDGProgressEvent;
    FOnAfterCompress: TDGCompressorEvent;
    FOnBeforeCompress: TDGCompressorEvent;
    FOnAfterDecompress: TDGCompressorEvent;
    FOnBeforeDecompress: TDGCompressorEvent;
    FOnDecompressFail: TDGDecompressFailEvent;
  public
    constructor Create;
  public
    procedure CompressFile(const InFileName, OutFileName: string);
    procedure DecompressFile(const InFileName, OutFileName: string);
    procedure CompressStream(const InStream, OutStream: TStream);
    procedure DecompressStream(const InStream, OutStream: TStream);
  published
    //  properties  //
    property BufferSize: Integer read FBufferSize write FBufferSize;
    property Cipher: TDGCipherBase read FCipher write FCipher;
    property InStreamSize: Int64 read FInStreamSize;
    property OutStreamSize: Int64 read FOutStreamSize;
    //  events  //
    property OnAfterCompress: TDGCompressorEvent read FOnAfterCompress write FOnAfterCompress;
    property OnBeforeCompress: TDGCompressorEvent read FOnBeforeCompress write FOnBeforeCompress;
    property OnAfterDecompress: TDGCompressorEvent read FOnAfterDecompress write FOnAfterDecompress;
    property OnBeforeDecompresss: TDGCompressorEvent read FOnBeforeDecompress write FOnBeforeDecompress;
    property OnDecompressFail: TDGDecompressFailEvent read FOnDecompressFail write FOnDecompressFail;
    property OnProgress: TDGProgressEvent read FOnProgress write FOnProgress;
  end;

implementation

{ TDGCompressor }

procedure TDGCompressor.CompressFile(const InFileName, OutFileName: string);
var
  LInFileStream: TFileStream;
  LOutFileStream: TFileStream;
begin
  //  create TFileStream instances  //
  LInFileStream := TFileStream.Create(InFileName, fmOpenRead or fmShareDenyNone);
  LOutFileStream := TFileStream.Create(OutFileName, fmCreate or fmShareDenyNone);
  //  set the position of LInFileStream to the begining
  LInFileStream.Position := 0;
  //  call OnBeforeCompress event if assigned //
  if Assigned(FOnBeforeCompress) then
    FOnBeforeCompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
  try
    //  attempt to compress stream  //
    CompressStream(LInFileStream, LOutFileStream);
  finally
    //  free objects  //
    FreeAndNil(LInFileStream);
    FreeAndNil(LOutFileStream);
  end; // tryf
  //  call OnAfterCompress event if assigned  //
  if Assigned(FOnAfterCompress) then
    FOnAfterCompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
end;

procedure TDGCompressor.CompressStream(const InStream, OutStream: TStream);

    function ThereAreBytes: Boolean;
    begin
      Result := (InStream.Position < InStream.Size) and
        ((InStream.Size - InStream.Position) > 0);
    end; // function ThereAreBytes: Boolean;

var
  LInBuffer: Pointer;
  LOutBuffer: Pointer;
  LWriteBuffer: Pointer;
  LBlockDesc: TDGBlockDesc;
  LProgress: Integer;
  LWriteSize: Integer;
  LReadBytes: Integer;
  LProgressMax: Integer;
  LCompressedSize: Integer;
begin
  //  store the size of the InStream
  FInStreamSize := InStream.Size;
  //  allocate memory for the read buffer //
  LInBuffer := AllocMem(BufferSize);
  //  initalize progress  //
  LProgress := 0;
  //  set the max progress  //
  LProgressMax := InStream.Size;
  //  while we have bytes in InStream that are not compressed //
  while ThereAreBytes do begin
    //  attempt to read the BufferSize number of bytes from InStream  //
    LReadBytes := InStream.Read(LInBuffer^, BufferSize);
    //  compress the read bytes based on LReadBytes variable which holds
    //  the actual number of read bytes from InStream
    ZCompress(LInBuffer, LReadBytes, LOutBuffer, LCompressedSize);
    //  if we don't have a cipher assigned
    if NOT Assigned(FCipher) then begin
      //  set the reference to LOutBuffer
      LWriteBuffer := LOutBuffer;
      //  copy the size of the buffer
      LWriteSize := LCompressedSize;
    end else
      //  we have a cipher assigned, this means that we need to
      //  call the default EncryptData method which will encrypt our
      //  compressed data
      FCipher.EncryptData(LOutBuffer, LCompressedSize, LWriteBuffer, LWriteSize);
    //  set the inital size of the block, we check it on decompress
    LBlockDesc.InitialSize := LReadBytes;
    //  set the number of bytes that we have compressed and/or encrypted
    LBlockDesc.Size := LWriteSize;
    //  write the block descriptor
    OutStream.WriteBuffer(LBlockDesc, szDGBlockDesc);
    //  write the block data
    OutStream.WriteBuffer(LWriteBuffer^, LWriteSize);
    //  free memory from LOutBuffer
    FreeMem(LOutBuffer);
    //  free memory from LWriteBuffer only if a cipher is assigned
    if Assigned(FCipher) then
      FreeMem(LWriteBuffer);
    //  increment the progress by the number of read bytes
    Inc(LProgress, LReadBytes);
    // update the size of the OutStream
    FOutStreamSize := OutStream.Size;
    //  if the OnProgress event is assigned then call it by passing
    //  the current progress and the maximum progress
    if Assigned(FOnProgress) then
      FOnProgress(LProgress, LProgressMax);
  end; // while ThereAreBytes do begin
  //  free memory from LInBuffer
  FreeMem(LInBuffer, BufferSize);
end;

constructor TDGCompressor.Create;
begin
  //  initialize default values //
  FBufferSize := CBUFFER_SIZE;
  FInStreamSize := 0;
  FOutStreamSize := 0;
end;

procedure TDGCompressor.DecompressFile(const InFileName, OutFileName: string);
var
  LInFileStream: TFileStream;
  LOutFileStream: TFileStream;
begin
  //  create TFileStream instances  //
  LInFileStream := TFileStream.Create(InFileName, fmOpenRead or fmShareDenyNone);
  LOutFileStream := TFileStream.Create(OutFileName, fmCreate or fmShareDenyNone);
  //  call OnBeforeDecompress event if assigned //
  if Assigned(FOnBeforeDecompress) then
    FOnBeforeDecompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
  //  attempt to decompress stream  //
  try
    DecompressStream(LInFileStream, LOutFileStream);
  finally
    //  free objects  //
    FreeAndNil(LInFileStream);
    FreeAndNil(LOutFileStream);
  end; // tryf
  //  call OnAfterDecompress event if assigned  //
  if Assigned(FOnAfterDecompress) then
    FOnAfterDecompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
end;

procedure TDGCompressor.DecompressStream(const InStream, OutStream: TStream);

    function ThereAreBytes: Boolean;
    begin
      Result := (InStream.Position < InStream.Size) and
        ((InStream.Size - InStream.Position) > 0);
    end; // function ThereAreBytes: Boolean;

var
  LInBuffer: Pointer;
  LOutBuffer: Pointer;
  LWriteBuffer: Pointer;
  LBlockDesc: TDGBlockDesc;
  LProgress: Integer;
  LWriteSize: Integer;
  LReadBytes: Integer;
  LProgressMax: Integer;
  LDecompressedSize: Integer;
begin
  //  store the size of the InStream
  FInStreamSize := InStream.Size;
  //  allocate memory for the read buffer //
  LInBuffer := AllocMem(BufferSize);
  //  initalize progress  //
  LProgress := 0;
  //  set the max progress  //
  LProgressMax := InStream.Size;
  //  while we have bytes in InStream ... //
  while ThereAreBytes do begin
    //  read the block descriptor from stream
    InStream.ReadBuffer(LBlockDesc, szDGBlockDesc);
    //  attempt to read the number of bytes in the block descriptor
    LReadBytes := InStream.Read(LInBuffer^, LBlockDesc.Size);
    //  if we don't have a cipher assigned  ///
    if NOT Assigned(FCipher) then begin
      //  decompress the buffer //
      ZDecompress(LInBuffer, LReadBytes, LOutBuffer, LDecompressedSize);
      //  set reference to LOutBuffer //
      LWriteBuffer := LOutBuffer;
      //  copy the number of bytes  //
      LWriteSize := LDecompressedSize;
    end else begin
      //  we have a cipher assigned, we first decrypt data  //
      FCipher.DecryptData(LInBuffer, LReadBytes, LOutBuffer, LDecompressedSize);
      //  and then decompress it  //
      ZDecompress(LOutBuffer, LDecompressedSize, LWriteBuffer, LWriteSize);
    end; // if NOT Assigned(FCipher) then begin
    //  check if initial size is equal to current (decrypted and) decompressed size //
    if LBlockDesc.InitialSize <> LWriteSize then
      if Assigned(FOnDecompressFail) then
        FOnDecompressFail(LBlockDesc, LInBuffer, LWriteBuffer, LReadBytes, LWriteSize);
    OutStream.WriteBuffer(LWriteBuffer^, LWriteSize);
    FreeMem(LOutBuffer);
    if Assigned(FCipher) then
      FreeMem(LWriteBuffer);
    Inc(LProgress, LReadBytes + szDGBlockDesc);
    //  update the size of the OutStream
    FOutStreamSize := OutStream.Size;
    //  if the OnProgress event is assigned then call it by passing
    //  the current progress and the maximum progress
    if Assigned(FOnProgress) then
      FOnProgress(LProgress, LProgressMax);
  end; // while ThereAreBytes do begin
  //  free memory from LInBuffer
  FreeMem(LInBuffer, BufferSize);
end;

end.

You can download:
- only the source code
- source code + binary

As always any comments are welcomed.

Thursday, September 9, 2010

Delphigeist group is available on Facebook

I've been thinking of creating Delphigeist group on Facebook so here's the link http://www.facebook.com/group.php?gid=159341794080763

Custom Client-Server application with Delphi 2010 and Indy 10


I'm pretty sure you've tried and failed at least one time to implement a custom protocol with Indy, am I right?! of course you did...
I'm glad I caught your attention, now let's start creating our client-server application using Indy.
In order to implement a protocol we need to think what we want to achieve, therefore we need to define the protocol commands so that the client can communicate with server and vice-versa.
Create a new unit and save it as "uDGProtocol.pas"
We define the commands as
type
  TCommand = (
    cmdConnect,
    cmdDisconnect,
    cmdMessageBroadcast,
    cmdMessagePrivate,
    cmdScreenShotGet,
    cmdScreenShotData);
Now we need to define the client information holder, basically a structure which holds the client user name & a ID
type
  TClient = record
    UserName: string[50];
    ID: TDateTime;
  end; // TClient = record
The protocol will be defined as a structure which contains the following members: "Command", "Sender", "Receiver" and "DataSize"
type
  TProtocol = record
    // the command
    Command: TCommand;
    // sender information
    Sender: TClient;
    // receiver
    Receiver: TClient;
    // additional data
    DataSize: Integer;
  end; // TProtocol = record
TIdTCPServer has a event called "OnExecute"(we use this event to process commands) which passes a parameter called "AContext" of type "TIdContext" we will define our custom client context which will do most of the work for us
type
  TClientContext = class(TIdServerContext)
  private
    // we use critical section to ensure a single access on the connection
    // at a time
    FCriticalSection: TCriticalSection;
    // client information
    FClient: TClient;
  public
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
      AList: TThreadList = nil); override;
    destructor Destroy; override;
  public
    // enter critical section
    procedure Lock;
    // leave critical section
    procedure Unlock;
    // broadcast a buffer to connected clients
    procedure BroadcastBuffer(const ABuffer: TBytes);
    // send a buffer to a specific client
    procedure SendBuffer(const ABuffer: TBytes; const AReceiverID: TDateTime);
    // send all clients data to this client when he connects
    procedure SendClientList;
  public
    property Client: TClient read FClient write FClient;
  end;
On the client side we need three to define three custom events and a listener thread which will read from the InputBuffer of the TIdTCPClient constantly and whenever we have some data the listener thread will process it and act accordingly
type
  // connect/disconnect event
  TClientStatus = procedure (const AClient: TClient) of Object;

  // on message event
  TClientMessage = procedure (const AClient: TClient; const AMessage: string) of Object;

  // on screen shot receive event
  TClientScreenShot = procedure (const AClient: TClient; AImage: TPngImage) of Object;

// our custom listener thread for the client
type
  TClientThread = class(TThread)
  private
    // the TCP client
    FTCPClient: TIdTCPClient;
    // our client information
    FClient: TClient;
    // temporary client data holder
    FClientSender: TClient;
    // temporary buffer for message or screen shot
    FTempBuffer: TBytes;
    // temporary message holder
    FTempMessage: string;
    // a critical section
    FCriticalSection: TCriticalSection;
    // a client is connected
    FOnClientConnect: TClientStatus;
    // a client is disconnected
    FOnClientDisconnect: TClientStatus;
    // receive a message
    FOnClientMessage: TClientMessage;
    // receive a screen shot
    FOnClientScreenShotGet: TClientScreenShot;
    // procedures that will be executed in synchronization with main thread
    procedure DoClientConnect;
    procedure DoClientDisconnect;
    procedure DoClientMessage;
    procedure DoClientScreenShotSend;
    procedure DoClientScreenShotGet;
  public
    // constructor and destructor
    constructor Create(ATCPClient: TIdTCPClient);
    destructor Destroy; override;
  protected
    procedure Execute; override;
  public
    // enter critical section
    procedure Lock;
    // leave critical section
    procedure Unlock;
    // notify clients that we're connected
    procedure SendConnected;
    // notify clients that we disconnect
    procedure SendDisconnected;
    // broadcast a message
    procedure SendMessageBroadcast(const AMessage: string);
    // send a private message
    procedure SendMessagePrivate(const AReceiver: TClient; const AMessage: string);
    // send a screen shot request to a client
    procedure SendScreenShotReq(const AReceiver: TClient);
  public
    property ClientData: TClient read FClient write FClient;
    // events
    property OnClientConnect: TClientStatus read FOnClientConnect write FOnClientConnect;
    property OnClientDisconnect: TClientStatus read FOnClientDisconnect write FOnClientDisconnect;
    property OnClientMessage: TClientMessage read FOnClientMessage write FOnClientMessage;
    property OnClientScreenShotGet: TClientScreenShot read FOnClientScreenShotGet write FOnClientScreenShotGet;
  end;
Since Indy 10 is writing array of bytes on connection we need to define some helper methods like
// converts the protocol structure to an array of bytes
function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
begin
  // set the length of result to the length of the protocol
  SetLength(Result, szProtocol);
  // move a block of memory from AProtocol to Result
  Move(AProtocol, Result[0], szProtocol);
end;

// converts a array of bytes to our protocol
function BytesToProtocol(const ABytes: TBytes): TProtocol;
begin
  // move a block of memory from ABytes to Result
  Move(ABytes[0], Result, szProtocol);
end;

// fills the memory with zero
procedure InitProtocol(var AProtocol: TProtocol);
begin
  FillChar(AProtocol, szProtocol, 0);
end;

// sets the length of the array of bytes to zero
procedure ClearBuffer(var ABuffer: TBytes);
begin
  // set the length to zero
  SetLength(ABuffer, 0);
end;
In the implementation section of "uDGProtocol.pas" unit we implement TClientContext class
{ TClientContext }

procedure TClientContext.BroadcastBuffer(const ABuffer: TBytes);
var
  // loop variable
  Index: Integer;
  // client list, holds TClientContext objects
  LClients: TList;
  // temporary client context reference
  LClientContext: TClientContext;
begin
  // lock the client list
  LClients := FContextList.LockList;
  try
    // for each client
    for Index := 0 to LClients.Count -1 do begin
      // store locally the current client in the list
      LClientContext := TClientContext(LClients[Index]);
      // lock it
      LClientContext.Lock;
      try
        // write the buffer
        LClientContext.Connection.IOHandler.Write(ABuffer);
      finally
        // unlock
        LClientContext.Unlock;
      end; // tryf
    end; // for Index := 0 to LClients.Count -1 do begin
  finally
    // unlock client list
    FContextList.UnlockList;
  end; // tryf
end;

constructor TClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
  AList: TThreadList);
begin
  inherited Create(AConnection, AYarn, AList);
  // create the critical section
  FCriticalSection := TCriticalSection.Create;
end;

destructor TClientContext.Destroy;
begin
  // free and nil critical section
  FreeAndNil(FCriticalSection);
  inherited;
end;

procedure TClientContext.Lock;
begin
  FCriticalSection.Enter;
end;

procedure TClientContext.SendBuffer(const ABuffer: TBytes;
  const AReceiverID: TDateTime);
var
  // loop variable
  Index: Integer;
  // client list, holds TClientContext objects
  LClients: TList;
  // temporary client context reference
  LClientContext: TClientContext;
begin
  // lock client list
  LClients := FContextList.LockList;
  try
    // search for the target client by ID
    for Index := 0 to LClients.Count -1 do begin
      LClientContext := TClientContext(LClients[Index]);
      if LClientContext.Client.ID = AReceiverID then begin
        // we found our target client, lock it
        LClientContext.Lock;
        try
          // write the buffer
          LClientContext.Connection.IOHandler.Write(ABuffer);
        finally
          // unlock client
          LClientContext.Unlock;
        end; // tryf
        // break loop, we've found our target client
        Break;
      end; // if LClientContext.Client.ID = AReceiverID then begin
    end; // for Index := 0 to LClients.Count -1 do begin
  finally
    // unlock client list
    FContextList.UnlockList;
  end; // tryf
end;

procedure TClientContext.SendClientList;
var
  // loop variable
  Index: Integer;
  // a buffer
  LBuffer: TBytes;
  // client list
  LClients: TList;
  // protocol structure
  LProtocol: TProtocol;
  // temporary client context reference
  LClientContext: TClientContext;
begin
  // clear the protocol structure
  InitProtocol(LProtocol);
  // set command
  LProtocol.Command := cmdConnect;
  // lock client list
  LClients := FContextList.LockList;
  try
    // for each connected client
    for Index := 0 to LClients.Count -1 do begin
      // store it temporarly
      LClientContext := TClientContext(LClients[Index]);
      // if the client is not this client
      if LClientContext.Client.ID <> Self.Client.ID then begin
        // set the sender
        LProtocol.Sender := LClientContext.Client;
        // covert protocol to array of bytes
        LBuffer := ProtocolToBytes(LProtocol);
        Lock;
        try
          // write the buffer
          Self.Connection.IOHandler.Write(LBuffer);
        finally
          Unlock;
        end; // tryf
      end;
    end; // for Index := 0 to LClients.Count -1 do begin
  finally
    // unlock client list
    FContextList.UnlockList;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientContext.Unlock;
begin
  FCriticalSection.Leave;
end;
and the listener thread
{ TClientThread }

constructor TClientThread.Create(ATCPClient: TIdTCPClient);
begin
  // set reference to the TCP client
  FTCPClient := ATCPClient;
  // create a critical section instance
  FCriticalSection := TCriticalSection.Create;
  inherited Create(True);
end;

destructor TClientThread.Destroy;
begin
  // free and nil the critical section
  FreeAndNil(FCriticalSection);
  // clear the temporary message
  FTempMessage := '';
  inherited;
end;

procedure TClientThread.DoClientConnect;
begin
  // check if the event is assign
  if Assigned(FOnClientConnect) then
    // call it
    FOnClientConnect(FClientSender);
end;

procedure TClientThread.DoClientDisconnect;
begin
  // check if the event is assign
  if Assigned(FOnClientDisconnect) then
    // call it
    FOnClientDisconnect(FClientSender);
end;

procedure TClientThread.DoClientMessage;
begin
  // check if the event is assign
  if Assigned(FOnClientMessage) then
    // call it
    FOnClientMessage(FClientSender, FTempMessage);
end;

procedure TClientThread.DoClientScreenShotGet;
var
  // temporary memory stream
  LStream: TMemoryStream;
  // we send, receive PNG images
  LPngImage: TPngImage;
begin
  // create a memory strema instance
  LStream := TMemoryStream.Create;
  // create a png image instance
  LPngImage := TPngImage.Create;
  Lock;
  try
    // the screen shot is saved in FTempBuffer, write it to stream
    LStream.Write(FTempBuffer[0], Length(FTempBuffer));
    // reset the position of the stream to the begining
    LStream.Position := 0;
    // load the png image from the stream
    LPngImage.LoadFromStream(LStream);
    // if the event is assigned
    if Assigned(FOnClientScreenShotGet) then
      // call it
      FOnClientScreenShotGet(FClientSender, LPngImage);
  finally
    Unlock;
    FreeAndNil(LStream);
    FreeAndNil(LPngImage);
    ClearBuffer(FTempBuffer);
  end; // tryf
end;

procedure TClientThread.DoClientScreenShotSend;
var
  LBuffer: TBytes;
  // screen shot holder
  LBitmap: TBitmap;
  // the protocol
  LProtocol: TProtocol;
  // in memory bytes stream
  LBytesStream: TBytesStream;
  // the png image, we assign LBitmap to LPngImage so we send less data
  LPngImage: TPngImage;
  // handle to the desktop canvas
  LDesktopCanvasHandle: HDC;
begin
  // fill protocol variable with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdScreenShotData;
  // set the sender
  LProtocol.Sender := FClient;
  // set the receiver, the client who requested the screen shot
  LProtocol.Receiver := FClientSender;
  // create object instances
  LBitmap := TBitmap.Create;
  LPngImage := TPngImage.Create;
  LBytesStream := TBytesStream.Create;
  Lock;
  try
    // get handle to desktop canvas
    LDesktopCanvasHandle := GetWindowDC(GetDesktopWindow);
    // set the bitmap height and width
    LBitmap.Height := Screen.Height;
    LBitmap.Width := Screen.Width;
    // copy the screen data from desktop to LBitmap
    BitBlt(
      LBitmap.Canvas.Handle,
      0, 0,
      Screen.Width, Screen.Height,
      LDesktopCanvasHandle,
      0, 0,
      SRCCOPY);
    // convert from bitmap to png image
    LPngImage.Assign(LBitmap);
    // save the png image to stream
    LPngImage.SaveToStream(LBytesStream);
    // set the data size in protocol structure
    LProtocol.DataSize := LBytesStream.Size;
    // convert protocol to array of bytes
    LBuffer := ProtocolToBytes(LProtocol);
    // increase the size of the buffer to  + 
    SetLength(LBuffer, szProtocol + LProtocol.DataSize);
    // move screen shot data from the stream to the buffer that we send
    Move(LBytesStream.Bytes[0], LBuffer[szProtocol], LProtocol.DataSize);
    // send buffer to the server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
    FreeAndNil(LBitmap);
    FreeAndNil(LPngImage);
    FreeAndNil(LBytesStream);
  end; // tryf
end;

procedure TClientThread.Execute;
var
  LBuffer: TBytes;
  LMessage: TBytes;
  LDataSize: Integer;
  LProtocol: TProtocol;
begin
  inherited;
  // while the thread is not terminated and the client is connected
  while NOT Terminated and FTCPClient.Connected do begin
    // store the size of the InputBuffer in LDataSize
    LDataSize := FTCPClient.IOHandler.InputBuffer.Size;
    // if we have some data in the InputBuffer, at least the size of the Protocol structure
    if LDataSize >= szProtocol then
      try
        // then read from InputBuffer the size of the protocol structure
        FTCPClient.IOHandler.ReadBytes(LBuffer, szProtocol);
        // convert array of bytes to protocol
        LProtocol := BytesToProtocol(LBuffer);
        // store the sender to private variable
        FClientSender := LProtocol.Sender;
        // check the command
        case LProtocol.Command of
          cmdConnect: begin
            // sync with main thread
            Synchronize(Self.DoClientConnect);
          end; // cmdConnect: begin
          cmdDisconnect: begin
            // sync with main thread
            Synchronize(Self.DoClientDisconnect);
          end; // cmdDisconnect: begin
          cmdMessageBroadcast, cmdMessagePrivate: begin
            // when we get a message after the protoocl we also get additional
            // data which is the message in this case
            // read the message data, the size of the message is in LProtocol.DataSize
            FTCPClient.IOHandler.ReadBytes(LMessage, LProtocol.DataSize);
            // decompress the message and store it in private variable
            FTempMessage := ZDecompressStr(LMessage);
            // sync with main thread
            Synchronize(Self.DoClientMessage);
          end; // cmdMessageBroadcast, cmdMessagePrivate: begin
          cmdScreenShotGet: begin
            // a client requested a screen shot
            // sync with main thread
            Synchronize(Self.DoClientScreenShotSend);
          end; // cmdScreenShotGet: begin
          cmdScreenShotData: begin
            // we received a screen shot on request
            // read the screen shot data
            FTCPClient.IOHandler.ReadBytes(FTempBuffer, LProtocol.DataSize);
            // sync with main thread
            Synchronize(Self.DoClientScreenShotGet);
          end; // cmdScreenShotData: begin
        end; // case LProtocol.Command of
      finally
        // clear buffer and message
        ClearBuffer(LBuffer);
        ClearBuffer(LMessage);
      end; // tryf
    // we needs to call Sleep so that this thread will not eat too much CPU
    // 50 miliseconds should be perfect
    // NOTE: we do NOT lose data, we just create a small latency
    Sleep(50);
  end; // while NOT Terminated and FTCPClient.Connected do begin
end;

procedure TClientThread.Lock;
begin
  FCriticalSection.Enter;
end;

procedure TClientThread.SendConnected;
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdConnect;
  // set the sender
  LProtocol.Sender := FClient;
  // convert protocol to array of bytes
  LBuffer := ProtocolToBytes(LProtocol);
  Lock;
  try
    // send command to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientThread.SendDisconnected;
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdDisconnect;
  // set the sender
  LProtocol.Sender := FClient;
  // convert protocol to array of bytes
  LBuffer := ProtocolToBytes(LProtocol);
  Lock;
  try
    // send command to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientThread.SendMessageBroadcast(const AMessage: string);
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
  LMessage: TBytes;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // compress the message
  LMessage := ZCompressStr(AMessage);
  // set the command
  LProtocol.Command := cmdMessageBroadcast;
  // set the sender
  LProtocol.Sender := FClient;
  // set the DataSize to the number of bytes that the message contains
  LProtocol.DataSize := Length(LMessage);
  // convert protocol to bytes
  LBuffer := ProtocolToBytes(LProtocol);
  // set the length of the buffer to  + 
  SetLength(LBuffer, szProtocol + LProtocol.DataSize);
  // move message to buffer
  Move(LMessage[0], LBuffer[szProtocol], LProtocol.DataSize);
  Lock;
  try
    // send message to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
    ClearBuffer(LMessage);
  end; // tryf
end;

procedure TClientThread.SendMessagePrivate(const AReceiver: TClient;
  const AMessage: string);
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
  LMessage: TBytes;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // compress the message
  LMessage := ZCompressStr(AMessage);
  // set the command
  LProtocol.Command := cmdMessagePrivate;
  // set the sender
  LProtocol.Sender := FClient;
  // set the receiver
  LProtocol.Receiver := AReceiver;
  // set the DataSize to the number of bytes the message contains
  LProtocol.DataSize := Length(LMessage);
  // convert protocol to bytes
  LBuffer := ProtocolToBytes(LProtocol);
  // set the length of the buffer to  + 
  SetLength(LBuffer, szProtocol + LProtocol.DataSize);
  // move message to buffer
  Move(LMessage[0], LBuffer[szProtocol], LProtocol.DataSize);
  Lock;
  try
    // send message to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
    ClearBuffer(LMessage);
  end; // tryf
end;

procedure TClientThread.SendScreenShotReq(const AReceiver: TClient);
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdScreenShotGet;
  // set the sender
  LProtocol.Sender := FClient;
  // set the receiver
  LProtocol.Receiver := AReceiver;
  // convert protocol to bytes
  LBuffer := ProtocolToBytes(LProtocol);
  Lock;
  try
    // send request to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientThread.Unlock;
begin
  FCriticalSection.Leave;
end;
In the "OnExecute" event of the TIdTCPServer component we need to handle client requests like so
procedure TfrmMain.ServerExecute(AContext: TIdContext);
var
  // temporary buffer
  LBuffer: TBytes;
  // temporary message buffer
  LMessageBuffer: TBytes;
  // data size in InputBuffer
  LDataSize: Integer;
  // protocol structure
  LProtocol: TProtocol;
  // we need to HARD CAST AContext to TClientContext
  // in order to access our custom methods(procedures)
  LClientContext: TClientContext;
begin
  // hard cast AContext to TClientContext
  LClientContext := TClientContext(AContext);
  // store the size of the InputBuffer of the client
  LDataSize := LClientContext.Connection.IOHandler.InputBuffer.Size;
  // in order to prevent spams or to make sure that we have at least
  // the protocol structure sent we check the size of the InputBuffer
  if LDataSize >= szProtocol then
    try
      // read the protocol structure from the client so we can handle
      // the client's request
      LClientContext.Connection.IOHandler.ReadBytes(LBuffer, szProtocol);
      // convert the buffer to protocol structure
      LProtocol := BytesToProtocol(LBuffer);
      // check client command and act accordingly
      case LProtocol.Command of
        cmdConnect: begin
          // the client just connected
          AddFmtLog(' %s', [LProtocol.Sender.UserName]);
          // set the client information in client context
          LClientContext.Client := LProtocol.Sender;
          // send the client list to this client so he knows who's connected
          LClientContext.SendClientList;
          // notify other clients that this client is connected
          LClientContext.BroadcastBuffer(LBuffer);
        end; // cmdConnect: begin
        cmdDisconnect: begin
          // client is disconnecting
          AddFmtLog(' %s', [LProtocol.Sender.UserName]);
          // notify other clients that this client is diconnecting
          LClientContext.BroadcastBuffer(LBuffer);
        end; // cmdDisconnect: begin
        cmdMessageBroadcast: begin
          // client is broadcasting a message
          // read the message from the sender client, the size of the mssages is
          // stored in DataSize member of the protocol structure
          LClientContext.Connection.IOHandler.ReadBytes(LBuffer, LProtocol.DataSize);
          // set the length of the temporary message buffer
          SetLength(LMessageBuffer, LProtocol.DataSize);
          // move the message data from the buffer to message buffer
          Move(LBuffer[szProtocol], LMessageBuffer[0], LProtocol.DataSize);
          AddFmtLog('<%s> %s', [
            LProtocol.Sender.UserName,
            ZDecompressStr(LMessageBuffer)]);
          // broadcast the message
          LClientContext.BroadcastBuffer(LBuffer);
        end; // cmdMessageBroadcast: begin
        cmdMessagePrivate: begin
          // client is sending a private message
          // read the message from the sender client
          LClientContext.Connection.IOHandler.ReadBytes(LBuffer, LProtocol.DataSize);
          // set the length of the temporary message buffer
          SetLength(LMessageBuffer, LProtocol.DataSize);
          // move the message data from the buffer to message buffer
          Move(LBuffer[szProtocol], LMessageBuffer[0], LProtocol.DataSize);
          AddFmtLog(' %s> %s', [
            LProtocol.Sender.UserName,
            LProtocol.Receiver.UserName,
            ZDecompressStr(LMessageBuffer)]);
          // send the message to the receiver client
          LClientContext.SendBuffer(LBuffer, LProtocol.Receiver.ID);
        end; // cmdMessagePrivate: begin
        cmdScreenShotGet: begin
          // client is requesting a screen shot
          AddFmtLog(' %s from %s', [
            LProtocol.Sender.UserName,
            LProtocol.Receiver.UserName]);
          // forward the request to target client
          LClientContext.SendBuffer(LBuffer, LProtocol.Receiver.ID);
        end; // cmdScreenShotGet: begin
        cmdScreenShotData: begin
          // client is sending screen shot data to the client that requested
          // read the screen shot data from the sender client
          LClientContext.Connection.IOHandler.ReadBytes(LBuffer, LProtocol.DataSize);
          AddFmtLog(' %s to %s', [
            (LProtocol.DataSize / 1024),
            LProtocol.Sender.UserName,
            LProtocol.Receiver.UserName]);
          // forward the screen shot data to the target client
          LClientContext.SendBuffer(LBuffer, LProtocol.Receiver.ID);
        end; // cmdScreenShotData: begin
      end; // case LProtocol.Command of
    finally
      ClearBuffer(LBuffer);
      ClearBuffer(LMessageBuffer);
    end; // tryf
end;
In the form's "OnCreate" event you needs to set the context class of the server to our custom TClientContext so that the server will create our client context instance when a client is connected
procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Server.ContextClass := TClientContext;
end;
The above code is just a overview of the application and protocol implementation, if your curious to see the rest of the code and test the application then
- get the source code
- get the source code + binary
Any comments highly appreciated.

Monday, September 6, 2010

OSD component

I bet a lot of you guys needed at least one time a OSD(On screen display) component and you searched for hours and eventually created one yourself or dumped the idea... well here's my OSD implementation
—Copy-Paste and save as uOnScreenDisplay.pas—
unit uOnScreenDisplay;

// Author Dorin Duminica
// Free to use for personal and/or commercial purpose

interface

uses
  Windows,
  SysUtils,
  Messages,
  Classes,
  Graphics,
  StdCtrls,
  ExtCtrls,
  Controls,
  Forms;

type
  TOnScreenDisplay = class(TComponent)
  private
    FOSDForm: TForm;
    FOSDText: TLabel;
    FTimer: TTimer;
    FOnShow: TNotifyEvent;
    FOnHide: TNotifyEvent;
    procedure OnTimer(Sender: TObject);
    function GetHeight: Integer;
    procedure SetHeight(const Value: Integer);
    function GetFont: TFont;
    procedure SetFont(const Value: TFont);
    function GetColor: TColor;
    procedure SetColor(const Value: TColor);
    function GetOnHide: TNotifyEvent;
    function GetOnShow: TNotifyEvent;
    procedure SetOnHide(const Value: TNotifyEvent);
    procedure SetOnShow(const Value: TNotifyEvent);
    function GetAlphaBlendValue: Byte;
    procedure SetAlphaBlendValue(const Value: Byte);
  public
    constructor Create;
    destructor Destroy; override;
  public
    function OSDForm: TForm;
    function OSDText: TLabel;
    procedure Show(const AMessage: string; const TimeOut: Cardinal = 2500);
    procedure ShowFmt(const AMessage: string; const Args: array of const;
      const TimeOut: Cardinal = 2500);
  published
    property AlphaBlendValue: Byte read GetAlphaBlendValue write SetAlphaBlendValue;
    property Color: TColor read GetColor write SetColor;
    property Height: Integer read GetHeight write SetHeight;
    property Font: TFont read GetFont write SetFont;
    // events
    property OnShow: TNotifyEvent read GetOnShow write SetOnShow;
    property OnHide: TNotifyEvent read GetOnHide write SetOnHide;
  end;

var
  GlobalOSD: TOnScreenDisplay;

implementation

{ TOnScreenDisplay }

constructor TOnScreenDisplay.Create;
begin
  // OSDForm
  FOSDForm := TForm.Create(NIL);
  FOSDForm.AlphaBlend := True;
  FOSDForm.AlphaBlendValue := 150;
  FOSDForm.Color := clBlack;
  FOSDForm.Align := alTop;
  FOSDForm.Height := 55;
  FOSDForm.BorderStyle := bsNone;
  FOSDForm.FormStyle := fsStayOnTop;
  SetWindowLong(FOSDForm.Handle, GWL_EXSTYLE, WS_EX_TRANSPARENT or WS_EX_LAYERED);
  // if AlphaBlending is not available uncomment the next line
  // SetLayeredWindowAttributes(FOSDForm.Handle, 0, 150{transparent value}, LWA_ALPHA);
  // OSDText
  FOSDText := TLabel.Create(FOSDForm);
  FOSDText.Parent := FOSDForm;
  FOSDText.Align := alClient;
  FOSDText.AlignWithMargins := True;
  FOSDText.Margins.SetBounds(10, 10, 10, 10);
  FOSDText.Font.Size := 20;
  FOSDText.Font.Name := 'Verdana';
  FOSDText.Font.Style := [fsBold];
  FOSDText.Font.Color := clInfoBk;
  FOSDText.Alignment := taCenter;
  FOSDText.WordWrap := True;
  // timer
  FTimer := TTimer.Create(FOSDForm);
  FTimer.Enabled := False;
  FTimer.OnTimer := Self.OnTimer;
end;

destructor TOnScreenDisplay.Destroy;
begin
  FreeAndNil(FOSDForm);
  inherited;
end;

function TOnScreenDisplay.GetAlphaBlendValue: Byte;
begin
  Result := FOSDForm.AlphaBlendValue;
end;

function TOnScreenDisplay.GetColor: TColor;
begin
  Result := FOSDForm.Color;
end;

function TOnScreenDisplay.GetFont: TFont;
begin
  Result := FOSDText.Font;
end;

function TOnScreenDisplay.GetHeight: Integer;
begin
  Result := FOSDForm.Height;
end;

function TOnScreenDisplay.GetOnHide: TNotifyEvent;
begin
  Result := FOSDForm.OnHide;
end;

function TOnScreenDisplay.GetOnShow: TNotifyEvent;
begin
  Result := FOSDForm.OnShow;
end;

procedure TOnScreenDisplay.OnTimer(Sender: TObject);
begin
  FTimer.Enabled := False;
  FOSDForm.Close;
end;

function TOnScreenDisplay.OSDForm: TForm;
begin
  Result := FOSDForm;
end;

function TOnScreenDisplay.OSDText: TLabel;
begin
  Result := FOSDText;
end;

procedure TOnScreenDisplay.SetAlphaBlendValue(const Value: Byte);
begin
  FOSDForm.AlphaBlendValue := Value;
end;

procedure TOnScreenDisplay.SetColor(const Value: TColor);
begin
  FOSDForm.Color := Value;
end;

procedure TOnScreenDisplay.SetFont(const Value: TFont);
begin
  FOSDText.Font := Value;
end;

procedure TOnScreenDisplay.SetHeight(const Value: Integer);
begin
  FOSDForm.Height := Value;
end;

procedure TOnScreenDisplay.SetOnHide(const Value: TNotifyEvent);
begin
  FOSDForm.OnHide := Value;
end;

procedure TOnScreenDisplay.SetOnShow(const Value: TNotifyEvent);
begin
  FOSDForm.OnShow := Value;
end;

procedure TOnScreenDisplay.Show(const AMessage: string; const TimeOut: Cardinal);
begin
  FTimer.Enabled := False;
  FOSDText.Caption := AMessage;
  FTimer.Interval := TimeOut;
  FTimer.Enabled := True;
  FOSDForm.Show;
end;

procedure TOnScreenDisplay.ShowFmt(const AMessage: string;
  const Args: array of const; const TimeOut: Cardinal);
begin
  Show(Format(AMessage, Args), TimeOut);
end;

initialization
  GlobalOSD := TOnScreenDisplay.Create;

finalization
  FreeAndNil(GlobalOSD);

end.
If you wish you can register the component into the IDE, but I really don't see any need for that, your choice...

Usage: GlobalOSD.Show('I love delphigeist!!', 4000);
the message will be displayed for 4 seconds on the screen.

NOTE: If you call GlobalOSD.Show before the previous OSD message disappears then the text will be changed and the Time out timer will be reseted.

Blogroll(General programming and Delphi feeds)