Planet Source Code Jumbo …e CD Visual Basic 1 to 7/4_2005-2006.ISO/data/Zips/Real_3D_Di1974452182006.psc/cGifReader.cls

Text File | 2006-02-17 | 23KB | 785 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cGifReader"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'=========================================================================
'
'   VB Gif Library Project
'   Copyright (c) 2003 Vlad Vissoultchev
'
'   GIF87a/89a reader. Implements an LZW decoder. Warning! use of this
'     code in commercial applications may fall under patent claims
'     from Unisys which are holding patents on LZW algorithm.
'
'=========================================================================
Option Explicit
Private Const MODULE_NAME As String = "cGifReader"

'=========================================================================
' Events
'=========================================================================

Event Progress(ByVal CurrentLine As Long)
Event ImageComplete()

'=========================================================================
' API
'=========================================================================

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

'=========================================================================
' Constants and member variables
'=========================================================================

Private Const ERR_INVALID_GIF_FILE      As String = "Invalid GIF file"
Private Const ERR_UNEXPECTED_BLOCK      As String = "Unexpected image block"
Private Const ERR_PAST_END_OF_STACK     As String = "Past end of stack (stacksize=4000)"
Private Const ERR_INVALID_LZW_CODE      As String = "Invalid LZW code encountered"
Private Const ERR_INPUT_PAST_EOF        As String = "Input past end of file"
Private Const STR_GIF87A                As String = "GIF87a"
Private Const STR_GIF89A                As String = "GIF89a"
Private Const MAX_BITS                  As Long = 12
Private Const TABLE_SIZE                As Long = 2 ^ MAX_BITS

'--- look-up table 'powers-of-two'
Private m_aPOT(-1 To 31)            As Long
'--- GIF file
Private m_nFile                     As Integer
Private m_sFileName                 As String
Private m_lFirstFrameLoc            As Long
Private m_bEOF                      As Boolean
'--- for GIF content
Private m_uHeader                   As UcsGifHeader
Private m_uImageDesc                As UcsGifImageDescriptor
Private m_uGraphicControl           As UcsGifGraphicControl
Private m_lFrameIndex               As Long
'--- for current frame buffers
Private m_aImageBits()              As Byte
Private m_aGlobalLut(0 To 767)      As Byte '--- 767 = 3 * 256 - 1
Private m_aImageLut(0 To 767)       As Byte
'--- for LZW decoder
Private m_lInitBits                 As Long
Private m_lClearTable               As Long
Private m_lInputBitCount            As Long
Private m_lInputBitBuffer           As Long
Private m_lCurrentBits              As Long
Private m_lMaxCode                  As Long
Private m_lSubBlockSize             As Long
Private m_aPrefixCode(0 To TABLE_SIZE) As Long
Private m_aAppendChar(0 To TABLE_SIZE) As Byte

Private Type UcsGifHeader
    aSigVersion(0 To 5)     As Byte
    nScreenWidth            As Integer
    nScreenHeight           As Integer
    bFlags                  As Byte
    bBackgroungColor        As Byte
    bAspectRatio            As Byte
End Type

Private Type UcsGifImageDescriptor
    nImageLeft              As Integer
    nImageTop               As Integer
    nImageWidth             As Integer
    nImageHeight            As Integer
    bFlags                  As Byte
End Type

Private Type UcsGifGraphicControl
    cbSize                  As Byte
    bFlags                  As Byte
    nDelayTime              As Integer
    bTransparentColor       As Byte
    bTerminator             As Byte
End Type

Private Enum UcsGifFlags
    '--- for header flags
    ucsGflGlobalLut = &H80
    ucsGflColorResolution = &H70
    ucsGflGlobalLutSorted = &H4
    ucsGflGlobalLutSize = &H7
    '--- for image descriptor flags
    ucsGflLocalLut = &H80
    ucsGflInterlace = &H40
    ucsGflLocalLutSorted = &H20
    ucsGflLocalLutSize = &H7
    '--- for graphics control
    ucsGflDisposalMethod = &H1C
    ucsGflUserInput = &H2
    ucsGflTransparentColor = &H1
