form1.frm

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

Dim xOffset As Long, xWidth As Long, xHeight As Long
Dim srcDC As Long, lTransColor As Long
With c_Frames(Abs(frameNr))
  If c_SolidBkgUsed Then '如果使用逻辑屏幕背景色，先为矩形背景着色
    SetRect dcRect, 0, 0, c_gifProps.Width, c_gifProps.Height
    If c_SolidBgkFill < 0& Then '如果设置为系统颜色(&H80000001－&H80000016)
      hBrush = CreateSolidBrush(GetSysColor(c_SolidBgkFill And &HFF)) 'GetSysColor获取指定对象的颜色
    Else
      hBrush = CreateSolidBrush(c_SolidBgkFill) 'CreateSolidBrush用纯色创建一个刷子
    End If
    FillRect hdc, dcRect, hBrush '用指定的刷子填充一个矩形
    DeleteObject hBrush
  End If

  If frameNr < 0& Then
    xWidth = c_gifProps.Width
    xHeight = c_gifProps.Height
    SelectObject c_BkBuff.DC, c_BkBuff.hDibBW
    BitBlt hdc, destR.Left, destR.Top, destR.Right, destR.Bottom, c_BkBuff.DC, 0&, 0&, vbSrcAnd
    SelectObject c_BkBuff.DC, c_BkBuff.hDib
    mROP = vbSrcPaint           '为颜色部分设置光栅操作方式
    srcDC = c_BkBuff.DC         '逻辑屏幕的背景色缓冲区
  Else                          '将帧转移到目标DC
    srcDC = c_DC.DC
    xOffset = .imgOffset
    xWidth = .Dimensions.Right
    xHeight = .Dimensions.Bottom
    If .IsTransparent = 1 Then           '如果包装域的透明位＝1，创建 masks 彩色表
      c_maskTable(.TransIndex) = vbWhite '设置为白色索引。下面的SetDIBColorTable函数设置颜色表
      SetDIBColorTable c_DC.DC, 0, c_ColorTables.Tables(PALETTECOUNT, .TblIndex), c_maskTable(0)
      c_maskTable(.TransIndex) = vbBlack '设置为黑色索引
      mROP = vbSrcPaint                  '为颜色部分设置光栅操作方式
      BitBlt hdc, destR.Left, destR.Top, destR.Right, destR.Bottom, srcDC, xOffset, 0&, vbSrcAnd
      lTransColor = c_ColorTables.Tables(.TransIndex, .TblIndex)
      c_ColorTables.Tables(.TransIndex, .TblIndex) = vbBlack
    Else
      mROP = vbSrcCopy                   '透明位＝0的光栅操作方式
    End If
    If .IsTransparent = 1 Or Not .TblIndex = c_ColorTables.Index Then
      c_ColorTables.Index = .TblIndex     '更新当前表索引
      SetDIBColorTable c_DC.DC, 0, c_ColorTables.Tables(PALETTECOUNT, .TblIndex), c_ColorTables.Tables(0, .TblIndex)
      If .IsTransparent = 1 Then c_ColorTables.Tables(.TransIndex, .TblIndex) = lTransColor
    End If
  End If
  BitBlt hdc, destR.Left, destR.Top, destR.Right, destR.Bottom, srcDC, xOffset, 0&, mROP
End With
End Sub

Private Sub ArrayFromVarRef(inArray() As Byte, Offset As Long) '复制数组
CopyMemory c_gifData(1), inArray(Offset), UBound(c_gifData) '将inArray数组从第Offset元素开始，复制UBound(c_gifData)个元素到c_gifData数组中
End Sub

Private Function IsArrayEmpty(ByVal FarPointer As Long) As Long '如果数组已经初始化，返回其指针
CopyMemory IsArrayEmpty, ByVal FarPointer, 4&
End Function

Private Function ByteAlignOnWord(ByVal BitDepth As Byte, ByVal Width As Long) As Long
ByteAlignOnWord = (((Width * BitDepth) + &H1F) And Not &H1F&) \ &H8 '边界为任一 bit 深度的字节队列
End Function

Private Sub SkipGifBlock() '读取字节，直到发现一个零字节块终结，读出的字节均废弃
For c_Ptr = c_Ptr To UBound(c_gifData)
  If c_gifData(c_Ptr) = 0 Then Exit For
    c_Ptr = c_Ptr + c_gifData(c_Ptr)
