vbAccelerator - Contents of code file: cAVIFrameExtract.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cAVIFrameExtract"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit


Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
 (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal
 dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments
 As Long) As Long

Private Type RECT
   Left As Long
   TOp As Long
   Right As Long
   Bottom As Long
End Type

Private Type BITMAPINFOHEADER '40 bytes
    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 BITMAPINFO2
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 1) As RGBQUAD
End Type
Private Type BITMAPINFO16
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 15) As RGBQUAD
End Type
Private Type BITMAPINFO256
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
End Type

Private Const ERR_BASE As Long = vbObjectError + 1024 + 77561

Private Const STREAM_TYPE_VIDEO = &H73646976 ' reads "vids"

Private Const OF_READ = &H0
Private Const OF_SHARE_EXCLUSIVE = &H10

Private Const AVIIF_LIST = &H1                 ' // chunk is a 'LIST'
Private Const AVIIF_KEYFRAME = &H10      '// this frame is a key frame.
Private Const AVIIF_FIRSTPART = &H20     '// this frame is the start of a
 partial frame.
Private Const AVIIF_LASTPART = &H40      '// this frame is the end of a partial
 frame.
Private Const AVIIF_MIDPART = (AVIIF_LASTPART Or AVIIF_FIRSTPART)
Private Const AVIIF_NOTIME = &H100     '// this frame doesn't take any time
Private Const AVIIF_COMPUSE = &HFFF0000      ' // these bits are for compressor
 use

Private Type TAVISTREAMINFO ' this is the ANSI version
    fccType As Long
    fccHandler As Long
    dwFlags As Long         '/* Contains AVITF_* flags */
    dwCaps As Long
    wPriority As Integer
    wLanguage As Integer
    dwScale As Long
    dwRate As Long ' /* dwRate / dwScale == samples/second */
    dwStart As Long
    dwLength As Long '; /* In units above... */
    dwInitialFrames As Long
    dwSuggestedBufferSize As Long
    dwQuality As Long
    dwSampleSize As Long
    rcFrame As RECT
    dwEditCount As Long
    dwFormatChangeCount As Long
    szName(0 To 63) As Byte
End Type

Private Declare Sub AVIFileInit Lib "avifil32.dll" ()
Private Declare Sub AVIFileExit Lib "avifil32.dll" ()
Private Declare Function AVIStreamOpenFromFile Lib "avifil32.dll" Alias
 "AVIStreamOpenFromFileA" ( _
      ppavi As Any, ByVal szFile As String, _
      ByVal fccType As Long, ByVal lParam As Long, _
      ByVal mode As Long, pclsidHandler As Any _
   ) As Long
Private Declare Function AVIFileCreateStream Lib "avifil32.dll" ( _
      pfile As Any, _
      ppavi As Any, _
      psi As TAVISTREAMINFO _
   ) As Long
Private Declare Function AVIStreamSetFormat Lib "avifil32.dll" ( _
      pavi As Any, _
      ByVal lPos As Long, _
      lpFormat As Any, _
      ByVal cbFormat As Long _
   ) As Long
Private Declare Function AVIStreamRelease Lib "avifil32.dll" (pavi As Any) As
 Long
Private Declare Function AVIStreamLength Lib "avifil32.dll" (pavi As Any) As
 Long
Private Declare Function AVIStreamGetFrameOpen Lib "avifil32.dll" ( _
         pavi As Any, lpbiWanted As Any _
      ) As Long
Private Declare Function AVIStreamGetFrameClose Lib "avifil32.dll" (pg As Any)
 As Long
Private Declare Function AVIStreamStart Lib "avifil32.dll" (pavi As Any) As Long
Private Declare Function AVIStreamSampleToTime Lib "avifil32.dll" (pavi As Any,
 ByVal lSample As Long) As Long
Private Declare Sub AVIStreamInfo Lib "avifil32.dll" Alias "AVIStreamInfoA"
 (pavi As Any, psi As TAVISTREAMINFO, ByVal lSize As Long)
