Delphi压缩图片代码



Delphi 压缩图片代码

添加引用：uses JPEG;

//=====================图片处理函数，将覆盖原图片文件===========================
//=====filename:图片完整路径  PressQuality: 压缩质量 Width:宽  Height:高
function CompressMainFun(filename: String; PressQuality,Width,Height:integer): Boolean;
var
  bmp: TBitmap;
  jpg: TJpegImage;
  i: Integer;
  sTemp:string;
begin
  Result := False;
    if pos(UpperCase('.bmp'), UpperCase(filename)) <> 0 then   //bmp 格式
    begin
      bmp.LoadFromFile(filename);
      jpg.Assign(bmp);
      jpg.CompressionQuality := PressQuality;
      jpg.Compress;
      bmp.height := Height;
      bmp.Width := Width;
      bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect, jpg);
      jpg.Assign(bmp);
      sTemp := filename + '.jpg';
      jpg.SaveToFile(sTemp);
      DeleteFile(filename);
      CopyFile(PChar(sTemp), PChar(filename), True);
      DeleteFile(sTemp);
    end
    else                                                     //其它 格式
    begin
      jpg.LoadFromFile(filename);
      bmp.height := Height;
      bmp.Width := Width;
      bmp.Canvas.StretchDraw(bmp.Canvas.ClipRect, jpg);
      jpg.Assign(bmp);
      jpg.CompressionQuality := PressQuality;
      jpg.Compress;
      sTemp := filename + '.jpg';
      jpg.SaveToFile(sTemp);
      DeleteFile(filename);
      CopyFile(PChar(sTemp), PChar(filename), True);
      DeleteFile(sTemp);
    end;
  Result := True;
end;


压缩图像文件并转换成BMP 格式

function GraphicToBmp(P: TPicture; Quality: Integer = 80): TBitmap;
var
  Jpg: TJpegImage;
begin
  Result := TBitmap.Create;
  with Result do
  begin
    Width := P.Width;
    Height := P.Height;
    Canvas.Draw(0, 0, P.Graphic);
  end;
  if Assigned(Result) then
  begin
    Jpg := TJpegImage.Create;
    Jpg.Assign(Result);
    Jpg.CompressionQuality := Quality;
    Jpg.JPEGNeeded;
    Jpg.Compress;
    if Assigned(Jpg) then
    begin
      Jpg.DIBNeeded;
      Result.Assign(Jpg);
    end;
  end;
end;


delphi显示 jpg、png、gif 图片及 gif 动画

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses jpeg, GIFImg, pngimage;
{显示 jpg 图片}
procedure TForm1.Button1Click(Sender: TObject);
var
jpg: TJPEGImage;
begin
jpg := TJPEGImage.Create;
jpg.LoadFromFile('C:\Temp\Test.jpg');
Canvas.Draw(0, 0, jpg);
jpg.Free;
end;
{显示 png 图片}
procedure TForm1.Button2Click(Sender: TObject);
var
png: TPngImage;
begin
png := TPngImage.Create;
png.LoadFromFile('C:\Temp\Test.png');
Canvas.Draw(0, 0, png);
png.Free;
end;
{显示 gif 图片}
procedure TForm1.Button3Click(Sender: TObject);
var
gif: TGIFImage;
begin
gif := TGIFImage.Create;
gif.LoadFromFile('C:\Temp\Test.gif');
Canvas.Draw(0, 0, gif);
gif.Free;
end;
{显示 gif 动画}
procedure TForm1.Button4Click(Sender: TObject);
var
gif: TGIFImage;
begin
gif := TGIFImage.Create;
gif.LoadFromFile('C:\Temp\Test.gif');
gif.Animate := True;
with TImage.Create(Self) do begin
    Parent := Self;
    Left := 0;
    Top := 0;
    Picture.Assign(gif);
end;
gif.Free;
end;
end.


