ExcelVBA/xls2smf - Sample is best!

開発環境	Microsoft Office Excel 2007 (SP3)
実行環境	Microsoft Windows 7 Home Premium (32bit)

手順

1. 下にあるSheet1.csvファイルを用意しExcelで開く（Sheet1というワークシートに取り込まれるはず）
2. ワークシートSheet2を作る
3. Alt+F11でVisual Basic Editorを起動する
4. メニューから[挿入]-[標準モジュール]を選択しModule1をコピペする
5. Excelマクロ有効ブック(*.xlsm)で保存する（例：xls2smf.xlsm）
6. Mainプロシージャ内にカーソルを合わせてF5キーを押す

Module1

Const colmax = 33
Const path_out = "sample.mid"   ' ライブラリ／ドキュメント
Const timebase = 480
 
Dim datalen As Long     ' データ長
Dim fileno As Integer   ' ファイル番号
 
Sub Main()
    scalelist = Array(0, 2, 4, 5, 7, 9, 11)
 
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    ws2.Cells.Clear
    r2 = 1
    For Row = 1 To 12
        notelen = 0
        For col = 1 To colmax
            output = False
            c = ws1.Cells(Row, col)
            c1 = Left(c, 1)
            If c1 <> "" Then
                If notelen = 0 Then
                    startc = c1
                    startcol = col
                End If
                notelen = notelen + 1
                If Right(c, 1) = ";" Then
                    output = True
                End If
            Else
                output = True
            End If
            If output Then
                If notelen <> 0 Then
                    starttick = (timebase * 4) * (startcol - 1) \ 8
                    notetick = (timebase * 4) * notelen \ 8
 
                    r = 12 - Row
                    notenum = (r \ 7 + 5) * 12 + scalelist(r Mod 7)
                    If startc = "#" Then notenum = notenum + 1
 
                    ws2.Cells(r2, 1) = starttick
                    ws2.Cells(r2, 2) = &H90
                    ws2.Cells(r2, 3) = notenum
                    ws2.Cells(r2, 4) = &H70
                    r2 = r2 + 1
                    ws2.Cells(r2, 1) = starttick + notetick * 7 \ 8
                    ws2.Cells(r2, 2) = &H80
                    ws2.Cells(r2, 3) = notenum
                    ws2.Cells(r2, 4) = &H0
                    r2 = r2 + 1
                    notelen = 0
                End If
            End If
        Next
    Next
    ws2.UsedRange.Sort key1:=ws2.Columns(1)
    ' トラック終了
    ws2.Cells(r2, 1) = CLng(timebase * 4) * colmax \ 8
    ws2.Cells(r2, 2) = &HFF
    ws2.Cells(r2, 3) = &H2F
    ws2.Cells(r2, 4) = &H0
 
    ' ファイル出力
    fileno = FreeFile
    If Dir(path_out) <> "" Then
        Kill path_out
    End If
    Open path_out For Binary Access Write As #fileno
 
    ' ヘッダチャンク
    PutBE 4, &H4D546864 ' MThd
    PutBE 4, 6          ' データ長
    PutBE 2, 0          ' フォーマットタイプ
    PutBE 2, 1          ' トラック数
    PutBE 2, timebase   ' タイムベース
 
    ' トラックチャンク
    PutBE 4, &H4D54726B ' MTrk
    PutBE 4, 0          ' データ長（仮）
    datalen = 0
 
    Dim prevtick As Long
    prevtick = 0
    For Row = 1 To r2
 
        ' 可変長tick
        Dim tick, t As Long
        tick = ws2.Cells(Row, 1)
        t = tick - prevtick
        t = ((t And &HFE00000) * 8) Or ((t And &H1FC000) * 4) Or ((t And &H3F80) * 2) Or (t And &H7F)
        For c = 3 To 0 Step -1
            Dim b As Long
            b = t \ (2 ^ (8 * c)) And &HFF
            If 0 < c Then b = b Or &H80
            If b <> &H80 Then
                Put #fileno, , CByte(b)
                datalen = datalen + 1
            End If
        Next
 
        For col = 2 To 4
            Put #fileno, , CByte(ws2.Cells(Row, col))
        Next
        datalen = datalen + 3
        prevtick = tick
    Next
 
    ' データ長
    For c = 0 To 3
        Put #fileno, 19 + c, CByte(datalen \ (2 ^ (8 * (3 - c))) And &HFF)
    Next
    Close #fileno

    ' 再生
    CreateObject("Wscript.Shell").Run path_out
 
End Sub
 
Sub PutBE(count, value As Long)
    For c = count - 1 To 0 Step -1
        Put #fileno, , CByte(value \ (2 ^ (8 * c)) And &HFF)
    Next
End Sub

Sheet1.csv

,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
,,,,#,,#,,,,,,#,,#,,,,,,#,#,,,#,#,,,o,,o
,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
#,,,,,,,,#,,,,,,,,#,,,,,,,,,,,,,,
,#,,,,,,,,#,,,,,,,,#,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,,,,,,o,,o
,,,,#,,#,,,,,,#,,#,,,,,,#,#,,,#,#,,,,,
,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
,,#,#,,,,,,,#,#,,,,,,,#,#,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,#,#,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,,,,#,#,,,