form1.frm

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

      UnloadGIF
    End If
  End If
End If
LoadGif = nrItems
setpic
End Function

Private Function ParseGIF() As Long  '解析GIF，返回帧总数
On Error Resume Next
Dim gByte As Byte                    '目标字节
Dim gLong As Long                    '目标长整形
Dim gString As String                '文本
Dim lFrameCount As Long              '帧数
Dim bGlobalColorTable As Boolean     '是否有全局彩色表标记
Dim cFrame As GIFframeProperties     '帧数据
Dim emptyFrame As GIFframeProperties '空帧数据
On Error GoTo ExitReadRoutine

ReDim c_DataLen(1 To 10)             '轨迹开始位置 图像大小描述 压缩数据
c_Ptr = 1
Call ReadGifFile_Variable(6)                              '读GIF文件头
gString = LCase(StrConv(c_aBuff, vbUnicode))              '转为小写字符
If InStr("gif89a gif87a", gString) = 0 Then Exit Function '如果不是GIF文件退出
c_Ptr = 11                    '11是包装域在GIF文件中的偏移量
gByte = ReadGifFile_Byte()    '读取逻辑屏幕描述块中的包装域
If (gByte And 128) = 128 Then '如果包装域的标志域（7位）=1，表示全局彩色表将紧跟在这个逻辑屏幕描述块之后
  c_Ptr = 14                  '14是全局彩色表在GIF文件中的偏移量
  c_ColorTables.Index = 0     '索引＝0表示要读取的是全局彩色表
  Call ReadGifFile_ColorTable(0, (gByte And &H7) + 1) '包装域中的0-2位是全局彩色表大小域，这个值一般=7，所以传到ReadGifFile_ColorTable去的第二个参数是8
  bGlobalColorTable = True
End If

With c_gifProps                        '扫描整个文件，找到所有的图像和其他关键数据
  Do
    Select Case ReadGifFile_Byte()     '读入一个字节
      Case 0                           '块结束符
      Case 33                          '扩展控制块
        Select Case ReadGifFile_Byte() '读入一个字节
          Case 255                     '应用扩展块
            gByte = ReadGifFile_Byte() '块大小（11）
            Call ReadGifFile_Variable(gByte) '读入11字节
            gString = UCase(StrConv(c_aBuff, vbUnicode))
            If gString = "NETSCAPE2.0" Then
              gByte = ReadGifFile_Byte()
              If gByte = 3 Then        '扩展名有效
                c_Ptr = c_Ptr + 1
                .Loops = (ReadGifFile_Integer And &HFFFF&) '无符号整形转为长整形
              Else
                c_Ptr = c_Ptr - 1
              End If
            End If
            SkipGifBlock
          Case 249                      '图形控制扩展块
            cFrame = emptyFrame         '开始一个新帧
            With cFrame
              .imgOffset = c_Ptr - 2
              gByte = ReadGifFile_Byte() '跳过块大小域
              gByte = ReadGifFile_Byte() '获取包装域
              .Disposal = ((gByte \ &H4) And &H3) '取得包装域中的处理方法
              If .Disposal = 3 Then
                If lFrameCount = 0& Then .Disposal = lFrameCount
              ElseIf .Disposal > 3 Then
                .Disposal = 0
              End If
              .Delay = (ReadGifFile_Integer And &HFFFF&) * 10 '取得延迟时间并转为长整形
              .IsTransparent = (gByte And &H1) '获取包装域中的透明标志
              If .IsTransparent = 1 Then       '如果透明标志位=1
                .TransIndex = ReadGifFile_Byte '获取透明索引
              Else
                c_Ptr = .imgOffset + 7 '跳出图形控制扩展块
              End If
               Call SkipGifBlock       '跳至下一块
            End With
          Case Else
            Call SkipGifBlock          '忽略其它控制块，跳至下一块
        End Select
      Case 44                          '图像描述块
        With cFrame
          c_DataLen(lFrameCount + 1).Y = c_Ptr - 1
          If .imgOffset = 0 Then .imgOffset = c_DataLen(lFrameCount + 1).Y
          .Dimensions.Left = (ReadGifFile_Integer And &HFFFF&)
          .Dimensions.Top = (ReadGifFile_Integer And &HFFFF&)
          .Dimensions.Right = (ReadGifFile_Integer And &HFFFF&)
          .Dimensions.Bottom = (ReadGifFile_Integer And &HFFFF&) '获取图像高度并转为长整形

          gByte = ReadGifFile_Byte()            '获取图像描述块的包装域
          If (gByte And 128) = 128 Then         ' 如果局部彩色表标志=1，表示有一个局部彩色表紧跟在这个图像描述块之后
            .TblIndex = c_ColorTables.Index + 1
            Call ReadGifFile_ColorTable(.TblIndex, (gByte And &H7) + 1) '获取局部彩色表
            c_ColorTables.Index = .TblIndex
          Else
            If bGlobalColorTable = False Then Exit Function ''如果既没有局部彩色表又没有全局彩色表，则无法显示GIF图像
          End If
          gByte = ReadGifFile_Byte()
          SkipGifBlock                       '跳至下一块
        End With
 
        lFrameCount = lFrameCount + 1
        c_DataLen(lFrameCount).X = c_Ptr - c_DataLen(lFrameCount).Y
        If c_DataLen(lFrameCount).X < 3 Then '图像数据无效
          lFrameCount = lFrameCount - 1      '回到前一帧
        Else
          ReDim Preserve c_Frames(1 To lFrameCount)
          If lFrameCount = UBound(c_DataLen) Then
            ReDim Preserve c_DataLen(1 To lFrameCount + 5)
          End If
          c_Frames(lFrameCount) = cFrame
          With c_Frames(lFrameCount).Dimensions
            If .Left + .Right > c_gifProps.Width Then c_gifProps.Width = .Left + .Right
            If .Top + .Bottom > c_gifProps.Height Then c_gifProps.Height = .Top + .Bottom
          End With
        End If
        cFrame = emptyFrame '开始一个新的帧
      Case 59               'GIF文件结束块
        Exit Do
      Case Else
        Exit Do
    End Select
  Loop
