というわけで、少し手直ししたものをまた公開しようと思います。
今回のプログラムは、Excelで書いたMIDI EventをSMF0形式で保存します。init関数で初期化すれば、使えるはずです。
今回は、最近のプログラムっぽく、Collectionを使ってみました。要素数が分からないデータを扱うときは、やっぱりCollectionが便利です。ただ、クラスモジュールを用意しないといけないのが、ひと手間ですが。
ついでにAPIを使って、作成したMIDIをExcelから再生できるようにしました。
趣味のプログラミングなので、動作保証はありません。悪しからず。
ここから下がクラスモジュール (MIDI_EVENTクラス)
Option Explicit
Public DeltaTime As Long
Public EventType As Byte
Public Param1 As Byte
Public Param2 As Byte
Public Sub SetEvent(dt As Long, evt As Byte, p1 As Byte, p2 As Byte)
DeltaTime = dt
EventType = evt
Param1 = p1
Param2 = p2
End Sub
ここから下が標準モジュール
Option Explicit
'--------------------------------------------------
'API
'64bitの場合はコチラ
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
'32bitの場合はコチラ
'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 Type HEADER_CHUNK
ChunkID As String * 4
ChunkSize As Long
FormatType As Integer
NumberOfTracks As Integer
TimeDivision As Integer
End Type
Private hChunk As HEADER_CHUNK
Private Type TRACK_CHUNK
ChunkID As String * 4
ChunkSize As Long
data() As Byte
End Type
Private tChunk() As TRACK_CHUNK
Public Sub init()
Dim shp As Shape
Dim btn As Button
Sheet1.Cells.Clear
For Each shp In Sheet1.Shapes
shp.Delete
Next
Set btn = Sheet1.Buttons.Add(0, 0, 80, 40)
btn.Text = "write midi"
btn.OnAction = "write_sample"
'--------------------------------------------------
Sheet1.Cells(9, 1) = "DeltaTime"
Sheet1.Cells(9, 2) = "EventType"
Sheet1.Cells(9, 3) = "Param1"
Sheet1.Cells(9, 4) = "Param2"
Sheet1.Cells(10, 1) = 0
Sheet1.Cells(10, 2) = Hex(&HC0)
Sheet1.Cells(10, 3) = &H0
Sheet1.Cells(10, 4) = &H0
Sheet1.Cells(11, 1) = 0
Sheet1.Cells(11, 2) = Hex(&H90)
Sheet1.Cells(11, 3) = &H3C
Sheet1.Cells(11, 4) = &H7F
Sheet1.Cells(12, 1) = 384
Sheet1.Cells(12, 2) = Hex(&H80)
Sheet1.Cells(12, 3) = &H3C
Sheet1.Cells(12, 4) = &H7F
End Sub
Public Sub write_sample()
Dim i As Long
Dim N As Long
Dim filename As String
'--------------------------------------------------
ReDim tChunk(0) As TRACK_CHUNK
Dim midi As Collection
Set midi = New Collection
Dim temp As MIDI_EVENT
N = Sheet1.Cells(9, 1).End(xlDown).row - 9
For i = 0 To N - 1
Set temp = New MIDI_EVENT
temp.DeltaTime = CInt(Sheet1.Cells(10 + i, 1))
temp.EventType = CByte("&H" & Sheet1.Cells(10 + i, 2))
temp.Param1 = CByte(Sheet1.Cells(10 + i, 3))
temp.Param2 = CByte(Sheet1.Cells(10 + i, 4))
midi.Add temp
Next i
'--------------------------------------------------
encode tChunk(0), midi
filename = ThisWorkbook.Path + "\test.mid"
writeMidi filename
'--------------------------------------------------
'APIを使って再生
Dim rc As Long
Dim str As String * 8
rc = mciSendString("open " & Chr(34) & filename & Chr(34), str, Len(str), 0)
rc = mciSendString("play " & Chr(34) & filename & Chr(34), str, Len(str), 0)
Do While InStr(str, "stopped") = 0
rc = mciSendString("status " & Chr(34) & filename & Chr(34) & " mode", str, Len(str), 0)
Loop
rc = mciSendString("close " & Chr(34) & filename & Chr(34), str, Len(str), 0)
'--------------------------------------------------
End Sub
'MIDIファイルを閉じる
Public Sub CloseMidi()
Dim rc As Long
rc = mciSendString("close all", "", 0, 0)
End Sub
'ファイルに書き込む
'SMF0のみ対応
Public Sub writeMidi(filename As String)
Dim i As Long
Dim hc(13) As Byte
Dim tc(7) As Byte
hChunk.ChunkID = "MThd"
hChunk.ChunkSize = 6
hChunk.FormatType = 0
hChunk.NumberOfTracks = 1
hChunk.TimeDivision = 96
Open filename For Binary As 1
'--------------------------------------------------
hc(0) = Asc("M")
hc(1) = Asc("T")
hc(2) = Asc("h")
hc(3) = Asc("d")
hc(4) = CByte((((hChunk.ChunkSize \ 256) \ 256) \ 256) Mod 256)
hc(5) = CByte(((hChunk.ChunkSize \ 256) \ 256) Mod 256)
hc(6) = CByte((hChunk.ChunkSize \ 256) Mod 256)
hc(7) = CByte(hChunk.ChunkSize Mod 256)
hc(8) = CByte((hChunk.FormatType \ 256) Mod 256)
hc(9) = CByte(hChunk.FormatType Mod 256)
hc(10) = CByte((hChunk.NumberOfTracks \ 256) Mod 256)
hc(11) = CByte(hChunk.NumberOfTracks Mod 256)
hc(12) = CByte((hChunk.TimeDivision \ 256) Mod 256)
hc(13) = CByte(hChunk.TimeDivision Mod 256)
Put 1, , hc
'--------------------------------------------------
For i = 0 To hChunk.NumberOfTracks - 1
tChunk(i).ChunkID = "MTrk"
tc(0) = Asc("M")
tc(1) = Asc("T")
tc(2) = Asc("r")
tc(3) = Asc("k")
tc(4) = CByte((((tChunk(i).ChunkSize \ 256) \ 256) \ 256) Mod 256)
tc(5) = CByte(((tChunk(i).ChunkSize \ 256) \ 256) Mod 256)
tc(6) = CByte((tChunk(i).ChunkSize \ 256) Mod 256)
tc(7) = CByte(tChunk(i).ChunkSize Mod 256)
Put 1, , tc
Put 1, , tChunk(i).data
Next i
'--------------------------------------------------
Close 1
End Sub
Public Sub encode(ByRef track As TRACK_CHUNK, ByRef midi As Collection)
Dim i As Long
Dim N As Long
Dim buf() As Byte
Dim temp1 As Byte
Dim temp4 As Long
ReDim buf(midi.Count * 8) As Byte
N = 0
For i = 1 To midi.Count
'--------------------------------------------------
'DeltaTime
temp4 = 128
Do While temp4 <= midi(i).DeltaTime
temp4 = temp4 * 128
Loop
Do While 128 < temp4
temp4 = temp4 \ 128
buf(N) = CByte((midi(i).DeltaTime \ temp4) Mod 128 + &H80)
N = N + 1
Loop
buf(N) = CByte(midi(i).DeltaTime Mod 128)
N = N + 1
'--------------------------------------------------
'EventType
If 0 < N And midi(i).EventType < &HF0 And midi(i).EventType = temp1 Then
'running status
Else
temp1 = midi(i).EventType
buf(N) = temp1
N = N + 1
End If
'--------------------------------------------------
'Data
If temp1 < &HF0 Then
If &HC0 <= temp1 And temp1 < &HE0 Then
buf(N) = midi(i).Param1
N = N + 1
Else
buf(N) = midi(i).Param1
buf(N + 1) = midi(i).Param2
N = N + 2
End If
Else
'System Event, Meta Eventには未対応
End If
'--------------------------------------------------
Next i
'Track終端メッセージ
buf(N) = &H0
buf(N + 1) = &HFF
buf(N + 2) = &H2F
buf(N + 3) = &H0
N = N + 4
track.ChunkID = "MTrk"
track.ChunkSize = N
ReDim track.data(track.ChunkSize - 1) As Byte
For i = 0 To track.ChunkSize - 1
track.data(i) = buf(i)
Next i
Erase buf
End Sub
0 件のコメント:
コメントを投稿