Private Declare Function AVIStreamRead Lib "avifil32.dll" ( _
      pavi As Any, _
      ByVal lStart As Long, _
      ByVal lSamples As Long, _
      lpBuffer As Any, _
      ByVal cbBuffer As Long, _
      plBytes As Long, _
      plSamples As Long _
   ) As Long
Private Declare Function AVIStreamWrite Lib "avifil32.dll" ( _
      pavi As Any, _
      ByVal lStart As Long, _
      ByVal lSamples As Long, _
      lpBuffer As Any, _
      ByVal cbBuffer As Long, _
      ByVal dwFlags As Long, _
      plSampWritten As Long, _
      plBytesWritten As Long _
   ) As Long
Private Declare Function AVIStreamReadFormat Lib "avifil32.dll" ( _
      pavi As Any, _
      ByVal lPos As Long, _
      lpFormat As Any, _
      ByRef lpcbFormat As Long) As Long
Private Declare Function AVIStreamGetFrame Lib "avifil32.dll" (pg As Any, ByVal
 lPos As Long) As Long

Private Declare Function DrawDibOpen Lib "MSVFW32.dll" () As Long
Private Declare Function DrawDibClose Lib "MSVFW32.dll" (ByVal hDD As Long) As
 Long
Private Declare Function DrawDibDraw Lib "MSVFW32.dll" (ByVal hDD As Long,
 ByVal hDC As Long, _
      ByVal xDst As Long, ByVal yDst As Long, ByVal dxDst As Long, ByVal dyDst
       As Long, _
      lpBI As Any, lpBits As Any, _
      ByVal xSrc As Long, ByVal ySrc As Long, ByVal dxSrc As Long, ByVal dySrc
       As Long, _
      ByVal wFlags As Long) As Long
   
