Option Explicit

'MCI文字列
'http://eternalwindows.jp/winmm/mci/mci02.html

Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, _
     ByVal uFlags As Long) As Long

Private Const SND_SYNC = &H0
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
Private Const SND_MEMORY = &H4
Private Const SND_LOOP = &H8
Private Const SND_NOSTOP = &H10

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


Dim Com As String

Public Const SOUND_ALIAS = "MySound"


'■PlaySound　−　サウンドファイルを開く
'■引数：strFileName ファイルパス
'　　　　strAlias    MCI名
Public Sub OpenSound(strFileName As String, strAlias As String)

    On Error GoTo MyErr
    Com = "open " & """" & strFileName & """" & " alias " & strAlias & " type MPEGVideo"
    Call mciSendString(Com, "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0
    
End Sub

'■CloseSound　−　サウンドファイルを閉じる
'■引数：strAlias   MCI名
Public Sub CloseSound(strAlias As String)

    On Error GoTo MyErr
    Call mciSendString("close """ & strAlias & """", "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Sub

'■PlaySound　−　サウンドを再生する
'■引数：strAlias   MCI名
Public Sub PlaySound(strAlias As String)

    On Error GoTo MyErr
    Call mciSendString("play " & strAlias, "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Sub

'■PauseSound　−　サウンドの再生を一時停止する
'■引数：strAlias   MCI名
Public Sub PauseSound(strAlias As String)

    On Error GoTo MyErr
    Call mciSendString("pause " & strAlias, "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Sub

'■ResumeSound　−　一時停止の続きからサウンドの再生をする
'■引数：strAlias   MCI名
Public Sub ResumeSound(strAlias As String)

    On Error GoTo MyErr
    Call mciSendString("resume " & strAlias, "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Sub

'■StopSound　−　サウンドの再生を停止する
'■引数：strAlias   MCI名
Public Sub StopSound(strAlias As String)

    On Error GoTo MyErr
    Call mciSendString("stop " & strAlias, "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Sub

'■GetLength　−　ファイルの長さを秒単位で返す。
'■引数：strAlias   MCI名
Public Function GetSoundLength(strAlias As String) As Double

    Dim strStatus As String * 256
    Dim MCICommandString As String
    
    On Error GoTo MyErr
    
    MCICommandString = "status " & strAlias & " length"
    Call mciSendString(MCICommandString, strStatus, Len(strStatus), 0)
    GetSoundLength = Val(strStatus) / 1000
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Function

'■GetPosition　−　再生中のファイルの位置を秒単位で返す。
'■引数：strAlias   MCI名
Public Function GetSoundPosition(strAlias As String) As Double

    Dim strStatus As String * 256
    Dim MCICommandString As String

    On Error GoTo MyErr
    MCICommandString = "status " & strAlias & " position"
    mciSendString MCICommandString, strStatus, Len(strStatus), 0
    
    GetSoundPosition = Val(strStatus) / 1000
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Function

'■SetPosition　−　ファイルの再生位置を指定する。
'■引数：strAlias   MCI名
'■      Position   再生位置を秒単位で指定する
Public Sub SetSoundPosition(strAlias As String, Position As Double)

    Dim NewPosition As Long

    On Error GoTo MyErr
    NewPosition = Position * 1000

    Call mciSendString("seek " & strAlias & " to " & NewPosition, "", 0, 0)
    Call mciSendString("play " & strAlias, "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Sub

'■GetSoundStatus　−　現在の再生状態を取得する
'■引数：strAlias   MCI名
'■戻り値：再生中のとき"PLAYING"、停止中のとき"STOPPED"、一時停止中のとき"PAUSED"
Public Function GetSoundStatus(strAlias As String) As String

    Dim MCICommandString As String

    On Error GoTo MyErr
    Dim strStatus As String * 256
    MCICommandString = "status " & strAlias & " mode"
    Call mciSendString(MCICommandString, strStatus, Len(strStatus), 0)

    GetSoundStatus = GetString(strStatus)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Function


'■SetVolume　−　音量を取得
'■引数：strAlias   MCI名
Public Function GetSoundVolume(strAlias As String) As Double

    Dim strStatus As String * 256
    
    On Error GoTo MyErr
    Call mciSendString("status " & strAlias & " volume ", strStatus, Len(strStatus), 0)
    GetSoundVolume = Val(GetString(strStatus))
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0

End Function

'■SetVolume　−　音量をセット
'■引数：strAlias   MCI名
'■      Vol   音量を指定する
Public Sub SetSoundVolume(strAlias As String, Vol As Double)


    On Error GoTo MyErr
    Call mciSendString("setaudio " & strAlias & " volume to " & Vol, "", 0, 0)
    GoTo MyEnd
MyErr:
    MsgBox Err.Number & " " & Err.Description
MyEnd:
    On Error GoTo 0
End Sub

Public Function GetString(strBuf As String) As String
'
' Null位置までの文字列を取得する
'
    Dim p As Long
    p = InStr(1, strBuf, vbNullChar) - 1
    If p < 0 Then p = 0
    GetString = Left(strBuf, p)
End Function