End With

ExitReadRoutine:
If Err Then Err.Clear
If Not lFrameCount = 0 Then
  If lFrameCount > UBound(c_Frames) Then ReDim Preserve c_Frames(1 To lFrameCount)
End If
ParseGIF = lFrameCount
End Function

Private Function BuildDIBstrip(InitialLoad As Boolean) As Boolean '脱壳解压，输入参数：是否第一帧
Dim f As Long, aPtr As Long
Dim frameStart As Long, frameStop As Long
Dim uniquePal(0 To 767) As Byte '彩色表
Dim stripBMP As BITMAPINFO
Dim tPic As StdPicture
On Error GoTo EH
If InitialLoad Then
  Dim maxDataLen As Long, maxHeight As Long, totalWidth As Long
  Dim bTransparency As Byte, tDC As Long
  Dim bEraseAll As Boolean, bNeedMask As Boolean
  bEraseAll = True
  For f = 1 To UBound(c_Frames)
    With c_Frames(f)
      totalWidth = totalWidth + .Dimensions.Right
      If .Dimensions.Bottom > maxHeight Then maxHeight = .Dimensions.Bottom
      bTransparency = bTransparency Or .IsTransparent
      If c_DataLen(f).X > maxDataLen Then maxDataLen = c_DataLen(f).X
      Select Case .Disposal   '根据图形控制扩展块包装域中的处理方法
        Case 0, 1
          bEraseAll = False   '需要重新缓冲
        Case 2
          bNeedMask = True    '可能需要重新缓冲和Mask，除非所有帧都已是二进制编码
        Case 3
          bEraseAll = False   '肯定需要重新缓冲
          bNeedMask = True    '肯定需要一个 mask
      End Select
    End With
  Next
  If f = 2 Then
    totalWidth = c_Frames(1).Dimensions.Right
    maxHeight = c_Frames(1).Dimensions.Bottom
    bNeedMask = False       '单帧不需要缓冲区或 mask
  Else
    If bEraseAll = True Then
      bNeedMask = False     '所有帧被清除后不需要缓冲区或 mask
    Else
      If bNeedMask = False Then
        If c_Frames(1).IsTransparent = 1 Then
          bNeedMask = True  '帧透明时需要 mask
        ElseIf bTransparency = 1 Then
          If Not c_Frames(1).Dimensions.Bottom = c_gifProps.Height Then
            bNeedMask = True
          ElseIf Not c_Frames(1).Dimensions.Right = c_gifProps.Width Then
            bNeedMask = True
          End If
        End If
      End If
      If BuildBackBuffer(bNeedMask) = False Then Exit Function
    End If
  End If
  With stripBMP.bmiHeader   '创建颜色
    .biBitCount = 8
    .biClrUsed = PALETTECOUNT
    .biHeight = maxHeight
    .biWidth = totalWidth
    .biPlanes = 1
    .biSize = 40
  End With
  With stripBMP
    For f = 1 To PALETTECOUNT - 1& ' 确保每个彩色表条目只使用一次
      uniquePal(f * 3& + 2&) = f   ' RGB
      .bmiPalette(f) = f           ' BGR
    Next
  End With
    
  tDC = GetDC(0&)
  c_DC.DC = CreateCompatibleDC(tDC)
  If Not c_DC.DC = 0& Then
    c_DC.hDib = CreateDIBSection(tDC, stripBMP, 0&, c_DC.dibPtr, 0&, 0&) '创建DIB
    If c_DC.hDib = 0& Then
      DeleteDC c_DC.DC
      c_DC.DC = 0&
    End If
  End If
  ReleaseDC 0&, tDC
  If (c_DC.DC = 0& Or c_DC.hDib = 0&) Then Exit Function
  c_DC.hBmp = SelectObject(c_DC.DC, c_DC.hDib)
  
  If bNeedMask = True Or bTransparency = 1 Then ReDim c_maskTable(0 To PALETTECOUNT - 1)
  ReDim c_DIBarray(1 To maxDataLen + 790)
  CopyMemory c_DIBarray(1), c_gifData(1), 13&                '复制文件头和逻辑屏幕描述块13字节
  CopyMemory c_DIBarray(14), uniquePal(0), PALETTECOUNT * 3& '复制全局彩色表256*3字节
  c_DIBarray(11) = c_DIBarray(11) Or 135                     '135=全局彩色表(256色)
  frameStart = 1&: frameStop = 1&
