Here is a minimalistic cAviWriter class (less than 200 LOC w/ no dependencies) that can be used to create uncompressed AVIs for use in standard animation control.
The sample projects loads a transparent ajax-loader PNG strip and blends it with current vbButtonFace color (Form's back color). Then the frames are split from the bitmap strip and appended to a temporary AVI file. Then an animation control is placed on the form (all API) and the temp AVI file is loaded and played.
The nice thing about animation control is that it uses a separate thread to cycle the animation, so when long running tasks are executed on the UI thread the ajax-loader continues to spin. Enjoy!
cheers,
</wqw>
Code:
Option Explicit
'=========================================================================
' API
'=========================================================================
'--- for AVIFileOpen
Private Const OF_WRITE As Long = &H1
Private Const OF_CREATE As Long = &H1000
'--- for CreateDIBSection
Private Const DIB_RGB_COLORS As Long = 0
Private Declare Sub AVIFileInit Lib "avifil32.dll" ()
Private Declare Sub AVIFileExit Lib "avifil32.dll" ()
Private Declare Function AVIFileOpen Lib "avifil32.dll" Alias "AVIFileOpenA" (ppfile As Long, ByVal szFile As String, ByVal uMode As Long, ByVal lpHandler As Long) As Long
Private Declare Function AVIFileCreateStream Lib "avifil32.dll" (ByVal pfile As Long, ppavi As Long, psi As TAVISTREAMINFO) As Long
Private Declare Function AVIFileRelease Lib "avifil32.dll" (ByVal pfile As Long) As Long
Private Declare Function AVIStreamSetFormat Lib "avifil32.dll" (ByVal pavi As Long, ByVal lPos As Long, lpFormat As Any, ByVal cbFormat As Long) As Long
Private Declare Function AVIStreamWrite Lib "avifil32.dll" (ByVal pavi As Long, ByVal lStart As Long, ByVal lSamples As Long, ByVal lpBuffer As Long, ByVal cbBuffer As Long, ByVal dwFlags As Long, plSampWritten As Long, plBytesWritten As Long) As Long
Private Declare Function AVIStreamRelease Lib "avifil32.dll" (ByVal pavi As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw 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 ApiBitBlt Lib "gdi32" Alias "BitBlt" (ByVal hdcDest As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TAVISTREAMINFO
fccType As Long
fccHandler As Long
dwFlags As Long
dwCaps As Long
wPriority As Integer
wLanguage As Integer
dwScale As Long
dwRate As Long
dwStart As Long
dwLength As Long
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 Type BITMAPINFOHEADER
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
'=========================================================================
' Constants and member variables
'=========================================================================
Private m_hAviFile As Long
Private m_hAviStream As Long
Private m_lSample As Long
Private m_uBmpInfo As BITMAPINFOHEADER
Private m_hDC As Long
Private m_hDib As Long
Private m_hPrevDib As Long
Private m_lpBits As Long
'=========================================================================
' Methods
'=========================================================================
Public Function Init( _
sFile As String, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
Optional ByVal lRate As Long = 10) As Boolean
Dim uStream As TAVISTREAMINFO
Terminate
If AVIFileOpen(m_hAviFile, sFile, OF_CREATE Or OF_WRITE, 0) < 0 Then
GoTo QH
End If
With uStream
.fccType = pvToFourCC("vids")
.fccHandler = 0 ' pvToFourCC("DIB ")
.dwScale = 1
.dwRate = lRate
.rcFrame.Right = lWidth
.rcFrame.Bottom = lHeight
End With
If AVIFileCreateStream(m_hAviFile, m_hAviStream, uStream) < 0 Then
GoTo QH
End If
With m_uBmpInfo
.biSize = Len(m_uBmpInfo)
.biWidth = lWidth
.biHeight = lHeight
.biPlanes = 1
.biBitCount = 24 ' 32
.biSizeImage = ((lWidth * .biBitCount \ 8 + 3) And -4&) * lHeight
End With
If AVIStreamSetFormat(m_hAviStream, 0, m_uBmpInfo, Len(m_uBmpInfo)) < 0 Then
GoTo QH
End If
m_hDC = CreateCompatibleDC(0)
m_hDib = CreateDIBSection(m_hDC, m_uBmpInfo, DIB_RGB_COLORS, m_lpBits, 0, 0)
m_hPrevDib = SelectObject(m_hDC, m_hDib)
m_lSample = 0
'--- success
Init = True
Exit Function
QH:
Terminate
End Function
Public Function AddFrame( _
oPic As StdPicture, _
Optional ByVal lX As Long, _
Optional ByVal lY As Long) As Boolean
Dim hTempDC As Long
Dim hPrevBmp As Long
hTempDC = CreateCompatibleDC(m_hDC)
hPrevBmp = SelectObject(hTempDC, oPic.handle)
Call ApiBitBlt(m_hDC, 0, 0, m_uBmpInfo.biWidth, m_uBmpInfo.biHeight, hTempDC, lX, lY, vbSrcCopy)
Call SelectObject(hTempDC, hPrevBmp)
Call DeleteDC(hTempDC)
If AVIStreamWrite(m_hAviStream, m_lSample, 1, m_lpBits, m_uBmpInfo.biSizeImage, 0, 0, 0) < 0 Then
GoTo QH
End If
m_lSample = m_lSample + 1
'--- success
AddFrame = True
QH:
End Function
Private Sub Terminate()
If m_hAviStream <> 0 Then
Call AVIStreamRelease(m_hAviStream)
m_hAviStream = 0
End If
If m_hAviFile <> 0 Then
Call AVIFileRelease(m_hAviFile)
m_hAviFile = 0
End If
If m_hDC <> 0 Then
If m_hPrevDib <> 0 Then
Call SelectObject(m_hDC, m_hPrevDib)
m_hPrevDib = 0
End If
If m_hDib <> 0 Then
Call DeleteObject(m_hDib)
m_hDib = 0
m_lpBits = 0
End If
Call DeleteDC(m_hDC)
m_hDC = 0
End If
End Sub
'= private ===============================================================
Private Function pvToFourCC(sText As String) As Long
Call CopyMemory(pvToFourCC, ByVal StrPtr(StrConv(sText, vbFromUnicode)), 4)
End Function
'=========================================================================
' Base class events
'=========================================================================
Private Sub Class_Initialize()
Call AVIFileInit
End Sub
Private Sub Class_Terminate()
Terminate
Call AVIFileExit
End SubThe nice thing about animation control is that it uses a separate thread to cycle the animation, so when long running tasks are executed on the UI thread the ajax-loader continues to spin. Enjoy!
cheers,
</wqw>