To use this class declare an instance and set the filename. Then you can play, stop and pause the file and get the position.
Option Explicit
'API declares
Private Declare Function mciGetErrorString Lib "WINMM.DLL" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
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
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
'Current State Enumeration
Private Enum enumState
Stopped = 0
Playing = 1
Paused = 2
End Enum
'Our class variables
Private strAlias As String
Private strFilename As String
Private lngLastTick, lngElapsedTime, lngLastPosition As Long
Private stState As enumState
'This function send the message out to the API.
Private Function DoCmd(ByVal cCmd As String, Optional ByRef ReturnString As String = 0, Optional ByVal ReturnStringLength As Long = 0) As String
On Error GoTo ErrHap
Dim retString As String
Dim ret As String * 128
'Send message
retString = mciSendString(cCmd, ReturnString, ReturnStringLength, 0)
If retString <> 0 Then
mciGetErrorString retString, ret, 128
DoCmd = Right$(ret, Len(ret) - InStr(1, ret, "263") - 2)
Debug.Print "MCI Error: " & DoCmd
End If
Exit Function
ErrHap:
Debug.Print "DoCmd: "; Err.Description
End Function
Private Sub Class_Initialize()
'Initialize the MCI
Debug.Print "*** Created by Smile005 ***"
Debug.Print "*** Using MCI ***"
Debug.Print "*** Copyright © 2003 ***"
strAlias = "MMedia"
DoCmd "CLOSE ALL"
End Sub
Public Sub Play()
'Send play message if not playing
If Not stState = Playing And strFilename <> "" Then
DoCmd "PLAY " & strAlias
stState = Playing
End If
End Sub
Public Sub StopPlay()
'Send stop message if not already stopped
If Not stState = Stopped And strFilename <> "" Then
DoCmd "STOP " & strAlias
Position = 0
stState = Stopped
End If
End Sub
Public Sub Pause()
'Check current state
If stState = Paused And strFilename <> "" Then
DoCmd "PLAY " & strAlias
stState = Playing
ElseIf strFilename <> "" Then
DoCmd "PAUSE " & strAlias
stState = Paused
End If
End Sub
Public Property Get Position() As Long
'Check what state
If Not stState = Stopped And strFilename <> "" Then
'Check if 2 seconds have passed since we last checked
If lngLastTick < GetTickCount - 3000 Or lngLastTick = 0 Then
'Set last tick
lngLastTick = GetTickCount
Dim RetPos As String * 30
DoCmd "STATUS " & strAlias & " POSITION", RetPos, Len(RetPos)
lngLastPosition = CLng(Mid$(RetPos, 1, Len(RetPos)) / 1000)
Position = lngLastPosition
Else
'Return last position and elapsed time
Position = lngLastPosition + ((GetTickCount - lngLastTick) / 1000)
End If
End If
End Property
Public Property Let Position(ByVal lngNewValue As Long)
'Check if we've opened a file
If strFilename <> "" And strFilename <> "" Then
DoCmd "SEEK " & strAlias & " TO " & lngNewValue
End If
End Property
Public Property Get Filename() As String
'Return filename string
Filename = strFilename
End Property
Public Property Let Filename(ByVal strNewValue As String)
'Check that it's ok
If Not strNewValue = "" Then
'Set filename string
strFilename = strNewValue
'Load filename
Dim lenshort As Long
Dim tmp As String * 255
'Set
lenshort = GetShortPathName(strNewValue, tmp, 255)
strFilename = Left$(tmp, lenshort)
'Close existing files
DoCmd "CLOSE ALL"
'Open file
If DoCmd("OPEN " & strFilename & " TYPE MPEGVideo ALIAS " & strAlias) = "" Then
DoCmd "SET " & strAlias & " TIME FORMAT Milliseconds"
Else
'Bail out
strFilename = ""
'Show error message
Call MsgBox("Error! File was not found!")
End If
Else
'Show error message
Call MsgBox("Error! Need non-empty filename!")
End If
End Property
Private Sub Class_Terminate()
'Close all when leaving
DoCmd "CLOSE ALL"
End Sub
Comments