Option Compare Database
Option Explicit
Public vid As Integer
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function GetResSpec Lib "user32" _
Alias "GetDC" _
(ByVal hWnd As Long) As Long
Declare Function GetPixPerIn Lib "gdi32" _
Alias "GetDeviceCaps" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Declare Function RelResSpec Lib "user32" _
Alias "ReleaseDC" _
(ByVal hWnd As Long, _
ByVal hDC As Long) As Long
Declare Function GetAVISize Lib "user32" _
Alias "GetClientRect" _
(ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function AVIFunction Lib "winmm" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnStr As Any, _
ByVal wReturnLen As Long, _
ByVal hCallBack As Long) As Long
Declare Function GetAVIError Lib "winmm" _
Alias "mciGetErrorStringA" _
(ByVal dwError As Long, _
ByVal lpstrBuffer As String, _
ByVal uLength As Long) As Long
Sub PlayAVI(AVIFile As String, _
ScreenTop As Single, ScreenHeight As Single, _
ScreenLeft As Single, ScreenWidth As Single, _
Auto As Boolean)
Dim PixPerInX As Integer, PixPerInY As Integer
Dim CmdStr As String, TheError As String * 100
Dim TheAVIHwnd As String * 100
Dim AVISizeH As Long, AVISizeW As Long
Dim FRMHwnd As Long, hDC As Long
Dim TheAVIRect As RECT
On Error GoTo TheEnd
'Get the active form's window handle.
FRMHwnd = Screen.ActiveForm.hWnd
'Open the AVIVideo device with AVIFile
CmdStr = ("open " & AVIFile & _
" type AVIVideo alias TheVideo parent " & _
FRMHwnd & " style " & &H40000000)
vid = AVIFunction(CmdStr, 0&, 0, 0)
If vid <> 0 Then ' An error occurred.
vid = GetAVIError(vid, TheError, Len(TheError))
MsgBox TheError, vbOKOnly + vbCritical, "AVI Error"
GoTo TheEnd
End If
'Determine the .AVI Height and Width
vid = AVIFunction("status TheVideo window handle", TheAVIHwnd, Len(TheAVIHwnd), 0)
vid = GetAVISize(TheAVIHwnd, TheAVIRect)
AVISizeH = TheAVIRect.Bottom - TheAVIRect.Top
AVISizeW = TheAVIRect.Right - TheAVIRect.Left
'Retrieve pixels per inch
hDC = GetResSpec(FRMHwnd)
PixPerInX = GetPixPerIn(hDC, 88)
PixPerInY = GetPixPerIn(hDC, 90)
vid = RelResSpec(FRMHwnd, hDC)
If Auto = True Then
'Proportionally resize .AVI if necessary and center in display area.
If AVISizeW > ((ScreenWidth / 1440) * PixPerInY) Then
AVISizeH = (((ScreenWidth / 1440) * PixPerInY) / AVISizeW) * AVISizeH
AVISizeW = ((ScreenWidth / 1440) * PixPerInY)
End If
If AVISizeH > ((ScreenHeight / 1440) * PixPerInX) Then
AVISizeW = (((ScreenHeight / 1440) * PixPerInX) / AVISizeH) * AVISizeW
AVISizeH = ((ScreenHeight / 1440) * PixPerInX)
End If
ScreenTop = Int(((ScreenTop + (ScreenHeight / 2)) / 1440 * PixPerInY) - (AVISizeH / 2))
ScreenLeft = Int(((ScreenLeft + (ScreenWidth / 2)) / 1440 * PixPerInX) - (AVISizeW / 2))
Else 'Auto = False
'Non-proportionally resize .AVI to fit the display area
AVISizeW = Int((ScreenWidth / 1440) * PixPerInX)
AVISizeH = Int((ScreenHeight / 1440) * PixPerInY)
ScreenTop = Int((ScreenTop / 1440) * PixPerInY)
ScreenLeft = Int((ScreenLeft / 1440) * PixPerInX)
End If
'Put the AVI window on the display area
vid = AVIFunction("put TheVideo window at" & " " & _
" " & ScreenLeft & " " & ScreenTop & _
" " & AVISizeW & " " & AVISizeH _
, 0&, 0, 0)
'Stop any playing .WAV
StopSound
'play the avi
vid = AVIFunction("play TheVideo", 0&, 0, 0)
TheEnd:
End Sub
Sub PauseAVI()
vid = AVIFunction("pause TheVideo", 0&, 0, 0)
End Sub
Sub ResumeAVI()
vid = AVIFunction("resume TheVideo", 0&, 0, 0)
End Sub
Sub StopAVI()
vid = AVIFunction("close TheVideo", 0&, 0, 0)
End Sub
Sub PlaySound(WAVFile As String)
Dim CmdStr As String
StopAVI 'Stop any playing AVI
StopSound 'Stop any playing .WAV
'Open the waveaudio device with WAVFile
CmdStr = ("open " & WAVFile & " type waveaudio alias TheWAV"

vid = AVIFunction(CmdStr, 0&, 0, 0)
'Play WAVFile
vid = AVIFunction("play TheWAV", 0&, 0, 0)
End Sub
Sub StopSound()
'Stop any playing .WAV
vid = AVIFunction("close TheWAV", 0&, 0, 0)
End Sub