form1.frm

GIF数据结构解析以及播放~代码也许不是很重要。但是希望大家多理解

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "播放 gif 动画"
   ClientHeight    =   4410
   ClientLeft      =   60
   ClientTop       =   645
   ClientWidth     =   6675
   DrawStyle       =   2  'Dot
   ForeColor       =   &H80000006&
   LinkTopic       =   "Form1"
   ScaleHeight     =   294
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   445
   StartUpPosition =   1  '所有者中心
   WindowState     =   2  'Maximized
   Begin VB.PictureBox Pic 
      BorderStyle     =   0  'None
      Height          =   1215
      Index           =   0
      Left            =   120
      ScaleHeight     =   81
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   177
      TabIndex        =   0
      Top             =   120
      Width           =   2655
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Left            =   4920
      Top             =   3600
   End
   Begin MSComDlg.CommonDialog CD 
      Left            =   4320
      Top             =   3600
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Menu File 
      Caption         =   "文件"
      Begin VB.Menu menuOpen 
         Caption         =   "打开"
         Shortcut        =   ^O
      End
      Begin VB.Menu menuSave 
         Caption         =   "保存"
         Shortcut        =   ^S
      End
   End
   Begin VB.Menu operate 
      Caption         =   "操作"
      Begin VB.Menu menuOperate 
         Caption         =   "停止"
         Index           =   0
         Shortcut        =   {F1}
      End
      Begin VB.Menu menuOperate 
         Caption         =   "开始"
         Index           =   1
         Shortcut        =   {F2}
      End
      Begin VB.Menu menuOperate 
         Caption         =   "暂停"
         Index           =   2
         Shortcut        =   {F3}
      End
      Begin VB.Menu menuOperate 
         Caption         =   "单步"
         Index           =   3
         Shortcut        =   {F4}
      End
   End
   Begin VB.Menu options 
      Caption         =   "选项"
      Begin VB.Menu menuPart 
         Caption         =   "播放"
         Checked         =   -1  'True
         Index           =   0
      End
      Begin VB.Menu menuPart 
         Caption         =   "分解"
         Index           =   1
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'根据字节流创建图画
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function GlobalAlloc Lib "KERNEL32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "KERNEL32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "KERNEL32" (ByVal hMem As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Byte)

Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long

Private Declare Function SetDIBColorTable Lib "gdi32.dll" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pcRGBQuad As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As Long, ByRef pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long

Private Const PALETTECOUNT = 256&    '调色板颜色总数

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Type POINTAPI
  X As Long
  Y As Long
End Type
Private Type SAFEARRAYBOUND
  cElements As Long
  lLbound As Long
End Type
Private Type SAFEARRAY2D
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  rgSABound(0 To 1) As SAFEARRAYBOUND
End Type
Private Type BITMAPINFOHEADER   'BMP位图信息头结构
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiPalette(0 To PALETTECOUNT - 1) As Long
End Type

Private Type ColorTableSTRCUT 'GIF彩色表
  Index As Long               '索引，0表示全局彩色表；1-xxx 表示局部彩色表
  Tables() As Long            '颜色表数据(0 to 256, 0 to xxx)
End Type
Private Type GIFcoreProperties 'GIF逻辑屏幕描述
  Width As Long               '图像宽
  Height As Long              '图像高
  Loops As Long               '循环次数(0=无限循环)
End Type
Private Type GIFframeProperties '帧数据
  Dimensions As RECT          '帧的边界矩形
  Delay As Long               '延迟时间
  TblIndex As Long            '颜色索引
  imgOffset As Long           '开始创建 GIF 图像时的文件字节位置，解压后,开始在 DIB 中脱壳
  TransIndex As Byte          '透明色的调色板索引
  IsTransparent As Byte       '帧是否使用透明(0=no, 1=yes)
  Disposal As Byte            '处理方法
End Type
Private Type CoreDCInfo
  DC As Long                  'off-screen DC
  hDib As Long                '为 DC 创建 DIB(our DIB strip)
  dibPtr As Long              'DIB 指针
  hBmp As Long                '原始单色位图 DC
End Type
Private Type BufferDCInfo     '缓冲区DC信息
  DC As Long
  hDib As Long
  dibPtr As Long
  hBmp As Long
  hDibBW As Long
  dibPtrBW As Long
End Type

Dim c_OffSetX As Long         '图像左边距
Dim c_OffSetY As Long         '图像顶边距
Dim c_SolidBgkFill As Long    '逻辑屏幕背景色
Dim c_SolidBkgUsed As Boolean '使用逻辑屏幕背景色标记