Next
c_Ptr = c_Ptr + 1
End Sub

Private Function ReadGifFile_Byte() As Byte '从GIF文件中读取一个字节
If c_Ptr > UBound(c_gifData) Then
  Err.Raise 53, "ReadGifFile", "读文件时出错"
  Exit Function
End If
ReadGifFile_Byte = c_gifData(c_Ptr)
c_Ptr = c_Ptr + 1
End Function

Private Function ReadGifFile_Integer() As Integer '从GIF文件中读取两个字节
If c_Ptr + 1 > UBound(c_gifData) Then
  Err.Raise 53, "ReadGifFile", "读文件时出错"
  Exit Function
End If
CopyMemory ReadGifFile_Integer, c_gifData(c_Ptr), 2&
c_Ptr = c_Ptr + 2
End Function

Private Sub ReadGifFile_Variable(ByVal nrBytes As Long) '从GIF 文件中读出nrBytes个字节
ReDim c_aBuff(0 To nrBytes - 1)                    '该数组存放读出的字节
If c_Ptr + nrBytes - 1 <= UBound(c_gifData) Then
  CopyMemory c_aBuff(0), c_gifData(c_Ptr), nrBytes '将从c_gifData数组中读出的nrBytes个字节复制到c_aBuff数组
  c_Ptr = c_Ptr + nrBytes
End If
End Sub

Private Sub ReadGifFile_ColorTable(ByVal TableSlot As Long, ByVal BitDepth As Long) '从GIF文件中读取彩色表
If c_Ptr + c_aPOT(BitDepth) * 3 > UBound(c_gifData) Then
  Err.Raise 53, "ReadGifFile", "读文件时出错" '产生53号错误
  Exit Sub
End If
Dim c As Long
ReDim Preserve c_ColorTables.Tables(0 To PALETTECOUNT, 0 To TableSlot)
For c = 0 To c_aPOT(BitDepth) - 1 '
  c_ColorTables.Tables(c, TableSlot) = (c_gifData(c_Ptr) * &H10000) Or (c_gifData(c_Ptr + 1) * &H100&) Or c_gifData(c_Ptr + 2)
  c_Ptr = c_Ptr + 3
Next
c_ColorTables.Tables(PALETTECOUNT, TableSlot) = c_aPOT(BitDepth)
End Sub

Private Sub UpdateMask(Index As Long, bDisposing As Boolean, d3Mask() As Byte, d3Color() As Byte)
Dim Rows As Long, gD3row As Long
Dim mOffset As Long, mScanWidth As Long
Dim maskBytes() As Byte, colorBytes() As Byte
Dim maskSA As SAFEARRAY2D, colorSA As SAFEARRAY2D
Dim eRect As RECT, hBrush As Long

If Index = 1 Or c_Frames(Index).Disposal = 3 Then
  If Not c_BkBuff.hDibBW = 0& Then
    With maskSA
      .cbElements = 1
      .cDims = 2
      .pvData = c_BkBuff.dibPtrBW
      .rgSABound(0).cElements = c_gifProps.Height
      .rgSABound(1).cElements = ByteAlignOnWord(1, c_gifProps.Width)
    End With
    CopyMemory ByVal VarPtrArray(maskBytes), VarPtr(maskSA), 4&
  End If
  With colorSA      '缓冲区覆盖
    .cbElements = 1
    .cDims = 2
    .pvData = c_BkBuff.dibPtr
    .rgSABound(0).cElements = c_gifProps.Height
    .rgSABound(1).cElements = ByteAlignOnWord(24, c_gifProps.Width)
  End With
  CopyMemory ByVal VarPtrArray(colorBytes), VarPtr(colorSA), 4&
