包对象的音乐文件VBA怎么播放(小fisher文件)

dongdonggege · 发表于 2020-4-24 13:43

我从小fisher的游戏文件里下载了包(对象)，里面有音乐WAV文件，我想用程序打开这些音乐文件播放，不知道怎么操作，请各位大侠帮忙，谢谢。文件图标

附件：

约定的童话 · 发表于 2020-4-25 08:51

要调用windows自带播放器

dongdonggege · 发表于 2020-4-25 12:35

约定的童话发表于 2020-4-25 08:51
要调用windows自带播放器

不好意思，上午值班，让你久等了。
老师能不能讲具体点，我的文件里已经有了程序，但是好像运行没有效果。小fisher的这个文章http://club.excelhome.net/thread-420067-1-1.html里有文件，在窗体调用时能播放包里的文件，但是单独怎么调用，或者在工作表里调用没说，麻烦你了。

dongdonggege · 发表于 2020-4-28 16:48

哪位老师帮帮我？谢谢了。

laiwatch · 发表于 2020-4-28 18:39

不清楚你的问题的具体是什么.......这些文件就是wav格式的, 你可以在temp文件夹下找到这写文件,然后随便一个音频播放器都可以播放.....
如果你需要在vba里播放, @小fisher都已经写好了怎么播放这些文件, 在"sound"模块中
播放方式为调用api来实现

sndPlaySound Lib "winmm.dll"

dongdonggege · 发表于 2020-4-30 14:25

laiwatch 发表于 2020-4-28 18:39
不清楚你的问题的具体是什么.......这些文件就是wav格式的, 你可以在temp文件夹下找到这写文件,然后随便一 ...

直接播放还是有难度的，我理解播放的过程了。
1、导出包文件。
2、播放这个文件里的音乐文件。
我觉得这个思路是对的。见http://club.excelhome.net/forum. ... 708&pid=2721115。
后来我把它改编成PowerPoint了。
模块代码：

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As Any, ByVal uFlags As Long) As Long
Public Const SND_NODEFAULT& = &H2
Public Const SND_RESOURCE& = &H40004
Public Const SND_ASYNC = &H1 ' play asynchronously
Public Const SND_MEMORY = &H4 ' lpszSoundName points to a memory file
Public Const SND_SYNC = &H0 ' play synchronously (default)
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
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 mciGetDeviceID Lib "winmm.dll" Alias "mciGetDeviceIDA" (ByVal lpstrName As String) As Long
Public Declare Function mciGetCreatorTask Lib "winmm.dll" (ByVal wDeviceID As Long) As Long
Public Const MAX_PATH = 255
Public tmpFile As String
Dim lRet As Long
Dim ret As String * 1024
Public bPlaying As Boolean
Public Enum AudioFormatConstants
wav = 0
other = 1
End Enum
Public Function GetTempFile() As String
Dim sTmpPath As String
Dim sTmpFile As String
sTmpPath = Space(MAX_PATH)
GetTempPath MAX_PATH, sTmpPath
sTmpPath = Left(sTmpPath, InStr(sTmpPath, Chr(0)) - 1)
sTmpFile = Space(MAX_PATH)
GetTempFileName sTmpPath, "bgm" & Chr(0), 0, sTmpFile
GetTempFile = Left(sTmpFile, InStrRev(sTmpFile, ".") - 1) & ".mp3"
End Function
Sub playSound()
lRet = mciSendString("play " & tmpFile & " repeat", ret, 1024, 0)
Id = mciGetDeviceID(tmpFile)
bPlaying = True
End Sub
Sub stopSound()
On Error Resume Next
mciSendString "close all", ret, 1024, 0
bPlaying = False
End Sub
Sub test()
tmpFile = GetTempFile
On Error Resume Next
itop = ActivePresentation.Slides(1).Shapes("Object 5").Top
On Error GoTo 0
If IsEmpty(itop) Then Exit Sub
Export tmpFile, ActivePresentation.Slides(1).Shapes("Object 5"), other
playSound
End Sub
Sub test2()
On Error Resume Next
stopSound
Kill tmpFile
End Sub
Public Sub Export(targetFile As String, objOLE As Shape, AudioFormat As AudioFormatConstants)
Dim hMem As Long
Dim nClipsize As Long
Dim lpData As Long
Dim bytData() As Byte
objOLE.Copy
OpenClipboard 0&
hMem = GetClipboardData(49156)
If CBool(hMem) Then
nClipsize = GlobalSize(hMem)
lpData = GlobalLock(hMem)
If lpData <> 0 Then
ReDim bytData(0 To nClipsize) As Byte
CopyMemory bytData(0), ByVal lpData, nClipsize
End If
GlobalUnlock hMem
End If
EmptyClipboard
CloseClipboard
If AudioFormat <> wav Then
Dim iPos As Long
Dim iCountZero As Integer
Dim lOffset As Long
Dim lFilesize As Long
For iPos = 0 To nClipsize
If bytData(iPos) = 0 Then
iCountZero = iCountZero + 1
If iCountZero = 3 Then Exit For
End If
Next
iPos = iPos + 5
CopyMemory lOffset, bytData(iPos), 4
iPos = iPos + lOffset + 4
CopyMemory lFilesize, bytData(iPos), 4
iPos = iPos + 4
CopyMemory bytData(0), bytData(iPos), lFilesize
ReDim Preserve bytData(0 To lFilesize) As Byte
End If
Dim fileNumber As Integer
fileNumber = FreeFile
Open targetFile For Binary As #fileNumber
Put #fileNumber, , bytData
Close #fileNumber
End Sub

复制代码

slide1代码(播放、停止两个按钮)

Private Sub CommandButton1_Click()
test
End Sub
Private Sub CommandButton2_Click()
stopSound
End Sub

复制代码

谢谢你的指导，稍后我会认真理解你的图意的。

dongdonggege · 发表于 2020-4-30 14:35

laiwatch 发表于 2020-4-28 18:39
不清楚你的问题的具体是什么.......这些文件就是wav格式的, 你可以在temp文件夹下找到这写文件,然后随便一 ...

这两天没看到提醒的，好像我的这个功能被关闭了，郁闷，老师，不好意思，迟点回复你了。

说实在话，我对@小fisher的程序还是没有理解透。我对你的话好像也没理解透，明明我已经调用这些api，分步运行没有什么问题，问题出在哪里，不一定和@小fisher的一模一样吧，api我调用的不少。我模仿另一个程序，包对象导出文件、音乐文件播放，成功了。
文件太大，传不上去，代码我已上传，还没到。请老师指点，谢谢。

		自动登录	找回密码
密码			免费注册

[求助] 包对象的音乐文件VBA怎么播放(小fisher文件)