vbAccelerator - Contents of code file: cVideoHandlers.cls

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

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 Declare Function ICLocate Lib "MSVFW32.dll" ( _
    ByVal fccType As Long, _
    ByVal fccHandler As Long, _
    lpbiIn As Any, _
    lpbOut As Any, _
    ByVal wFlags As Long _
    ) As Long

Public Enum EBitmapCompressionTypes
   BI_RGB = 0&
   BI_RLE8 = 1&
End Enum

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

Private Declare Function ICOpen Lib "MSVFW32.dll" ( _
    ByVal fccType As Long, _
    ByVal fccHandler As Long, _
    ByVal wMode As Long _
    ) As Long

Private Declare Function ICClose Lib "MSVFW32.dll" ( _
    ByVal hiC As Long _
    ) As Long

Private Declare Function ICGetInfo Lib "MSVFW32.dll" ( _
    ByVal hiC As Long, _
    picInfo As Any, _
    ByVal cb As Long _
    ) As Long

Private Declare Function ICSendMessage Lib "MSVFW32.dll" ( _
    ByVal hiC As Long, _
    ByVal msg As Long, _
    dw1 As Any, _
    ByVal dw2 As Long _
    ) As Long


Private Const ICMODE_COMPRESS = 1
Private Const ICMODE_DECOMPRESS = 2
Private Const ICMODE_FASTDECOMPRESS = 3
Private Const ICMODE_QUERY = 4
Private Const ICMODE_FASTCOMPRESS = 5
Private Const ICMODE_DRAW = 8

Private Const ICERR_OK = 0
Private Const ICERR_DONTDRAW = 1
Private Const ICERR_NEWPALETTE = 2
Private Const ICERR_GOTOKEYFRAME = 3
Private Const ICERR_STOPDRAWING = 4

Private Const ICERR_UNSUPPORTED = -1&
Private Const ICERR_BADFORMAT = -2&
Private Const ICERR_MEMORY = -3&
Private Const ICERR_INTERNAL = -4&
Private Const ICERR_BADFLAGS = -5&
Private Const ICERR_BADPARAM = -6&
Private Const ICERR_BADSIZE = -7&
Private Const ICERR_BADHANDLE = -8&
Private Const ICERR_CANTUPDATE = -9&
Private Const ICERR_ABORT = -10&
Private Const ICERR_ERROR = -100&
Private Const ICERR_BADBITDEPTH = -200&
Private Const ICERR_BADIMAGESIZE = -201&

Private Const ICERR_CUSTOM = -400&             '// errors less than
 ICERR_CUSTOM...


Private m_colHandlers As Collection


Public Function SuggestedVideoHandlerFourCC( _
      ByVal bitsPerPixel As Long _
   ) As Long
Dim bIh As BITMAPINFOHEADER
Dim hiC As Long
Dim tICI As TICInfo

   '// Initialize the bitmap structure.
   bIh.biSize = LenB(bIh)
   bIh.biPlanes = 1
   bIh.biCompression = BI_RGB      '// standard RGB bitmap
   If (bitsPerPixel = 8) Then
      bIh.biBitCount = 8              '// 8 bits-per-pixel format
      bIh.biClrUsed = 256
      bIh.biClrImportant = 256
   Else
      bIh.biBitCount = 24
   End If
    
   Dim ICTYPE_VIDEO As Long
   ICTYPE_VIDEO = FourCCFromString("vidc")
    
   hiC = ICLocate(ICTYPE_VIDEO, ByVal 0&, bIh, _
       ByVal 0&, ICMODE_COMPRESS)
       
   If Not (hiC = 0) Then
      ICGetInfo hiC, tICI, LenB(tICI)
      SuggestedVideoHandlerFourCC = tICI.fccHandler
   
      ICClose hiC
   End If

End Function

Private Sub getHandlers()
Dim i As Long
Dim iLast As Long
Dim iNext As Long
Dim tICBlank As TICInfo
Dim tIC As TICInfo
Dim tBIH As BITMAPINFOHEADER
Dim fccType As Long
Dim lPtrTic As Long
Dim hiC As Long
Dim sName As String
Dim sDescription As String
Dim lR As Long
Dim cV As cVideoHandler

   Set m_colHandlers = New Collection

   fccType = FourCCFromString("vidc")
   iLast = 0
   Do
      LSet tIC = tICBlank
      iNext = ICInfo(fccType, iLast, tIC)
      If Not (iNext = 0) Then
         hiC = ICOpen(tIC.fccType, tIC.fccHandler, ICMODE_QUERY)
         If Not (hiC = 0) Then
            ICGetInfo hiC, tIC, Len(tIC)
                        
            sName = tIC.szName
            sDescription = tIC.szDescription
            
            Set cV = New cVideoHandler
            cV.fInit sName, sDescription, tIC.fccHandler
            m_colHandlers.Add cV
            
            ICClose hiC
         End If
         iLast = iLast + 1
      Else
      End If
   Loop While (iNext > 0)
End Sub

' Gets long value of FourCC value from string, e.g. 'vids'
Public 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

' Gets the string from a FourCC long value
Public 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

Public Property Get HandlerCount() As Long
   HandlerCount = m_colHandlers.Count
End Property

Public Property Get Handler(ByVal Index As Long) As cVideoHandler
   Set Handler = m_colHandlers(Index)
End Property

Public Function IndexForFourCC(ByVal lFourCC As Long) As Long
Dim cVH As cVideoHandler
Dim i As Long
   For Each cVH In m_colHandlers
      i = i + 1
      If cVH.FourCC = lFourCC Then
         IndexForFourCC = i
      End If
   Next
End Function

Private Sub Class_Initialize()
   
   getHandlers
   
End Sub