用 delphi2010 可以将图片的 格式在
Bmp, Png,   Jpeg,     Gif,    Tiff       WMPhoto
等 格式之间互相转换
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//   JXSF_PIC_Format_Convert
//   图片 格式转换
//   [in]   pic_stream     原图片的数据流
//   [in]   toPicForMat    要转换的图片 格式
//           0      1       2        3       4         5
//           Bmp, Png,   Jpeg,     Gif,    Tiff       WMPhoto
//   [out] targ_stream
//          转换后的数据流
// 返回:
//          转换是否成功
//          0 = 失败
//          1 = 成功
function JXSF_PIC_Format_Convert (
              const pic_stream :TMemoryStream;
              const toPicForMat : INT32;
              const targ_stream : TMemoryStream
            ) : INT32;
var   wi:TWICImage;
var   flag        : INT32;
begin
    if not ( toPicForMat in [0..5] ) then
    begin
          try
               targ_stream.Clear;
          except
          end;
          Result:=0;exit;
    end;
    wi:=TWICImage.Create;
    try
        pic_stream.Position:=0;
        targ_stream.Clear;
       // 下面是 格式转换核心代码
        wi.LoadFromStream(pic_stream);
        wi.ImageFormat := TWICImageFormat( toPicForMat);
        wi.SaveToStream( targ_stream);
        targ_stream.Position:=0;
        flag:=1;
    except
        flag:=0;
    end;
    wi.Free;
    Result:=flag;
end;
procedure TForm1.Button1Click(Sender: TObject);
var sm1,sm2:TMemoryStream;
   var wi:TWICImage;
begin
    sm1:= TMemoryStream.Create;
    sm2:= TMemoryStream.Create;
    sm1.LoadFromFile( 'c:\tt\0002.jpg');
     sm1.Position :=0;
     JXSF_PIC_Format_Convert( sm1,0,sm2) ;
    wi:=TWICImage.Create;
    wi.LoadFromStream(sm2);
     Image1.Picture.Assign( wi);
    wi.Free;
    sm1.Free;
    sm2.Free;
end;
end.



�6�1 Delphi常见图象 格式转换技术(二)
作者:lyboy99
e-mail:lyboy99@sina.com  
url: http://hnh.126.com
给大家提供几个常用的图象 格式转换方法和其转换函数
希望能对你有帮助
1.TxT 转换为 GIF
2.WMF 格式转换为BMP 格式
3.BMP 格式转换为WMF 格式
4.TBitmaps to 视窗系统 Regions
-----------------------------------------------------------------------
TxT 转换为 GIF
------------------------------------------------
procedure TxtToGif (txt, FileName: String);
var
    temp: TBitmap;
    GIF : TGIFImage;
begin
temp:=TBitmap.Create;
try
        temp.Height     :=400;
        temp.Width      :=60;
        temp.Transparent:=True;
        temp.Canvas.Brush.Color:=colFondo.ColorValue;
        temp.Canvas.Font.Name:=Fuente.FontName;
        temp.Canvas.Font.Color:=colFuente.ColorValue;
        temp.Canvas.TextOut (10,10,txt);
        Imagen.Picture.Assign(nil);
      GIF := TGIFImage.Create;
      try
       
        GIF.Assign(Temp);
        //保存 GIF
        GIF.SaveToFile(FileName);
        Imagen.Picture.Assign (GIF);
     finally
        GIF.Free;
      end;
Finally
        temp.Destroy;
End;
end;
---------------------------------------------------------------------
2.WMF 格式转换为BMP 格式
--------------------------------------------------------------------
procedure WmfToBmp(FicheroWmf,FicheroBmp:string); 
var 
  MetaFile:TMetafile; 
  Bmp:TBitmap; 
begin 
  Metafile:=TMetaFile.create; 
  {Create a Temporal Bitmap} 
  Bmp:=TBitmap.create; 
  {Load the Metafile} 
  MetaFile.LoadFromFile(FicheroWmf); 
  {Draw the metafile in Bitmaps canvas} 
  with Bmp do 
  begin 
   Height:=Metafile.Height; 
   Width:=Metafile.Width; 
   Canvas.Draw(0,0,MetaFile); 
   {Save the BMP} 
   SaveToFile(FicheroBmp); 
   {Free BMP} 
   Free; 
  end; 
  {Free Metafile} 
  MetaFile.Free; 
