使用vba excel播放任何音频文件

时间:2015-01-01 17:09:57

标签: excel vba audio

祝新年快乐。

我目前有一段代码可以读取大多数音频文件(包括wav,mp3,midi ......),但如果路径或文件名中有空格,它就无法使用。

所以我必须恢复我接受它的其他代码,但只读wav文件......

这是用于阅读所有类型音频的代码:

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

任何帮助非常感谢,(我不希望与外部播放器弹出窗口一起解决,也不希望我无法停止使用vba)

4 个答案:

答案 0 :(得分:1)

去老派......想想DOS 例如:
&#34; C:\ Way Too Long \ Long Directory \ File.mp3&#34;
成为
&#34; C:\ WayToo〜1 \帝〜1 \ File.mp3&#34;

诀窍是摆脱空格并保持目录和文件名不超过8个字符。要执行此操作,请删除所有空格,然后在前6个字符后截断并添加波形符(〜)加上数字1。 我尝试了这种方法,它对我来说很有效
需要注意的一件事是,如果缩短的目录名称中存在歧义(例如&#34; \长文件路径\&#34;和&#34; \长文件路径\&#34;和&#34; \长文件路径1436 \&#34;)然后你需要在波形符号后调整数字(&#34; \ LongFi~1 \&#34;&#34; \ LongFi 〜2 \&#34;和&#34; \ LongFi~3 \&#34;,按照创建目录的顺序)。

因此,可能会调用前一个文件夹&#34; FilePa~1&#34;并被删除时,一个类似名称&#34; FilePa~2&#34;被留下。因此,您的文件路径可能不会自动以&#34; ~1&#34;为后缀。它可能是&#34; ~2&#34;或更高的东西,取决于有多少类似命名的目录或文件名
我发现令人难以置信的是,35年前发布了dos,VBA程序员仍然不得不处理目录中这个问题的恐龙!

答案 1 :(得分:0)

我找到了解决方法,在路径名中更正空格(和(编辑)文件名(使用没有空格的文件副本,丑陋但有效(name as不是一个好的解决方案):

首次尝试播放声音后,如果失败,我将当前目录更改为声音目录(临时):

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

注意:对于名称中的空格,我还有一个新方法:Filecopy sMusicFile replace(sMusicFile," ","%")然后播放这个新文件

答案 2 :(得分:0)

尝试:

Public Sub Sound2(ByVal File$)

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

sMusicFile = File

...

如果有空格,这将把路径包装在引号中,这是某些API函数所必需的。

答案 3 :(得分:0)

以下解决方案无需复制文件即可运行。

它将您的代码与来自Get full path with Unicode file name的osknows的代码以及上述Jared的想法结合在一起......

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