VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CMultiMedia"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Enum EMMStatus
    EMM_notReady
    EMM_playing
    EMM_paused
    EMM_stopped
    EMM_unknow
End Enum

Private m_strAlias As String
Private m_strPath As String
Private m_lParentHwnd As Long
Private m_bRepeat As Boolean
Private m_dLength As Double
Private m_lFrames As Long
Private m_bWait As Boolean
Private m_lWhere(3) 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 mciGetErrorString Lib "winmm.dll" _
    Alias "mciGetErrorStringA" (ByVal dwError As Long, _
    ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32" _
    (ByVal hwnd As Long, lpRect As RECT) As Long


Public Function mmOpen(ByVal sTheFile As String) As Long
    Dim lReturn As Long
    Static lCount As Long

    mmClose

    m_strPath = sTheFile

    lCount = lCount + 1
    m_strAlias = Right$(sTheFile, 3) & lCount
    If InStr(sTheFile, " ") Then sTheFile = Chr(34) & sTheFile & Chr(34)

    Dim str As String
    str = "Open " & sTheFile & " alias " & m_strAlias
    If m_lParentHwnd <> 0 Then
        str = str & " parent " & m_lParentHwnd & " style child"
    End If
    str = str & " wait"
    lReturn = mciSendString(str, "", 0, 0)
    mmOpen = lReturn

    If lReturn <> 0 Then
        Exit Function
    End If
'    If m_lParentHwnd <> 0 Then
'        SendString "window", "handle " & Format(m_lParentHwnd)
'    End If

    GetLength
    SendString "window", "state show"
'    str = SendString("setvideo", "brightness to 50")
    str = SendString("status", "video source")
'    str = SendString("status", "sharpness")
'    str = SendString("status", "tint")

    Dim ss As String
    ss = SendString("where", "source")
    Dim pvar As Variant
    pvar = Split(ss, " ")
    If VarType(pvar) And vbArray <> 0 Then
        If UBound(pvar) > 2 Then
            m_lWhere(0) = pvar(0)
            m_lWhere(1) = pvar(1)
            m_lWhere(2) = pvar(2)
            m_lWhere(3) = pvar(3)
        End If
    End If

End Function

Public Property Get mmErrorString(ByVal lErr As Long) As String
    Dim str As String
    str = Space(128)
    If mciGetErrorString(lErr, str, 128) = 0 Then
        mmErrorString = "Unknow error: & hex(lerr)"
    Else
        Dim k As Integer
        k = InStr(str, Chr(0))
        If k > 0 Then
            str = Left$(str, k)
        End If
        mmErrorString = str
    End If
End Property

Public Function mmClose() As Long
    mmClose = 0
    If m_strAlias = "" Then Exit Function
    mmClose = mciSendString("Close " & m_strAlias, "", 0, 0)
    m_strAlias = ""
    m_strPath = ""
    m_dLength = 0
    m_lWhere(0) = 0
    m_lWhere(1) = 0
    m_lWhere(2) = 0
    m_lWhere(3) = 0
End Function

Public Function mmPause() As Long
    mmPause = 0
    If m_strAlias = "" Then Exit Function
    mmPause = mciSendString("Pause " & m_strAlias, "", 0, 0)
End Function

Public Function mmPlay() As Long
    If m_strAlias = "" Then Exit Function
'    SendString "put", "destination"
    Dim str As String
    str = "Play " & m_strAlias
    If m_bWait Then
        str = str & " wait"
    End If
    If m_bRepeat Then
        str = str & " repeat"
    End If
    mmPlay = mciSendString(str, "", 0, 0)
    Dim ks As Long
    ks = GetTickCount
    Dim k As Integer
    Do
        If Me.Status = EMM_playing Then Exit Do
        k = k + 1
        If GetTickCount - ks > 1000 Then Exit Do
    Loop
    Debug.Print "Play status: ", Me.Status, k
End Function

Public Function mmStop() As Long
    If m_strAlias = "" Then Exit Function
    mmStop = mciSendString("Stop " & m_strAlias, "", 0, 0)
End Function

Public Function mmSeek(ByVal nPosition As Single) As Long
    If m_strAlias = "" Then Exit Function
    mmSeek = mciSendString("Seek " & m_strAlias & " to " & nPosition, "", 0, 0)
End Function

Public Function mmStep(ByVal lstep As Long) As Long
    mmStep = mciSendString("step " & m_strAlias & " by " & lstep, "", 0, 0)
End Function

Public Property Get FilePath() As String
    FilePath = m_strPath
End Property
Public Property Let FilePath(ByVal sFile As String)
    mmOpen sFile
End Property
Public Property Get Filename() As String
    Dim k As Integer
    k = InStrRev(m_strPath, "\")
    If k = 0 Then
        Filename = m_strPath
    Else
        Filename = Right$(m_strPath, Len(m_strPath) - k)
    End If
End Property

Public Property Let ParentHwnd(ByVal hwnd As Long)
    m_lParentHwnd = hwnd
End Property

Public Property Get Wait() As Boolean
    Wait = m_bWait
End Property
Public Property Let Wait(bWaitValue As Boolean)
    m_bWait = bWaitValue
End Property

Public Property Get HasVideo() As Boolean
    Dim str As String
    str = GetCapability("has video")
    HasVideo = (str = "true")
End Property
Public Property Get HasAudio() As Boolean
    Dim str As String
    str = GetCapability("has audio")
    HasAudio = (str = "true")
End Property
Public Property Get HasReverse() As Boolean
    Dim str As String
    str = GetCapability("has reverse")
    HasReverse = (str = "true")
End Property

Public Property Get Length() As Double
    Length = m_dLength
End Property
Public Property Get Frames() As Long
    Frames = m_lFrames
End Property
Public Property Get Repeat() As Boolean
    Repeat = m_bRepeat
End Property
Public Property Let Repeat(ByVal rpt As Boolean)
    m_bRepeat = rpt
End Property

Public Property Get Volume() As Double
    Dim st As String
    st = GetStatus("volume")
    If Len(st) > 0 Then
        Volume = st / 1000
    End If
End Property
Public Property Let Volume(ByVal fact As Double)
    If fact > 1 Then fact = 1
    If fact < 0 Then fact = 0
    SendString "setaudio", "volume to " & fact * 1000
End Property

Public Property Get AudioMute() As Boolean
    Dim st As String
    st = GetStatus("audio")
    AudioMute = Not (st = "on")
End Property
Public Property Let AudioMute(ByVal mute As Boolean)
    SendString "setaudio", IIf(mute, "off", "on")
End Property

Public Property Let Position(ByVal nPosition As Single)
    mmSeek nPosition
End Property
Public Property Get Position() As Single
    On Error Resume Next
    Dim str As String
    str = GetStatus("position")
    Position = str
End Property

Public Property Let SpeedFactor(ByVal sp As Double)
    SendString "set", "speed " & (sp * 1000)
End Property

Public Property Get Status() As EMMStatus
    Dim str As String
    str = GetStatus("mode")
    str = StrConv(str, vbLowerCase)
    Select Case str
    Case "not ready"
        Status = EMM_notReady
    Case "playing"
        Status = EMM_playing
    Case "paused"
        Status = EMM_paused
    Case "stopped"
        Status = EMM_stopped
    Case Else
        Status = EMM_unknow
    End Select
End Property
Public Property Get StatusString() As String
    StatusString = GetStatus("mode")
End Property

Public Property Get XOffset() As Long
    XOffset = m_lWhere(0)
End Property
Public Property Get XSize() As Long
    XSize = m_lWhere(2)
End Property
Public Property Get YOffset() As Long
    YOffset = m_lWhere(1)
End Property
Public Property Get YSize() As Long
    YSize = m_lWhere(3)
End Property

Public Sub SetNormalSize()
    SendString "put", "window client at 0 0 " & m_lWhere(2) & " " & m_lWhere(3)
End Sub
Public Sub StretchDisplay()
    Dim rc As RECT
    If m_strAlias = "" Then Exit Sub
    GetWindowRect m_lParentHwnd, rc
    Dim w As Long
    Dim h As Long
    w = rc.Right - rc.Left
    h = rc.Bottom - rc.Top
    Dim xx As Long
    xx = w * m_lWhere(3) / m_lWhere(2)
    If xx > h Then
        w = h * m_lWhere(2) / m_lWhere(3)
    Else
        h = w * m_lWhere(3) / m_lWhere(2)
'        xx = h * m_lWhere(2) / m_lWhere(3)
'        If xx > w Then
'        End If
    End If
    SendString "put", "window client at 0 0 " & w & " " & h
End Sub

Private Function GetStatus(ByVal cmd As String) As String
    On Error Resume Next
    GetStatus = SendString("status", cmd)
End Function
Private Function GetCapability(ByVal cmd As String) As String
    On Error Resume Next
    Dim sStatus As String
    sStatus = SendString("capability", cmd)
    GetCapability = StrConv(sStatus, vbLowerCase)
End Function

Private Function SendString(ByVal scommand As String, ByVal soption As String) As String
    On Error Resume Next
    Dim lRet As Long
    Dim sStatus As String
    sStatus = Space(256)
    lRet = mciSendString(scommand & " " & m_strAlias & " " & soption, sStatus, 255, 0)
    Dim nLength As Integer
    nLength = InStr(sStatus, Chr$(0))
    If nLength > 0 Then
        sStatus = Left$(sStatus, nLength - 1)
    End If
    SendString = sStatus
End Function

Private Sub GetLength()
    Dim wRate As Double
    Dim ss As String
    ss = SendString("status", "time format")

    Select Case ss
    Case "milliseconds"
        m_dLength = GetStatus("length")
        m_lFrames = m_dLength
        m_dLength = m_dLength / 1000
    Case Else
        SendString "set", "time format frames"
        wRate = GetStatus("nominal frame rate") / 1000
        m_lFrames = GetStatus("length")
        m_dLength = m_lFrames / wRate
    End Select
    Debug.Print "Time,Frames: " & m_dLength & " " & m_lFrames
    Debug.Print "Audio,Video,Reverse: " & HasAudio & " " & HasVideo & " " & HasReverse
End Sub

Private Sub Class_Terminate()
    mmClose
End Sub