End Enum

Private Enum UcsGifFileBlock
    ucsGblImageBlock = &H2C         '--- ","
    ucsGblExtension = &H21          '--- "!"
    ucsGblTrailer = &H3B            '--- ";"
End Enum

Private Enum UcsGifExtensionType
    ucsGexGraphicsControl = &HF9    '--- transparency etc. extension
End Enum

Public Enum UcsGifDisposalMethod
    ucsDsmNotSpecified
    ucsDsmDontDispose
    ucsDsmRestoreBackground
    ucsDsmRestorePrevious
End Enum

'=========================================================================
' Error management
'=========================================================================

Private Sub RaiseError(sFunction As String)

    With Err
        ' .Raise .Number, MODULE_NAME & "." & sFunction & IIf(Erl <> 0, "(" & Erl & ")", "") & vbCrLf _
            & .Source, .Description, .HelpFile, .HelpContext
    End With 'ERR

End Sub

Private Sub PrintError(sFunction As String)

    Debug.Print MODULE_NAME; "."; sFunction; IIf(Erl <> 0, "(" & Erl & ")", ""); ": "; Err.Description

End Sub

'=========================================================================
' Properties
'=========================================================================

Property Get filename() As String ':( Missing Scope

    filename = m_sFileName

End Property

Property Get SigVersion() As String ':( Missing Scope

    SigVersion = StrConv(m_uHeader.aSigVersion, vbUnicode)

End Property

Property Get HasGlobalLut() As Boolean ':( Missing Scope

    HasGlobalLut = (pvGetFlag(m_uHeader.bFlags, ucsGflGlobalLut) <> 0)

End Property

Property Get ScreenWidth() As Long ':( Missing Scope

    ScreenWidth = m_uHeader.nScreenWidth

End Property

Property Get ScreenHeight() As Long ':( Missing Scope

    ScreenHeight = m_uHeader.nScreenHeight

End Property

Property Get BackgroundColor() As Long ':( Missing Scope

    BackgroundColor = RGB(m_aImageLut(3 * m_uHeader.bBackgroungColor), _
                      m_aImageLut(3 * m_uHeader.bBackgroungColor + 1), _
                      m_aImageLut(3 * m_uHeader.bBackgroungColor + 2))

End Property

Property Get BackgroundIndex() As Long ':( Missing Scope

    BackgroundIndex = m_uHeader.bBackgroungColor

End Property

Property Get GlobalLutSize() As Long ':( Missing Scope

    GlobalLutSize = m_aPOT(1 + pvGetFlag(m_uHeader.bFlags, ucsGflGlobalLutSize))

End Property

Property Get IsInterlaced() As Boolean ':( Missing Scope

    IsInterlaced = (pvGetFlag(m_uImageDesc.bFlags, ucsGflInterlace) <> 0)

End Property

Property Get HasLocalLut() As Boolean ':( Missing Scope

    HasLocalLut = (pvGetFlag(m_uImageDesc.bFlags, ucsGflLocalLut) <> 0)

End Property

Property Get LocalLutSize() As Long ':( Missing Scope

    LocalLutSize = m_aPOT(1 + pvGetFlag(m_uImageDesc.bFlags, ucsGflLocalLutSize))

End Property

Property Get ImageLeft() As Long ':( Missing Scope

    ImageLeft = m_uImageDesc.nImageLeft

End Property

Property Get ImageTop() As Long ':( Missing Scope

    ImageTop = m_uImageDesc.nImageTop

End Property

Property Get ImageWidth() As Long ':( Missing Scope

    ImageWidth = m_uImageDesc.nImageWidth

End Property

Property Get ImageHeight() As Long ':( Missing Scope

    ImageHeight = m_uImageDesc.nImageHeight

End Property

Property Get IsTransparent() As Boolean ':( Missing Scope

    IsTransparent = (pvGetFlag(m_uGraphicControl.bFlags, ucsGflTransparentColor) <> 0)

