'sType="waveaudio" -to play WAV
  'sType="MPEGVideo" -to play mp3

  If MP3_Open(AudioStr, "MyWavFile", "waveaudio") Then
    SliderPos.Enabled = True
    SliderPos.Max = MP3_length("MyWavFile")
    SliderPos.SmallChange = SliderPos.Max / 40
    SliderPos.LargeChange = SliderPos.Max / 20
    LabelWavLength.Caption = "Duration: " & TimeFromMilliseconds(SliderPos.Value) & "/" & TimeFromMilliseconds(SliderPos.Max)
    ToolbarPlayPauseStop.Buttons("PLAY").Enabled = True
    'ToolbarPlayPauseStop.Buttons("PAUSE").Enabled = True
    'ToolbarPlayPauseStop.Buttons("PAUSE").Value = tbrUnpressed
    'ToolbarPlayPauseStop.Buttons("STOP").Enabled = True
  End If

'http://www.vbarchiv.net/tipps/details.php?id=499

' Module MP3-Play and Stop via API
Option Explicit

'Multimedia Functions
Public Declare Function mciSendString Lib "winmm.dll" _
 Alias "mciSendStringA" ( _
 ByVal lpszCommand As String, _
 ByVal lpszReturnString As String, _
 ByVal cchReturn As Long, _
 ByVal hwndCallback As Long) As Long

'Multimedia Messages

'wFlags (MM_MCINOTIFY message) - Reason for the notification
Public Const MCI_NOTIFY_SUCCESSFUL = &H1        'Notification successful
Public Const MCI_NOTIFY_SUPERSEDED = &H2        'Notification superseded
Public Const MCI_NOTIFY_ABORTED = &H4           'Notification aborted
Public Const MCI_NOTIFY_FAILURE = &H8           'Notification failed

Public Const MM_MCINOTIFY = &H3B9
'

Public Function MP3_Play(ByVal sFile As String, _
 ByVal sAlias As String, ByVal sType As String, ByVal hwnd_cb As Long) As Boolean
 
  'sType="waveaudio" -to play WAV
  'sType="MPEGVideo" -to play mp3
 
  Dim bResult As Boolean
 
  ' Dateinamen in DOS 8.3 Format, da z.B. Sonderzeichen
  ' wie Leerzeichen Probleme machen
  Dim sBuffer As String
  Dim lResult As Long
 
  sBuffer = Space$(255)
  lResult = GetShortPathName(sFile, sBuffer, Len(sBuffer))

  If lResult <> 0 Then
    sFile = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
 
    ' MCI &#246;ffnen
    lResult = mciSendString("open " & sFile & " type " & sType & " alias " & sAlias, 0, 0, 0)
 
    If lResult = 0 Then
      ' MP3 abspielen
      If mciSendString("play " & sAlias & " from 0 notify", 0, 0, hwnd_cb) = 0 Then
        bResult = True
      End If
    End If
  End If
 
  MP3_Play = bResult
End Function

Public Sub MP3_Stop(ByVal sAlias As String)
  mciSendString "stop " & sAlias, 0, 0, 0
  mciSendString "close " & sAlias, 0, 0, 0
End Sub

Public Function MP3_Play_only(ByVal sAlias As String, sPosition As String, ByVal hwnd_cb As Long) As Boolean
  If mciSendString("play " & sAlias & " from " & sPosition & " notify", 0, 0, hwnd_cb) = 0 Then
    MP3_Play_only = True
  End If
End Function

Public Function MP3_Stop_only(ByVal sAlias As String) As Boolean
  If mciSendString("stop " & sAlias, 0, 0, 0) = 0 Then
    MP3_Stop_only = True
  End If
End Function

Public Sub MP3_Close_only(ByVal sAlias As String)
  mciSendString "close " & sAlias, 0, 0, 0
End Sub

Public Function MP3_Open(ByVal sFile As String, _
 ByVal sAlias As String, ByVal sType As String) As Boolean
 
  Dim bResult As Boolean
 
  ' Dateinamen in DOS 8.3 Format, da z.B. Sonderzeichen
  ' wie Leerzeichen Probleme machen
  Dim sBuffer As String
  Dim lResult As Long
 
  sBuffer = Space$(255)
  lResult = GetShortPathName(sFile, sBuffer, Len(sBuffer))

  If lResult <> 0 Then
    sFile = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
 
    ' MCI &#246;ffnen
    lResult = mciSendString("open " & sFile & " type " & sType & " alias " & sAlias, 0, 0, 0)
 
    If lResult = 0 Then
      bResult = True
    End If
  End If
 
  MP3_Open = bResult
