{***************************************************************************}
{ TMS IntraWeb Component Pack Pro                                           }
{ for Delphi & C++Builder                                                   }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright © 2002 - 2007                                        }
{            Email : info@tmssoftware.com                                   }
{            Web : http://www.tmssoftware.com                               }
{                                                                           }
{ The source code is given as is. The author is not responsible             }
{ for any possible damage done due to the use of this code.                 }
{ The component can be freely used in any application. The complete         }
{ source code remains property of the author and may not be distributed,    }
{ published, given or sold in any form as such. No parts of the source      }
{ code can be included in any other component or application without        }
{ written authorization of the author.                                      }
{***************************************************************************}

unit IWTMSImg;

{$I tmsdefs.inc}

interface

uses
  Classes, Graphics, ComObj, ActiveX, Windows, Controls, SysUtils
  {$IFDEF DELPHI6_LVL}
  ,Types
  {$ENDIF}
  ;

type

  TIPicture = class(TGraphic)
  private
    { Private declarations }
    gpPicture: IPicture;
    FDatastream: TMemoryStream;
    FIsEmpty: Boolean;
    FStretched: Boolean;
    FLogPixX,FLogPixY: Integer;
    FID: string;
    FFrame: Integer;
    FFrameCount: Integer;
    FOnFrameChange: TNotifyEvent;
    FFrameXPos: Word;
    FFrameYPos: Word;
    FFrameXSize: Word;
    FFrameYSize: Word;
    FFrameTransp: Boolean;
    FFrameDisposal: Word;
    FAnimMaxX,FAnimMaxY: Word;
    FDoubleBuffered: Boolean;
    FBackgroundColor: TColor;
    procedure LoadPicture;
    function GetFrameCount: Integer;
    function IsGIFFile: Boolean;
    function GetFrameTime(i: Integer): Integer;
  protected
    { Protected declarations }
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;
    procedure ReadData(Stream: TStream); override;
    procedure WriteData(Stream: TStream); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    procedure SetFrame(const Value:Integer);
  public
    { Public declarations }
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromFile(const FileName: string); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromResourceName(Instance: THandle; const ResName: String);
    procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
    procedure LoadFromURL(url:string);
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    property ID:string read fID write fID;
    property IsGIF: Boolean read IsGIFFile;
    property FrameCount:Integer read GetFrameCount;
    property FrameTime[i:Integer]:Integer read GetFrameTime;
    function GetMaxHeight: Integer;
    function GetMaxWidth: Integer;
    property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered;
    property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor;

  published
    { Published declarations }
    property Stretch:Boolean read FStretched write FStretched;
    property Frame:Integer read FFrame write SetFrame;
    property OnFrameChange: TNotifyEvent read FOnFrameChange write FOnFrameChange;
  end;


implementation

const
  HIMETRIC_INCH = 2540;
  TIMER_ID = 500;
  
{ TIPicture }

procedure TIPicture.Assign(Source: TPersistent);
begin
  FIsEmpty := True;
  FFrameCount := -1;
  gpPicture := nil;
  if Source = nil then
  begin
    FDataStream.Clear;
    if Assigned(OnChange) then
      OnChange(Self);
  end
  else
  begin
    if Source is TIPicture then
    begin
      FDataStream.LoadFromStream(TIPicture(Source).FDataStream);
      FIsEmpty := False;
      LoadPicture;
      if Assigned(OnChange) then
        OnChange(self);
    end;
  end;
end;

constructor TIPicture.Create;
begin
  inherited;
  FDataStream := TMemoryStream.Create;
  FIsEmpty := True;
  gpPicture := nil;
  FLogPixX := 96;
  FLogPixY := 96;
  FFrame := 0;
  FFrameCount := -1; 
end;

destructor TIPicture.Destroy;
begin
  FDataStream.Free;
  inherited;
end;

procedure TIPicture.SetFrame(const Value:Integer);
begin
  FFrame := Value;
  if (FDataStream.Size > 0) then
  begin
    LoadPicture;
    if Assigned(OnFrameChange) then
      OnFrameChange(self);
  end;
end;

procedure TIPicture.LoadPicture;
const
  IID_IPicture: TGUID = (
  D1:$7BF80980;D2:$BF32;D3:$101A;D4:($8B,$BB,$00,$AA,$00,$30,$0C,$AB));

var
  hGlobal:thandle;
  pvData:pointer;
  pstm:IStream;
  hr:hResult;
  gifstream: TMemoryStream;
  i:Integer;
  b,c,d,e:byte;
  skipimg:Boolean;
  imgidx:Integer;
begin
  hGlobal := GlobalAlloc(GMEM_MOVEABLE, fDataStream.Size);
  if (hGlobal = 0) then raise Exception.Create('Could not allocate memory for image');

  try
    pvData := GlobalLock(hGlobal);
    FDataStream.Position:=0;

    FFrameXPos := 0;
    FFrameYPos := 0;
    FAnimMaxX := 0;
    FAnimMaxY := 0;

    {skip first image ctrl}

    if IsGIF and (FrameCount>0) then
     begin
      //manipulate the stream here for animated GIF ?
      Gifstream := TMemoryStream.Create;
      imgidx:=1;
      skipimg:=false;

      fDataStream.Position:=6;
      fDataStream.Read(FAnimMaxX,2);
      fDataStream.Read(FAnimMaxY,2);

      for i:=1 to fDataStream.Size do
       begin
         fDataStream.Position:=i-1;
         fDataStream.Read(b,1);

         if (b=$21) and (i+8<fDataStream.Size) then
          begin
           fDataStream.Read(c,1);
           fDataStream.Read(d,1);
           fDataStream.Position:=fDataStream.Position+5;

           fDataStream.Read(e,1);
           if (c=$F9) and (d=$4) and (e=$2C) then
             begin
               if imgidx=fFrame then
                begin
                 fDataStream.Read(FFrameXPos,2);
                 fDataStream.Read(FFrameYPos,2);
                 fDataStream.Read(FFrameXSize,2);
                 fDataStream.Read(FFrameYSize,2);
                end;

               inc(imgidx);
               if imgidx<=fFrame then skipimg:=true else
                                skipimg:=false;

             end;
          end;
        if not skipimg then gifstream.write(b,1);
       end;
      GifStream.Position:=0;
      GifStream.ReadBuffer(pvData^,GifStream.Size);
      GifStream.Free;
     end
    else
     fDataStream.ReadBuffer(pvData^,fDataStream.Size);

    GlobalUnlock(hGlobal);

    pstm := nil;

    // Create IStream* from global memory
    hr := CreateStreamOnHGlobal(hGlobal, TRUE, pstm);

    if (not hr = S_OK) then
        raise Exception.Create('Could not create image stream')
     else
      if (pstm = nil) then
        raise Exception.Create('Empty image stream created');

    // Create IPicture from image file
    hr := OleLoadPicture(pstm,
                         fDataStream.Size,
                         FALSE,
                         IID_IPicture,
                         gpPicture);

    if (not (hr=S_OK)) then
     raise Exception.Create('Could not load image. Invalid format')
    else if (gpPicture = nil) then
     raise Exception.Create('Could not load image');
  finally
    GlobalFree(hGlobal);
  end;
end;

procedure TIPicture.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  hmWidth: Integer;
  hmHeight: Integer;
  DrwRect: TRect;

begin
  if Empty then
    Exit;

  if gpPicture = nil then
    Exit;

  hmWidth  := 0;
  hmHeight := 0;
  gpPicture.get_Width(hmWidth);
  gpPicture.get_Height(hmHeight);

  DrwRect := Rect;

  OffsetRect(DrwRect,FFrameXPos,FFrameYPos);

  gpPicture.Render(ACanvas.Handle,DrwRect.Left,DrwRect.Bottom,DrwRect.Right-DrwRect.Left,
                   -(DrwRect.Bottom-DrwRect.Top),0,0, hmWidth,hmHeight, DrwRect);

end;

function TIPicture.GetEmpty: Boolean;
begin
  Result := FIsEmpty;
end;

function TIPicture.GetHeight: Integer;
var
  hmHeight: Integer;
begin
  if gpPicture = nil then
    Result := 0
  else
  begin
    gpPicture.get_Height(hmHeight);
    Result := MulDiv(hmHeight, FLogPixY, HIMETRIC_INCH);
  end;
end;

function TIPicture.GetWidth: Integer;
var
  hmWidth: Integer;
begin
  if gpPicture = nil then
    Result := 0
  else
  begin
    gpPicture.get_Width(hmWidth);
    Result := MulDiv(hmWidth, fLogPixX, HIMETRIC_INCH);
  end;
end;

procedure TIPicture.LoadFromFile(const FileName: string);
begin
  try
    FDataStream.LoadFromFile(Filename);
    FIsEmpty := False;
    FFrame := 1;
    FAnimMaxX := 0;
    FAnimMaxY := 0;

    LoadPicture;
    if Assigned(OnChange) then
      OnChange(self);
  except
    FIsEmpty:=true;
  end;
end;

procedure TIPicture.LoadFromStream(Stream: TStream);
begin
  if Assigned(Stream) then
  begin
    FDataStream.LoadFromStream(Stream);
    FIsEmpty := False;
    FFrame := 1;
    FAnimMaxX := 0;
    FAnimMaxY := 0;
    LoadPicture;
    if Assigned(OnChange) then
      OnChange(self);
  end;
end;

procedure TIPicture.ReadData(Stream: TStream);
begin
  if assigned(Stream) then
  begin
    FDataStream.LoadFromStream(stream);
    FIsEmpty := False;
    LoadPicture;
  end;
end;

procedure TIPicture.SaveToStream(Stream: TStream);
begin
  if Assigned(Stream) then
    FDataStream.SaveToStream(Stream);
end;


procedure TIPicture.LoadFromResourceName(Instance: THandle; const ResName: string);
var
  Stream: TCustomMemoryStream;
begin
  if FindResource(Instance,PChar(ResName),RT_RCDATA) <> 0 then
  begin
    Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA);
    try
      LoadFromStream(Stream);
    finally
      Stream.Free;
    end;
  end;