End If
If bDisposing Then
  With c_Frames(Index)
    Select Case .Disposal
      Case 2 '恢复成背景颜色
        SetRect eRect, .Dimensions.Left, .Dimensions.Top, .Dimensions.Left + .Dimensions.Right, .Dimensions.Top + .Dimensions.Bottom
        FillRect c_BkBuff.DC, eRect, GetStockObject(4&)
        If Not c_BkBuff.hDibBW = 0& Then
          SelectObject c_BkBuff.DC, c_BkBuff.hDibBW
          FillRect c_BkBuff.DC, eRect, GetStockObject(0&)
          SelectObject c_BkBuff.DC, c_BkBuff.hDib
        End If
      Case 3 '恢复成以前显示的图形
        mOffset = .Dimensions.Left * 3&
        mScanWidth = .Dimensions.Right * 3&
        For Rows = c_gifProps.Height - .Dimensions.Top - 1& To c_gifProps.Height - .Dimensions.Bottom - .Dimensions.Top Step -1&
          CopyMemory colorBytes(mOffset, Rows), d3Color(0, gD3row), mScanWidth
          gD3row = gD3row + 1&
        Next
        If Not c_BkBuff.hDibBW = 0& Then
          gD3row = 0&
          mOffset = .Dimensions.Left \ 8
          mScanWidth = ByteAlignOnWord(1, .Dimensions.Right)
          For Rows = c_gifProps.Height - .Dimensions.Top - 1& To c_gifProps.Height - .Dimensions.Bottom - .Dimensions.Top Step -1&
            CopyMemory maskBytes(mOffset, Rows), d3Mask(0, gD3row), mScanWidth
            gD3row = gD3row + 1&
          Next
        End If
    End Select
  End With
Else  '复制新帧
  With c_Frames(Index)
    If Index = 1 Then   '擦除第一帧
      FillMemory colorBytes(0, 0), colorSA.rgSABound(1).cElements * c_gifProps.Height, 0
      If Not c_BkBuff.hDibBW = 0& Then FillMemory maskBytes(0, 0), maskSA.rgSABound(1).cElements * c_gifProps.Height, 255
    End If
    If .Disposal = 3 Then '如果域值=3,恢复成以前显示的图形
      mOffset = .Dimensions.Left * 3&
      mScanWidth = .Dimensions.Right * 3&
      ReDim d3Color(0 To mScanWidth - 1&, 0 To .Dimensions.Bottom - 1&)
      For Rows = c_gifProps.Height - .Dimensions.Top - 1& To c_gifProps.Height - .Dimensions.Bottom - .Dimensions.Top Step -1&
        CopyMemory d3Color(0, gD3row), colorBytes(mOffset, Rows), mScanWidth
        gD3row = gD3row + 1&
      Next
      If Not c_BkBuff.hDibBW = 0& Then
        gD3row = 0&
        mScanWidth = ByteAlignOnWord(1, .Dimensions.Right)
        mOffset = .Dimensions.Left \ 8
        ReDim d3Mask(0 To mScanWidth - 1&, 0 To .Dimensions.Bottom - 1&)
        For Rows = c_gifProps.Height - .Dimensions.Top - 1& To c_gifProps.Height - .Dimensions.Bottom - .Dimensions.Top Step -1&
          CopyMemory d3Mask(0, gD3row), maskBytes(mOffset, Rows), mScanWidth
          gD3row = gD3row + 1&
        Next
      End If
    End If
  End With
  If Not c_BkBuff.hDibBW = 0& Then  '更新 mask
    SelectObject c_BkBuff.DC, c_BkBuff.hDibBW
    With c_Frames(Index)
      If .IsTransparent = 1 Then
        c_maskTable(.TransIndex) = vbWhite
        SetDIBColorTable c_DC.DC, 0&, c_ColorTables.Tables(PALETTECOUNT, .TblIndex), c_maskTable(0) ' put the table to the DIB
        c_maskTable(.TransIndex) = vbBlack
        BitBlt c_BkBuff.DC, .Dimensions.Left, .Dimensions.Top, .Dimensions.Right, .Dimensions.Bottom, c_DC.DC, .imgOffset, 0&, vbSrcAnd
      Else
        SetDIBColorTable c_DC.DC, 0&, c_ColorTables.Tables(PALETTECOUNT, .TblIndex), c_maskTable(0) ' put the table to the DIB
        BitBlt c_BkBuff.DC, .Dimensions.Left, .Dimensions.Top, .Dimensions.Right, .Dimensions.Bottom, c_DC.DC, .imgOffset, 0&, vbSrcCopy
      End If
    End With
    SelectObject c_BkBuff.DC, c_BkBuff.hDib
    c_ColorTables.Index = -1&
  End If