End Function

Public Function MP3_length(ByVal sAlias As String) As Long

  Dim RetString As String * 256
  Dim strCommand As String
  Dim lResult As Long

  strCommand = "set " & sAlias & " time format milliseconds"
  mciSendString strCommand, vbNullString, 0, 0&
  strCommand = "status " & sAlias & " length"
  lResult = mciSendString(strCommand, RetString, Len(RetString), 0&)
  If lResult = 0 Then
    MP3_length = CLng(RetString)
  End If
End Function

Public Function MP3_position(ByVal sAlias As String) As Long

  Dim RetString As String * 256
  Dim strCommand As String
  Dim lResult As Long

  strCommand = "status " & sAlias & " position"
  lResult = mciSendString(strCommand, RetString, Len(RetString), 0&)
  If lResult <> 0 Then
    MP3_position = -1   'Not playing
  Else
    MP3_position = CLng(RetString)
  End If
End Function

Public Function MP3_seek(ByVal sAlias As String, ByVal sPosition As Long) As Boolean

  Dim RetString As String * 256
  Dim strCommand As String
  Dim lResult As Long

  strCommand = "seek " & sAlias & " to " & CStr(sPosition)
  lResult = mciSendString(strCommand, 0&, 0&, 0&)
  If lResult = 0 Then
    MP3_seek = True
  End If
End Function

'Pause the named media instance
Public Function MP3_pause(ByVal sAlias As String) As Boolean

  Dim strCommand As String
  Dim lResult As Long

  strCommand = "pause " & sAlias
  lResult = mciSendString(strCommand, 0&, 0&, 0&)

  'Get the error message if there is any else return current status
  If lResult = 0 Then
    MP3_pause = True
  End If
End Function

'Resume the named media instance
Public Function MP3_resume(ByVal sAlias As String) As Boolean

  Dim strCommand As String
  Dim lResult As Long

  strCommand = "resume " & sAlias
  lResult = mciSendString(strCommand, 0&, 0&, 0&)

  'Get the error message if there is any else return current status
  If lResult = 0 Then
    MP3_resume = True
  End If
End Function

Public Function TimeFromMilliseconds(the_ms As Long) As String
  'используется с mp3_play
  Dim s_hour As Long
  Dim s_min As Long
  Dim s_sec As Long
  Dim s_ms As Long
  
  s_hour = the_ms \ 3600000 '3600sec*1000
  s_min = (the_ms Mod 3600000) \ 60000 '60sec*1000
  s_sec = (the_ms Mod 60000) \ 1000 '1000ms в минуте
  s_ms = the_ms Mod 1000
  TimeFromMilliseconds = IIf((s_hour > 0), Format$(s_hour, "00:"), "") & _
   Format$(s_min, "00:") & Format$(s_sec, "00:") & _
   Format$(CLng(s_ms \ 100) * 10, "00")
End Function

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

  Dim the_wav As WavFileInfo
  
  the_wav = GetWavFileInfo(m_FilePath)
  If the_wav.is_wav Then
    Dim wSize As Long 'размер файла в байтах
    Dim msLenth As Long 'длина записи в миллисекундах
    wSize = GetFileS(m_recFilePath)
    msLenth = GetWavFileDuration(the_wav.wav_format.nAvgBytesPerSec, wSize)
...
    ... = TimeSecFromMillisecondsStr(msLenth)
    ... = GetWavFormatFreq(the_wav.wav_format.nSamplesPerSec)
  End If

Private Const OF_READ = &H0&