end;

procedure TIPicture.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
  Stream: TCustomMemoryStream;
begin
  Stream := TResourceStream.CreateFromID(Instance, ResID, RT_RCDATA);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;


procedure TIPicture.SetHeight(Value: Integer);
begin

end;

procedure TIPicture.SetWidth(Value: Integer);
begin

end;

procedure TIPicture.WriteData(Stream: TStream);
begin
  if Assigned(Stream) then
  begin
    FDataStream.SaveToStream(stream);
  end;
end;

procedure TIPicture.LoadFromURL(url: string);
begin
  if (pos('RES://',UpperCase(url))=1) then
  begin
    ID := url;
    Delete(url,1,6);
    if (url<>'') then
      LoadFromResourceName(hinstance,url);
    Exit;
  end;

  if (pos('FILE://',uppercase(url))=1) then
  begin
    ID:=url;
    Delete(url,1,7);
    if (url<>'')
      then LoadFromFile(url);
  end;
end;

procedure TIPicture.LoadFromClipboardFormat(AFormat: Word;
  AData: THandle; APalette: HPALETTE);
begin
end;

procedure TIPicture.SaveToClipboardFormat(var AFormat: Word;
  var AData: THandle; var APalette: HPALETTE);
begin
end;

function TIPicture.GetFrameCount: Integer;
var
  i: Integer;
  b,c,d,e: Byte;
  Res: Integer;
