Musik wiedergabe

Option Explicit

' Benötigte API-Deklarationen
Public 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

Public Declare Function GetShortPathName Lib "kernel32" _
  Alias "GetShortPathNameA" ( _
  ByVal lpszLongPath As String, _
  ByVal lpszShortPath As String, _
  ByVal cchBuffer As Long) As Long

Public Enum mciType
  fromVideo = 0
  fromSound = 1
End Enum

' Multimedia-Datei öffnen
' Falls es sich um eine Videoausgabe handelt, erwartet die Funktion
' das Fensterhandle des Ausgabe-Controls (z.B. PictureBox oder Form)
' als 2. Parameter (hwnd_Output)
Public Sub mciOpen(ByVal sFile As String, _
  Optional ByVal hwnd_Output As Long = 0)
  
  Dim sBuffer As String * 255
  Dim sType As String
  Dim nResult As Long
  Dim sExt As String
  Dim bVideo As Boolean
  
  On Error Resume Next
  
  ' kurzen Dateinamen ermitteln
  nResult = GetShortPathName(sFile, sBuffer, Len(sBuffer))
  sFile = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)

  ' Multimedia-Typ ermitteln
  sType = mciGetType(sFile, bVideo)
  
  ' File öffnen
  mciSendString "open " & sFile & " type " & sType & " alias TempMCI", 0, 0, 0
  DoEvents

  ' Zeitformat auf Millisekunden einstellen
  mciSendString "set TempMCI time format milliseconds", 0, 0, 0
  DoEvents

  ' Falls es sich um eine Video-Datei handelt...
  If bVideo And hwnd_Output <> 0 Then
    mciSendString "window TempMCI handle " & CStr(hwnd_Output), 0, 0, 0
  End If
End Sub

' Multimedia-Datei abspielen
Public Sub mciPlay(Optional nFromPos As Long = 0)
  On Error Resume Next
  mciSendString "play TempMCI from " & CStr(nFromPos), 0, 0, 0
  mciSendString "put TempMCI destination", 0, 0, 0
End Sub

' Multimedia-Datei schließen
Public Sub mciClose()
  On Error Resume Next
  mciSendString "close TempMCI", 0, 0, 0
End Sub

' Abspielvorgang stoppen
Public Sub mciStop()
  On Error Resume Next
  mciSendString "stop TempMCI", 0, 0, 0
End Sub

' Pause
Public Sub mciPause()
  On Error Resume Next
  mciSendString "pause TempMCI", 0, 0, 0
End Sub

' Weiterspielen
Public Sub mciResume()
  On Error Resume Next
  mciSendString "resume TempMCI", 0, 0, 0
  mciSendString "put TempMCI destination", 0, 0, 0
End Sub

Public Function mciGetLength() As Long
  Dim sBuffer As String * 255

  On Error Resume Next
  mciSendString "status TempMCI length", sBuffer, Len(sBuffer), 0
  mciGetLength = Val(sBuffer)
End Function

Public Function mciGetStatus() As String
  Dim sBuffer As String * 255

  On Error Resume Next
  mciSendString "status TempMCI mode", sBuffer, Len(sBuffer), 0
  mciGetStatus = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
End Function

Public Function mciGetCurPos() As Long
  Dim sBuffer As String * 255
  
  On Error Resume Next
  mciSendString "status TempMCI position", sBuffer, Len(sBuffer), 0
  mciGetCurPos = Val(sBuffer)
End Function

' Millisekunden nach mm:ss umrechnen
 Public Function mciFormatTime(ByVal nMSec As Long) As String
  Dim nMin As Integer
  Dim nSec As Integer

  nSec = Int(nMSec / 1000)
  nMin = Int(nSec / 60)
  nSec = nSec - (nMin * 60)
  mciFormatTime = Format$(nMin, "00") & ":" & Format$(nSec, "00")
End Function

' Multimedia-Typ ermitteln
Public Function mciGetType(ByVal sFile As String, _
  ByRef bVideo As Boolean) As String

  Dim sExt As String
  
  bVideo = False
  If InStr(sFile, ".") > 0 Then
    sExt = Right$(sFile, Len(sFile) - InStrRev(sFile, ".", Len(sFile)))
    Select Case LCase(sExt)
      Case "mid", "midi"
        mciGetType = "Sequencer"
      Case "rmi"
        mciGetType = "Sequencer"
      Case "wav"
        mciGetType = "waveaudio"
      Case "cda"
        mciGetType = "CDAudio"
      Case "aif", "aifc", "aiff", "au", "mp3", "snd"
        mciGetType = "MPEGVideo"
      Case "wma"
        mciGetType = "MPEGVideo2"
      Case "mpeg", "mpg", "m1v", "mp2", "mpa", "mpe"
        mciGetType = "MPEGVideo"
        bVideo = True
      Case "avi"
        mciGetType = "AVIVideo"
        bVideo = True
      Case "wmv"
        mciGetType = "MPEGVideo2"
        bVideo = True
      Case Else
        mciGetType = "MPEGVideo"
    End Select
  End If
End Function