Else
  If Not UBound(c_Frames) = 1& Then
    For f = 1& To PALETTECOUNT - 1& '确保每个彩色表项只用一次
      uniquePal(f * 3& + 2&) = f    '在GIF流中使用的RGB(byte)
      stripBMP.bmiPalette(f) = f    '在DIB中使用的BGR(long)
    Next
    SetDIBColorTable c_DC.DC, 0, 256, stripBMP.bmiPalette(0)
  End If
  frameStart = 2&: frameStop = UBound(c_Frames)
End If

c_ColorTables.Index = -1&           '强制在下一帧中更新彩色表
For f = frameStart To frameStop
  aPtr = 782&                       '下一个位置
  With c_Frames(f)
    If Not c_DataLen(f).Y = .imgOffset Then
      CopyMemory c_DIBarray(aPtr), c_gifData(.imgOffset), 8& '复制图像控制扩展块8字节
      c_DIBarray(aPtr + 3&) = (c_DIBarray(aPtr + 3&) And Not 1)
      aPtr = aPtr + 8&
    End If
      '复制图像描述块、局部彩色表、图像数据
    CopyMemory c_DIBarray(aPtr), c_gifData(c_DataLen(f).Y), c_DataLen(f).X
    CopyMemory c_DIBarray(aPtr + 1), 0&, 4&
    CopyMemory c_DIBarray(7), c_DIBarray(aPtr + 5&), 4&
    If Not .TblIndex = 0& Then CopyMemory c_DIBarray(aPtr + 10&), uniquePal(0), c_aPOT((c_DIBarray(aPtr + 9&) And &H7) + 1&) * 3&
    aPtr = aPtr + c_DataLen(f).X    '帧的总字节
    c_DIBarray(aPtr) = 59           '59为文件结束标记
    If f = 1& Then .imgOffset = 0& Else .imgOffset = c_Frames(f - 1&).imgOffset + c_Frames(f - 1&).Dimensions.Right
    Set tPic = PictureFromByteStream(c_DIBarray(), aPtr)
    If Not tPic Is Nothing Then tPic.Render c_DC.DC + 0&, .imgOffset + 0&, 0&, .Dimensions.Right + 0&, .Dimensions.Bottom + 0&, 0&, tPic.Height, tPic.Width, -tPic.Height, ByVal 0& '在目标对象上绘制源图像的部分或整体
  End With
