gif_anifile.pas

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

        end;
      end;
    except
      NewImage;
      raise;
    end;
  end
  else inherited Assign(Source);
end;

procedure TAnimatedCursorImage.AssignTo(Dest: TPersistent);
var
  I: Integer;
begin
  if Dest is TIcon then begin
    if IconCount > 0 then Dest.Assign(Icons[0])
    else Dest.Assign(nil);
  end
  else if Dest is TBitmap then begin
    if IconCount > 0 then
      AssignToBitmap(TBitmap(Dest), TBitmap(Dest).Canvas.Brush.Color,
        True, False)
    else Dest.Assign(nil);
  end
  else if Dest is TIconList then begin
    TIconList(Dest).BeginUpdate;
    try
      TIconList(Dest).Clear;
      for I := 0 to IconCount - 1 do TIconList(Dest).Add(Icons[I]);
    finally
      TIconList(Dest).EndUpdate;
    end;
  end
  else inherited AssignTo(Dest);
end;

function TAnimatedCursorImage.ReadCreateIcon(Stream: TStream; ASize: Longint;
  var HotSpot: TPoint; var IsIcon: Boolean): TIcon;
type
  PIconRecArray = ^TIconRecArray;
  TIconRecArray = array[0..300] of TIconRec;
var
  List: PIconRecArray;
  Mem: TMemoryStream;
  HeaderLen, I: Integer;
  BI: PBitmapInfoHeader;
begin
  Result := nil;
  Mem := TMemoryStream.Create;
  try
    Mem.SetSize(ASize);
    Mem.CopyFrom(Stream, Mem.Size);
    HotSpot := Point(0, 0);
    IsIcon := PCursorOrIcon(Mem.Memory)^.wType = RC3_ICON;
    if PCursorOrIcon(Mem.Memory)^.wType = RC3_CURSOR then
      PCursorOrIcon(Mem.Memory)^.wType := RC3_ICON;
    if PCursorOrIcon(Mem.Memory)^.wType = RC3_ICON then begin
      { determinate original icon color }
      HeaderLen := PCursorOrIcon(Mem.Memory)^.Count * SizeOf(TIconRec);
      GetMem(List, HeaderLen);
      try
        Mem.Position := SizeOf(TCursorOrIcon);
        Mem.Read(List^, HeaderLen);
        for I := 0 to PCursorOrIcon(Mem.Memory)^.Count - 1 do
          with List^[I] do begin
            GetMem(BI, DIBSize);
            try
              Mem.Seek(DIBOffset, soFromBeginning);
              Mem.Read(BI^, DIBSize);
              FOriginalColors := Max(GetDInColors(BI^.biBitCount), FOriginalColors);
              HotSpot := Point(xHotspot, yHotspot);
            finally
              FreeMem(BI, DIBSize)
            end;
          end;
      finally
        FreeMem(List, HeaderLen);
      end;
      { return to start of stream }
      Mem.Position := 0;
      Result := TIcon.Create;
      try
        Result.LoadFromStream(Mem);
        if IsIcon then
          HotSpot := Point(Result.Width div 2, Result.Height div 2);
      except
        Result.Free;
        Result := nil;
      end;
    end;
  finally
    Mem.Free;
  end;
end;

{ Loads an animatied cursor from a RIFF file. The RIFF file format for
  animated cursors looks like this:

  RIFF('ACON'
    LIST('INFO'
          INAM(<name>)
          IART(<artist>))
      anih(<anihdr>)
      [rate(<rateinfo>)]
      ['seq '( <seq_info>)]
      LIST('fram' icon(<icon_file>)))
}

procedure TAnimatedCursorImage.ReadAniStream(Stream: TStream);
var
  iFrame, iRate, iSeq, I: Integer;
  Tag: TAniTag;
  Frame: TIconFrame;
  cbChunk, cbRead, Temp: Longint;
  Icon: TIcon;
  bFound, IsIcon: Boolean;
  HotSpot: TPoint;
