2016年12月24日土曜日

もう1回、ExcelでMIDI

 以前、Excel VBAでMIDIをいじるモジュールを作りました。今でもこのブログで公開していますが、残念ながら、出来が悪かったと思っています。(お試しで作ったMIDIシーケンサーはもっとひどかった気がしてます。)

 というわけで、少し手直ししたものをまた公開しようと思います。
 今回のプログラムは、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 件のコメント:

コメントを投稿