Next

If frameStart = 1& Then
  c_curFrame = 1&
  Pic(picIndex).Move Pic(picIndex).Left, Pic(picIndex).Top, c_gifProps.Width, c_gifProps.Height '去掉这一句，图片框大小不变化
  If UBound(c_Frames) = 1& Then '单帧
    InitialLoad = False
  Else
    Timer1.Interval = c_Frames(c_curFrame).Delay: Timer1.Enabled = True
  End If
End If

If InitialLoad = False Then     '清理
  Erase c_DIBarray
  Erase c_aPOT
  Erase c_DataLen
  Erase c_gifData
  c_AniLoops = c_gifProps.Loops
  Timer1.Interval = c_Frames(c_curFrame).Delay: Timer1.Enabled = True
End If

BuildDIBstrip = True
EH:
If Err Then Err.Clear
End Function

Private Function PictureFromByteStream(inArray() As Byte, Size As Long) As IPicture '图片字节流
Dim o_hMem  As Long
Dim o_lpMem  As Long
Dim aGUID(0 To 3) As Long
Dim IIStream As IUnknown
aGUID(0) = &H7BF80980
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000

o_hMem = GlobalAlloc(&H2&, Size)
If Not o_hMem = 0& Then
  o_lpMem = GlobalLock(o_hMem)
  If Not o_lpMem = 0& Then
    CopyMemory ByVal o_lpMem, inArray(LBound(inArray)), Size
    Call GlobalUnlock(o_hMem)
    If CreateStreamOnHGlobal(o_hMem, 1&, IIStream) = 0& Then
      Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, 0&, aGUID(0), PictureFromByteStream)
    End If
  End If
End If
End Function

Private Sub RenderFrame() '创建帧图片
Pic(picIndex).Refresh
If c_curFrame = 0 Then Exit Sub
Dim drawRect As RECT                    '帧的边界矩形
Dim d3Mask() As Byte, d3Color() As Byte '当前使用的缓冲区内容

If c_BkBuff.hDib = 0& Then  '没有Mask
  With c_Frames(c_curFrame).Dimensions
    SetRect drawRect, .Left + c_OffSetX, .Top + c_OffSetY, .Right, .Bottom
  End With
  TransferFrame c_curFrame, Pic(picIndex).hdc, drawRect
Else
  UpdateMask c_curFrame, False, d3Mask(), d3Color()
  drawRect = c_Frames(c_curFrame).Dimensions
  TransferFrame c_curFrame, c_BkBuff.DC, drawRect
  SetRect drawRect, c_OffSetX, c_OffSetY, ScaleWidth, ScaleHeight
  TransferFrame -c_curFrame, Pic(picIndex).hdc, drawRect
  If c_Frames(c_curFrame).Disposal > 1 Then UpdateMask c_curFrame, True, d3Mask(), d3Color()
End If
End Sub

Private Sub TransferFrame(ByVal frameNr As Long, hdc As Long, destR As RECT) '移动帧矩形
If destR.Bottom < 1 Or destR.Right < 1 Then Exit Sub
Dim mROP As Long, dcRect As RECT, hBrush As Long