end; 

---------------------------------------------------------------------
3.BMP 格式转换为WMF 格式
---------------------------------------------------------------------
procedure BmpToWmf (BmpFile,WmfFile:string); 
var 
  MetaFile : TMetaFile; 
  MFCanvas : TMetaFileCanvas; 
  BMP : TBitmap; 
begin 
  {Create temps} 
  MetaFile := TMetaFile.Create; 
  BMP := TBitmap.create; 
  BMP.LoadFromFile(BmpFile); 
  {Igualemos tama?os} 
  {Equalizing sizes} 
  MetaFile.Height := BMP.Height; 
  MetaFile.Width := BMP.Width; 
  {Create a canvas for the Metafile} 
  MFCanvas:=TMetafileCanvas.Create(MetaFile, 0); 
  with MFCanvas do 
  begin 
  {Draw the BMP into canvas} 
  Draw(0, 0, BMP); 
  {Free the Canvas} 
  Free; 
  end; 
  {Free the BMP} 
  BMP.Free; 
  with MetaFile do 
  begin 
  {Save the Metafile} 
  SaveToFile(WmfFile); 
   {Free it...} 
  Free; 
  end; 
end;
---------------------------------------------------------------------
4.TBitmaps to 视窗系统 Regions
---------------------------------------------------------------------
function BitmapToRegion(bmp: TBitmap; TransparentColor: TColor=clBlack;
  RedTol: Byte=1; GreenTol: Byte=1; BlueTol: Byte=1): HRGN;
const
  AllocUnit = 100;
type
  PRectArray = ^TRectArray;
  TRectArray = Array[0..(MaxInt div SizeOf(TRect))-1] of TRect;
var
  pr: PRectArray;   
  h: HRGN;         
  RgnData: PRgnData;
  lr, lg, lb, hr, hg, hb: Byte;
  x,y, x0: Integer; 
  b: PByteArray;   
  ScanLinePtr: Pointer;
  ScanLineInc: Integer;
  maxRects: Cardinal;  