End Property

Property Get TransparentColor() As Long ':( Missing Scope

    TransparentColor = RGB(m_aImageLut(3 * m_uGraphicControl.bTransparentColor), _
                       m_aImageLut(3 * m_uGraphicControl.bTransparentColor + 1), _
                       m_aImageLut(3 * m_uGraphicControl.bTransparentColor + 2))

End Property

Property Get TransparentIndex() As Long ':( Missing Scope

    TransparentIndex = m_uGraphicControl.bTransparentColor

End Property

'--- note: usually this is interpreted as 'gif animation is looped'
Property Get UserInput() As Boolean ':( Missing Scope

    UserInput = (pvGetFlag(m_uGraphicControl.bFlags, ucsGflUserInput) <> 0)

End Property

Property Get DisposalMethod() As UcsGifDisposalMethod ':( Missing Scope

    DisposalMethod = pvGetFlag(m_uGraphicControl.bFlags, ucsGflDisposalMethod)

End Property

Property Get ImageLut() As Byte() ':( Missing Scope

    ImageLut = m_aImageLut

End Property

Property Get ImageBits() As Byte() ':( Missing Scope

    ImageBits = m_aImageBits

End Property

Property Get FrameIndex() As Long ':( Missing Scope

    FrameIndex = m_lFrameIndex

End Property

Property Get EOF() As Boolean ':( Missing Scope

    EOF = m_bEOF

End Property

Property Get DelayTime() As Long ':( Missing Scope

    DelayTime = m_uGraphicControl.nDelayTime

End Property

'=========================================================================
' Methods
'=========================================================================

Private Function pvFileExists(sFilename As String) As Boolean

    On Error Resume Next
      pvFileExists = (GetAttr(sFilename) <> -1)
    On Error GoTo 0

End Function

Public Function Init(sFilename As String) As Boolean

  Const FUNC_NAME     As String = "Init"
  Dim lIdx            As Long
  Dim bColor          As Boolean

    On Error GoTo EH
    '--- init/clear member vars
    m_sFileName = sFilename
    FillMemory m_uImageDesc, Len(m_uImageDesc), 0
    FillMemory m_uGraphicControl, Len(m_uGraphicControl), 0
    m_lFrameIndex = -1
    m_bEOF = False
    '--- check if file exists
    If Not pvFileExists(sFilename) Then
        Exit Function '>---> Bottom
    End If
    '--- open file (first close previous)
    pvCloseFile
    m_nFile = FreeFile()
    Open filename For Binary Shared As #m_nFile
    '--- get file header
    pvReadBuffer VarPtr(m_uHeader), Len(m_uHeader) '--- 13
    If SigVersion <> STR_GIF87A And SigVersion <> STR_GIF89A Then
        Err.Raise vbObject, , ERR_INVALID_GIF_FILE
    End If
    '--- get global LUT
    If HasGlobalLut Then
        pvReadBuffer VarPtr(m_aGlobalLut(0)), 3 * GlobalLutSize
    End If
    m_lFirstFrameLoc = Seek(m_nFile)
    '--- success
    Init = True

Exit Function

EH:
    RaiseError FUNC_NAME

End Function