Private Declare Function lOpen Lib "kernel32" Alias "_lopen" _
 (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" _
 (ByVal hFile As Long) As Long

Public Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long

Public Function GetFileS(FilePath As String) As Long
  Dim lpFSHigh As Long
  Dim Pointer As Long, sizeofFile As Long
  Pointer = lOpen(FilePath, OF_READ)
  'have size of the file in bytes as long
  sizeofFile = GetFileSize(Pointer, lpFSHigh)
  GetFileS = sizeofFile
  lclose Pointer
End Function

Option Explicit

Public Const MMSYSERR_NOERROR As Long = 0

'Multimedia Structures

Public Type MMCKINFO
  ckid As Long
  ckSize As Long
  fccType As Long
  dwDataOffset As Long
  dwFlags As Long
End Type

Public Type MMIOINFO
  dwFlags As Long
  fccIOProc As Long
  pIOProc As Long
  wErrorRet As Long
  htask As Long
  cchBuffer As Long
  pchBuffer As Long 'String
  pchNext As String
  pchEndRead As String
  pchEndWrite As String
  lBufOffset As Long
  lDiskOffset As Long
  adwInfo(4) As Long
  dwReserved1 As Long
  dwReserved2 As Long
  hmmio As Long
End Type

'внимательно с этой структурой! некоторое несоответствие с MSDN
Public Type WAVEFORMATEX
  wFormatTag As Integer       ' format type
  nChannels As Integer        ' number of channels (i.e. mono, stereo, etc.)
  nSamplesPerSec As Long      ' sample rate
  nAvgBytesPerSec As Long     ' for buffer estimation
  nBlockAlign As Integer      ' block size of data
  wBitsPerSample As Integer   ' Bits Per Sample
  cbSize As Integer           ' Size Of (FACT CHUNK)
  xBytes(11) As Byte
End Type

'Multimedia Functions

Public Declare Function mmioAscend Lib "winmm.dll" (ByVal hmmio As Long, _
 lpck As MMCKINFO, ByVal wFlags As Long) As Long
Public Declare Function mmioClose Lib "winmm.dll" (ByVal hmmio As Long, ByVal wFlags As Long) As Long

' wFlags - Search flags
Public Const MMIO_FINDCHUNK = &H10 'Searches for a chunk with the specified chunk identifier
Public Const MMIO_FINDRIFF = &H20 'Searches for a chunk with the chunk identifier "RIFF" and with the specified form type

Public Declare Function mmioDescend Lib "winmm.dll" (ByVal hmmio As Long, lpck As MMCKINFO, _
 lpckParent As MMCKINFO, ByVal wFlags As Long) As Long
Public Declare Function mmioDescendParent Lib "winmm.dll" Alias "mmioDescend" (ByVal hmmio As Long, _
 lpck As MMCKINFO, ByVal lpckParent As Long, ByVal wFlags As Long) As Long

' dwOpenFlags - Flags for the open operation
Public Const MMIO_READ = &H0
Public Const MMIO_READWRITE = &H2
Public Const MMIO_CREATE = &H1000&
Public Const MMIO_ALLOCBUF = &H10000

Public Declare Function mmioOpen Lib "winmm.dll" Alias "mmioOpenA" (ByVal szFileName As String, _
 lpmmioinfo As MMIOINFO, ByVal dwOpenFlags As Long) As Long

Public Declare Function mmioRead Lib "winmm.dll" (ByVal hmmio As Long, _
 ByVal pch As Long, ByVal cch As Long) As Long
Public Declare Function mmioReadString Lib "winmm.dll" Alias "mmioRead" (ByVal hmmio As Long, _
 ByVal pch As String, ByVal cch As Long) As Long
 
' iOrigin - Flags indicating how the offset specified by lOffset is interpreted
Public Const SEEK_CUR = 1
Public Const SEEK_SET = 0

Public Declare Function mmioSeek Lib "winmm.dll" (ByVal hmmio As Long, _
 ByVal lOffset As Long, ByVal iOrigin As Long) As Long

Public Declare Function mmioStringToFOURCC Lib "winmm.dll" Alias "mmioStringToFOURCCA" (ByVal sz As String, _
 ByVal wFlags As Long) As Long

Private Type ChunkInfo
  start               As Long
  length              As Long
End Type

Public Type WavFileInfo
  is_wav              As Boolean
  wav_format          As WAVEFORMATEX
End Type

Private Function GetWavChunkPos(ByVal strFile As String, ByVal strChunk As String) As ChunkInfo
  Dim hMmioIn_ch          As Long
  Dim lR                  As Long
  Dim mmckinfoParentIn    As MMCKINFO
  Dim mmckinfoSubchunkIn  As MMCKINFO
  Dim mmioinf             As MMIOINFO

  ' open WAV for read access
  hMmioIn_ch = mmioOpen(strFile, mmioinf, MMIO_READ)
  If hMmioIn_ch = 0 Then
    Exit Function
  End If

  ' check if it is really a WAV
  mmckinfoParentIn.fccType = mmioStringToFOURCC("WAVE", 0)
  lR = mmioDescendParent(hMmioIn_ch, mmckinfoParentIn, 0, MMIO_FINDRIFF)
  If Not (lR = MMSYSERR_NOERROR) Then
    mmioClose hMmioIn_ch, 0
    Exit Function
  End If

  ' search for the requested chunk
  mmckinfoSubchunkIn.ckid = mmioStringToFOURCC(strChunk, 0)
  lR = mmioDescend(hMmioIn_ch, mmckinfoSubchunkIn, mmckinfoParentIn, MMIO_FINDCHUNK)
  If Not (lR = MMSYSERR_NOERROR) Then
    mmioClose hMmioIn_ch, 0
    Exit Function
  End If

  ' return startpos and length of the chunk
  GetWavChunkPos.start = mmioSeek(hMmioIn_ch, 0, SEEK_CUR)
  GetWavChunkPos.length = mmckinfoSubchunkIn.ckSize

  mmioClose hMmioIn_ch, 0
End Function

Public Function GetWavFileInfo(ByVal strFile As String) As WavFileInfo
  Dim WavChunkPos As ChunkInfo
  Dim FF      As Integer
  
  GetWavFileInfo.is_wav = False
  
  If Err Then Exit Function
  On Error GoTo 0
  
  ' get fmt Chunk Position
  WavChunkPos = GetWavChunkPos(strFile, "fmt ")

  With WavChunkPos
    ' valid Chunk?
    If .start <> 0 And .length <> 0 Then
      ' read Wave Format
      FF = FreeFile
      Open strFile For Binary As #FF
      Get #FF, .start + 1, GetWavFileInfo.wav_format
      Close #FF
      GetWavFileInfo.is_wav = True
    End If
  End With
  
End Function

Public Function GetWavFormatName(w_FormatTag As Integer) As String
  Select Case w_FormatTag
    Case 1:
      GetWavFormatName = "PCM"
    Case 2:
      GetWavFormatName = "Microsoft ADPCM"
    Case 6:
      GetWavFormatName = "CCITT A-law"
    Case 7:
      GetWavFormatName = "CCITT u-law"
    Case 17:
      GetWavFormatName = "IMA ADPCM"
    Case 20:
      GetWavFormatName = "ITU G.723 ADPCM (Yamaha)"
    Case 49:
      GetWavFormatName = "GSM 6.10"
    Case 64:
      GetWavFormatName = "ITU G.721 ADPCM"
    Case 66:
      GetWavFormatName = "Microsoft G.723.1"
    Case 80:
      GetWavFormatName = "MPEG"
    Case 85:
      GetWavFormatName = "MPEG Layer-3"
    Case Else
      GetWavFormatName = CStr(w_FormatTag) & "(Unknown)"
  End Select
End Function

Public Function GetWavFormatDetails(n_SamplesPerSec As Long, w_BitsPerSample As Integer, _
 n_Channels As Integer) As String
  Dim fmt_SamplesPerSec As String
  fmt_SamplesPerSec = CStr(n_SamplesPerSec)
  If Len(fmt_SamplesPerSec) > 3 Then
    fmt_SamplesPerSec = Left(fmt_SamplesPerSec, Len(fmt_SamplesPerSec) - 3) & "," & Right(fmt_SamplesPerSec, 3)
  Else
    fmt_SamplesPerSec = "0," & Format(fmt_SamplesPerSec, "000")
  End If
  fmt_SamplesPerSec = fmt_SamplesPerSec & " kHz"
  GetWavFormatDetails = fmt_SamplesPerSec & "; " & CStr(w_BitsPerSample) & " Bit; " & _
   IIf((n_Channels = 1), "Mono", "Stereo")
End Function

Public Function GetWavFileDuration(nAvgBytesPerSec As Long, file_lenth As Long) As Long
  If nAvgBytesPerSec <= 0 Then 'страховка
    GetWavFileDuration = 0
  ElseIf file_lenth < 44 Then 'страховка
    GetWavFileDuration = 0
  Else
    GetWavFileDuration = 1000 * ((file_lenth - 44) / nAvgBytesPerSec)
  End If
End Function

Public Function GetWavFormatFreq(n_SamplesPerSec As Long) As String
  Dim fmt_SamplesPerSec As String
  fmt_SamplesPerSec = CStr(n_SamplesPerSec)
  If Len(fmt_SamplesPerSec) > 3 Then
    fmt_SamplesPerSec = Left(fmt_SamplesPerSec, Len(fmt_SamplesPerSec) - 3) & "," & Right(fmt_SamplesPerSec, 3)
  Else
    fmt_SamplesPerSec = "0," & Format(fmt_SamplesPerSec, "000")
  End If
  fmt_SamplesPerSec = fmt_SamplesPerSec & " kHz"
  GetWavFormatFreq = fmt_SamplesPerSec
End Function