begin
  Result := 0;
  { Keep on hand lowest and highest values for the "transparent" pixels }
  lr := GetRValue(TransparentColor);
  lg := GetGValue(TransparentColor);
  lb := GetBValue(TransparentColor);
  hr := Min($ff, lr + RedTol);
  hg := Min($ff, lg + GreenTol);
  hb := Min($ff, lb + BlueTol);

  bmp.PixelFormat := pf32bit;
 
  maxRects := AllocUnit;
  GetMem(RgnData,SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects));
  try
    with RgnData^.rdh do
    begin
      dwSize := SizeOf(RGNDATAHEADER);
      iType := RDH_RECTANGLES;
      nCount := 0;
      nRgnSize := 0;
      SetRect(rcBound, MAXLONG, MAXLONG, 0, 0);
    end;
 
    ScanLinePtr := bmp.ScanLine[0];
    ScanLineInc := Integer(bmp.ScanLine[1]) - Integer(ScanLinePtr);
    for y := 0 to bmp.Height - 1 do
    begin
      x := 0;
      while x < bmp.Width do
      begin
        x0 := x;
        while x < bmp.Width do
        begin
          b := @PByteArray(ScanLinePtr)[x*SizeOf(TRGBQuad)];
          // BGR-RGB: 视窗系统 32bpp BMPs are made of BGRa quads (not RGBa)
          if (b[2] >= lr) and (b[2] <= hr) and
             (b[1] >= lg) and (b[1] <= hg) and
             (b[0] >= lb) and (b[0] <= hb) then
            Break; // pixel is transparent
          Inc(x);
        end;
        { test to see if we have a non-transparent area in the image }
        if x > x0 then
        begin
          { increase RgnData by AllocUnit rects if we exceeds maxRects }
          if RgnData^.rdh.nCount >= maxRects then
          begin
            Inc(maxRects,AllocUnit);
            ReallocMem(RgnData,SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
          end;
          { Add the rect (x0, y)-(x, y+1) as a new visible area in the region }
          pr := @RgnData^.Buffer; // Buffer is an array of rects
          with RgnData^.rdh do
          begin
            SetRect(pr[nCount], x0, y, x, y+1);
            { adjust the bound rectangle of the region if we are "out-of-bounds" }
            if x0 < rcBound.Left then rcBound.Left := x0;
            if y < rcBound.Top then rcBound.Top := y;
            if x > rcBound.Right then rcBound.Right := x;
            if y+1 > rcBound.Bottom then rcBound.Bottom := y+1;
            Inc(nCount);
          end;
        end; // if x > x0
      
       
        if RgnData^.rdh.nCount = 2000 then
        begin
          h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects), RgnData^);
          if Result > 0 then
          begin // Expand the current region
            CombineRgn(Result, Result, h, RGN_OR);
            DeleteObject(h);
          end
          else  // First region, assign it to Result
            Result := h;
          RgnData^.rdh.nCount := 0;
          SetRect(RgnData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
        end;
        Inc(x);
      end; // scan every sample byte of the image
      Inc(Integer(ScanLinePtr), ScanLineInc);
    end;
    { need to call ExCreateRegion one more time because we could have left    }
    { a RgnData with less than 2000 rects, so it wasnt yet created/combined  }
    h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects), RgnData^);
    if Result > 0 then
    begin
      CombineRgn(Result, Result, h, RGN_OR);
      DeleteObject(h);
    end
    else
      Result := h;
  finally
    FreeMem(RgnData,SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
  end;
----------------------------------------------------------------------------------


常见图象 格式转换技术
作者:lyboy99
e-mail:lyboy99@sina.com  
url: http://hnh.126.com/
给大家提供几个常用的图象 格式转换方法和其转换函数
希望可以对你有帮助
1. ICO图标转换BMP 格式
2. 32x32 BMP 格式图象转换为 ICO 格式
3.转换BMP->JPEG文件 格式
4.JPEG 转换为BMP函数
5.Bmp转换为JPEG文件 格式函数
-------------------------------------------------------------------------------------------------------------------------
1.Chinese : ICO图标转换BMP 格式
English :(Conversion from ICO to BMP)
--------------------------------------------------------
  var
    Icon   : TIcon;
    Bitmap : TBitmap;
  begin
     Icon   := TIcon.Create;
     Bitmap := TBitmap.Create;
     Icon.LoadFromFile('c:\picture.ico');
     Bitmap.Width := Icon.Width;
     Bitmap.Height := Icon.Height;
     Bitmap.Canvas.Draw(0, 0, Icon );
     Bitmap.SaveToFile('c:\picture.bmp');
     Icon.Free;
     Bitmap.Free;
===================================
2.Chinese: 32x32 BMP 格式图象转换为 ICO 格式
English :32x32 bit Bitmaps to ICO's
-----------------------------------
unit main;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms,Dialogs,ExtCtrls, StdCtrls;
type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var winDC, srcdc, destdc : HDC;
    oldBitmap : HBitmap;
    iinfo : TICONINFO;
begin
    GetIconInfo(Image1.Picture.Icon.Handle, iinfo);
    WinDC := getDC(handle);
    srcDC := CreateCompatibleDC(WinDC);
    destDC := CreateCompatibleDC(WinDC);
    oldBitmap := SelectObject(destDC, iinfo.hbmColor);
    oldBitmap := SelectObject(srcDC, iinfo.hbmMask);
    BitBlt(destdc, 0, 0, Image1.picture.icon.width,
     Image1.picture.icon.height,
           srcdc, 0, 0, SRCPAINT);
    Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
    DeleteDC(destDC);
    DeleteDC(srcDC);
    DeleteDC(WinDC);
image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
          + 'myfile.bmp');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  image1.picture.icon.loadfromfile('c:\myicon.ico');
end;
end.
==================================================================
3. Chinese:转换BMP->JPEG文件 格式
Englsh:convert the bitmap into a JPEG file format
------------------------------------------------------------------
var
  MyJpeg: TJpegImage;
  Image1: TImage;