Dim c_AniLoops As Integer     '循环剩余数
Dim c_curFrame As Long        '当前帧
Dim c_DC As CoreDCInfo        '帧信息
Dim c_BkBuff As BufferDCInfo  '掩码信息
Dim c_gifProps As GIFcoreProperties   'GIF 逻辑屏幕描述
Dim c_Frames() As GIFframeProperties  '单个帧的属性，其下标为总帧数
Dim c_ColorTables As ColorTableSTRCUT '彩色表
Dim c_maskTable() As Long     'GIF 掩码彩色表
Dim c_DataLen() As POINTAPI   '帧坐标
Dim c_aBuff() As Byte         '读取GIF文件数据时的临时存放数组
Dim c_DIBarray() As Byte      '通用阵列（用于ConvertStripToGIF 和 BuildDIBstrip）
Dim c_aPOT() As Long          'Power of 2 look up table
Dim c_gifData() As Byte       'GIF的全部数据
Dim c_Ptr As Long             '读取数据时的指针
Dim z_CbMem   As Long         '分配的内存地址
Dim BjTemer As Boolean        '首次显示第一帧标记
Dim BjPart As Boolean         '分拆标记
Dim picIndex As Integer       '当前图片框索引

Private Sub Form_Unload(Cancel As Integer)
UnloadGIF
End Sub

Private Sub menuOperate_Click(Index As Integer) '0停止1开始2暂停3单步
If c_curFrame = 0& Then Exit Sub
Timer1.Enabled = False
Select Case Index
  Case 0: c_AniLoops = c_gifProps.Loops: c_curFrame = 1: RenderFrame '重新设置循环剩余数和当前帧
  Case 1: Timer1.Interval = c_Frames(c_curFrame).Delay: Timer1.Enabled = True
  Case 2:
  Case 3
    c_curFrame = IIf(c_curFrame >= UBound(c_Frames), 1, c_curFrame + 1) '如果是最后一帧，就从头开始，否则准备显示后一个帧
    If BjPart Then picIndex = c_curFrame - 1
    RenderFrame
End Select
End Sub

Private Sub menuOpen_Click()
CD.DialogTitle = "打开"
CD.Filter = "GIF动画文件(*.gif)|*.gif"
CD.ShowOpen
If Len(CD.FileName) > 4 Then OpenGIF CD.FileName
End Sub

Private Sub menuSave_Click()
CD.DialogTitle = "保存"
CD.Filter = "bmp文件(*.bmp)|*.bmp"
CD.ShowSave
If Len(CD.FileName) = 0 Then Exit Sub
Dim I As Integer, N As String, pic2 As Object
Set pic2 = Controls.Add("VB.PictureBox", "pic2")
pic2.AutoRedraw = True: pic2.BorderStyle = 0
pic2.Width = c_gifProps.Width: pic2.Height = c_gifProps.Height
N = Left(CD.FileName, InStr(CD.FileName, ".") - 1)
For I = 0 To Pic.Count - 1
  pic2.Cls
  BitBlt pic2.hdc, 0, 0, c_gifProps.Width, c_gifProps.Height, Pic(I).hdc, 0, 0&, vbSrcCopy
  pic2.Refresh
  SavePicture pic2.Image, N & I & ".bmp"
Next
Controls.Remove pic2
End Sub

Private Sub menuPart_Click(Index As Integer)
menuPart(0).Checked = False
menuPart(1).Checked = False
menuPart(Index).Checked = True
BjPart = Index
setpic
End Sub

Private Sub setpic()
Dim I As Integer, L As Long, T As Long
If Pic.Count > 1 Then For I = 1 To Pic.Count - 1: Unload Pic(I): Next '删除上一次建立的图片框控件数组
If BjPart And c_curFrame > 0 Then
  Pic(0).Move 0, 0, c_gifProps.Width, c_gifProps.Height
  For I = 1 To UBound(c_Frames) - 1 '建立当前的图片框控件数组
    L = L + c_gifProps.Width: If L + c_gifProps.Width > Me.ScaleWidth Then L = 0: T = T + c_gifProps.Height + 10
    Load Pic(I)
    Pic(I).Move L, T
    Pic(I).Visible = True
  Next
End If
End Sub

Private Sub OpenGIF(gifName As String)
On Error GoTo ReadErr
Dim gifLen As Long
picIndex = 0
BjTemer = False
gifLen = FileLen(gifName) '获取文件长度
ReDim c_gifData(1 To gifLen)
Open gifName For Binary As #1
Get #1, , c_gifData
Close #1
LoadGif
RenderFrame
Exit Sub
ReadErr:
Close #1
End Sub

Private Function LoadGif() As Long '装入GIF，返回帧总数
Dim newProps As GIFcoreProperties
Dim nrItems As Long
UnloadGIF             '卸载原 GIF
c_gifProps = newProps '开始一个新 UDT
If Not IsArrayEmpty(VarPtrArray(c_gifData)) = 0& Then ''获取数组地址指针成功
  ReDim c_aPOT(0 To 8)
  c_aPOT(0) = 1
  For nrItems = 1 To 8: c_aPOT(nrItems) = c_aPOT(nrItems - 1) * 2: Next '1,2,4,8,16,32,64,128,256
  nrItems = ParseGIF() '解析GIF
  If Not nrItems = 0 Then '如果解析成功，总帧数>0
    Erase c_aBuff()
    c_Ptr = 0
    If BuildDIBstrip(True) = False Then '如果解压失败
      nrItems = 0
      If Err Then Err.Clear
      Erase c_gifData