Public Function MoveNext() As Boolean

  Const FUNC_NAME     As String = "MoveNext"

    On Error GoTo EH
    '--- check if anything's left
    If m_nFile = 0 Or m_bEOF Then
        Exit Function '>---> Bottom
    End If
    Do While True
        Select Case pvReadByte()
          Case ucsGblImageBlock
            m_lFrameIndex = m_lFrameIndex + 1
            '--- get image desc
            pvReadBuffer VarPtr(m_uImageDesc), Len(m_uImageDesc) '--- 9
            '--- get image LUT
            If HasLocalLut Then
                pvReadBuffer VarPtr(m_aImageLut(0)), 3 * LocalLutSize
              Else 'HASLOCALLUT = 0
                CopyMemory m_aImageLut(0), m_aGlobalLut(0), 3 * 256
            End If
            '--- init vars for LZW decoding
            m_lInitBits = pvReadByte() + 1
            m_lClearTable = m_aPOT(m_lInitBits - 1)
            m_lInputBitCount = 0
            m_lInputBitBuffer = 0
            m_lCurrentBits = m_lInitBits
            m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
            m_lSubBlockSize = 0
            ReDim m_aImageBits(0 To ImageWidth * ImageHeight)
            pvLzwExpand m_aImageBits, UBound(m_aImageBits)
            '--- read to the end of block
            Do
                '--- skip to the end end of sub-block
                Do While m_lSubBlockSize > 0
                    pvReadSubBlockByte
                Loop
                '--- check for block terminator
                m_lSubBlockSize = pvReadByte()
            Loop While m_lSubBlockSize > 0
            RaiseEvent ImageComplete
            Exit Do '>---> Loop
          Case ucsGblExtension
            '--- look for 'Graphic Control Label' extension
            Select Case pvReadByte()
              Case ucsGexGraphicsControl
                '--- fill member struct
                pvReadBuffer VarPtr(m_uGraphicControl), Len(m_uGraphicControl)
              Case Else
                '--- unknown extension
                pvSkipBlock
            End Select
          Case ucsGblTrailer
            m_bEOF = True
            Exit Function '>---> Bottom
          Case 0 '--- silence this just in case
            Debug.Print MODULE_NAME; "."; FUNC_NAME; ": "; ERR_UNEXPECTED_BLOCK; " = 0"
          Case Else
            Err.Raise vbObjectError + 1, , ERR_UNEXPECTED_BLOCK
        End Select
    Loop
    '--- success
    MoveNext = True

Exit Function

EH:
    m_bEOF = True
    RaiseError FUNC_NAME

End Function

Public Function MoveFirst() As Boolean

  Const FUNC_NAME     As String = "MoveFirst"

    On Error GoTo EH
    '--- state check
    If m_nFile = 0 Then
        Exit Function '>---> Bottom
    End If
    Seek #m_nFile, m_lFirstFrameLoc
    m_lFrameIndex = -1
    m_bEOF = False
    '--- success
    MoveFirst = True

Exit Function

EH:
    RaiseError FUNC_NAME

End Function

Public Function MoveLast() As Long

  Const FUNC_NAME     As String = "MoveLast"

    On Error GoTo EH
    '--- state check
    If m_nFile = 0 Then
        Exit Function '>---> Bottom
    End If
    If Not EOF Then
        Do While True
            Select Case pvReadByte()
              Case ucsGblImageBlock
                m_lFrameIndex = m_lFrameIndex + 1
                pvReadBuffer VarPtr(m_uImageDesc), Len(m_uImageDesc) '--- 9
                If HasLocalLut Then
                    pvReadBuffer VarPtr(m_aImageLut(0)), 3 * LocalLutSize
                End If
                pvReadByte '--- initial bits
                pvSkipBlock
              Case ucsGblExtension
                pvReadByte '--- extension type
                pvSkipBlock
              Case ucsGblTrailer
                m_bEOF = True
                Exit Do '>---> Loop
              Case 0
              Case Else
                Err.Raise vbObjectError + 1, , ERR_UNEXPECTED_BLOCK
            End Select
        Loop
    End If
    '--- success
    MoveLast = True

Exit Function

EH:
    RaiseError FUNC_NAME

End Function

'= private ===============================================================

Private Function pvGetFlag(ByVal lFlags As Long, ByVal lMask As UcsGifFlags) As Long

    If lMask > 0 Then
        pvGetFlag = (lFlags And lMask)
        Do While (lMask And 1) = 0
            lMask = lMask \ 2
            pvGetFlag = pvGetFlag \ 2
        Loop
    End If

End Function

Private Function pvPadScanline(ByVal lOffset As Long)

  '--- DIB section horizontal scanline padding to dword

    pvPadScanline = (lOffset + 3) And (Not 3)

End Function

'= I/O handling ==========================================================

