Private Declare PtrSafe Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringW" (ByVal lpstrCommand As LongPtr, ByVal lpstrRetumString As LongPtr, ByVal uReturnLength As Long, ByVal hwndCallback As LongPtr) As Long
Private Declare PtrSafe Function GetShortPathNameW Lib "kernel32" (ByVal lpszLongPath As LongPtr, ByVal lpszShortPath As LongPtr, ByVal cchBuffer As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function PathFindExtension Lib "shlwapi.dll" Alias "PathFindExtensionW" (ByVal pszPath As LongPtr) As LongPtr
Private Declare PtrSafe Function lStrLen Lib "kernel32.dll" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemoryByPtr Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
#Else
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringW" (ByVal lpstrCommand As Long, ByVal lpstrRetumString As Long, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function GetShortPathNameW Lib "kernel32" (ByVal lpszLongPath As Long, ByVal lpszShortPath As Long, ByVal cchBuffer As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function PathFindExtension Lib "shlwapi.dll" Alias "PathFindExtensionW" (ByVal pszPath As Long) As Long
Private Declare Function lStrLen Lib "kernel32.dll" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemoryByPtr Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If
Private Type FileList
FileName As String
ShortName As String
End Type
Private FileList() As FileList
Private ListCount As Long
Public Sub Clean()
ListCount = 0
Erase FileList
End Sub
Public Property Get Item(ByVal Index As Long) As String
If Index > 0 And Index <= ListCount Then
Item = FileList(Index).FileName
End If
End Property
Public Property Let Item(ByVal Index As Long, ByVal FileName As String)
Dim I As Long
If Index = ListCount + 1 Then
ListCount = ListCount + 1
ReDim Preserve FileList(1 To ListCount)
End If
If (Index > 0) And (Index <= ListCount) Then
With FileList(Index)
.FileName = FileName
I = Len(FileName)
If I > 0 Then
.ShortName = GetShortPathName(FileName)
Else
.ShortName = vbNullString
End If
End With
End If
End Property
Public Function ItemAdd(ByVal FileName As String) As Long
Dim I As Long
I = ListCount + 1
Item(I) = FileName
ItemAdd = I
End Function
Public Function ItemReMove(ByVal Index As Long) As Boolean
If Index > 0 And Index <= ListCount Then
With FileList(Index)
.FileName = vbNullString
.ShortName = vbNullString
End With
End If
End Function
Public Sub StartPlay()
Dim I As Long
If waveOutGetNumDevs > 0 Then
For I = 1 To ListCount Step 1
With FileList(I)
If Len(.ShortName) Then
Select Case UCase$(ExtractFileExtension(.ShortName))
Case ".WAV": mciSendString StrPtr("open " & .ShortName & " type waveaudio alias JofornMusic"), 0, 0, 0
Case ".MDI": mciSendString StrPtr("open " & .ShortName & " type sequencer alias JofornMusic"), 0, 0, 0
Case Else: mciSendString StrPtr("open " & .ShortName & " alias JofornMusic"), 0, 0, 0
End Select
mciSendString StrPtr("play JofornMusic FROM 0"), 0&, 0, 0
Private Const SND_RESOURCE = &H40004 ' name is a resource name or atom
Private Const SND_SYNC = &H0 ' play synchronously (default)
#If VBA7 Then
Private Declare PtrSafe Function PlaySoundA Lib "winmm.dll" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
' 以上係 .Wav 檔之參數宣告； 下列三行為 .MP3 檔案宣告之引用功能函式及變數宣告。
Private Declare PtrSafe 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
Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
#Else
Private Declare Function PlaySoundA Lib "winmm.dll" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
' 以上係 .Wav 檔之參數宣告； 下列三行為 .MP3 檔案宣告之引用功能函式及變數宣告。
Private 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
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
#End If
Dim Mp3File, LastMp3File As String, lst() As String, idx As Long
To stillfish00大大
不好意思，小弟沒貼到後面的。
To Joforn、c_c_lai兩位大大
感謝您的指導，目前正在努力測試中，
因小弟學習剛起步，對於兩位大大所寫的還是一知半解，
目前努力的理解中，
想請問大大，若使用MediaPlayer 控件，
是否有辦法解決小弟的問題，
謝謝!作者: 准提部林 時間: 2016-1-22 13:12
以〔短語音〕mp3實測，
WindowsMediaPlayer並無四檔即停播問題，
或許上傳檔案較可能找出原因∼∼作者: c_c_lai 時間: 2016-1-22 18:48
回復 6#lshsien
雖然你偏好使用 Windows Media Player，
但我使用 Joforn 大大提供的程式碼測試
三種型態的媒體檔 (*.mp3;*.wav;*.mp4)
它在執行撥放過程非常穩定，DoEvents 的
時段拿捏得恰當，尤其是 mp4 影片撥放
視窗也很流暢，蠻值得你採用。其實
Windows Media Player元件亦使用同樣之
Windows System 程式庫 (Lib)。
二、控制聲音大小(1-1000)：
Dim V As Long
mciSendString "status JofornMusic volume",&V, len(v), 0 'V是獲取的音量大小值。
V = 50
mciSendString "setaudio JofornMusic volume to 數值", 0, 0, 0 'V是設置的音量值
三、設置播放位置.(需事先設定時間格式)，格式：Seek 設備名[to 位置| to start | to end]
Dim P1 as Long, P2 as Long
P1 = 100: P2 = 3000
mciSendString "seek JofornMusic to ", P1, 0, 0 'P1是當前起始位置，單位：毫秒
mciSendString "seek JofornMusic to start", 0&, 0, 0 '定位到開頭位置
mciSendString "play JofornMusic", 0&, 0, 0 '定位後再播放
或者：
mciSendString "play JofornMusic FROM P1 to P2",0&, 0, 0 'P1是起始位置，P2是停止位置。單位：毫秒
mciSendString "seek JofornMusic to end", 0&, 0, 0 '定位到最後位置
四、在指定控件上播放視頻：
mciSendString "open AVI 文件名parent hWnd style child", 0&, 0, 0
其中，hWnd 是控件的句柄
執行上述命令之後，影片會被放置在控件的左上角，且影片的大小不受控件大小的影響，如果想要改變
影片播放的位置及大小，可以在執行play 指令前先執行put 指令，格式如下：
mcisendString "put AVI 文件名window at XY [Width Height]", 0&, 0, 0
其中：X、Y為影片左上角坐標，Width、Height為影片的寬高度
五、如果播放視頻還可控制亮度(1-2000)
Dim B As Long
mciSendString "status JofornMusic brightness", B, 0, 0 'B是獲取的亮度值。
B = 50
mciSendString "setvideo JofornMusic brightness to " & B, &0, 0, 0 'B是設置的亮度值
To Joforn 大大
小弟想要控制音量，
在Public Sub StartPlay()中插入了音量控制code，
但無法控制音量大小，再請您解惑。
Public Sub StartPlay()
Dim V As Long
V = 1
mciSendString StrPtr("setaudio movie volume to " & V), &O0, 0, 0 'V是設置的音量值
Dim I As Long
If waveOutGetNumDevs > 0 Then
For I = 1 To ListCount Step 1
With FileList(I)
If Len(.ShortName) Then
Select Case UCase$(ExtractFileExtension(.ShortName))
Case ".WAV": mciSendString StrPtr("open " & .ShortName & " type waveaudio alias JofornMusic"), 0, 0, 0
Case ".MDI": mciSendString StrPtr("open " & .ShortName & " type sequencer alias JofornMusic"), 0, 0, 0
Case Else: mciSendString StrPtr("open " & .ShortName & " alias JofornMusic"), 0, 0, 0
End Select
mciSendString StrPtr("play JofornMusic FROM 0"), 0&, 0, 0
Do While Not IsEnd
Sleep 50
DoEvents
Loop
mciSendString StrPtr("close JofornMusic"), 0&, 0, 0
End If
End With
Next I
End If
End Sub
