htmlgif1.pas

查看html文件的控件

    while (rCurSize > rBits) do
        begin
        if (fDataStream.Position >= fDataStream.Size) then
          b := 0
        else
          fDataStream.Read(b, 1);
        n := b;
        n := (n shl rBits);                 // scoot bits over to avoid previous data
        rBitString := (rBitString or n);    // put bits in the BitString
        rBits := rBits + 8;                 // number of bits in a byte
        end;


// get the code, then dump the bits we used from the BitString

    case rCurSize of
         0:     mask := 0;
         1:     mask := $0001;
         2:     mask := $0003;
         3:     mask := $0007;
         4:     mask := $000f;
         5:     mask := $001f;
         6:     mask := $003f;
         7:     mask := $007f;
         8:     mask := $00ff;
         9:     mask := $01ff;
        10:     mask := $03ff;
        11:     mask := $07ff;
        12:     mask := $0fff;
        else
          begin
          GIF_Error(12);
          Mask := 0;    //stop warning
          end;
        end;

    cc := (rBitString and mask);                // mask off bits wanted
    rBitString := (rBitString shr rCurSize);    // delete bits we just took
    rBits  := rBits - rCurSize;                 // number of bits left in BitString
    end;    // with

// done

LZWGetCode := cc;
end;

{ ---------------------------------------------------------------------------- }
{ save a code value on the code stack }

procedure TGif.LZWSaveCode(Code: integer);
begin
with fZipData^ do
    begin
    rCodeStack[rSP] := Code;
    rSP := rSP + 1;
    end;
end;


{ ---------------------------------------------------------------------------- }
{ decode the CurrentCode into the clear-text pixel value }
{ mainly, just save the CurrentCode on the output stack, along with }
{ whatever prefixes go with it }

procedure TGif.LZWDecodeCode(var Code: integer);
begin
with fZipData^ do
    begin
    while (Code > rHighCode) do
        begin
        LZWSaveCode(rSuffix[Code]);
        Code := rPrefix[Code];
        end;
    LZWSaveCode(Code);
    end;
end;   


{ ---------------------------------------------------------------------------- }
{ save a new prefix/suffix pair }

procedure TGif.LZWSaveSlot(Prefix, Suffix: integer);
begin
with fZipData^ do
    begin
    rPrefix[rCurSlot] := Prefix;
    rSuffix[rCurSlot] := Suffix;
    rCurSlot := rCurSlot + 1;
    end;
end;