End If
If Not maskSA.pvData = 0& Then CopyMemory ByVal VarPtrArray(maskBytes), 0&, 4&
If Not colorSA.pvData = 0& Then CopyMemory ByVal VarPtrArray(colorBytes), 0&, 4&
End Sub

Private Function BuildBackBuffer(IncludeMask As Boolean) As Boolean
Dim dDC As Long, bErrors As Boolean, tBMPI As BITMAPINFO
With tBMPI.bmiHeader
  .biSize = 40
  .biBitCount = 24
  .biHeight = c_gifProps.Height
  .biWidth = c_gifProps.Width
  .biPlanes = 1
End With
dDC = GetDC(0&)
c_BkBuff.DC = CreateCompatibleDC(dDC)
If c_BkBuff.DC = 0& Then
  bErrors = True
Else
  c_BkBuff.hDib = CreateDIBSection(dDC, tBMPI, 0, c_BkBuff.dibPtr, 0, 0)
  If c_BkBuff.hDib = 0& Then
    bErrors = True
  Else
    c_BkBuff.hBmp = SelectObject(c_BkBuff.DC, c_BkBuff.hDib)
    If IncludeMask Then
      With tBMPI.bmiHeader
        .biBitCount = 1         ' monochrome mask
        .biClrUsed = 2
        .biClrImportant = 2
      End With
      tBMPI.bmiPalette(1) = vbWhite
      c_BkBuff.hDibBW = CreateDIBSection(dDC, tBMPI, 0, c_BkBuff.dibPtrBW, 0, 0)
      bErrors = (c_BkBuff.hDibBW = 0&)
    End If
  End If
End If
ReleaseDC 0&, dDC
BuildBackBuffer = Not bErrors
End Function

Private Sub Timer1_Timer()
If Not BjTemer Then Timer1.Enabled = False: BjTemer = True: BuildDIBstrip False '继续处理剩余的帧
Dim bRestart As Boolean
Dim bLoopComplete As Boolean
Dim tValue As Long
tValue = c_curFrame: c_curFrame = c_curFrame + 1: If BjPart Then picIndex = c_curFrame - 1
If c_curFrame > UBound(c_Frames) Then
  c_curFrame = 1: picIndex = 0
  If BjPart Then
    Timer1.Enabled = False: c_AniLoops = 0
    Exit Sub
  Else
    bLoopComplete = True
  End If
End If
If UBound(c_Frames) = 1 Then  '单帧图片
  c_AniLoops = 0
Else
  bRestart = True
  If bLoopComplete Then       '开始另一个循环
    If Not c_gifProps.Loops = 0 Then '已指定循环数
      c_AniLoops = c_AniLoops - 1    '循环剩余数
      If c_AniLoops = 0 Then bRestart = False
    End If
  End If
End If
RenderFrame
If bRestart Then '开始下一个循环
  Timer1.Interval = c_Frames(c_curFrame).Delay: Timer1.Enabled = True
End If
EH:
End Sub

Private Sub UnloadGIF() '释放内存
On Error Resume Next
Timer1.Enabled = False: c_curFrame = 0&: c_Ptr = 0&
Erase c_Frames()         '清除所有帧信息
With c_DC                '清除 GDI 内存对象
  If Not .hDib = 0& Then '删除所有 DIB
    DeleteObject SelectObject(.DC, .hBmp)
    .hDib = 0&
    .hBmp = 0&
  End If
  If Not .DC = 0& Then   '删除所有 DC
    DeleteDC .DC
    .DC = 0&
  End If
End With
With c_BkBuff
  If Not .hDib = 0& Then '删除所有创建的 DIB
    DeleteObject SelectObject(.DC, .hBmp)
    .hDib = 0&
    .hBmp = 0&
  End If
  If Not .hDibBW = 0& Then
    DeleteObject .hDibBW
    .hDibBW = 0&
  End If
  If Not .DC = 0& Then   '删除所有背景缓冲 DC
    DeleteDC .DC
    .DC = 0&
  End If
End With
Erase c_ColorTables.Tables()
Erase c_maskTable()
Erase c_aPOT()
Erase c_DataLen()
c_ColorTables.Index = 0&
If Err Then Err.Clear
End Sub