Option Explicit
' **** IMPORTANT! ****
' Note that this code as is won't know if a video file plays all the way through to the end.
' If this happens, the timer will keep testing the last captured frame.
' I've taken a simple approach of using a frame counter variable, and once it reaches
' the maximum value, the thumbnail is saved regardless of whether or not it passes the test.
' This means that there is a limit on the number of frames tested for each file.
' You would need to modify this to suit your own needs if necessary.
' Hardware Acceleration Declarations...
Private Const CCHDEVICENAME As Long = 32
Private Const CCHFORMNAME As Long = 32
Private Const CDS_TEST = &H4
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function ChangeDisplaySettings Lib "user32.dll" Alias "ChangeDisplaySettingsA" (ByRef lpDevMode As DEVMODE, ByVal dwFlags As Long) As Long
Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, ByRef lpDevMode As DEVMODE) As Long
Private mRegAccelKey As String ' <= Registry key (full path) for the Hardware Acceleration value.
Private mAccelValue As Long ' <= Original Hardware Acceleration value.
' GetDIBits Declarations...
Private Const BI_RGB As Long = 0
Private Const DIB_RGB_COLORS As Long = 0
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
Private Type RGBQUAD
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal wUsage As Long) As Long
Private mBmpHdr As BITMAPINFOHEADER
Private mOldBits() As RGBQUAD ' <= Previous frame bits (you only need this if you're comparing frame to frame).
Private mTmpBits() As RGBQUAD ' <= Current frame bits.
Private mCount As Long ' <= Upper bound of the 2 arrays above.
Private mFirstFrame As Boolean ' <= (See Timer1_Timer event.)
' MCI Playback Declarations...
Private Const SRCCOPY = &HCC0020
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
' Blitting Declarations...
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 GetDC Lib "user32" (ByVal hWnd As Long) As Long
' General Variables...
Private mVideoPath As String
Private mThumbFile As String
Private mThumbWidth As Long
Private mThumbHeight As Long
Private mFrameCount As Long
Private mFrameMax As Long
Private mWshShell As Object
Private mFileList As Collection
Private mAbort As Boolean
' Form_Load '
Private Sub Form_Load()
' START SETUP:
' mVideoPath:
' Set the path to the video files (make sure it ends with a backslack)...
mVideoPath = Replace(App.Path & "\", "\\", "\")
' mRegAccelKey:
' You would need to find the correct registry key for each target OS and do an OS test here.
' This key is correct for XP Pro SP3.
mRegAccelKey = "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\ialm\Device0\Acceleration.Level"
' mThumbWidth:
' Set the desired thumbnail width in pixels...
mThumbWidth = 128
' mThumbHeight:
' Set the desired thumbnail height in pixels...
mThumbHeight = 96
' Timer1.Interval:
' You can set the test interval as necessary. For example, if the Timer1_Timer routine takes
' 5ms to run, then setting the interval to 35 would give a test rate of around 25 frames
' per second. ( 1000 / (35+5) = 25 ).
' If doing comparison between frames, you should calculate this value so that you are testing
' at the same or slower frame rate than the source video.
Timer1.Interval = 35
' mFrameMax:
' Set the maximum number of frames to test...
mFrameMax = 250 ' <= (10 seconds if everything is 25fps).
' END SETUP.
Set mWshShell = CreateObject("WScript.Shell")
Me.ScaleMode = vbPixels
With cmStart
.Caption = "Start"
.Move 5, 5, 80, 30
.Enabled = True
End With
With cmAbort
.Caption = "Abort"
.Move 90, 5, 80, 30
.Enabled = False
End With
With pbSource
.ScaleMode = vbPixels
.BackColor = vbApplicationWorkspace
.BorderStyle = 0
.Move 5, 40, mThumbWidth, mThumbHeight
End With
With pbThumb
.AutoRedraw = True
.ScaleMode = vbPixels
.BackColor = vbApplicationWorkspace
.BorderStyle = 0
.Move mThumbWidth + 10, 40, mThumbWidth, mThumbHeight
End With
With mBmpHdr
.biSize = 40
.biWidth = mThumbWidth
.biHeight = -mThumbHeight
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
.biSizeImage = (mThumbWidth * .biBitCount * 4)
End With
mCount = (mThumbWidth * mThumbHeight - 1)
ReDim mOldBits(mCount)
ReDim mTmpBits(mCount)
' Get the current Harware Acceleration value...
GetHarwareAcceleration
' Disable Harware Acceleration if not disabled already...
If mAccelValue <> 5 Then
SetHarwareAcceleration 5
End If
End Sub
' Form_QueryUnload '
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' Restore Harware Acceleration value if necessary...
If mAccelValue <> 5 Then
SetHarwareAcceleration mAccelValue
End If
Set mWshShell = Nothing
Set mFileList = Nothing
End Sub
' cmStart_Click '
Private Sub cmStart_Click()
cmStart.Enabled = False
cmAbort.Enabled = True
mAbort = False
' Clear the video file list...
Set mFileList = New Collection
' Add video files to the list using their extensions...
AddFiles "avi"
AddFiles "flv"
AddFiles "mp4"
' Start processing...
ProcessNextFile
End Sub
' cmAbort_Click '
Private Sub cmAbort_Click()
mAbort = True
cmAbort.Enabled = False
End Sub
' AddFiles '
Private Sub AddFiles(Extension As String)
Dim sFilename As String
sFilename = Dir$(mVideoPath & "*." & Extension)
Do While Len(sFilename)
mFileList.Add mVideoPath & sFilename
sFilename = Dir$
Loop
End Sub
' ProcessNextFile '
Private Sub ProcessNextFile()
Dim sFilename As String
pbSource.Cls
pbThumb.Cls
DoEvents
' Sanity check...
CloseVideo
If (mFileList.Count > 0) And (Not mAbort) Then
' Reset the FirstFrame flag...
mFirstFrame = True
' Get the next file in the list...
sFilename = mFileList(1)
mFileList.Remove 1
mThumbFile = Left$(sFilename, InStrRev(sFilename, ".") - 1) & "_Thumbnail.bmp"
' Open and play video. Note that the filename needs to be quoted if it contains spaces...
mciSendString "open """ & sFilename & """ type mpegvideo alias avi parent " & pbSource.hWnd & " style child", 0, 0, 0
mciSendString "put avi client at 0 0 " & mThumbWidth & " " & mThumbHeight, 0, 0, 0
' No need for "from frame to frame" anymore, just play from the start...
mciSendString "play avi", 0, 0, 0
Timer1 = True
Else
cmStart.Enabled = True
cmAbort.Enabled = False
End If
End Sub
' Timer1_Timer '
Private Sub Timer1_Timer()
Dim i As Long
Dim lFrameWnd As Long
Dim sResult As String
Timer1 = False ' <= Stop the timer.
pbThumb.Cls
' Check if aborted...
If mAbort Then
CloseVideo
pbSource.Cls
pbThumb.Cls
cmStart.Enabled = True
Exit Sub
End If
sResult = Space(16)
mciSendString "status avi window handle", sResult, 16, 0
lFrameWnd = Val(sResult)
If lFrameWnd Then
With pbThumb
' Grab current frame to pbThumb...
BitBlt .hDC, 0, 0, mThumbWidth, mThumbHeight, GetDC(lFrameWnd), 0, 0, SRCCOPY
' Store the current frame RGBA bits in the mTmpBits array...
GetDIBits .hDC, .Image.Handle, 0, mThumbHeight, mTmpBits(0), mBmpHdr, DIB_RGB_COLORS
End With
' mFirstFrame:
' If you are doing comparison (using both mOldBits and mTmpBits arrays), you need to
' fill the mOldBits array with the first frame before you can do any testing...
If mFirstFrame Then
' This is the first frame grabbed, so copy it to the mOldBits array and don't test.
mOldBits = mTmpBits
' Set the FirstFrame flag to false...
mFirstFrame = False
' Reset the frame counter variable...
mFrameCount = 1
' Restart the timer for the next test, and exit.
Timer1 = True
Exit Sub
Else
' Increment the frame counter...
mFrameCount = (mFrameCount + 1)
End If
' Here is where you can do any checking you desire...
' In this example, I simply test for a pixel with 50% or more red and green.
' You can increase the Step value here to speed up the code, although this
' shouldn't be necessary with modern PC's and thumbnail size images.
' Eg: Step 1 = test every pixel, Step 5 = test every 5th pixel, etc.
For i = 0 To mCount Step 1
With mTmpBits(i)
If .Red > 128 And .Green > 128 Then ' <= THE EXAMPLE TEST CODE.
' Once your test succeeds, save the thumbnail and exit...
SaveThumbnail
Exit Sub
End If
End With
DoEvents
Next
' Check if we have reached the frame limit for this file...
If mFrameCount >= mFrameMax Then
' If you wanted to, you could save a default thumb here. or a picture that
' reads "image not available" etc.
' In this example, I just save the current frame regardless.
SaveThumbnail
Else
' The test failed, so here you can copy the current bits to the mOldBits array.
' You can use this to compare the current frame (mTmpBits) with the last frame you
' checked (mOldBits) in the next test. (Eg: if you were testing for motion detection.)
mOldBits = mTmpBits
' Restart the timer for the next test...
Timer1 = True
End If
End If
End Sub
' CloseVideo '
Private Sub CloseVideo()
mciSendString "stop avi", 0, 0, 0
mciSendString "close avi", 0, 0, 0
End Sub
' SaveThumbnail '
Private Sub SaveThumbnail()
CloseVideo
SavePicture pbThumb.Image, mThumbFile
ProcessNextFile
End Sub
' GetHarwareAcceleration '
Private Sub GetHarwareAcceleration()
Dim vTmp As Variant
On Error Resume Next
vTmp = mWshShell.RegRead(mRegAccelKey)
If Err Then
mAccelValue = 0
Else
mAccelValue = Val(vTmp)
End If
On Error GoTo 0
End Sub
' SetHarwareAcceleration '
Private Sub SetHarwareAcceleration(Value As Long)
Dim uDevMode As DEVMODE
mWshShell.RegWrite mRegAccelKey, Value, "REG_DWORD"
EnumDisplaySettings 0, 0, uDevMode
ChangeDisplaySettings uDevMode, CDS_TEST
End Sub
![[bigsmile]](/data/assets/smilies/bigsmile.gif "[bigsmile] [bigsmile]")
![[smile]](/data/assets/smilies/smile.gif "[smile] [smile]")
