gif_myrxgif.~pas

可以用来显示 Gif 的VCL控件 完整源码版本

end;

procedure FillColorTable(var ColorTable: TGIFColorTable;
  const Colors: TRGBPalette; Count: Integer);
var
  I: Byte;
begin
  FillChar(ColorTable, SizeOf(ColorTable), 0);
  ColorTable.Count := Min(256, Count);
  for I := 0 to ColorTable.Count - 1 do begin
    ColorTable.Colors[I].Red := Colors[I].rgbRed;
    ColorTable.Colors[I].Green := Colors[I].rgbGreen;
    ColorTable.Colors[I].Blue := Colors[I].rgbBlue;
  end;
end;

procedure WriteGIFData(Stream: TStream; var Header: TBitmapInfoHeader;
  Interlaced: Boolean; Data: Pointer; ProgressProc: TProgressProc);
  { LZW encode data }
var
  LineIdent: Longint;
  MinCodeSize, Col, Temp: Byte;
  InitCodeSize, X, Y: Longint;
  Pass: Integer;
  MaxCode: Longint; { 1 shl CodeSize }
  ClearCode, EndingCode, LastCode, Tail: Longint;
  I, HashValue: Longint;
  LenString: Word;
  Dict: PDictTable;
  HashTable: TList;
  PData: PByte;
  WriteCtxt: TWriteContext;
begin
  LineIdent := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;
  Tail := 0; HashValue := 0;
  Dict := AllocMem(SizeOf(TDictTable));
  try
    HashTable := TList.Create;
    try
      for I := 0 to HASH_TABLE_SIZE - 1 do HashTable.Add(nil);
      { Initialise encoder variables }
      InitCodeSize := Header.biBitCount + 1;
      if InitCodeSize = 2 then Inc(InitCodeSize);
      MinCodeSize := InitCodeSize - 1;
      Stream.WriteBuffer(MinCodeSize, 1);
      ClearCode := 1 shl MinCodeSize;
      EndingCode := ClearCode + 1;
      LastCode := EndingCode;
      MaxCode := 1 shl InitCodeSize;
      LenString := 0;
      { Setup write context }
      WriteCtxt.Inx := 0;
      WriteCtxt.CodeSize := InitCodeSize;
      FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
      WriteCode(Stream, ClearCode, WriteCtxt);
      for I := 0 to HASH_TABLE_SIZE - 1 do HashTable[I] := nil;
      Data := HugeOffset(Data, (Header.biHeight - 1) * LineIdent);
      Y := 0; Pass := 0;
      if Assigned(ProgressProc) then ProgressProc(psStarting, 0, '');
      try
        while (Y < Header.biHeight) do begin
          PData := HugeOffset(Data, -(Y * LineIdent));
          for X := 0 to Header.biWidth - 1 do begin
            case Header.biBitCount of
              8: begin
                   Col := PData^;
                   PData := HugeOffset(PData, 1);
                 end;
              4: begin
                   if X and 1 <> 0 then begin
                     Col := PData^ and $0F;
                     PData := HugeOffset(PData, 1);
                   end
                   else Col := PData^ shr 4;
                 end;
              else { must be 1 }
                begin
                  if X and 7 = 7 then begin
                    Col := PData^ and 1;
                    PData := HugeOffset(PData, 1);
                  end
                  else Col := (PData^ shr (7 - (X and $07))) and $01;
                end;
            end; { case }
            Inc(LenString);
            if LenString = 1 then begin
              Tail := Col;
              HashValue := InitHash(Col);
            end
            else begin
              HashValue := HashValue * (Col + LenString + 4);
              I := HashValue mod HASH_TABLE_SIZE;
              HashValue := HashValue mod HASH_TABLE_SIZE;
              while (HashTable[I] <> nil) and
                ((PImageDict(HashTable[I])^.Tail <> Tail) or
                (PImageDict(HashTable[I])^.Col <> Col)) do
              begin
                Inc(I);
                if (I >= HASH_TABLE_SIZE) then I := 0;
              end;
              if (HashTable[I] <> nil) then { Found in the strings table }
                Tail := PImageDict(HashTable[I])^.Index
              else begin
                { Not found }
                WriteCode(Stream, Tail, WriteCtxt);
                Inc(LastCode);
                HashTable[I] := @Dict^[LastCode];
                PImageDict(HashTable[I])^.Index := LastCode;
                PImageDict(HashTable[I])^.Tail := Tail;
                PImageDict(HashTable[I])^.Col := Col;
                Tail := Col;
                HashValue := InitHash(Col);
                LenString := 1;
                if (LastCode >= MaxCode) then begin
                  { Next Code will be written longer }
                  MaxCode := MaxCode shl 1;
                  Inc(WriteCtxt.CodeSize);
                end
                else if (LastCode >= CODE_TABLE_SIZE - 2) then begin
                  { Reset tables }
                  WriteCode(Stream, Tail, WriteCtxt);
                  WriteCode(Stream, ClearCode, WriteCtxt);
                  LenString := 0;
                  LastCode := EndingCode;
                  WriteCtxt.CodeSize := InitCodeSize;
                  MaxCode := 1 shl InitCodeSize;
                  for I := 0 to HASH_TABLE_SIZE - 1 do HashTable[I] := nil;
                end;
              end;
            end;
          end; { for X loop }
          if Interlaced then Y := InterlaceStep(Y, Header.biHeight, Pass)
          else Inc(Y);
          Temp := Trunc(100.0 * (Y / Header.biHeight));
          if Assigned(ProgressProc) then ProgressProc(psRunning, Temp, '');
        end; { while Y loop }
        WriteCode(Stream, Tail, WriteCtxt);
        WriteCode(Stream, EndingCode, WriteCtxt);
        FlushCode(Stream, WriteCtxt);
      finally
        if Assigned(ProgressProc) then begin
          if ExceptObject = nil then ProgressProc(psEnding, 100, '')
          else ProgressProc(psEnding, 0, Exception(ExceptObject).Message);
        end;
      end;
    finally
      HashTable.Free;
    end;
  finally
    FreeMem(Dict, SizeOf(TDictTable));
  end;