{ ---------------------------------------------------------------------------- }
{ given current line number, compute the next line to be filled }
{ this gets a little tricky if an interlaced image }
{ what is the purpose of this interlace, anyway?  it doesn't save space, }
{ and I can't imagine it makes for any faster image disply or loading }

procedure TGif.LZWIncrPosition;
var
    n:    integer;
begin
with fZipData^ do
    begin

// if first pass, make sure CurPass was initialized

    if (rCurPass = 0) then rCurPass := 1;

// incr X position

    rCurX := rCurX + 1;

// bumping Y ?

    if (rCurX >= rID^.rWidth) then
        begin
        rCurX := 0;

// if not interlaced image, then just move down the page

        if (not  rID^.rInterlaced) then
            begin
            rCurY := rCurY + 1;
            end

// interlaced images select the next line by some archane black-magical sheme

        else
            begin
            case rCurPass of                // delta to next row on this pass
                1:      n := 8;
                2:      n := 8;
                3:      n := 4;
                4:      n := 2;
                else
                  begin
                  GIF_Error(21);
                  n := 0;  //prevent warning
                  end;
                end;

            rCurY := rCurY + n;

// if past the end of the bitmap, start next pass

            if (rCurY >= rID^.rHeight) then
                begin
                rCurPass := rCurPass + 1;
                if (rCurPass = 5) then rCurPass := 1;
                case rCurPass of            // first line for given pass
                    1:      n := 0;
                    2:      n := 4;
                    3:      n := 2;
                    4:      n := 1;
                    else    GIF_Error(21);
                    end;

                rCurY := n;
                end;
            end;
        end;
    end;    // with
end;

{ ---------------------------------------------------------------------------- }
{ see if it is time to add a new slot to the decoder tables }

procedure TGif.LZWCheckSlot;
begin
with fZipData^ do
    begin
    if (rCurSlot >= rTopSlot) then
        begin
        if (rCurSize < 12) then
            begin
            rTopSlot := (rTopSlot shl 1);
            rCurSize := rCurSize + 1;
            end
        else
            begin
            rMaxVal := true;
            end;
        end;
    end;
end;

{ ---------------------------------------------------------------------------- }
{ empty the Codes stack and write to the Bitmap }

procedure TGif.LZWWriteBitmap;
var
    i,n:    integer;
    j:      longint;
    p:      PChar;
begin
with fZipData^ do
    begin
    for n := (rSP - 1) downto 0 do
        begin
        rCount := rCount + 1;

// get next code from the stack, and index into PixelList

        i := rCodeStack[n];
        j := (rCurY * rID^.rWidth) + rCurX;
        if ((0 <= j) and (j < rID^.rPixelCount)) then
            begin

// store the pixel index into PixelList

            p := rID^.rPixelList + j;
            p^ := chr(i);
            end;

        LZWIncrPosition;
        end;

    rSP := 0;
    end;    // with
end;

{ ---------------------------------------------------------------------------- }
{ get the next pixel from the bitmap, and return it as an index into }
{ the colormap }

function TGif.LZWReadBitmap: integer;
var
    n:    integer;
    j:      longint;
    p:      PChar;
begin
with fZipData^ do
    begin
    if (rUnget) then
        begin
        n := rLast;
        rUnget := false;
        end
    else
        begin
        rCount := rCount + 1;
        j := (rCurY * rID^.rWidth) + rCurX;
        if ((0 <= j) and (j < rID^.rPixelCount)) then
            begin
            p := rID^.rPixelList + j;
            n := ord(p^);
            end
        else
            begin
            n := 0;
            end;

        LZWIncrPosition;
        end;

    rLast := n;
    end;    // with

LZWReadBitmap := n;
end;

{ ---------------------------------------------------------------------------- }
{ PROCEDURES TO IMPLEMENT PROPERTIES ----------------------------------------- }

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

function TGif.GetSignature: string;
var
    s:      string;
begin
s := fSignature^.rSignature;
GetSignature := s;
end;


{ ---------------------------------------------------------------------------- }
{ return screen descriptor data pointer, or set a new record block }

function TGif.GetScreenDescriptor: PGifScreenDescriptor;
begin
GetScreenDescriptor := fScreenDescriptor;
end;


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

function TGif.GetImageCount: integer;
begin
GetImageCount := fImageDescriptorList.Count;
end;


function TGif.GetImageDescriptor(image: integer): PGifImageDescriptor;
begin
if ((image < 0) or (image >= fImageDescriptorList.Count)) then GIF_Error(15);
GetImageDescriptor := fImageDescriptorList.Items[image];
end;


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

function TGif.GetBitmap(image: integer): TBitmap;
var
    p:      PGifImageDescriptor;
    b:      TBitmap;
begin
p := GetImageDescriptor(image);
if (p^.rBitmap = nil) then MakeBitmaps;
b := p^.rBitmap;

GetBitmap := b;
end;

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

function TGif.GetColorTableCount: integer;
begin
GetColorTableCount := fColorTableList.Count;
end;


function TGif.GetColorTable(table: integer): PGifColorTable;
begin
if ((table < 0) or (table >= fColorTableList.Count)) then GIF_Error(15);
GetColorTable := fColorTableList.Items[table];
end;

function TGif.GetImageDelay(Image: integer): integer;
var
    gx:     PGifExtensionGraphic;
begin
gx := FindGraphicExtension(Image);
if (gx <> nil) then
  begin
  Result := gx^.rDelayTime;
  if Result < 1 then
    Result := 1;
  end
else Result := 1;
end;

function TGif.GetImageDisposal(Image: integer): integer;
var
    gx:     PGifExtensionGraphic;
begin
gx := FindGraphicExtension(Image);
if (gx <> nil) then
  Result := gx^.rDisposal and 3
else Result := 0;
end;

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

function TGif.GetColorIndex(image, x, y: integer): integer;
var
    i,n:    integer;
    id:     PGifImageDescriptor;
    p:      PChar;
begin
if ((image < 0) or (image >= fImageDescriptorList.Count)) then GIF_Error(15);
id := fImageDescriptorList.Items[image];
if ((x < 0) or (x >= id^.rWidth))  then GIF_Error(15);
if ((y < 0) or (y >= id^.rHeight)) then GIF_Error(15);

n := (y * id^.rWidth) + x;
p := id^.rPixelList + n;
i := ord(p^);

GetColorIndex := i;
end;

{ ---------------------------------------------------------------------------- }
{ transparent color for each individual image.
  returns -1 if none. }

function TGif.GetTransparentIndex(image: integer): integer;
var
    i:    integer;
    gx:     PGifExtensionGraphic;
begin
i := -1;
gx := FindGraphicExtension(image);
if (gx <> nil) and (gx^.rTransparentValid) then   {LDB}
  i := gx^.rTransparentIndex;

GetTransparentIndex := i;
end;

{ ---------------------------------------------------------------------------- }
{ transparent color for all images }
{LDB Changed to always return the standard used for the transparent color}

function TGif.GetTransparentColor: TColor;
begin
GetTransparentColor := TransColor;
end; 

procedure TGif.ExtractLoopCount(List: TList);
begin
if List.Count > 0 then