Basic media playing class

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
   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
           '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
       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"
           'Bail out
           strFilename = ""
           'Show error message
           Call MsgBox("Error! File was not found!")
       End If
       '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

You might also like...


Marc Pritchard Apart from my school work I put most of my effort into running my joke site, I'd like to think that it makes someone smile each day. For about 1/2 a year I've been programming more and more in serv...


Why not write for us? Or you could submit an event or a user group in your area. Alternatively just tell us what you think!

Our tools

We've got automatic conversion tools to convert C# to VB.NET, VB.NET to C#. Also you can compress javascript and compress css and generate sql connection strings.

“Walking on water and developing software from a specification are easy if both are frozen.” - Edward V Berard