{***************************************************************************}
{ TMS IntraWeb Component Pack Pro                                           }
{ for Delphi & C++Builder                                                   }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright © 2002 - 2008                                        }
{            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 IWPicCntnr;

interface

{$I TMSDEFS.INC}
{$DEFINE USEWININET}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComObj, ActiveX, WinInet;

type
  TIWPicturePosition = (bpTopLeft,bpTopRight,bpBottomLeft,bpBottomRight,bpCenter,bpTiled,bpStretched);

  TIWHTMLPicture = class;

  PInternetContent = ^TInternetContent;
  TInternetContent = record
  {$IFDEF USEWININET}
    hresource: hinternet;
  {$ENDIF}
    Complete: Boolean;
    HTMLPicture:TIWHTMLPicture;
  end;

  TDownloadErrorEvent = procedure(Sender:TObject;err:string) of object;
  TDownloadCompleteEvent = procedure(Sender:TObject) of object;
  TDownloadCancelEvent = procedure(Sender:TObject;var Cancel:boolean) of object;
  TDownloadProgressEvent = procedure(Sender:TObject;dwSize,dwTotSize:dword) of object;

  TDownLoadThread = class(TThread)
  private
    HTMLPicture:TIWHTMLPicture;
  protected
    procedure Execute; override;
  public
    constructor Create(aHTMLPicture:TIWHTMLPicture);
  end;

  TIWHTMLPicture = class(TGraphic)
  private
    { Private declarations }
    FDatastream:TMemoryStream;
    FIsEmpty: Boolean;
    FStretched: Boolean;
    gpPicture: IPicture;
    FLogPixX,FLogPixY: Integer;
    FURL:string;
    FID:string;
    FIsDB: Boolean;
    FAsynch: Boolean;
    FThreadBusy: Boolean;
    FFrame: Integer;
    FFrameCount: Integer;
    FOnFrameChange: TNotifyEvent;
    FFrameXPos: Word;
    FFrameYPos: Word;
    FFrameXSize: Word;
    FFrameYSize: Word;
    FFrameTransp: Boolean;
    FFrameDisposal: Word;
    FAnimMaxX,FAnimMaxY: Word;
    FNextCount: Integer;
    FTimerCount: Integer;
    FOnDownLoadProgress: TDownLoadProgressEvent;
    FOnDownLoadCancel: TDownLoadCancelEvent;
    FOnDownLoadComplete: TDownLoadCompleteEvent;
    FOnDownLoadError: TDownLoadErrorEvent;
    FInstance: DWord;
    FBaseDir: string;
    FDesignLive: Boolean;
    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 DownLoadError(err:string);
    procedure DownLoadComplete;
    procedure DownLoadCancel(var cancel:boolean);
    procedure DownLoadProgress(dwSize,dwTotSize:dword);
    {$IFDEF USEWININET}
    procedure DownLoad;
    {$ENDIF}
  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 Busy: Boolean read fThreadBusy;
    property Asynch: Boolean read fAsynch write fAsynch;
    property ID: string read FID write FID;
    property IsDB: boolean read FIsDB write FIsDB;
    property IsGIF: Boolean read IsGIFFile;
    property FrameCount:Integer read GetFrameCount;
    property FrameTime[i:Integer]:Integer read GetFrameTime;
    function GetMaxHeight: Integer;
    function GetMaxWidth: Integer;
    procedure SetFrame(const Value: Integer);
    procedure FrameNext;
    procedure FramePrev;
    function Step: Boolean;
    property MaxWidth: integer read GetMaxWidth;
    property MaxHeight: integer read GetMaxHeight;
    property FrameXPos: word read FFrameXPos;
    property FrameYPos: word read FFrameYPos;
    property Instance: DWord read FInstance write FInstance;
  published
    { Published declarations }
    property BaseDir: string read FBaseDir write FBaseDir;
    property DesignLive: Boolean read FDesignLive write FDesignLive;
    property Stretch: Boolean read FStretched write FStretched;
    property Frame: Integer read FFrame write SetFrame;
    property OnFrameChange: TNotifyEvent read FOnFrameChange write FOnFrameChange;
    property OnDownLoadError: TDownLoadErrorEvent read fOnDownLoadError write fOnDownLoadError;
    property OnDownLoadComplete: TDownLoadCompleteEvent read fOnDownLoadComplete write fOnDownLoadComplete;
    property OnDownLoadCancel: TDownLoadCancelEvent read fOnDownLoadCancel write fOnDownLoadCancel;
    property OnDownLoadProgress: TDownLoadProgressEvent read fOnDownLoadProgress write fOnDownLoadProgress;
  end;

  TIWHTMLPictureCache = class(TList)
  private
    FInstance: DWord;
    FBaseDir: string;
    FDesignLive: Boolean;
    procedure SetPicture(Index: Integer; Value: TIWHTMLPicture);
    function GetPicture(Index: Integer):TIWHTMLPicture;
  public
    property Items[index: Integer]: TIWHTMLPicture read GetPicture write SetPicture; default;
    function AddPicture: TIWHTMLPicture;
    function FindPicture(ID:string):TIWHTMLPicture;
    procedure ClearPictures;
    function Animate: boolean;
    constructor Create;
    property BaseDir: string read FBaseDir write FBaseDir;
    property DesignLive: Boolean read FDesignLive write FDesignLive;
    property Instance: DWord read FInstance write FInstance;
  end;

  TIWHTMLImage = class(TGraphicControl)
  private
    { Private declarations }
    FHTMLPicture:TIWHTMLPicture;
    FPicturePosition:TIWPicturePosition;
    FOnDownLoadCancel: TDownLoadCancelEvent;
    FOnDownLoadComplete: TDownLoadCompleteEvent;
    FOnDownLoadError: TDownLoadErrorEvent;
    FOnDownLoadProgress: TDownLoadProgressEvent;
    FBaseDir: string;
    FDesignLive: Boolean;
    procedure SetPicture(const Value: TIWHTMLPicture);
    procedure PictureChanged(sender:TObject);
    procedure SetPicturePosition(const Value: TIWPicturePosition);
    procedure DownLoadError(Sender:TObject;err:string);
    procedure DownLoadComplete(Sender:TObject);
    procedure DownLoadCancel(Sender:TObject;var Cancel: Boolean);
    procedure DownLoadProgress(Sender:TObject;dwSize,dwTotSize:dword);
  protected
    { Protected declarations }
     procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    { Published declarations }
    property BaseDir: string read FBaseDir write FBaseDir;
    property DesignLive: Boolean read FDesignLive write FDesignLive;
    property HTMLPicture: TIWHTMLPicture read FHTMLPicture write SetPicture;
    property PicturePosition: TIWPicturePosition read FPicturePosition write SetPicturePosition;
    { inherited published properties}
    property Align;
    {$IFDEF DELPHI4_LVL}
    property Anchors;
    property Constraints;
    property DragKind;    
    {$ENDIF}
    property DragCursor;
    property DragMode;
    property Hint;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnClick;
    {$IFDEF DELPHI5_LVL}
    property OnContextPopup;
    {$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    {$IFDEF DELPHI4_LVL}
    property OnEndDock;
    property OnStartDock;
    {$ENDIF}
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseUp;
    property OnMouseMove;
    property OnStartDrag;
    property OnDownLoadError:TDownLoadErrorEvent read FOnDownLoadError write FOnDownLoadError;
    property OnDownLoadComplete:TDownLoadCompleteEvent read FOnDownLoadComplete write FOnDownLoadComplete;
    property OnDownLoadCancel:TDownLoadCancelEvent read FOnDownLoadCancel write FOnDownLoadCancel;
    property OnDownLoadProgress:TDownLoadProgressEvent read FOnDownLoadProgress write FOnDownLoadProgress;
  end;

  TIWPictureItem = class(TCollectionItem)
  private
    FPicture: TIWHTMLPicture;
    FTag: Integer;
    FName: string;
    FBaseDir: string;
    FDesignLive: Boolean;
    procedure SetPicture(const Value: TIWHTMLPicture);
    procedure SetBaseDir(const Value: string);
    procedure SetDesignLive(const Value: Boolean);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property BaseDir: string read FBaseDir write SetBaseDir;
    property DesignLive: Boolean read FDesignLive write SetDesignLive;
    property Name: string read FName write FName;
    property Picture: TIWHTMLPicture read FPicture write SetPicture;
    property Tag: Integer read FTag write FTag;
  end;

  TIWPictureCollection = class(TCollection)
  private
    FOwner: TComponent;
    FBaseDir: string;
    FDesignLive: Boolean;
    function GetItem(Index: Integer): TIWPictureItem;
    procedure SetItem(Index: Integer; Value: TIWPictureItem);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AOwner:TComponent);
    function Add: TIWPictureItem;
    function Insert(index: Integer): TIWPictureItem;
    property Items[Index: Integer]: TIWPictureItem read GetItem write SetItem;
    function Animate:Boolean;
  published
    property BaseDir: string read FBaseDir write FBaseDir;
    property DesignLive: Boolean read FDesignLive write FDesignLive;
  end;

  TIWPictureContainer = class(TComponent)
  private
    FItems: TIWPictureCollection;
    procedure SetItems(const Value: TIWPictureCollection);
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindPicture(s:string): TIWHTMLPicture;
  published
    { Published declarations }
    property Items: TIWPictureCollection read FItems write SetItems;
  end;


implementation

const
  HIMETRIC_INCH = 2540;


{ TIWHTMLPicture }

procedure TIWHTMLPicture.Assign(Source: TPersistent);
begin
  FIsEmpty := true;
  gpPicture := nil;
  FFrameCount := -1;
  FNextCount := -1;
  FTimerCount := -1;
  Frame := 1;

  if Source = nil then
    FDataStream.Clear
  else
  begin
    if Source is TIWHTMLPicture then
    begin
      FDataStream.LoadFromStream(TIWHTMLPicture(Source).fDataStream);
      FIsEmpty := False;
      LoadPicture;
      if Assigned(OnChange) then
        OnChange(self);
    end;
  end;
end;

constructor TIWHTMLPicture.Create;
begin
  inherited;
  FDataStream := TMemoryStream.Create;
  FIsEmpty := True;
  gpPicture := nil;
  FLogPixX := 96;
  FLogPixY := 96;
  FThreadBusy := False;
  FAsynch := True;
  FFrameCount := -1;
  FNextCount := -1;
  FTimerCount := -1;
  FFrame := 1;
  FIsDB := False;
end;

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

procedure TIWHTMLPicture.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 TIWHTMLPicture.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  hmWidth:integer;
  hmHeight:integer;
  nPixX,nPixY:integer;
  pnWidth,pnHeight:integer;

begin
  if Empty then Exit;
  if gpPicture = nil then Exit;

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


  if FStretched or (1>0) then
  begin
    gpPicture.Render(ACanvas.Handle,Rect.Left,Rect.Bottom,Rect.Right - Rect.Left,-(Rect.Bottom - Rect.Top),0,0,
                     hmWidth,hmHeight, Rect);
  end
  else
  begin
    nPixX := GetDeviceCaps(ACanvas.Handle,LOGPIXELSX);
    nPixY := GetDeviceCaps(ACanvas.Handle,LOGPIXELSY);
    //Convert to device units
    pnWidth  := MulDiv(hmWidth,  nPixX, HIMETRIC_INCH);
    pnHeight := MulDiv(hmHeight, nPixY, HIMETRIC_INCH);

    gpPicture.Render(ACanvas.Handle,Rect.Left,Rect.Top + pnHeight,pnWidth,-pnHeight,0,0,
                     hmWidth,hmHeight, Rect);
  end;
end;

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

function TIWHTMLPicture.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 TIWHTMLPicture.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 TIWHTMLPicture.LoadFromFile(const FileName: string);
var
  FName: string;
begin
  try
    ID := FileName;

    FName := FileName;
    if (BaseDir <> '') then
    begin
      {$IFDEF DELPHI_UNICODE}
      if not CharInSet(BaseDir[length(BaseDir)], ['\','/']) then
      {$ENDIF}
      {$IFNDEF DELPHI_UNICODE}
      if not (BaseDir[length(BaseDir)] in ['\','/']) then
      {$ENDIF}
        BaseDir := BaseDir + '\';
      FName := BaseDir + FileName;
    end;


    FDataStream.LoadFromFile(FName);
    FIsEmpty := False;
    LoadPicture;
    if Assigned(OnChange) then
      OnChange(Self);
  except
    FIsEmpty := True;
  end;
end;

procedure TIWHTMLPicture.LoadFromStream(Stream: TStream);
begin
  if Assigned(Stream) then
  begin
    FDataStream.LoadFromStream(Stream);
    FIsEmpty := False;
    LoadPicture;
    if Assigned(OnChange) then
      OnChange(self);
  end;
end;

procedure TIWHTMLPicture.ReadData(Stream: TStream);
begin

 if assigned(Stream) then
   begin
     fDataStream.LoadFromStream(stream);
     fIsEmpty:=false;
     LoadPicture;
   end;
end;

procedure TIWHTMLPicture.SaveToStream(Stream: TStream);
begin
  if Assigned(Stream) then fDataStream.SaveToStream(Stream);
end;

procedure TIWHTMLPicture.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 TIWHTMLPicture.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 TIWHTMLPicture.SetHeight(Value: integer);
begin

end;

procedure TIWHTMLPicture.SetWidth(Value: integer);
begin

end;

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

procedure TIWHTMLPicture.LoadFromURL(url: string);
begin
  if Pos('RES://',url) = 1 then
  begin
    ID := url;
    Delete(url,1,6);
    if url <> '' then
      LoadFromResourceName(finstance,url);
    Exit;
  end;

  if Pos('FILE://',url) = 1 then
  begin
    if url <> '' then
      LoadFromFile(copy(url,8,length(url)));
    ID := url;
    Exit;
  end;

  if FDesignLive then
  begin
    if FAsynch then
    begin
      if FThreadBusy then
        Exit;
      FURL := url;
      FThreadBusy := True;
      TDownLoadThread.Create(self);
    end
    else
    begin
      FURL := url;
      ID := url;
      {$IFDEF USEWININET}
      DownLoad;
      {$ENDIF}
    end;
  end;
end;

{$IFDEF USEWININET}
procedure TIWHTMLPicture.DownLoad;
var
  RBSIZE: DWord;
  httpstatus,httpsize,err: Integer;
  dwIdx: DWord;
  dwBufSize: DWord;
  ms: TMemoryStream;
  len: DWord;
  cbuf:array[0..255] of Char;
  rb:array[0..4095] of Byte;
  FISession: hinternet;
  FIHttp: hinternet;
  Cancel: Boolean;
begin
  FISession := InternetOpen('HTMLImage',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);

  if (FISession = nil) then
  begin
    DownLoadError('Cannot open internet session');
    FThreadBusy:=false;
    Exit;
  end;

  FIHttp := InternetOpenURL(FISession,PChar(FURL),nil,0,
    INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_RELOAD,0);

  if (FIHttp = nil) then
  begin
    InternetCloseHandle(fISession);
    DownLoadError('Cannot open http connection');
    fThreadBusy:=false;
    Exit;
  end;

  dwBufSize := SizeOf(cbuf);
  dwidx := 0;
  HttpQueryInfo(fIHttp,HTTP_QUERY_STATUS_CODE,@cbuf,dwBufSize,dwIdx);

  val(cbuf,httpstatus,err);
  if (httpstatus <> 200) or (err <> 0) then
  begin
    InternetCloseHandle(fISession);
    InternetCloseHandle(fIHttp);
    DownLoadError('Cannot open URL '+furl);
    FThreadBusy := False;
    Exit;
  end;

  dwBufSize := SizeOf(cbuf);
  dwidx := 0;
  HttpQueryInfo(fIHttp,HTTP_QUERY_CONTENT_TYPE,@cbuf,dwBufSize,dwIdx);

  if Pos('IMAGE',UpperCase(StrPas(cbuf))) = 0 then
  begin
    InternetCloseHandle(fISession);
    InternetCloseHandle(fIHttp);
    DownLoadError('Resource is not of image type : ' + FUrl);
    fThreadBusy := false;
    Exit;
  end;

  dwBufSize := SizeOf(cbuf);
  dwidx := 0;
  HttpQueryInfo(fIHttp,HTTP_QUERY_CONTENT_LENGTH,@cbuf,dwBufSize,dwIdx);

  val(cbuf,httpsize,err);
  if (httpsize = 0) or (err <> 0) then
  begin
    InternetCloseHandle(fISession);
    InternetCloseHandle(fIHttp);
    DownLoadError('Image size is 0');
    FThreadBusy := False;
    Exit;
  end;

  DownLoadProgress(0,httpsize);

  len := 4096;
  RBSIZE := 4096;

  ms := TMemoryStream.Create;

  Cancel := False;

  while (len = RBSIZE) and not Cancel do
  begin
    InternetReadFile(fIHttp,@rb,RBSIZE,len);
    if len>0 then ms.WriteBuffer(rb,len);
    DownLoadProgress(ms.Size,httpsize);
    DownLoadCancel(Cancel);
  end;

  if not cancel then
  begin
    ms.Position := 0;
    LoadFromStream(ms);
  end;

  ms.Free;

  InternetCloseHandle(FIHttp);
  InternetCloseHandle(FISession);
  FThreadBusy := False;
end;
{$ENDIF}

procedure TIWHTMLPicture.DownLoadCancel(var Cancel: boolean);
begin
  if Assigned(FOnDownLoadCancel) then
    FOnDownLoadCancel(Self,Cancel);
end;

procedure TIWHTMLPicture.DownLoadComplete;
begin
  if Assigned(FOnDownLoadComplete) then
    FOnDownLoadComplete(self);
end;

procedure TIWHTMLPicture.DownLoadError(err: string);
begin
  if Assigned(FOnDownloadError) then
    FOnDownLoadError(Self,err);
end;

procedure TIWHTMLPicture.DownLoadProgress(dwSize, dwTotSize: dword);
begin
  if Assigned(FOnDownLoadProgress) then
    FOnDownLoadProgress(self,dwSize,dwTotSize);
end;


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

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

function TIWHTMLPicture.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;
      Result := Res;
      FDataStream.Position := 0;
    end;
end;

function TIWHTMLPicture.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 TIWHTMLPicture.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 TIWHTMLPicture.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 TIWHTMLPicture.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;


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

procedure TIWHTMLPicture.FrameNext;
begin
  if FFrame < FFrameCount then
    Inc(FFrame)
  else
    FFrame := 1;
end;

function TIWHTMLPicture.Step: Boolean;
begin
  Result := False;
  if (FFrameCount <= 1) or FIsEmpty then
    Exit;

  if FNextCount = -1 then
    FrameTime[FFrame];

  if FTimerCount*10 >= FNextCount then
  begin
    FrameNext;
    LoadPicture;
    FNextCount := FNextCount + FrameTime[FFrame];
    Result := True;
  end;

  Inc(FTimerCount);
end;

procedure TIWHTMLPicture.FramePrev;
begin
  if FFrame > 1 then
    Dec(FFrame)
  else
    FFrame := FFrameCount;
end;


{ TIWHTMLImage }

constructor TIWHTMLImage.Create(aOwner: TComponent);
begin
  inherited;
  FHTMLPicture:=TIWHTMLPicture.Create;
  FHTMLPicture.OnChange := PictureChanged;
  Width := 100;
  Height := 100;
  FHTMLPicture.OnDownLoadError := DownLoadError;
  FHTMLPicture.OnDownLoadCancel := DownLoadCancel;
  FHTMLPicture.OnDownLoadProgress := DownLoadProgress;
  FHTMLPicture.OnDownLoadComplete := DownLoadComplete;
end;

destructor TIWHTMLImage.Destroy;
begin
  FHTMLPicture.Free;
  inherited;
end;

procedure TIWHTMLImage.Loaded;
begin
  inherited;
  FHTMLPicture.fLogPixX := GetDeviceCaps(canvas.handle,LOGPIXELSX);
  FHTMLPicture.fLogPixY := GetDeviceCaps(canvas.handle,LOGPIXELSY);
end;

procedure TIWHTMLImage.Paint;
var
 xo,yo:integer;

   function Max(a,b:integer):integer;
   begin
    if (a>b) then result:=a else result:=b;
   end;

begin
  inherited;
  if assigned(fHTMLPicture) then
  begin
   if not fHTMLPicture.Empty then
   case fPicturePosition of
   bpTopLeft:Canvas.Draw(0,0,fHTMLPicture);
   bpTopRight:Canvas.Draw(Max(0,width-fHTMLPicture.Width),0,fHTMLPicture);
   bpBottomLeft:Canvas.Draw(0,Max(0,height-fHTMLPicture.Height),fHTMLPicture);
   bpBottomRight:Canvas.Draw(Max(0,width-fHTMLPicture.Width),Max(0,height-fHTMLPicture.Height),fHTMLPicture);
   bpCenter:Canvas.Draw(Max(0,width-fHTMLPicture.Width) shr 1,Max(0,height-fHTMLPicture.Height) shr 1,fHTMLPicture);
   bpTiled:begin
            yo:=0;
            while (yo<Height) do
             begin
              xo:=0;
              while (xo<Width) do
               begin
                Canvas.Draw(xo,yo,fHTMLPicture);
                xo:=xo+fHTMLPicture.Width;
               end;
              yo:=yo+fHTMLPicture.Height;
             end;
           end;
   bpStretched:canvas.StretchDraw(rect(0,0,width,height),fHTMLPicture) else
   end;
  end;

end;

procedure TIWHTMLImage.PictureChanged(sender: TObject);
begin
  Invalidate;
end;

procedure TIWHTMLImage.SetPicture(const Value: TIWHTMLPicture);
begin
  FHTMLPicture.Assign(Value);
  Invalidate;
end;

procedure TIWHTMLImage.SetPicturePosition(const Value: TIWPicturePosition);
begin
  if (FPicturePosition <> Value) then
  begin
    FPicturePosition := Value;
    Invalidate;
  end;
end;

procedure TIWHTMLImage.DownLoadCancel(Sender: TObject; var Cancel: Boolean);
begin
  if Assigned(FOnDownLoadCancel) then
    FOnDownLoadCancel(Self,Cancel);
end;

procedure TIWHTMLImage.DownLoadComplete(Sender: TObject);
begin
  if Assigned(FOnDownLoadComplete) then
    FOnDownLoadComplete(Self);
end;

procedure TIWHTMLImage.DownLoadError(Sender: TObject; Err: string);
begin
  if Assigned(FOnDownloadError) then
    FOnDownLoadError(Self,Err);
end;

procedure TIWHTMLImage.DownLoadProgress(Sender: TObject; dwSize,
  dwTotSize: dword);
begin
  if Assigned(FOnDownLoadProgress) then
    FOnDownLoadProgress(Self,dwSize,dwTotSize);
end;

{ TDownLoadThread }

constructor TDownLoadThread.Create(aHTMLPicture: TIWHTMLPicture);
begin
  inherited Create(False);
  HTMLPicture := AHTMLPicture;
  FreeOnTerminate := True;
end;

procedure TDownLoadThread.Execute;
begin
  {$IFDEF USEWININET}
  HTMLPicture.DownLoad;
  {$ENDIF}
end;

{ TIWHTMLPictureCache }

function TIWHTMLPictureCache.AddPicture: TIWHTMLPicture;
begin
  Result := TIWHTMLPicture.Create;
  Add(pointer(Result));
  Result.Instance := Instance;
  Result.BaseDir := BaseDir;
  Result.DesignLive := DesignLive; 
end;

procedure TIWHTMLPictureCache.ClearPictures;
var
  i: Integer;
begin
  for i := 1 to Count do
    Items[i - 1].Free;
  inherited;
end;

function TIWHTMLPictureCache.FindPicture(ID: string): TIWHTMLPicture;
var
  i: Integer;
begin
  Result := nil;
  for i := 1 to Count do
  begin
    if (Items[i - 1].ID = ID) then
    begin
      Result := Items[i - 1];
      Break;
    end;
  end;
end;

function TIWHTMLPictureCache.GetPicture(Index: Integer): TIWHTMLPicture;
begin
  Result := TIWHTMLPicture(inherited Items[Index]);
end;

procedure TIWHTMLPictureCache.SetPicture(Index: Integer; Value: TIWHTMLPicture);
begin
  inherited Items[index] := Pointer(Value);
end;

function TIWHTMLPictureCache.Animate: Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := 1 to Count do
  begin
    if Items[i - 1].Step then
      Result := True;
  end;
end;

constructor TIWHTMLPictureCache.Create;
begin
  inherited;
  FInstance := HInstance;
end;

{ TIWPictureItem }

procedure TIWPictureItem.Assign(Source: TPersistent);
begin
  Name := (Source as TIWPictureItem).Name;
  Tag := (Source as TIWPictureItem).Tag;
  Picture.Assign((Source as TIWPictureItem).Picture)
end;

constructor TIWPictureItem.Create(Collection: TCollection);
begin
  inherited;
  FPicture := TIWHTMLPicture.Create;
  FPicture.BaseDir := BaseDir;
  FPicture.DesignLive := DesignLive;
end;

destructor TIWPictureItem.Destroy;
begin
  FPicture.Free;
  inherited;
end;

procedure TIWPictureItem.SetBaseDir(const Value: string);
begin
  FBaseDir := Value;
  Picture.BaseDir := Value;
end;

procedure TIWPictureItem.SetDesignLive(const Value: Boolean);
begin
  FDesignLive := Value;
  Picture.DesignLive := Value;
end;

procedure TIWPictureItem.SetPicture(const Value: TIWHTMLPicture);
begin
  FPicture.Assign(Value);
end;

{ TIWPictureCollection }

function TIWPictureCollection.Add: TIWPictureItem;
begin
  Result := TIWPictureItem(inherited Add);
end;

function TIWPictureCollection.Animate: Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := 1 to Count do
  begin
    if Items[i - 1].Picture.Step then
      Result := True;
  end;

end;

constructor TIWPictureCollection.Create(AOwner: TComponent);
begin
  inherited Create(TIWPictureItem);
  FOwner := AOwner;
end;

function TIWPictureCollection.GetItem(Index: Integer): TIWPictureItem;
begin
  Result := TIWPictureItem(inherited Items[Index]);
end;

function TIWPictureCollection.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

function TIWPictureCollection.Insert(index: Integer): TIWPictureItem;
begin
{$IFDEF DELPHI4_LVL}
  Result := TIWPictureItem(inherited Insert(Index));
{$ELSE}
  Result := TIWPictureItem(inherited Add);
{$ENDIF}  
end;

procedure TIWPictureCollection.SetItem(Index: Integer;
  Value: TIWPictureItem);
begin
  inherited SetItem(Index, Value);
end;

{ TIWPictureContainer }

constructor TIWPictureContainer.Create(AOwner: TComponent);
begin
  inherited;
  FItems := TIWPictureCollection.Create(Self);
end;

destructor TIWPictureContainer.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TIWPictureContainer.FindPicture(s: string): TIWHTMLPicture;
var
  i: Integer;
begin
  Result := nil;
  
  i := 1;
  while i <= Items.Count do
  begin
    if Uppercase(Items.Items[i - 1].Name) = s then
    begin
      Result := Items.Items[i - 1].Picture;
      Break;
    end;
    Inc(i);
  end;

end;

procedure TIWPictureContainer.SetItems(const Value: TIWPictureCollection);
begin
  FItems := Value;
end;

end.