end;

{ TGIF_Item }

destructor TGIF_Item.Destroy;
begin
  FImageData.Free;
  inherited Destroy;
end;

procedure TGIF_Item.FreeHandle;
begin
  if FImageData <> nil then FImageData.SetSize(0);
end;

{ TGIF_Data }

constructor TGIF_Data.Create;
begin
  inherited Create;
  FComment := TStringList.Create;
end;

destructor TGIF_Data.Destroy;
begin
  FComment.Free;
  inherited Destroy;
end;

procedure TGIF_Data.FreeHandle;
begin
  if FComment <> nil then FComment.Clear;
end;

{ TGIF_Frame }

constructor TGIF_Frame.Create(AOwner: TGIFImage);
begin
  FOwner := AOwner;
  inherited Create;
  NewImage;
end;

destructor TGIF_Frame.Destroy;
begin
  FBitmap.Free;
  FreeExtensions(FExtensions);
  FImage.Release;
  inherited Destroy;
end;

procedure TGIF_Frame.SetAnimateInterval(Value: Word);
begin
  if FAnimateInterval <> Value then begin
    FAnimateInterval := Value;
    if Value > 0 then FOwner.FVersion := gv89a;
    FOwner.Changed(FOwner);
  end;
end;

procedure TGIF_Frame.SetDisposalMethod(Value: TDisposalMethod);
begin
  if FDisposal <> Value then begin
    FDisposal := Value;
    if Value <> dmUndefined then FOwner.FVersion := gv89a;
    FOwner.Changed(FOwner);
  end;
end;

procedure TGIF_Frame.SetTopLeft(const Value: TPoint);
begin
  if (FTopLeft.X <> Value.X) or (FTopLeft.Y <> Value.Y) then begin
    FTopLeft.X := Value.X;
    FTopLeft.Y := Value.Y;
    FOwner.FScreenWidth := Max(FOwner.FScreenWidth,
      FImage.FSize.X + FTopLeft.X);
    FOwner.FScreenHeight := Max(FOwner.FScreenHeight,
      FImage.FSize.Y + FTopLeft.Y);
    FOwner.Changed(FOwner);
  end;
end;

procedure TGIF_Frame.SetTransparentColor(Value: TColor);
begin
  if FTransparentColor <> Value then begin
    FTransparentColor := Value;
    if Value <> clNone then FOwner.FVersion := gv89a;
    FOwner.Changed(FOwner);
  end;
end;

function TGIF_Frame.GetBitmap: TBitmap;
var
  Mem: TMemoryStream;
begin
  Result := FBitmap;
  if (Result = nil) or Result.Empty then begin
    NewBitmap;
    Result := FBitmap;
    if Assigned(FImage.FImageData) then
    try
      Mem := TMemoryStream.Create;
      try
        SaveToBitmapStream(Mem);
        FBitmap.LoadFromStream(Mem);
      finally
        Mem.Free;
      end;
    except
      raise;
    end;
  end;
end;

function TGIF_Frame.GetHeight: Integer;
begin
  if Assigned(FBitmap) or Assigned(FImage.FImageData) then
    Result := Bitmap.Height
  else Result := 0;
end;

function TGIF_Frame.GetWidth: Integer;
begin
  if Assigned(FBitmap) or Assigned(FImage.FImageData) then
    Result := Bitmap.Width
  else Result := 0;
end;

function TGIF_Frame.GetColorCount: Integer;
begin
  Result := FImage.FColormap.Count;
  if (Result = 0) and Assigned(FBitmap) and (FBitmap.Palette <> 0) then
    Result := PaletteEntries(FBitmap.Palette);
end;

procedure TGIF_Frame.GrayscaleImage(ForceEncoding: Boolean);
var
  Mem: TMemoryStream;
  TransIndex: Integer;