begin
  iFrame := 0; iRate := 0; iSeq := 0;
  { Make sure it's a RIFF ANI file }
  if not ReadTag(Stream, @Tag) or (Tag.ckID <> FOURCC_RIFF) then
    RiffReadError;
  if (Stream.Read(Tag.ckID, SizeOf(Tag.ckID)) < SizeOf(Tag.ckID)) or
    (Tag.ckID <> FOURCC_ACON) then RiffReadError;
  NewImage;
  { look for 'anih', 'rate', 'seq ', and 'icon' chunks }
  while ReadTag(Stream, @Tag) do begin
    if Tag.ckID = FOURCC_anih then begin
      if not ReadChunk(Stream, @Tag, @FHeader) then Break;
      if ((FHeader.fl and AF_ICON) <> AF_ICON) or
        (FHeader.cFrames = 0) then RiffReadError;
      for I := 0 to FHeader.cSteps - 1 do begin
        Frame := TIconFrame.Create(I, FHeader.jifRate);
        FIcons.Add(Frame);
      end;
    end
    else if Tag.ckID = FOURCC_rate then begin
      { If we find a rate chunk, read it into its preallocated space }
      if not ReadChunkN(Stream, @Tag, @Temp, SizeOf(Longint)) then
        Break;
      if iRate < FIcons.Count then
        TIconFrame(FIcons[iRate]).FJiffRate := Temp;
      Inc(iRate);
    end
    else if Tag.ckID = FOURCC_seq then begin
      { If we find a seq chunk, read it into its preallocated space }
      if not ReadChunkN(Stream, @Tag, @Temp, SizeOf(Longint)) then
        Break;
      if iSeq < FIcons.Count then
        TIconFrame(FIcons[iSeq]).FSeq := Temp;
      Inc(iSeq);
    end
    else if Tag.ckID = FOURCC_LIST then begin
      cbChunk := PadUp(Tag.ckSize);
      { See if this list is the 'fram' list of icon chunks }
      cbRead := Stream.Read(Tag.ckID, SizeOf(Tag.ckID));
      if cbRead < SizeOf(Tag.ckID) then Break;
      Dec(cbChunk, cbRead);
      if (Tag.ckID = FOURCC_fram) then begin
        while (cbChunk >= SizeOf(Tag)) do begin
          if not ReadTag(Stream, @Tag) then Break;
          Dec(cbChunk, SizeOf(Tag));
          if (Tag.ckID = FOURCC_icon) then begin
            { Ok, load the icon/cursor bits }
            Icon := ReadCreateIcon(Stream, Tag.ckSize, HotSpot, IsIcon);
            if Icon = nil then Break;
            bFound := False;
            for I := 0 to FIcons.Count - 1 do begin
              if TIconFrame(FIcons[I]).FSeq = iFrame then begin
                TIconFrame(FIcons[I]).FIcon := Icon;
                TIconFrame(FIcons[I]).FTag := Tag;
                TIconFrame(FIcons[I]).FHotSpot := HotSpot;
                TIconFrame(FIcons[I]).FIsIcon := IsIcon;
                bFound := True;
              end;
            end;
            if not bFound then begin
              Frame := TIconFrame.Create(-1, FHeader.jifRate);
              Frame.FIcon := Icon;
              Frame.FIsIcon := IsIcon;
              Frame.FTag := Tag;
              Frame.FHotSpot := HotSpot;
              FIcons.Add(Frame);
            end;
            Inc(iFrame);
          end
          else begin
            { Unknown chunk in fram list, just ignore it }
            SkipChunk(Stream, @Tag);
          end;
          Dec(cbChunk, PadUp(Tag.ckSize));
        end;
      end
      else if (Tag.ckID = FOURCC_INFO) then begin
        { now look for INAM and IART chunks }
        while (cbChunk >= SizeOf(Tag)) do begin
          if not ReadTag(Stream, @Tag) then Break;
          Dec(cbChunk, SizeOf(Tag));
          if Tag.ckID = FOURCC_INAM then begin
            if (cbChunk < Tag.ckSize) or not
              ReadChunkN(Stream, @Tag, @FTitle, SizeOf(TANINAME) - 1) then
              Break;
            Dec(cbChunk, PadUp(Tag.ckSize));
          end
          else if Tag.ckID = FOURCC_IART then begin
            if (cbChunk < Tag.ckSize) or not
              ReadChunkN(Stream, @Tag, @FCreator, SizeOf(TANINAME) - 1) then
              Break;
            Dec(cbChunk, PadUp(Tag.ckSize));
          end
          else begin
            if not SkipChunk(Stream, @Tag) then Break;
            Dec(cbChunk, PadUp(Tag.ckSize));
          end;
        end;
      end
      else begin
        { Not the fram list or the INFO list. Skip the rest of this
          chunk. (Don't forget that we have already skipped one dword) }
        Tag.ckSize := cbChunk;
        SkipChunk(Stream, @Tag);
      end;
    end
    else begin { We're not interested in this chunk, skip it. }
      if not SkipChunk(Stream, @Tag) then Break;
    end;
  end; { while }
  { Update the frame count incase we coalesced some frames while reading
    in the file. }
  for I := FIcons.Count - 1 downto 0 do begin
    if TIconFrame(FIcons[I]).FIcon = nil then begin
      TIconFrame(FIcons[I]).Free;
      FIcons.Delete(I);
    end;
  end;
  FHeader.cFrames := FIcons.Count;
  if FHeader.cFrames = 0 then RiffReadError;
end;

procedure TAnimatedCursorImage.ReadStream(Size: Longint; Stream: TStream);
var
  Data: TMemoryStream;
begin
  Data := TMemoryStream.Create;
  try
    Data.SetSize(Size);
    Stream.ReadBuffer(Data.Memory^, Size);
    if Size > 0 then begin
      Data.Position := 0;
      ReadAniStream(Data);
    end;
  finally
    Data.Free;
  end;
end;

procedure TAnimatedCursorImage.WriteStream(Stream: TStream;
  WriteSize: Boolean);
begin
  NotImplemented;
end;

procedure TAnimatedCursorImage.LoadFromStream(Stream: TStream);
begin
  ReadStream(Stream.Size - Stream.Position, Stream);
end;

procedure TAnimatedCursorImage.SaveToStream(Stream: TStream);
begin
  WriteStream(Stream, False);
end;

procedure TAnimatedCursorImage.LoadFromFile(const Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(Filename, fmOpenRead + fmShareDenyNone);
  try
    try
      LoadFromStream(Stream);
    except
      NewImage;
      raise;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TAnimatedCursorImage.Draw(ACanvas: TCanvas; const ARect: TRect);
begin
  if FIcons.Count > 0 then
    DrawRealSizeIcon(ACanvas, Icons[0], ARect.Left, ARect.Top);
end;

procedure TAnimatedCursorImage.AssignToBitmap(Bitmap: TBitmap; BackColor: TColor;
  DecreaseColors, Vertical: Boolean);
var
  I: Integer;
  Temp: TBitmap;
begin
  Temp := TBitmap.Create;
  try
    if FIcons.Count > 0 then begin
      with Temp do begin
        Monochrome := False;
        Canvas.Brush.Color := BackColor;
        if Vertical then begin
          Width := Icons[0].Width;
          Height := Icons[0].Height * FIcons.Count;
        end
        else begin
          Width := Icons[0].Width * FIcons.Count;
          Height := Icons[0].Height;
        end;
        Canvas.FillRect(Bounds(0, 0, Width, Height));
        for I := 0 to FIcons.Count - 1 do begin
          if Icons[I] <> nil then
            Canvas.Draw(Icons[I].Width * I * Ord(not Vertical),
              Icons[I].Height * I * Ord(Vertical), Icons[I]);
        end;
      end;
      if DecreaseColors then
        DecreaseBMPColors(Temp, Max(OriginalColors, 16));
    end;
    Bitmap.Assign(Temp);
  finally
    Temp.Free;
  end;
end;

end.