begin
  Image1:= TImage.Create;
  MyJpeg:= TJpegImage.Create;
  Image1.LoadFromFile('TestImage.BMP');  // 读取Bitmap文件
  MyJpeg.Assign(Image1.Picture.Bitmap); 
object
  MyJpeg.SaveToFile('MyJPEGImage.JPG'); //保存JPEG
end;
--------------------------------------------------------------------
4.JPEG 转换为BMP函数
procedure Jpg2Bmp(const source,dest:string);
var
  MyJpeg: TJpegImage;
  bmp: Tbitmap;
begin
bmp:=tbitmap.Create;
MyJpeg:= TJpegImage.Create;
try
  myjpeg.LoadFromFile(source);
  bmp.Assign(myjpeg);
  bmp.SaveToFile(dest);
finally
  bmp.free;
  myjpeg.Free;
end;
end;
----------------------------------------------------------
5.Bmp转换为JPEG文件 格式函数
----------------------------------------------------------
procedure Bmp2Jpg(const source,dest:string;const scale:byte);
var
  MyJpeg: TJpegImage;
  Image1: TImage;
begin
Image1:= TImage.Create(application);
MyJpeg:= TJpegImage.Create;
try
  Image1.Picture.Bitmap.LoadFromFile(source);
  MyJpeg.Assign(Image1.Picture.Bitmap);
  MyJpeg.CompressionQuality:=scale;
  MyJpeg.Compress;
  MyJpeg.SaveToFile(dest);
finally
  image1.free;
  myjpeg.Free;
end;
end;
-----------------------------------------------------------------------
delphi中我用了了第三方提供的BMP2GIF控件后，出现的问题，  12-14

我用了了第三方提供的BMP2GIF控件后，
代码如下
gif:=TGIFImage.Create;
mmm:=extractfilepath(Application.exename) 'temp\';
Screen.Cursor:=crhourglass;
form1.CoolBar2.Visible:=True;
form1.Gauge2.MaxValue:=Form1.ScrollBar2.Max;
for i:=1 to Form1.ScrollBar2.Max do
Begin
Form1.ScrollBar2.Position:=i;
form1.Gauge2.Progress:=i-10;
form1.POLARDraw1.Write(mmm inttostr(i-1) '.bmp',3);
End;
bitmap :=TBitmap.Create;

for i:=0 to form1.ScrollBar2.Max-1 do
Begin
try
bitmap.LoadFromFile(mmm inttostr(i) '.bmp');
Index :=Gif.Add(bitmap);
If Index=0 Then
Begin
LoopExt := TGIFAppExtNSLoop.Create(GIF.Images[Index]);
LoopExt.Loops := 0; // Forever
LoopExt.BufferSize:=32768;
GIF.Images[I].Extensions.Add(LoopExt);
End;
Ext := TGIFGraphicControlExtension.Create(GIF.Images[Index]);
If Flag =1 Then
Ext.Delay := 10
Else
If Flag=2 Then
Ext.Delay:=30
Else
Ext.Delay:=60;
GIF.Images[Index].Extensions.Add(Ext);
finally
LoopExt.Free;
LoopExt:=Nil;
Ext.Free;
Ext:=Nil;

End; //.//try ...finally;
End; //for scrollbar 2;
bitmap.FreeImage;
bitmap.Dormant;
bitmap.ReleaseHandle;
bitmap.Free;
bitmap:=Nil;
Gif.SaveToFile(FileName);
Finally
Gif.Free;


但是当BMP数量很多， GIF在ADD的时候内存一直增加，很快就内存益处了，高手们如何解决