Private Declare Function GetPixelAPI Lib "gdi32" Alias "GetPixel" (ByVal hDC As
 Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long,
 ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" ( _
    ByVal lpDriverName As String, lpDeviceName As Any, _
   lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As
 Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (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 SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal
 crColor As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long

Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL"
 (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic
 As IPicture) As Long

Private Type TICINFO
    dwSize As Long ';                 // sizeof(ICINFO)
    fccType As Long ';                // compressor type     'vidc' 'audc'
    fccHandler As Long ';             // compressor sub-type 'rle ' 'jpeg' 'pcm
     '
    dwFlags As Long ';                // flags LOWORD is type specific
    dwVersion As Long ';              // version of the driver
    dwVersionICM As Long ';           // version of the ICM used
    '//
    '// under Win32, the driver always returns UNICODE strings.
    '//
    'WCHAR   szName[16];             // short name
    szName(0 To 31) As Byte
    'WCHAR   szDescription[128];     // long name
    szDescription(0 To 255) As Byte
    'WCHAR   szDriver[128];          // driver that contains compressor
    szDriver(0 To 255) As Byte
End Type

Private Declare Function ICInfo Lib "MSVFW32.dll" ( _
    ByVal fccType As Long, _
    ByVal fccHandler As Long, _
    lpicinfo As Any _
    ) As Long

Public Enum EBitmapCompressionTypes
   BI_RGB = 0&
   BI_RLE8 = 1&
End Enum
   
Private m_sFileName As String
Private m_pAS As Long
Private m_pGF As Long
Private m_hDrawDib As Long
Private m_lFrames As Long
Private m_lFrameDuration As Long
Private m_tBMIH As BITMAPINFOHEADER
Private m_tBMIHBlank As BITMAPINFOHEADER
Private m_tBMI256 As BITMAPINFO256
Private m_cPal As cPalette
Private m_tAVI As TAVISTREAMINFO
Private m_tICI As TICINFO

Public Property Get Filename() As String
   Filename = m_sFileName
End Property

Public Property Let Filename(ByVal value As String)
   Unload
   m_sFileName = value
   Dim lErr As Long
   If (FileExists(value, lErr)) Then
      Load
   Else
      pErr 1
   End If
End Property

Private Function FileExists(ByVal file As String, ByRef lErr As Long) As Boolean
Dim sTest As String
   On Error Resume Next
   sTest = Dir(file)
   lErr = Err.Number
   FileExists = ((lErr = 0) And Len(sTest) > 0)
   On Error GoTo 0
End Function

Private Sub Unload()
Dim bS As Boolean

   ' close frame interface
   If (m_pGF) Then
      bS = (AVIStreamGetFrameClose(ByVal m_pGF) = 0)
      m_pGF = 0
   End If

   ' release avi stream
   If Not (m_pAS = 0) Then
      AVIStreamRelease ByVal m_pAS
      m_pAS = 0
   End If
   
   m_lFrames = 0
   m_lFrameDuration = 0
   
   ' reset bitmap info details:
   LSet m_tBMIH = m_tBMIHBlank
   
   ' clear up the palette
   Set m_cPal = Nothing
   
End Sub

Private Sub Load()
Dim hR As Long
Dim totalTime As Long
Dim hIC As Long
   
   hR = AVIStreamOpenFromFile(m_pAS, m_sFileName, STREAM_TYPE_VIDEO, _
                      0, OF_READ Or OF_SHARE_EXCLUSIVE, ByVal 0&)
   If FAILED(hR) Then
      m_pAS = 0
      Unload
      pErr 2
   Else
      ' open frames
      m_pGF = AVIStreamGetFrameOpen(ByVal m_pAS, ByVal 0&)
      If (m_pGF = 0) Then
         Unload
         pErr 3
      Else
         ' get number of frames
         m_lFrames = AVIStreamLength(ByVal m_pAS)
         If (m_lFrames = 0) Then
            Unload
            pErr 4
         Else
            ' calculate timer delay
            totalTime = AVIStreamEndTime()
            m_lFrameDuration = (totalTime / m_lFrames)
            
            ' Get the AVI format:
            Dim lSize As Long
            hR = AVIStreamReadFormat(ByVal m_pAS, 0, ByVal 0&, lSize)
            If (FAILED(hR) Or lSize < LenB(m_tBMIH)) Then
               pErr 5
            Else
               Debug.Print lSize
               lSize = LenB(m_tBMIH)
               
               hR = AVIStreamReadFormat(ByVal m_pAS, 0, m_tBMIH, lSize)
               If FAILED(hR) Then
                  ' An error here may not actually be an error,
                  ' just that we only read part of the buffer
                  Debug.Print "Read format error: " & Hex(hR)
               End If
               
               ' Palette reader
               If (m_tBMIH.biBitCount <= 8) Then
                  Set m_cPal = New cPalette
                  Select Case m_tBMIH.biBitCount
                  Case 8
                     lSize = LenB(m_tBMI256)
                     hR = AVIStreamReadFormat(ByVal m_pAS, 0, m_tBMI256, lSize)
                     m_cPal.CreateFromRGBQuadArray m_tBMI256.bmiColors
                  Case Else
                     pErr 6
                  End Select
               End If
               
               ' Read AVI Info:
               AVIStreamInfo ByVal m_pAS, m_tAVI, LenB(m_tAVI)
               
               Debug.Print "Rate:" & m_tAVI.dwRate
               Debug.Print "Scale:" & m_tAVI.dwScale
               Debug.Print "FrameDuration:" & FrameDuration
               
               
               ' Get driver info
               m_tICI.dwSize = LenB(m_tICI)
               ICInfo m_tAVI.fccType, m_tAVI.fccHandler, m_tICI
                              
            End If
            
         End If
      End If
   End If
   
End Sub

Public Property Get Name() As String
Dim sName As String
Dim iPos As Long
   sName = StrConv(m_tAVI.szName, vbUnicode)
   iPos = InStr(sName, vbNullChar)
   If (iPos > 0) Then
      sName = Left(sName, iPos - 1)
   End If
   Name = sName
End Property

Public Property Get Palette() As cPalette
   Set Palette = m_cPal
End Property

Public Property Get Width() As Long
   Width = m_tBMIH.biWidth
End Property

Public Property Get Height() As Long
   Height = m_tBMIH.biHeight
End Property

Public Property Get bitsPerPixel() As Long
   bitsPerPixel = m_tBMIH.biBitCount
End Property

Public Property Get Compression() As EBitmapCompressionTypes
   Compression = m_tBMIH.biCompression
End Property

Public Property Get FrameCount() As Long
   FrameCount = m_lFrames
End Property

Public Property Get FrameDuration() As Long
   FrameDuration = m_lFrameDuration
End Property

Public Property Get VideoHandlerFourCC() As Long
   VideoHandlerFourCC = m_tAVI.fccHandler
End Property

Public Property Get VideoHandlerFourCCString() As String
   VideoHandlerFourCCString = FourCCToString(m_tAVI.fccHandler)
End Property

Public Property Get VideoTypeFourCC() As Long
   VideoTypeFourCC = m_tAVI.fccType
End Property

Public Property Get VideoTypeFourCCString() As String
   VideoTypeFourCCString = FourCCToString(m_tAVI.fccType)
End Property


' Research these
'Public Property Get VideoHandlerName() As String
'   VideoHandlerName = m_tICI.szName
'End Property

'Public Property Get VideoHandlerDescription() As String
'   VideoHandlerDescription = m_tICI.szDescription
'End Property

'Public Property Get VideoHandlerDriver() As String
'   VideoHandlerDriver = m_tICI.szDriver
'End Property
' End Research these

Public Property Get FrameBitmap( _
      ByVal Index As Long, _
      Optional ByVal lWidth As Long = -1, _
      Optional ByVal lHeight As Long = -1, _
      Optional ByVal NewBackColor As OLE_COLOR = -1 _
   ) As cBmp
Dim hDCDisplay As Long
Dim hDCComp As Long
Dim hBmp As Long
Dim hBmpOld As Long
Dim tR As RECT
Dim hBr As Long
   
   ' Prepare parameters:
   If (lWidth < 0) Then lWidth = Width
   If (lHeight < 0) Then lHeight = Height
   
   ' Create a DC and bitmap to draw to:
   hDCDisplay = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   hDCComp = CreateCompatibleDC(hDCDisplay)
   hBmp = CreateCompatibleBitmap(hDCDisplay, lWidth, lHeight)
   hBmpOld = SelectObject(hDCComp, hBmp)
   DeleteDC hDCDisplay
   
   ' If back color set, then fill:
   If Not (NewBackColor = -1) Then
      tR.Right = lWidth
      tR.Bottom = lHeight
      hBr = CreateSolidBrush(TranslateColor(NewBackColor))
      FillRect hDCComp, tR, hBr
      DeleteObject hBr
   End If
   
   ' Draw the frame into the DC:
   DrawFrame hDCComp, Index, , , lWidth, lHeight, (NewBackColor = -1)
   
   ' Select the bitmap out:
   SelectObject hDCComp, hBmpOld
   
   Dim cB As New cBmp
   cB.Init hBmp
   Set FrameBitmap = cB
   
   ' Clear up
   DeleteDC hDCComp
   
End Property
Public Property Get FramePicture( _
      ByVal Index As Long, _
      Optional ByVal lWidth As Long = -1, _
      Optional ByVal lHeight As Long = -1, _
      Optional ByVal NewBackColor As OLE_COLOR = -1 _
   ) As StdPicture
   
   Dim cB As cBmp
   Dim hBmp As Long
   Set cB = FrameBitmap(Index, lWidth, lHeight, NewBackColor)
   hBmp = cB.ExtracthBmp()
   Set FramePicture = BitmapToPicture(hBmp)
   
End Property

Public Sub DrawFrame( _
      ByVal lhDC As Long, _
      ByVal Index As Long, _
      Optional ByVal x As Long = 0, _
      Optional ByVal y As Long = 0, _
      Optional ByVal lWidth As Long = -1, _
      Optional ByVal lHeight As Long = -1, _
      Optional ByVal Transparent As Boolean = False _
   )
Dim lpBI As Long
Dim hDCComp As Long
Dim hBmp As Long
Dim hBmpOld As Long

   ' Prepare parameters:
   If (lWidth < 0) Then lWidth = Width
   If (lHeight < 0) Then lHeight = Height
   Index = Index - 1

   ' Get the uncompressed frame:
   lpBI = AVIStreamGetFrame(ByVal m_pGF, Index)
   If (lpBI) Then
      If (Transparent) Then
         ' Create a work dc
         hDCComp = CreateCompatibleDC(lhDC)
         hBmp = CreateCompatibleBitmap(lhDC, lWidth, lHeight)
         hBmpOld = SelectObject(hDCComp, hBmp)
         
         DrawDibDraw m_hDrawDib, hDCComp, 0, 0, _
                     lWidth, lHeight, ByVal lpBI, ByVal 0&, _
                     0, 0, -1, -1, 0
         
         DrawTransparent hDCComp, lhDC, x, y, lWidth, lHeight
         
         SelectObject hDCComp, hBmpOld
         DeleteObject hBmp
         DeleteDC hDCComp
      Else
         ' Draw it directly onto the display:
         DrawDibDraw m_hDrawDib, lhDC, x, y, _
            lWidth, lHeight, ByVal lpBI, ByVal 0&, _
            0, 0, -1, -1, 0
      End If
   End If
   
End Sub

Private Sub DrawTransparent( _
      ByVal hDCSrc As Long, _
      ByVal hDCDest As Long, _
      ByVal x As Long, _
      ByVal y As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long _
   )
Dim hDCMask As Long
Dim hBmpMask As Long
Dim hBmpMaskOld As Long
Dim hDCMem As Long
Dim hBmpMem As Long
Dim hBmpMemOld As Long
   
   ' Prepare the mask DC & bitmap
   hDCMask = CreateCompatibleDC(0)
   hBmpMask = CreateCompatibleBitmap(hDCMask, lWidth, lHeight)
   hBmpMaskOld = SelectObject(hDCMask, hBmpMask)
   
   ' Prepare the output DC & bitmap
   hDCMem = CreateCompatibleDC(hDCDest)
   hBmpMem = CreateCompatibleBitmap(hDCDest, lWidth, lHeight)
   hBmpMemOld = SelectObject(hDCMem, hBmpMem)
   
   ' Copy the background into the output:
   BitBlt hDCMem, 0, 0, lWidth, lHeight, hDCDest, x, y, vbSrcCopy
   
   ' Set background colour of source to the top-left pixel of the AVI
   SetBkColor hDCSrc, GetPixelAPI(hDCSrc, 0, 0)
   ' Copy source onto the mask bitmap:
   BitBlt hDCMask, 0, 0, lWidth, lHeight, hDCSrc, 0, 0, vbSrcCopy

   ' Set fore/back colour of source DC to black/white
   SetBkColor hDCSrc, &H0&
   SetTextColor hDCSrc, &HFFFFFF
   ' AND the mask onto the source:
   BitBlt hDCSrc, 0, 0, lWidth, lHeight, hDCMask, 0, 0, vbSrcAnd

   ' Set fore/back color of the output DC to white/black:
   SetBkColor hDCMem, &HFFFFFF
   SetTextColor hDCMem, &H0&
   ' AND the mask onto the output
   BitBlt hDCMem, 0, 0, lWidth, lHeight, hDCMask, 0, 0, vbSrcAnd
   ' XOR source onto output
   BitBlt hDCMem, 0, 0, lWidth, lHeight, hDCSrc, 0, 0, vbSrcPaint

   ' Copy to destination:
   BitBlt hDCDest, x, y, lWidth, lHeight, hDCMem, 0, 0, vbSrcCopy

   
   ' Clear up the output DC & bitmap
   SelectObject hDCMem, hBmpMemOld
   DeleteObject hBmpMem
   DeleteDC hDCMem
   
   ' Clear up the mask DC & bitmap
   SelectObject hDCMask, hBmpMaskOld
   DeleteObject hBmpMask
   DeleteDC hDCMask

End Sub

Private Function AVIStreamEndTime() As Long
Dim lSample As Long
   lSample = AVIStreamStart(ByVal m_pAS) + AVIStreamLength(ByVal m_pAS)
   AVIStreamEndTime = AVIStreamSampleToTime(ByVal m_pAS, lSample)
End Function

Private Sub pErr(ByVal lErr As Long)
Dim sMsg As String
   
   Select Case lErr
   Case 1
      sMsg = "File not found"
   Case 2
      sMsg = "Failed to open AVI file"
   Case 3
      sMsg = "Unable to open AVI frames"
   Case 4
      sMsg = "AVI contains no frames"
   Case 5
      sMsg = "Could not read the format of the AVI"
   Case 6
      sMsg = "Unsupported AVI format"
   Case Else
      sMsg = "Unexpected error " & lErr
   End Select
   
   Err.Raise ERR_BASE + lErr, App.EXEName & ".cAVIFrameExtract", sMsg
   
End Sub

Private Function FAILED(ByVal hR As Long) As Boolean
   FAILED = Not (SUCCEEDED(hR))
End Function

Private Function SUCCEEDED(ByVal hR As Long) As Boolean
   SUCCEEDED = ((hR And &H80000000) = 0)
End Function

Private Function ApiError(ByVal e As Long) As String
    Dim s As String, c As Long
    s = String(256, 0)
    c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
                      FORMAT_MESSAGE_IGNORE_INSERTS, _
                      0, e, 0&, s, Len(s), ByVal 0)
    If c Then ApiError = Left$(s, c)
End Function

Private Function BitmapToPicture(ByVal hBmp As Long) As IPicture

    If (hBmp = 0) Then Exit Function
    
    Dim oNewPic As Picture, tPicConv As PictDesc, IGuid As Guid
    
    ' Fill PictDesc structure with necessary parts:
    With tPicConv
    .cbSizeofStruct = Len(tPicConv)
    .picType = vbPicTypeBitmap
    .hImage = hBmp
    End With
    
    ' Fill in IDispatch Interface ID
    With IGuid
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
    End With
    
    ' Create a picture object:
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    
    ' Return it:
    Set BitmapToPicture = oNewPic
    

End Function

Private Function FourCCFromString(ByVal sString As String) As Long
Dim lRet As Long
Dim sChar As String
Dim lChar As Long
   sChar = Mid(sString, 1)
   lRet = lRet Or Asc(sChar)
   sChar = Mid(sString, 2)
   lRet = lRet Or Asc(sChar) * &H100&
   sChar = Mid(sString, 3)
   lRet = lRet Or Asc(sChar) * &H10000
   sChar = Mid(sString, 4)
   lChar = Asc(sChar)
   lRet = lRet Or (lChar And &H7F&) * &H1000000
   If (lChar And &H80&) = &H80& Then
      lRet = lRet Or &H80000000
   End If
   FourCCFromString = lRet
End Function

Private Function FourCCToString(ByVal lFourCC As Long) As String
Dim sRet As String
Dim lUByte As Long
   sRet = Chr(lFourCC And &HFF)
   sRet = sRet & Chr((lFourCC And &HFF00&) \ &H100&)
   sRet = sRet & Chr((lFourCC And &HFF0000) \ &H10000)
   lUByte = (lFourCC And &H7F000000) \ &H1000000
   If (lFourCC And &H80000000) = &H80000000 Then
      lUByte = lUByte Or &H80&
   End If
   sRet = sRet & Chr(lUByte)
   FourCCToString = sRet
End Function

Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = -1 'CLR_INVALID
    End If
End Function

Private Sub Class_Initialize()
   LSet m_tBMIHBlank = m_tBMIH
   AVIFileInit
   m_hDrawDib = DrawDibOpen()
End Sub

Private Sub Class_Terminate()
   Unload
   AVIFileExit
   DrawDibClose m_hDrawDib
End Sub