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

7dl7o3gd  于 2023-02-05  发布在  其他
关注(0)|答案(6)|浏览(580)

我有一段代码,可以读取大多数音频文件(包括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)

xmakbtuz

xmakbtuz1#

我找到了解决办法,即更正路径名中的空格(和(编辑)文件名(使用没有空格的文件副本,丑陋,但工作(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," ","%"),然后播放此新文件

lyfkaqu1

lyfkaqu12#

用老办法想想DOS
例如:
"C:\路径太长\目录太长\File.mp3"
变成
"C:\路太~1\龙帝~1\文件. mp3"
诀窍是去掉空格,使目录和文件名少于8个字符。要做到这一点,去掉所有空格,然后在前6个字符后截断,并添加一个波浪号(~)加数字1。
我试过这个方法,效果很好。
需要注意的一点是,如果缩短的目录名(如"\Long File Path"、"\Long File Paths"和"\Long File Path 1436")可能会产生歧义,则需要调整波浪号后面的数字("\LongFi~1"、"\LongFi~2"和"\LongFi~3",按照目录创建的顺序)。
因此,有可能以前的文件夹名为"FilePa~1",并且在删除时留下了类似名称的"FilePa~2"。因此,您的文件路径可能不会自动添加后缀"~1 "。它可能是"~2"或更高的值,这取决于有多少类似名称的目录或文件名。
我觉得难以置信的是,dos在35年前就发布了,而VBA程序员仍然不得不处理这个目录问题的恐龙!

5f0d552i

5f0d552i3#

试试看:

Public Sub Sound2(ByVal File$)

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

sMusicFile = File

...

如果有空格,这将用引号将路径括起来,这是某些API函数所必需的。

q7solyqu

q7solyqu4#

以下解决方案无需复制文件即可工作。
它将您的代码与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
xpszyzbs

xpszyzbs5#

该函数将长完整文件名转换为8.3短格式。

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

试试看。

zu0ti5jz

zu0ti5jz6#

只是对改进VBA代码的一点小小贡献

1.第一步→下面是修改前的代码:
Play = mciSendString("play"& sMusicFile,0 &,0,0)If Play〈〉0 Then '如果无法播放文件,则触发此操作' Play = mciSendString("'play "& sMusicFile &"'",0 &,0,0)'我尝试过此方法,但似乎不起作用End If
1.第二步→这里是修正后的代码:

Play = mciSendString("play " & sMusicFile, 0&, 0, 0)

If Play <> vbNull Then 'this triggers if can't play the file

Play = mciSendString("play " & sMusicFile, 0&, 0, 0) 'i tried this aproach, and it works

End If

1.最后→完整代码
显式选项

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 musicFile$

Dim Play As Variant
Public Sub Sound2(ByVal File$)


     On Error GoTo errHandler
        musicFile = File    'path has been included. Ex. "C:\3rdMan.mp3
        If Play <> vbNull Then 'this triggers if can't play the file
           Play = mciSendString("play " & musicFile, 0&, 0, 0) 'i tried this aproach and it works
        End If
        Exit Sub

errHandler:
     MsgBox "The following error has occurred :" & vbCrLf _
                        & "Error number:  " & Err.Number & vbCrLf _
                        & "Type of error :  " & Err.Description, vbCritical
End Sub

相关问题