VB5 AVI Extractor (73K)
VB6 AVI Extractor (70K)
23 Nov 2003
First Posted
Transparent AVI Player Control
ComCtl32.DLL Animation Control Class
Reading Data from Local or External Library Resources
vbAccelerator - Contents of code file: frmAVIExtractor.frm
VERSION 5.00
Begin VB.Form frmAVIExtractor
Caption = "vbAccelerator AVI Frame Extractor"
ClientHeight = 7740
ClientLeft = 2520
ClientTop = 2550
ClientWidth = 7500
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmAVIExtractor.frx":0000
LinkTopic = "Form1"
ScaleHeight = 7740
ScaleWidth = 7500
Begin VB.PictureBox picTab
BorderStyle = 0 'None
Height = 7635
Index = 0
Left = 60
ScaleHeight = 7635
ScaleWidth = 7395
TabIndex = 23
TabStop = 0 'False
Top = 60
Width = 7395
Begin VB.PictureBox picPalette
AutoRedraw = -1 'True
Height = 1275
Left = 2160
ScaleHeight = 81
ScaleMode = 3 'Pixel
ScaleWidth = 341
TabIndex = 27
Top = 6240
Width = 5175
End
Begin VB.TextBox txtInfo
Height = 315
Index = 8
Left = 0
TabIndex = 24
Top = 5820
Width = 1995
End
Begin VB.TextBox txtInfo
Height = 315
Index = 7
Left = 0
TabIndex = 18
Top = 5220
Width = 1995
End
Begin VB.TextBox txtAVIFile
Height = 315
Left = 0
TabIndex = 1
Top = 300
Width = 6975
End
Begin VB.CommandButton cmdPick
Caption = "..."
Height = 315
Left = 7020
TabIndex = 2
Top = 300
Width = 375
End
Begin VB.CheckBox chkTransparent
Caption = "&Transparent"
Height = 255
Left = 2160
TabIndex = 21
Top = 1380
Width = 4095
End
Begin VB.PictureBox picFrame
AutoRedraw = -1 'True
Height = 4215
Left = 2160
ScaleHeight = 4155
ScaleWidth = 5115
TabIndex = 22
Top = 1680
Width = 5175
End
Begin VB.ComboBox cboFrame
Height = 315
Left = 2160
Style = 2 'Dropdown List
TabIndex = 20
Top = 1020
Width = 5175
End
Begin VB.TextBox txtInfo
Height = 315
Index = 6
Left = 0
TabIndex = 16
Top = 4620
Width = 1995
End
Begin VB.TextBox txtInfo
Height = 315
Index = 5
Left = 0
TabIndex = 14
Top = 4020
Width = 1995
End
Begin VB.TextBox txtInfo
Height = 315
Index = 4
Left = 0
TabIndex = 12
Top = 3420
Width = 1995
End
Begin VB.TextBox txtInfo
Height = 315
Index = 3
Left = 0
TabIndex = 10
Top = 2820
Width = 1995
End
Begin VB.TextBox txtInfo
Height = 315
Index = 2
Left = 0
TabIndex = 8
Top = 2220
Width = 1995
End
Begin VB.TextBox txtInfo
Height = 315
Index = 1
Left = 0
TabIndex = 6
Top = 1620
Width = 1995
End
Begin VB.TextBox txtInfo
Height = 315
Index = 0
Left = 0
TabIndex = 4
Top = 1020
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " Pa&lette:"
Height = 255
Index = 12
Left = 2160
TabIndex = 26
Top = 6000
Width = 4095
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " T&ype FourCC"
Height = 255
Index = 9
Left = 0
TabIndex = 25
Top = 5580
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " Handler Fo&urCC"
Height = 255
Index = 7
Left = 0
TabIndex = 17
Top = 4980
Width = 1995
End
Begin VB.Line linSep
BorderColor = &H80000010&
X1 = 0
X2 = 7320
Y1 = 720
Y2 = 720
End
Begin VB.Label lblFilename
BackStyle = 0 'Transparent
Caption = " &AVI File"
Height = 255
Left = 0
TabIndex = 0
Top = 0
Width = 7335
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " F&rame:"
Height = 255
Index = 8
Left = 2160
TabIndex = 19
Top = 780
Width = 4095
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " &Compression"
Height = 255
Index = 6
Left = 0
TabIndex = 15
Top = 4380
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " &Name"
Height = 255
Index = 5
Left = 0
TabIndex = 13
Top = 3780
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " &Height"
Height = 255
Index = 4
Left = 0
TabIndex = 11
Top = 3180
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " &Width"
Height = 255
Index = 3
Left = 0
TabIndex = 9
Top = 2580
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " &Bits/Pixel"
Height = 255
Index = 2
Left = 0
TabIndex = 7
Top = 1980
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " Frame &Duration"
Height = 255
Index = 1
Left = 0
TabIndex = 5
Top = 1380
Width = 1995
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " &Frames"
Height = 255
Index = 0
Left = 0
TabIndex = 3
Top = 780
Width = 1995
End
End
Begin VB.Menu mnuFileTOP
Caption = "&File"
Begin VB.Menu mnuFile
Caption = "&Open..."
Index = 0
Shortcut = ^O
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 1
End
Begin VB.Menu mnuFile
Caption = "&Save Frame..."
Index = 2
Shortcut = ^S
End
Begin VB.Menu mnuFile
Caption = "Save &Bitmap Strip..."
Index = 3
End
Begin VB.Menu mnuFile
Caption = "Save &Palette..."
Index = 4
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 5
End
Begin VB.Menu mnuFile
Caption = "E&xit"
Index = 6
End
End
End
Attribute VB_Name = "frmAVIExtractor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_cAVI As cAVIFrameExtract
Private Sub pLoadDialog()
Dim cD As New cCommonDialog
Dim sFile As String
If (cD.VBGetOpenFileName( _
sFile, _
Filter:="AVI Files (*.AVI)|*.AVI|All Files (*.*)|*.*", _
FilterIndex:=1, _
DefaultExt:="AVI", _
Owner:=Me.hWnd)) Then
pLoad sFile
End If
End Sub
Private Sub pSaveFrame()
Dim cD As New cCommonDialog
Dim sFile As String
sFile = pParseName(m_cAVI.Name) & "_" & cboFrame.ListIndex + 1 & ".bmp"
If (cD.VBGetSaveFileName( _
sFile, _
Filter:="Bitmap Files (*.BMP)|*.BMP|All Files (*.*)|*.*", _
FilterIndex:=1, _
DefaultExt:="BMP", _
Owner:=Me.hWnd)) Then
Dim hBmp As Long
hBmp = m_cAVI.FrameBitmap(cboFrame.ListIndex + 1)
Dim cDS As New cDIBSectionSave
If (m_cAVI.bitsPerPixel = 8) Then
cDS.Save8BitBitmap sFile, hBmp, m_cAVI.Palette, True
Else
cDS.Save24BitBitmap sFile, hBmp
End If
End If
End Sub
Private Function pParseName(ByVal sName As String) As String
Dim i As Long
Dim sChar As String
Dim sRet As String
For i = 1 To Len(sName)
sChar = Mid(sName, i, 1)
Select Case sChar
Case "&"
sRet = sRet & "_"
Case "?"
sRet = sRet & " "
Case ":"
sRet = sRet & "_"
Case "*"
sRet = sRet & "_"
Case """"
Case "'"
Case "#"
sRet = sRet & "_"
Case "."
sRet = sRet & "_"
Case Else
sRet = sRet & sChar
End Select
Next i
pParseName = sRet
End Function
Private Sub pSaveBitmapStrip()
Dim cD As New cCommonDialog
Dim sFile As String
Dim fD As New frmBitmapStripDialog
fD.AVI = m_cAVI
fD.Show vbModal, Me
If Not (fD.Cancelled) Then
sFile = pParseName(m_cAVI.Name)
If (cD.VBGetSaveFileName( _
sFile, _
Filter:="Bitmap Files (*.BMP)|*.BMP|All Files (*.*)|*.*", _
FilterIndex:=1, _
DefaultExt:="BMP", _
Owner:=Me.hWnd)) Then
pCreateBitmapStripAndSave _
sFile, fD.startFrame, fD.endFrame, fD.NewBackColor
End If
End If
End Sub
Private Sub pCreateBitmapStripAndSave( _
ByVal sFileName As String, _
ByVal startFrame As Long, _
ByVal endFrame As Long, _
ByVal oBackColor As OLE_COLOR _
)
Dim cDC As New cMemDC
cDC.Create
Dim cB As New cBmp
cB.Create m_cAVI.Width, m_cAVI.Height * (endFrame - startFrame + 1)
cDC.SelectObject cB
If (oBackColor <> -1) Then
cDC.Fill oBackColor
End If
Dim iFrame As Long
Dim y As Long
For iFrame = startFrame To endFrame
m_cAVI.DrawFrame cDC.hDC, iFrame, , y, , , (oBackColor <> -1)
y = y + m_cAVI.Height
Next iFrame
cDC.UnselectObject
Dim cDS As New cDIBSectionSave
If (m_cAVI.bitsPerPixel = 8) Then
cDS.Save8BitBitmap sFileName, cB.hBmp, m_cAVI.Palette, True
Else
cDS.Save24BitBitmap sFileName, cB.hBmp
End If
End Sub
Private Sub pSavePalette()
Dim cP As cPalette
Dim cD As New cCommonDialog
Dim sFile As String
If (cD.VBGetSaveFileName( _
sFile, _
Filter:="Palette Files (*.PAL)|*.PAL|All Files (*.*)|*.*", _
FilterIndex:=1, _
DefaultExt:="PAL", _
Owner:=Me.hWnd)) Then
Set cP = m_cAVI.Palette
cP.SaveToJASCFile sFile
End If
End Sub
Private Sub pLoad(ByVal sFile As String)
On Error GoTo ErrorHandler
Dim i As Long
' Clear display
For i = 0 To 8
txtInfo(i).Text = ""
txtInfo(i).Enabled = False
Next i
mnuFile(2).Enabled = False
mnuFile(3).Enabled = False
mnuFile(4).Enabled = False
cboFrame.Clear
cboFrame.Enabled = False
chkTransparent.Enabled = False
picPalette.Cls
picFrame.Cls
' Load the AVI:
m_cAVI.Filename = sFile
' Show the details
txtAVIFile.Text = sFile
txtInfo(0).Text = m_cAVI.FrameCount
txtInfo(1).Text = m_cAVI.FrameDuration
txtInfo(2).Text = m_cAVI.bitsPerPixel
txtInfo(3).Text = m_cAVI.Width
txtInfo(4).Text = m_cAVI.Height
txtInfo(5).Text = m_cAVI.Name
txtInfo(6).Text = m_cAVI.Compression
txtInfo(7).Text = m_cAVI.VideoHandlerFourCCString
txtInfo(8).Text = m_cAVI.VideoTypeFourCCString
For i = 1 To m_cAVI.FrameCount
cboFrame.AddItem i
Next i
pRenderPalette
' Re-enable the display:
For i = 0 To 8
txtInfo(i).Enabled = True
Next i
chkTransparent.Enabled = True
If (cboFrame.ListCount > 0) Then
cboFrame.Enabled = True
cboFrame.ListIndex = 0
cboFrame_Click
mnuFile(2).Enabled = True
mnuFile(3).Enabled = True
mnuFile(4).Enabled = Not (m_cAVI.Palette Is Nothing)
End If
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbExclamation
Exit Sub
End Sub
Private Sub pRenderPalette()
picPalette.Cls
Dim cP As cPalette
Set cP = m_cAVI.Palette
If Not cP Is Nothing Then ' else > 8bpp
Dim Index As Long
Dim x As Long
Dim y As Long
Dim palItemWidth As Long
Dim palItemHeight As Long
palItemWidth = picPalette.ScaleWidth \ 16
If (cP.Count > 16) Then
palItemHeight = picPalette.ScaleHeight \ (cP.Count \ 16)
Else
palItemHeight = 16
End If
For Index = 0 To cP.Count - 1
picPalette.Line (x, y)-(x + palItemWidth, y + palItemHeight),
RGB(cP.Red(Index), cP.Green(Index), cP.Blue(Index)), BF
x = x + palItemWidth
If (x > picPalette.ScaleWidth) Then
x = 0
y = y + palItemHeight
End If
Next Index
End If
picPalette.Refresh
End Sub
Private Sub pRenderFrame()
picFrame.Cls
m_cAVI.DrawFrame _
picFrame.hDC, cboFrame.ListIndex + 1, _
Transparent:=(chkTransparent.value = vbChecked)
picFrame.Refresh
End Sub
Private Sub cboFrame_Click()
If (cboFrame.Enabled) Then
pRenderFrame
End If
End Sub
Private Sub chkTransparent_Click()
cboFrame_Click
End Sub
Private Sub cmdPick_Click()
pLoadDialog
End Sub
Private Sub Form_Load()
' Set up the AVI Extractor
Set m_cAVI = New cAVIFrameExtract
' Load the demo file:
Dim sDefaultFile As String
sDefaultFile = App.Path
If Not (Right(sDefaultFile, 1) = "\") Then
sDefaultFile = sDefaultFile & "\"
End If
sDefaultFile = sDefaultFile & "Download.avi"
txtAVIFile.Text = sDefaultFile
pLoad sDefaultFile
End Sub
Private Sub Form_Resize()
On Error Resume Next
picTab(0).Move 2 * Screen.TwipsPerPixelX, 0, Me.ScaleWidth - 2 *
Screen.TwipsPerPixelX, Me.ScaleHeight
End Sub
Private Sub mnuFile_Click(Index As Integer)
Select Case Index
Case 0 ' Open
pLoadDialog
Case 2 ' Save frame
pSaveFrame
Case 3 ' Save bitmap strip
pSaveBitmapStrip
Case 4 ' Save palette
pSavePalette
Case 6 ' exit
Unload Me
End Select
End Sub
Private Sub picTab_Resize(Index As Integer)
Dim lWidth As Long
Dim lHeight As Long
Select Case Index
Case 0
On Error Resume Next
txtAVIFile.Width = picTab(0).ScaleWidth - txtAVIFile.Left - cmdPick.Width
- 4 * Screen.TwipsPerPixelX
cmdPick.Left = picTab(0).ScaleWidth - cmdPick.Width - 2 *
Screen.TwipsPerPixelX
linSep.X2 = picTab(0).ScaleWidth - linSep.X1 * 2
lWidth = picTab(0).ScaleWidth - cboFrame.Left - 2 * Screen.TwipsPerPixelX
cboFrame.Width = lWidth
chkTransparent.Width = lWidth
lHeight = Me.ScaleHeight - picFrame.TOp - lblInfo(12).Height -
picPalette.Height - 4 * Screen.TwipsPerPixelY
If (lHeight < m_cAVI.Height * Screen.TwipsPerPixelY) Then
lHeight = m_cAVI.Height * Screen.TwipsPerPixelY
End If
picFrame.Move picFrame.Left, picFrame.TOp, _
lWidth, lHeight
pRenderFrame
lblInfo(12).Move picFrame.Left, _
picFrame.TOp + picFrame.Height + 2 * Screen.TwipsPerPixelY, _
lWidth
picPalette.Move picFrame.Left, _
lblInfo(12).TOp + lblInfo(12).Height, _
lWidth
pRenderPalette
End Select
End Sub