Private Function pvReadByte() As Byte

  Const FUNC_NAME     As String = "pvReadByte"

    On Error GoTo EH
    If VBA.EOF(m_nFile) Then
        Err.Raise vbObjectError + 4, , ERR_INPUT_PAST_EOF
    End If
    Get #m_nFile, , pvReadByte

Exit Function

EH:
    RaiseError FUNC_NAME

End Function

Private Sub pvReadBuffer(ByVal pAddr As Long, ByVal lSize)

  Const FUNC_NAME     As String = "pvReadBuffer"
  Dim lIdx            As Long

    On Error GoTo EH
    '--- read from stream to local buffer
    ReDim aBuf(0 To lSize) As Byte
    For lIdx = 0 To lSize - 1
        aBuf(lIdx) = pvReadByte()
    Next lIdx
    '--- copy if necessary
    If pAddr <> 0 Then
        CopyMemory ByVal pAddr, aBuf(0), lSize
    End If

Exit Sub

EH:
    RaiseError FUNC_NAME

End Sub

Private Function pvReadSubBlockByte() As Byte

  Const FUNC_NAME     As String = "pvReadSubBlockByte"

    On Error GoTo EH
    If m_lSubBlockSize <= 0 Then
        m_lSubBlockSize = pvReadByte()
        '--- workaround for 3D Studio R4's non-compliant GIFs
        If m_lSubBlockSize = 0 Then
            m_lSubBlockSize = 256
        End If
    End If
    pvReadSubBlockByte = pvReadByte()
    m_lSubBlockSize = m_lSubBlockSize - 1

Exit Function

EH:
    RaiseError FUNC_NAME

End Function

Private Sub pvCloseFile()

  Const FUNC_NAME     As String = "pvCloseFile"

    On Error GoTo EH
    If m_nFile <> 0 Then
        Close #m_nFile
        m_nFile = 0
    End If

Exit Sub

EH:
    RaiseError FUNC_NAME

End Sub

Private Sub pvSkipBlock()

    Do
        m_lSubBlockSize = pvReadByte()
        Seek #m_nFile, Seek(m_nFile) + m_lSubBlockSize
    Loop While m_lSubBlockSize > 0

End Sub

'= LZW decompressor ======================================================

Private Function pvLzwReadCode() As Long

  Const FUNC_NAME     As String = "pvLzwReadCode"

    On Error GoTo EH
    Do While m_lInputBitCount < m_lCurrentBits
        m_lInputBitBuffer = m_lInputBitBuffer Or (pvReadSubBlockByte() * m_aPOT(m_lInputBitCount))
        m_lInputBitCount = m_lInputBitCount + 8
    Loop
    pvLzwReadCode = m_lInputBitBuffer And (m_aPOT(m_lCurrentBits) - 1)
    m_lInputBitBuffer = m_lInputBitBuffer \ m_aPOT(m_lCurrentBits)
    m_lInputBitCount = m_lInputBitCount - m_lCurrentBits

Exit Function

EH:
    RaiseError FUNC_NAME

End Function

Private Function pvLzwDecodeString(aStack() As Byte, ByVal lIdx As Long, _
                                   ByVal lCode As Long) As Long

  Const FUNC_NAME     As String = "pvLzwDecodeString"

    On Error GoTo EH
    Do While lCode >= m_lClearTable
        aStack(lIdx) = m_aAppendChar(lCode)
        lIdx = lIdx + 1
        lCode = m_aPrefixCode(lCode)
        If lIdx > UBound(aStack) Then
            Err.Raise vbObjectError + 2, , ERR_PAST_END_OF_STACK
        End If
    Loop
    aStack(lIdx) = lCode
    pvLzwDecodeString = lIdx

Exit Function

EH:
    RaiseError FUNC_NAME

End Function

