htmlgif1.pas

查看html文件的控件

  with PGifDataBlock(List[0])^ do
    if rSize = 3 then
      FLoopCount := rData[2] + rData[3]*256;
end;

{ ---------------------------------------------------------------------------- }

function TGif.GetImageLeft(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageLeft := id^.rLeft;
end;

function TGif.GetImageTop(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageTop := id^.rTop;
end;

function TGif.GetImageWidth(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageWidth := id^.rWidth;
end;

function TGif.GetImageHeight(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageHeight := id^.rHeight;
end;

function TGif.GetImageDepth(image: integer): integer;
var
    id:     PGifImageDescriptor;
    ct:     PGifColorTable;
begin
id := GetImageDescriptor(image);
ct := fColorTableList.Items[id^.rLocalColorTable];
GetImageDepth := ct^.rSize;
end;


{ ---------------------------------------------------------------------------- }
{ GENERAL INTERNAL ROUTINES -------------------------------------------------- }

{ ---------------------------------------------------------------------------- }

procedure TGif.FreeDataBlockList(var list: TList);
var
    i:    integer;
    db:     PGifDataBlock;
begin
if (list <> nil) then
    begin
    for i := 0 to (list.Count - 1) do
        begin
        db := list.Items[i];
        if (db <> nil) then dispose(db);
        end;

    list.Free;
    end;

list := nil;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.FreeExtensionList(var list: TList);
var
    i:    integer;
    ex:     PGifExtension;
begin
if (list <> nil) then
    begin
    for i := 0 to (list.Count - 1) do
        begin
        ex := list.Items[i];
        if (ex <> nil) then
            begin
            if      (ex^.rLabel = kGifLabelComment)     then FreeDataBlockList(ex^.rComment.rDataBlockList)
            else if (ex^.rLabel = kGifLabelText)        then FreeDataBlockList(ex^.rText.rDataBlockList)
            else if (ex^.rLabel = kGifLabelApplication) then FreeDataBlockList(ex^.rApp.rDataBlockList);

            dispose(ex);
            end;
        end;

    list.Free;
    end;

list := nil;
end;


{ ---------------------------------------------------------------------------- }
{ after an image has been LZW decoded, write a bitmap from the string of pixels }

{----------------TGif.MakeBitmaps}
procedure TGif.MakeBitmaps;
type
  LayoutType = Packed Record
    BFH: TBitmapFileHeader;
    BIH: TBitmapInfoHeader;
    end;
  PLayoutType = ^LayoutType;
var
  id:     PGifImageDescriptor;
  ct:     PGifColorTable;
  FullWidth, PixelSize, FileSize: integer;
  Stream: TMemoryStream;
  PL: PLayoutType;
  Color: TColor;
  Index: integer;
  Pix, P: PChar;
  I, X, Y, N: integer;
  TrIndex: integer;
begin
for i := 0 to (fImageDescriptorList.Count - 1) do
    begin
    id := fImageDescriptorList.Items[i];
    if ((id <> nil) and (id^.rBitmap = nil)) then      // don't do it again
      with id^ do
        begin
        FullWidth := rWidth * 3;
        if FullWidth and $3 <> 0 then
          FullWidth := (FullWidth and $FFFFFFFC) + $4;
        PixelSize := FullWidth * rHeight;
        FileSize := Sizeof(LayoutType)+PixelSize;
        Stream := TMemoryStream.Create;
        try
          Stream.Size := FileSize;
          PL := Stream.Memory;
          FillChar(PL^, FileSize, 0);

          with PL^.BFH do
            begin
            bfType := 19778;
            bfSize := FileSize;
            bfReserved1 := 0;
            bfReserved2 := 0;
            bfOffBits := Sizeof(LayoutType);
            end;
          with PL^.BIH do
            begin
            biSize := Sizeof(TBitmapInfoHeader);
            biWidth := rWidth;
            biHeight := rHeight;
            biPlanes := 1;
            biBitCount := 24;
            biCompression := 0;
            biSizeImage := 0;
            biXPelsPerMeter := 0;
            biYPelsPerMeter := 0;
            biClrUsed := 0;
            biClrImportant := 0;
            end;

          ct := fColorTableList.Items[rLocalColorTable];
          TrIndex := GetTransparentIndex(i);
          if (TrIndex >= 0) and (TrIndex < ct^.rSize) then
            {change transparent color to something that won't likely match any other color}
            ct^.rColors[TrIndex] := TransColor;

          N := 0;
          Pix := PChar(PL) + Sizeof(LayoutType);
          for Y := rHeight-1 downto 0 do
            begin
            P := Pix + (Y * FullWidth);
            for X := 0 to rWidth-1 do
              begin
              Index := Integer((rPixelList + N)^);
              Color := ct^.rColors[Index];
              P^ := Char((Color shr 16) and $FF);
              Inc(P);
              P^ := Char((Color shr 8) and $FF);
              Inc(P);
              P^ := Char(Color and $FF);
              Inc(P);
              Inc(N);
              end;
            end;
          rBitmap := TBitmap.Create;
          {$ifndef UseCLX}
          rBitmap.HandleType  := bmDIB;
          {$endif}
          rBitmap.LoadFromStream(Stream);
        finally
          Stream.Free;               
          end;

// is bitmap transparent?

        if ((0 <= TrIndex) and (TrIndex < ct^.rSize)) then
            begin
            rBitmap.Transparent      := true;
            rBitmap.TransparentMode  := tmFixed;
            rBitmap.TransparentColor := ct^.rColors[TrIndex];
            end;
        end;
    end;
end;

{----------------TGif.GetStripBitmap}
function TGif.GetStripBitmap(var Mask: TBitmap): TBitmap;   {LDB}
{This is a single bitmap containing all the frames.  A mask is also provided
 if the GIF is transparent.  Each Frame is set up so that it can be transparently
 blted to a background.}
type
  LayoutType = Packed Record
    BFH: TBitmapFileHeader;
    BIH: TBitmapInfoHeader;
    end;
  PLayoutType = ^LayoutType;
var
  id:     PGifImageDescriptor;
  ct:     PGifColorTable;
  FullWidth, PixelSize, FileSize: integer;
  Stream, MStream: TMemoryStream;
  PL, MPL: PLayoutType;
  Color: TColor;
  Index: integer;
  Pix, P, MPix, MP, PRight: PChar;
  I, X, Y, N: integer;
  TrIndex: integer;
  C: char;
  IsTransparent: boolean;
begin
MStream := Nil;
Result := Nil;
Mask := Nil;
MP := Nil;
MPix := Nil;
{find size needed for strip bitmap}
FullWidth := Width * 3 * ImageCount;  {3 bytes per pixel}
if FullWidth and $3 <> 0 then         {make sure it is DWord boundary}
  FullWidth := (FullWidth and $FFFFFFFC) + $4;
PixelSize := FullWidth * Height;
FileSize := Sizeof(LayoutType)+PixelSize;
if (FileSize > 200000000) or Transparent and (FileSize > 100000000) then
  GIF_Error(25);
Stream := TMemoryStream.Create;
try
  Stream.Size := FileSize;
  PL := Stream.Memory;
  FillChar(PL^, FileSize, 0);

  with PL^.BFH do
    begin          {set up the bitmap file header}
    bfType := 19778;
    bfSize := FileSize;
    bfReserved1 := 0;
    bfReserved2 := 0;
    bfOffBits := Sizeof(LayoutType);
    end;
  with PL^.BIH do
    begin           {and the bitmap info header}
    biSize := Sizeof(TBitmapInfoHeader);
    biWidth := Width * ImageCount;
    biHeight := Height;
    biPlanes := 1;
    biBitCount := 24;   {will use 24 bit pixel}
    biCompression := 0;
    biSizeImage := 0;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 0;
    biClrImportant := 0;
    end;

  Pix := PChar(PL) + Sizeof(LayoutType);  {where pixels start}

  IsTransparent := Transparent;
  if IsTransparent then
    begin           {set up a mask similarly}
    MStream := TMemoryStream.Create;
    MStream.Size := FileSize;
    MPL := MStream.Memory;
    Move(PL^, MPL^, FileSize);   {for now, this is a direct copy}
    MPix := PChar(MPL) + Sizeof(LayoutType);   {where mask pixels start}
    FillChar(MPix^, PixelSize, $FF);   {Need to make first frame totally transparent}
    end;

  for i := 0 to (fImageDescriptorList.Count - 1) do  {for all the frames}
    begin
    id := fImageDescriptorList.Items[i];
    if (id <> nil) then
      with id^ do
        begin
        ct := fColorTableList.Items[rLocalColorTable];
        TrIndex := GetTransparentIndex(i);

        N := 0;   {pixel index in rPixelList, the frame source pixels}
        for Y := Height-1 downto IntMax(Height-rHeight, ImageTop[I]) do    
          begin
          {find the start of each frame row in destination.  Note that the source
           frame may be smaller than the destination and positioned according to
           imagetop and imageleft}
          P := Pix + ((Y-ImageTop[i]) * FullWidth) + i*Width*3 +ImageLeft[i]*3;
          PRight := P + Width*3;   
          if IsTransparent then  {same for mask}
            MP := MPix + ((Y-ImageTop[i]) * FullWidth) + i*Width*3 +ImageLeft[i]*3;
          for X := 0 to rWidth-1 do
            begin
            if P < PRight then   {prevent write beyond proper right side in case rwidth to wide}
              begin
              Index := Integer((rPixelList + N)^);  {Source pixel index in colortable}
              Color := ct^.rColors[Index];          {its color}
              {for frames after the 0th, only the non transparent pixels are written
               as writing transparent ones might cover results copied from the previous frame}
              if (Index <> trIndex) then
                begin
                P^ := Char((Color shr 16) and $FF);
                Inc(P);
                P^ := Char((Color shr 8) and $FF);
                Inc(P);
                P^ := Char(Color and $FF);
                Inc(P);
                end
              else if i = 0 then
                begin     {transparent pixel, first frame, write black}
                P^ := #0;
                Inc(P);
                P^ := #0;
                Inc(P);
                P^ := #0;
                Inc(P);
                end
              else Inc(P, 3);   {ignore transparent pixel}
              if IsTransparent then   {also do the mask}
                begin
                if Index = trIndex then
                  C := #$FF  {transparent part is white}
                else C := #0;  {non transparent is black}
                {again for frames after the 0th, only non-transparent pixels are written}
                if (i = 0) or (C = #0) then
                  begin
                  MP^ := C;
                  Inc(MP);
                  MP^ := C;
                  Inc(MP);
                  MP^ := C;
                  Inc(MP);
                  end
                else Inc(MP, 3);
                end;
              end;
            Inc(N);    {bump source pixel index}
            end;
          end;
        end;
    {Now copy this frame to the next (unless it the last one).  This serves as a
     background for the next image.  This is all that's needed for the dtDoNothing
     disposal method but will be fixed up for dtBackground below}
    if (i < fImageDescriptorList.Count-1) then
      begin
      for Y := Height-1 downto 0 do
        begin  {copy line by line}
        P := Pix + (Y * FullWidth) + i*Width*3;
        if IsTransparent then
          MP := MPix + (Y * FullWidth) + i*Width*3;
        Move(P^, (P+Width*3)^, Width*3);
        if IsTransparent then
          Move(MP^, (MP+Width*3)^, Width*3);
        end;
      {for dtBackground, fill the mask area occupied by the current copied image with
       white. This makes it transparent so the original background will appear here
       (although the next image will no doubt write on part of this area.}
      if IsTransparent and (ImageDisposal[i] in [2,3]) then   {dtToPrevious run as dtBackground as it seems other browsers do this}
        with id^ do
          for Y := Height-1 downto IntMax(Height-rHeight, ImageTop[I]) do
            begin
            MP := MPix + ((Y-ImageTop[i]) * FullWidth) + (i+1)*Width*3 +ImageLeft[i]*3;
            FillChar(MP^, rWidth*3, $FF);
            end;
      end;
    end;

  Result := TBitmap.Create;
  {$ifndef UseCLX}
  Result.HandleType  := bmDIB;
  {$endif}
  Result.LoadFromStream(Stream); {turn the stream just formed into a TBitmap}
  if IsTransparent then
    begin
    Mask := TBitmap.Create;
    Mask.HandleType := bmDIB;
    Mask.LoadFromStream(MStream);
    Mask.Monochrome := True;      {crunch mask into a monochrome TBitmap}
    end;
  Stream.Free;
  MS