1：强烈关注，我也碰到这样的问题，不知道该如何解决，不知道可不可以边写到硬盘，边增加图片，这样就不要老增加内存，直到死[:(]
2：建议使用Windows 的GDI Plus,支持BMP、GIF、PNG、WMF、WMF 格式



我在转换BMP到GIF时，发现转换后的GIF图象严重缺色失真，各位知道怎样解决吗？    

我把真彩位图图象在PS中转换为256的位图或索引 格式时，在程序中转换就不会出现失真的现象。

我在转换BMP到GIF时，发现转换后的GIF图象严重缺色失真，各位知道怎样解决吗？各位，帮帮我。分不够就告诉我。先谢谢了。不知道下面的代码对你有没有用 jpg.Assign(bitmap). //file://将图象转成JPG 格式 jpg.CompressionQuality:=10.//文件 压缩大小设置 jpg.Compress. jpg.SaveToStream(result). //file://将JPG图象写入流中Gif用的是LZW算法。。。不知道用LZW算法来 压缩BMP是否可生成GIF。。。 我用的控件不支持从JPG 格式转换GIF啊我把真彩位图图象在PS中转换为256的位图或索引 格式时，在程序中转换就不会出现失真的现象。。

调色板的问题，自己做色彩量化生成调色板，而不是用系统调色板。

误差扩散可修正颜色过渡效果

遇到过此问题，但对我工作不是特别的重要；所以没去钻研；
我先打开一个BMP图片用ASSIGNFILE转换一下后，保存为GIF图片就出现失真现象；

我使用   GIFImage   的，但是运行以下代码从   BMP   文件转换成   GIF   文件后，GIF   的图像变差，我已经搜索了很多资料也没有提及，请帮个忙。
 
procedure   TForm1.Button1Click(Sender:   TObject);
var
       Bitmap:   TBitmap;
       GIFImage:   TGIFImage;
begin
       Bitmap   :=   TBitmap.Create;
       GIFImage   :=   TGIFImage.Create;
 
       Bitmap.LoadFromFile( '1.bmp ');
 
       try
             GIFImage.Assign(Bitmap);
             GIFImage.Palette   :=   WebPalette;
             GIFImage.Compression   :=   gcLZW;
             GIFImage.SaveToFile( '1.gif ');
       finally
       end;
 
       GIFImage.Free;
       Bitmap.Free;
 
end;

GIFImage.ColorReduction   :=   rmQuantize;



  delphi GDI+ 获取GIF图片的每一帧 转为bmp图片 收藏
声明：代码修改自万一的blog

=================

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    OpenDialog1: TOpenDialog;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses GDIPOBJ, GDIPAPI,GDIPUTIL;
var
  img: TGPImage;
  GifFrame, GifFrameCount: Word;

procedure TForm1.FormCreate(Sender: TObject);
begin
  OpenDialog1.Filter := 'GIF 文件|*.gif';
  img := TGPImage.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  img.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  DimensionsCount: Integer;
  DimensionsIDs: PGUID;
  i: Integer;
type
  ArrDimensions = array of TGUID;
begin
  if not OpenDialog1.Execute then Exit;
  img.Free;
  img := TGPImage.Create(OpenDialog1.FileName);

  {获取 Gif 总帧数}
  DimensionsCount := img.GetFrameDimensionsCount;
  GetMem(DimensionsIDs, DimensionsCount * SizeOf(TGUID));
  img.GetFrameDimensionsList(DimensionsIDs, DimensionsCount);
  GifFrameCount := img.GetFrameCount(ArrDimensions(DimensionsIDs)[0]);
  FreeMem(DimensionsIDs);

  Text := Format('共有 %d 帧', [GifFrameCount]);

  {显示帧列表}
  ListBox1.Clear;
  for i := 1 to GifFrameCount do
    ListBox1.Items.Add(Format('第 %d 帧', [i]));

  Repaint;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  g: TGPGraphics;

begin
  g := TGPGraphics.Create(Canvas.Handle);
  g.DrawImage(img, ListBox1.Width + 10, 10, img.GetWidth, img.GetHeight);
  g.Free;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
  i:integer;
  ImgGUID: TGUID;
begin
  //你可以在这里对Listbox1进行循环 获取每一帧的图片
  for  i:=0 to ListBox1.Items.Count-1 do
  begin
  //GifFrame := ListBox1.ItemIndex;
  //img.SelectActiveFrame(FrameDimensionTime, GifFrame);
  img.SelectActiveFrame(FrameDimensionTime, i);
  GetEncoderClsid('image/bmp', ImgGUID);
  img.Save('c:\test'+inttostr(i)+'.bmp',ImgGUID);
  //Repaint;
  end;
end;

end.