Private Sub pvLzwExpand(aBuffer() As Byte, ByVal lBufSize)

  Const FUNC_NAME     As String = "pvLzwExpand"
  Dim lIdx            As Long
  Dim lNewCode        As Long
  Dim lOldCode        As Long
  Dim lNextCode       As Long
  Dim bCharacter      As Byte
  Dim bClearFlag      As Boolean
  Dim aStack(0 To 4000) As Byte
  Dim lStackIdx       As Long
  Dim lPrevProgess    As Long

    On Error GoTo EH
    lNextCode = m_lClearTable + 2 '--- first code = m_lClearTable + 2
    bClearFlag = True
    lNewCode = pvLzwReadCode()
    Do While lIdx < lBufSize
        lNewCode = pvLzwReadCode()
        '--- check for terminator
        If lNewCode = m_lClearTable + 1 Then '--- terminator = m_lClearTable + 1
            Exit Sub '>---> Bottom
        End If
        If bClearFlag Then
            bClearFlag = False
            lOldCode = lNewCode
            bCharacter = lNewCode
            aBuffer(lIdx) = bCharacter
            lIdx = lIdx + 1
          ElseIf lNewCode = m_lClearTable Then 'BCLEARFLAG = 0
            bClearFlag = True
            m_lCurrentBits = m_lInitBits
            m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
            lNextCode = m_lClearTable + 2 '--- first code = m_lClearTable + 2
          Else 'NOT LNEWCODE...
            '--- decode string
            If lNewCode < lNextCode Then
                lStackIdx = pvLzwDecodeString(aStack, 0, lNewCode)
              ElseIf lNewCode = lNextCode Then 'NOT LNEWCODE...
                aStack(0) = bCharacter
                lStackIdx = pvLzwDecodeString(aStack, 1, lOldCode)
              Else 'NOT LNEWCODE...
                Err.Raise vbObjectError + 3, , ERR_INVALID_LZW_CODE
            End If
            '--- save first char
            bCharacter = aStack(lStackIdx)
            '--- reverse copy stack
            Do While lStackIdx >= 0
                aBuffer(lIdx) = aStack(lStackIdx)
                lStackIdx = lStackIdx - 1
                lIdx = lIdx + 1
            Loop
            '--- keep char table up-to-date
            m_aPrefixCode(lNextCode) = lOldCode
            m_aAppendChar(lNextCode) = bCharacter
            lNextCode = lNextCode + 1
            '--- expand code bitsize if max reached
            If lNextCode > m_lMaxCode Then
                If m_lCurrentBits < MAX_BITS Then
                    m_lCurrentBits = m_lCurrentBits + 1
                    m_lMaxCode = m_aPOT(m_lCurrentBits) - 1
                End If
            End If
            lOldCode = lNewCode
        End If
        '--- report progress
        lStackIdx = lIdx \ ImageWidth
        If lStackIdx >= lPrevProgess + 10 Then
            RaiseEvent Progress(lStackIdx)
            lPrevProgess = lStackIdx
        End If
    Loop

Exit Sub

EH:
    RaiseError FUNC_NAME

End Sub

'=========================================================================
' Base class events
'=========================================================================

Private Sub Class_Initialize()

  Dim lIdx            As Long

    '--- init look-up table for fast 2 ^ x
    m_aPOT(-1) = 0
    m_aPOT(0) = 1
    For lIdx = 1 To 30
        m_aPOT(lIdx) = 2 * m_aPOT(lIdx - 1)
    Next lIdx
    m_aPOT(31) = &H80000000

End Sub

Private Sub Class_Terminate()

  Dim lErrNum         As Long
  Dim sErrSrc         As String
  Dim sErrDesc        As String

    '--- preserve error info and try not to throw one
    '--- best practices: "destructors are never throwing an exception"
    lErrNum = Err.Number
    sErrSrc = Err.Source
    sErrDesc = Err.Description
    On Error Resume Next
      pvCloseFile
    On Error GoTo 0
    Err.Number = lErrNum
    Err.Source = sErrSrc
    Err.Description = sErrDesc

End Sub

':) Ulli's VB Code Formatter V2.3.18 (17/2/2006 13:50:19) 126 + 645 = 771 Lines