使用 VBA Excel 播放任何音频文件

Question

I have a piece of code which can read most audio files (including wav, mp3, midi...), but it won't work if there are spaces in the path or File name.

so I have to revert to my other code which accepts it, but reads only wav files...

this is the code for reading all type of audio:

Option Explicit

Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias _
   "mciSendStringA" (ByVal lpstrCommand As String, ByVal _
   lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
   hwndCallback As Long) As Long

Private sMusicFile As String
Dim Play

Public Sub Sound2(ByVal File$) 

sMusicFile = File    'path has been included. Ex. "C:\3rdMan.mp3

Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
If Play <> 0 Then 'this triggers if can't play the file
    'Play = mciSendString("'play " & sMusicFile & "'", 0&, 0, 0) 'i tried this aproach, but doesn't seem to work
End If
   
End Sub


Public Sub StopSound(Optional ByVal FullFile$)
Play = mciSendString("close " & sMusicFile, 0&, 0, 0)
End Sub

Any help much appreciated, (I don't want workaround with external player popup, nor which I can't stop from playing with VBA)

Answer 1

i found The work-around, that correct spaces in path name (and (edit) for file name (using copy of file with no spaces, ugly but works ( name as would not be a good solution) :

After the first attempt to play the sound, if fails i change the current directory to the sound directory (temporarely):

If Play <> 0 Then 

    Dim path$, FileName0$
    path = CurDir

    If InStr(sMusicFile, ":") > 0 Then ChDrive (Left(sMusicFile, 1))
    If InStr(sMusicFile, "\") > 0 Then
        ChDir (Left(sMusicFile, InStrRev(sMusicFile, "\") - 1))
        FileName0 = Mid(sMusicFile, InStrRev(sMusicFile, "\") + 1)
        If InStr(FileName0, " ") > 0 Then
            FileCopy FileName0, Replace(FileName0, " ", "")
            sMusicFile = Left(sMusicFile, InStrRev(sMusicFile, "\")) & Replace(FileName0, " ", "")
            Play = mciSendString("play " & Replace(FileName0, " ", ""), 0&, 0, 0)
        Else
            Play = mciSendString("play " & FileName0, 0&, 0, 0) 
        End If
    Else
        FileName0 = Replace(sMusicFile, " ", "")
        If sMusicFile <> FileName0 Then
            FileCopy sMusicFile, FileName0
            sMusicFile = FileName0
        End If
        Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
    End If

    ChDrive (Left(path, 1))
    ChDir (Left(path, InStrRev(path, "\") - 1))

End If

Note : for spaces in the name i got also a new method : Filecopy sMusicFile replace(sMusicFile," ","%") and then play this new file

Answer 2

Go old-school...think DOS.
For example:
"C:\\Way Too Long\\Long Directory\\File.mp3"
becomes
"C:\\WayToo~1\\LongDi~1\\File.mp3"

The trick is to get rid of spaces and keep directories and filenames under 8 characters. To do this, remove all spaces, then truncate after the first 6 characters and add a tilde (~) plus the number one.
I tried this method and it worked perfectly for me.

One thing to be cautious of is that if there is a chance of ambiguity in a shortened directory name (like "\\Long File Path\\" and "\\Long File Paths\\" and "\\Long File Path 1436\\") then you'll need to adjust the number after the tilde ("\\LongFi~1\\" and "\\LongFi~2\\" and "\\LongFi~3\\", in the order in which the directories were created).

Therefore, it is possible that a previous folder was called "FilePa~1" and was deleted while a similarly named "FilePa~2" was left. So your file path may not automatically be suffixed with a "~1". It might be "~2" or something higher, depending on how many similarly named directories or filenames there were.

I find it incredible that dos was released 35 years ago, and VBA programmers are still having to deal with this dinosaur of a problem with directories!

Answer 3

Try:

Public Sub Sound2(ByVal File$)

If InStr(1, File, " ") > 0 Then File = """" & File & """"

sMusicFile = File

...

This will wrap the path in quotes if there is a space, which is required for some API functions.

Answer 4

The following solution works without having to copy the file.

It incorporates your code together with code from osknows in Get full path with Unicode file name with the idea from Jared above...

Option Explicit

Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias _
   "mciSendStringA" (ByVal lpstrCommand As String, ByVal _
   lpstrReturnString As Any, 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 lBuffer As Long) As Long

Private sMusicFile As String
Dim Play, a

Public Sub Sound2(ByVal File$)

sMusicFile = GetShortPath(File)

Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
If Play <> 0 Then 'this triggers if can't play the file
   'Play = mciSendString("'play " & sMusicFile & "'", 0&, 0, 0) 'i tried this aproach, but doesn't seem to work
End If

End Sub


Public Sub StopSound(Optional ByVal FullFile$)
Play = mciSendString("close " & sMusicFile, 0&, 0, 0)
End Sub


Public Function GetShortPath(ByVal strFileName As String) As String
    'KPD-Team 1999
    'URL: [url]http://www.allapi.net/[/url]
    'E-Mail: [email]KPDTeam@Allapi.net[/email]
    Dim lngRes As Long, strPath As String
    'Create a buffer
    strPath = String$(165, 0)
    'retrieve the short pathname
    lngRes = GetShortPathName(strFileName, strPath, 164)
    'remove all unnecessary chr$(0)'s
    GetShortPath = Left$(strPath, lngRes)
End Function

Answer 5

The function converts long full filename to 8.3 short format.

Function get8_3FullFileName(ByVal sFullFileName As String) As String
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    get8_3FullFileName = FSO.GetFile(sFullFileName).ShortPath
End Function

Try it.