wiimpl.pas

TMS Component Pack Pro v4.2

  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 THTMLPicture.DownLoadCancel(var cancel: boolean);
begin
  if assigned(FOnDownLoadCancel) then
    FOnDownLoadCancel(self,cancel);
end;

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

procedure THTMLPicture.DownLoadError(err: string);
begin
  if Assigned(fOnDownloadError) then
    FOnDownLoadError(self,err);
end;

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


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

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

function THTMLPicture.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 THTMLPicture.IsGIFFile: Boolean;
var
  buf: array[0..4] of char;
begin
  Result := False;
  if FDataStream.Size>4 then
  begin
    FDataStream.Position := 0;
    {$IFNDEF TMSDOTNET}
    FDataStream.Read(buf,4);
    buf[4] := #0;
    Result := Strpas(buf) = 'GIF8';
    {$ENDIF}
    FDataStream.Position := 0;

  end;
end;

function THTMLPicture.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 THTMLPicture.GetMaxHeight: Integer;
var
  hmHeight: Integer;
begin
  {$IFNDEF TMSDOTNET}
  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;
  {$ENDIF}
end;

function THTMLPicture.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 THTMLPicture.SetFrame(const Value: Integer);
begin
  FFrame := Value;
  if FDataStream.Size > 0 then
  begin
    LoadPicture;
    if Assigned(OnFrameChange) then
      OnFrameChange(self);
  end;
end;

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

function THTMLPicture.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 THTMLPicture.FramePrev;
begin
  if FFrame > 1 then
    Dec(FFrame)
  else
    FFrame := FFrameCount;
end;


{ THTMLImage }

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

destructor THTMLImage.Destroy;
begin
  fHTMLPicture.Free;
  inherited;
end;

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

procedure THTMLImage.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 THTMLImage.PictureChanged(sender: TObject);
begin
 Invalidate;
end;

procedure THTMLImage.SetHTMLPicture(const Value: THTMLPicture);
begin
  fHTMLPicture.Assign(Value);
  Invalidate;
end;

procedure THTMLImage.SetPicturePosition(const Value: TPicturePosition);
begin
 if ( fPicturePosition <> Value) then
  begin
   fPicturePosition := Value;
   Invalidate;
  end;
end;

procedure THTMLImage.DownLoadCancel(Sender: TObject; var cancel: boolean);
begin
 if assigned(fOnDownLoadCancel) then fOnDownLoadCancel(self,cancel);
end;

procedure THTMLImage.DownLoadComplete(Sender: TObject);
begin
 if assigned(fOnDownLoadComplete) then fOnDownLoadComplete(self);
end;

procedure THTMLImage.DownLoadError(Sender: TObject; err: string);
begin
 if assigned(fOnDownloadError) then fOnDownLoadError(self,err);
end;

procedure THTMLImage.DownLoadProgress(Sender: TObject; dwSize,
  dwTotSize: dword);
begin
 if assigned(fOnDownLoadProgress) then fOnDownLoadProgress(self,dwSize,dwTotSize);
end;

{ TDownLoadThread }

constructor TDownLoadThread.Create(aHTMLPicture: THTMLPicture);
begin
  inherited Create(false);
  HTMLPicture:=aHTMLPicture;
  FreeOnTerminate := True;
end;

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

{ THTMLPictureCache }

function THTMLPictureCache.AddPicture: THTMLPicture;
begin
  Result := THTMLPicture.Create;
  {$IFNDEF TMSDOTNET}
  Add(pointer(result));
  {$ENDIF}
  {$IFDEF TMSDOTNET}
  Add(TObject(Result));
  {$ENDIF}
end;

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

function THTMLPictureCache.FindPicture(ID: string): THTMLPicture;
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 THTMLPictureCache.GetPicture(Index: Integer): THTMLPicture;
begin
  Result := THTMLPicture(inherited Items[Index]);
end;

procedure THTMLPictureCache.SetPicture(Index: Integer; Value: THTMLPicture);
begin
  {$IFNDEF TMSDOTNET}
  inherited Items[index] := Pointer(Value);
  {$ENDIF}
  {$IFDEF TMSDOTNET}
  inherited Items[index] := Value;
  {$ENDIF}
end;

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