begin
  if not FGrayscale and (Assigned(FBitmap) or
    Assigned(FImage.FImageData)) then
  begin
    if Assigned(FImage.FImageData) and (FImage.FColorMap.Count > 0) then begin
      FBitmap.Free;
      FBitmap := nil;
      TransIndex := FindColorIndex(FImage.FColorMap, FTransparentColor);
      GrayColorTable(FImage.FColorMap);
      if TransIndex >= 0 then
        FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex])
      else FTransparentColor := clNone;
      FGrayscale := True;
      try
        GetBitmap;
      except
        on EAbort do;
        else raise;
      end;
    end
    else begin
      Mem := BitmapToMemoryStream(Bitmap, pf8bit, mmGrayscale);
      try
        FImage.Release;
        FImage := TGIF_Item.Create;
        FImage.Reference;
        if ForceEncoding then EncodeBitmapStream(Mem);
        FGrayscale := True;
        if FTransparentColor <> clNone then
          FTransparentColor := GrayColor(FTransparentColor);
        FBitmap.LoadFromStream(Mem);
      finally
        Mem.Free;
      end;
    end;
  end;
end;

procedure TGIF_Frame.Assign(Source: TPersistent);
var
  AComment: TStrings;
begin
  if Source = nil then begin
    NewImage;
    FBitmap.Free;
    FBitmap := nil;
  end
  else if (Source is TGIF_Frame) then begin
    if Source <> Self then begin
      FImage.Release;
      FImage := TGIF_Frame(Source).FImage;
      if TGIF_Frame(Source).FOwner <> FOwner then FLocalColors := True
      else FLocalColors := TGIF_Frame(Source).FLocalColors;
      FImage.Reference;
      FTopLeft := TGIF_Frame(Source).FTopLeft;
      FInterlaced := TGIF_Frame(Source).FInterlaced;
      if TGIF_Frame(Source).FBitmap <> nil then begin
        NewBitmap;
        FBitmap.Assign(TGIF_Frame(Source).FBitmap);
      end;
      FTransparentColor := TGIF_Frame(Source).FTransparentColor;
      FAnimateInterval := TGIF_Frame(Source).FAnimateInterval;
      FDisposal := TGIF_Frame(Source).FDisposal;
      FGrayscale := TGIF_Frame(Source).FGrayscale;
      FCorrupted := TGIF_Frame(Source).FCorrupted;
      AComment := TGIF_Frame(Source).FindComment(False);
      if (AComment <> nil) and (AComment.Count > 0) then
        SetComment(AComment);
    end;
  end
  else if Source is TGIFImage then begin
    if (TGIFImage(Source).Count > 0) then begin
      if (TGIFImage(Source).FrameIndex >= 0) then
        Assign(TGIFImage(Source).Frames[TGIFImage(Source).FrameIndex])
      else
        Assign(TGIFImage(Source).Frames[0]);
    end
    else Assign(nil);
  end
  else if Source is TGraphic then begin
    { TBitmap, TJPEGImage... }
    if TGraphic(Source).Empty then begin
      Assign(nil);
      Exit;
    end;
    NewImage;
    NewBitmap;
    try
      FBitmap.Assign(Source);
      if Source is TBitmap then
        FBitmap.Monochrome := TBitmap(Source).Monochrome;
    except
      FBitmap.Canvas.Brush.Color := clFuchsia;
      FBitmap.Width := TGraphic(Source).Width;
      FBitmap.Height := TGraphic(Source).Height;
      FBitmap.Canvas.Draw(0, 0, TGraphic(Source));
    end;
    if (Source is TIcon) or (Source is TMetafile) then
      FTransparentColor := GetNearestColor(FBitmap.Canvas.Handle,
        ColorToRGB(FBitmap.Canvas.Brush.Color));
  end
  else inherited Assign(Source);
  if FOwner <> nil then FOwner.UpdateScreenSize;
end;

procedure TGIF_Frame.AssignTo(Dest: TPersistent);
begin
  if (Dest is TGIF_Frame) or (Dest is TGIFImage) then Dest.Assign(Self)
  else if Dest is TGraphic then begin
    Dest.Assign(Bitmap);
  end
  else inherited AssignTo(Dest);
end;

procedure TGIF_Frame.NewBitmap;
begin
  FBitmap.Free;
  FBitmap := TBitmap.Create;
end;

procedure TGIF_Frame.NewImage;
begin
  if FImage <> nil then FImage.Release;
  FImage := TGIF_Item.Create;
  FImage.Reference;
  FGrayscale := False;
  FCorrupted := False;
  FTransparentColor := clNone;
  FTopLeft := Point(0, 0);
  FInterlaced := False;
  FLocalColors := False;
  FAnimateInterval := 0;
  FDisposal := dmUndefined;
end;

function TGIF_Frame.FindComment(ForceCreate: Boolean): TStrings;
var
  Ext: TExtension;
begin
  Ext := FindExtension(FExtensions, etComment);
  if (Ext = nil) and ForceCreate then begin
    Ext := TExtension.Create;