begin
  Result := -1;

  if FFrameCount <> -1 then
    Result := FFrameCount
  else
    if IsGIFFile then
    begin
      Res := 0;
      for i := 1 to FDataStream.Size do
      begin
        FDataStream.Position := i - 1;
        FDataStream.Read(b,1);
        if (b = $21) and (i + 8 < FDataStream.Size) then
        begin
          FDataStream.Read(c,1);
          FDataStream.Read(d,1);
          FDataStream.Position:=fDataStream.Position+5;
          FDataStream.Read(e,1);
          if (c = $F9) and (d = $4) and (e = $2C) then Inc(res);
        end;
      end;
      FFrameCount := Res;  // cached FrameCount value
      Result := Res;
      FDataStream.Position := 0;
    end;
end;

function TIPicture.IsGIFFile: Boolean;
var
  buf: array[0..4] of char;
begin
  Result := False;
  if FDataStream.Size>4 then
  begin
    FDataStream.Position := 0;
    FDataStream.Read(buf,4);
    buf[4] := #0;
    Result := Strpas(buf) = 'GIF8';
    FDataStream.Position := 0;
  end;
end;

function TIPicture.GetFrameTime(i: Integer): Integer;
var
 j: Integer;
 b,c,d,e: Byte;
 res: Integer;
 ft: Word;

begin
  Result := -1;

  if IsGIFFile then
  begin
    Res := 0;
    for j := 1 to FDataStream.Size do
    begin
      fDataStream.Position := j-1;
      fDataStream.Read(b,1);
      if (b = $21) and (i + 8 < FDataStream.Size) then
      begin
        FDataStream.Read(c,1);
        FDataStream.Read(d,1);
        FDataStream.Read(b,1);
        {transp. flag here}

        FDataStream.Read(ft,2);
        FDataStream.Position:=fDataStream.Position+2;

        FDataStream.Read(e,1);
        if (c = $F9) and (d = $4) and (e = $2C) then
        begin
          Inc(res);
          if res = i then
          begin
            Result := ft;
            fFrameTransp := b and $01=$01;
            fFrameDisposal := (b shr 3) and $7;
          end;
        end;
      end;
    end;
  end;
  FDataStream.Position := 0;
end;

function TIPicture.GetMaxHeight: Integer;
var
  hmHeight: Integer;
begin
  if gpPicture=nil then Result:=0 else
  begin
    if FAnimMaxY>0 then Result:=FAnimMaxY
    else
    begin
      gpPicture.get_Height(hmHeight);
      Result := MulDiv(hmHeight, fLogPixY, HIMETRIC_INCH);
    end;
  end;

end;

function TIPicture.GetMaxWidth: Integer;
var
  hmWidth: Integer;
begin
  if gpPicture = nil then
    Result := 0
  else
  begin
    if FAnimMaxX > 0 then
      Result := FAnimMaxX
    else
    begin
      gpPicture.get_Width(hmWidth);
      Result := MulDiv(hmWidth, fLogPixX, HIMETRIC_INCH);
    end;
  end;
end;


end.
 