ExcelはMP3プレイヤーに成りうるのか_その２
前回記事からの続きです
ExcelMP3プレイヤーを改版してみました。
主な改版点は下記の通り
・ボタンを廃止し、UserFormにまとめました
・再生中の楽曲を表示できるようにしました
・一時停止機能を追加しました
・楽曲の再生終了後、自動で次の(アクティブセルから１つ下の)楽曲が再生されるようにしました
これで最低限の機能を有したMP3プレイヤーができあがったのではないかと思われます
再生終了後に、自動で次の楽曲を呼び出す機能は苦戦を強いられました(*_*;
ソースは後述しますが、自分で自分を呼び出す形になっているのでプログラム的にはあんまりよろしくないと思われます・・・まぁ初心者だし多少は大目に
処理の重さについて
メモリ:16GB
ストレージ：500GB SSD
上記PCで動作させましたが、CPU使用率は0.3%,メモリ使用は50MBくらいです
楽曲が多くなればなるほど処理は重くなっていく可能性があります
◆開発環境◆
Microsoft Excel 2019 MSO 32ビット
OS:Windows 10 Home 64bit
※以下ソース※
◆UserForm
Private Sub CommandButton1_Click()
Call MP3player
End Sub
Private Sub CommandButton2_Click()
Call MP3stopper
End Sub
Private Sub CommandButton3_Click()
Call MP3pause
End Sub
Private Sub CommandButton4_Click()
Call FolderSerch
End Sub
◆標準モジュール
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
Public FolderPath As String
Public PlayCnt As Long
Sub MP3player()
Dim rc As Long
FolderPath = Cells(2, 2).Value
If PlayCnt > 99999 Then
PlayCnt = 0
Exit Sub
End If
PlayCnt = PlayCnt + 1
If PlayCnt = 1 Then
rc = mciSendString("Play " & FolderPath & "\" & ActiveCell.Value, "", 0, 0)
UserForm1.Label1 = ActiveCell.Value
Application.OnTime Now() + TimeValue("00:00:03"), "MP3player"
Else
If GetStatus = "STOPPED" Then
ActiveCell.Offset(1, 0).Activate
rc = mciSendString("Play " & FolderPath & "\" & ActiveCell.Value, "", 0, 0)
UserForm1.Label1 = ActiveCell.Value
Application.OnTime Now() + TimeValue("00:00:03"), "MP3player"
Else
Application.OnTime Now() + TimeValue("00:00:03"), "MP3player"
End If
End If
End Sub
Sub MP3stopper()
Dim rs As Long
FolderPath = Cells(2, 2).Value
rs = mciSendString("Stop " & FolderPath & "\" & ActiveCell.Value, "", 0, 0)
PlayCnt = 100000
End Sub
Sub MP3pause()
Dim rp As Long
FolderPath = Cells(2, 2).Value
rp = mciSendString("Pause " & FolderPath & "\" & ActiveCell.Value, "", 0, 0)
PlayCnt = 100000
End Sub
Sub MP3resume()
Dim rr As Long
FolderPath = Cells(2, 2).Value
rr = mciSendString("Resume " & FolderPath & "\" & ActiveCell.Value, "", 0, 0)
End Sub
Sub FolderSerch()
Dim result As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
FolderPath = .SelectedItems(1)
End With
Cells(2, 2).Value = FolderPath
If Cells(2, 2) = "" Then
MsgBox "フォルダが指定されていません"
Exit Sub
End If
result = Dir(FolderPath, vbDirectory)
If result = "" Then
MsgBox "指定されたフォルダが存在しません"
Exit Sub
Else
Call GetMusicFile(FolderPath)
End If
End Sub
Sub GetMusicFile(Path As String)
Dim buf As String
Dim cnt As Long
cnt = 5
buf = Dir(Path & "\" & "*.mp3")
If buf = "" Then
MsgBox "MP3ファイルがフォルダに存在しません"
Exit Sub
End If
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 2) = buf
buf = Dir()
Loop
End Sub
Public Function GetStatus() As String
Dim RetBuffer As String
Dim MCICommandString As String
RetBuffer = Space(20)
MCICommandString = "status """ & FolderPath & "\" & ActiveCell.Value & """ mode"
Call mciSendString(MCICommandString, RetBuffer, Len(RetBuffer), 0)
RetBuffer = Left(RetBuffer, InStr(1, RetBuffer, vbNullChar) - 1)
GetStatus = UCase(RetBuffer)
End Function
