'Sleep API
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Dim C1_d(1 To 128) As Variant 'Note_column
Dim R1_d(1 To 128) As Variant 'Black_key = 1: White_key = 3:
Dim E(1 To 32768, 1 To 218) As Variant
Dim M_line_MAX
Sub MM_Format_Line(Optional S_Line)
Black_key = 1: White_key = 3:
Call key_column_initialize
Application.ScreenUpdating = False
ActiveSheet.Select
Application.StatusBar = False
oldStatusBar = Application.DisplayStatusBar
Start_P = 7: START_C = 3 - 1:
Select Case IsMissing(S_Line): Case True: S_Line = 1000: End Select
Call WorkArea_Line_Clear(S_Line)
Cells.FormatConditions.Delete
Range(Cells(10, 1), Cells(S_Line + 10, 1)).Value = "♪/2"
Application.StatusBar = True
For i = Start_P To S_Line + Start_P
L0 = i:
Select Case L0 Mod 20: Case 0:
Application.StatusBar = "Format_Line.Interior.Color ( " + Str(i) + " / " + Str(S_Line) + " )":
DoEvents: DoEvents:
End Select:
For j = 108 To 21 Step -1:
D_H0 = Cells(i, START_C + C1_d(j)).Value:
Select Case D_H0: Case Empty: Case Else:
D_H = Split(D_H0, vbLf):
Select Case R1_d(j):
Case 3: Set SC = Range(Cells(i, START_C + C1_d(j)), Cells(i, START_C + C1_d(j) + 1)): CK = 0:
Case 1: Set SC = Range(Cells(i, START_C + C1_d(j)), Cells(i, START_C + C1_d(j) + 1)): CK = -80:
End Select:
Select Case D_H(0):
Case "'-", "-": SC.Interior.Color = RGB(80, 80, 80): SC.Font.Color = RGB(80, 80, 80):
Case "A": SC.Interior.Color = RGB(100, 255 + CK, 100): SC.Font.Color = RGB(100, 255 + CK, 100):
Case "B": SC.Interior.Color = RGB(100, 100, 255 + CK): SC.Font.Color = RGB(100, 100, 255 + CK):
Case "C": SC.Interior.Color = RGB(255 + CK, 100, 100): SC.Font.Color = RGB(255 + CK, 100, 100):
Case "D": SC.Interior.Color = RGB(255 + CK, 255 + CK, 100): SC.Font.Color = RGB(255 + CK, 255 + CK, 100):
Case "E": SC.Interior.Color = RGB(100, 255 + CK, 255 + CK): SC.Font.Color = RGB(100, 255 + CK, 255 + CK):
Case "F": SC.Interior.Color = RGB(255 + CK, 100, 255 + CK): SC.Font.Color = RGB(255 + CK, 100, 255 + CK):
Case "G": SC.Interior.Color = RGB(255 + CK, 50, 50): SC.Font.Color = RGB(255 + CK, 50, 50):
Case "H": SC.Interior.Color = RGB(50, 255 + CK, 50): SC.Font.Color = RGB(50, 255 + CK, 50):
Case "I": SC.Interior.Color = RGB(50, 50, 255 + CK): SC.Font.Color = RGB(50, 50, 255 + CK):
Case "J": SC.Interior.Color = RGB(255 + CK, 255 + CK, 50): SC.Font.Color = RGB(255 + CK, 255 + CK, 50):
Case "K": SC.Interior.Color = RGB(50, 255 + CK, 255 + CK): SC.Font.Color = RGB(50, 255 + CK, 255 + CK):
Case "L": SC.Interior.Color = RGB(255 + CK, 0, 0): SC.Font.Color = RGB(255 + CK, 0, 0):
Case "M": SC.Interior.Color = RGB(0, 255 + CK, 0): SC.Font.Color = RGB(0, 255 + CK, 0):
Case "N": SC.Interior.Color = RGB(0, 0, 255 + CK): SC.Font.Color = RGB(0, 0, 255 + CK):
Case "O": SC.Interior.Color = RGB(255 + CK, 255 + CK, 0): SC.Font.Color = RGB(255 + CK, 255 + CK, 0):
Case "P": SC.Interior.Color = RGB(0, 255 + CK, 255 + CK): SC.Font.Color = RGB(0, 255 + CK, 255 + CK):
End Select
End Select:
Next j
Next i
Set SC = Nothing
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.ScreenUpdating = True
End Sub
Private Sub key_column_initialize()
START_C = 0:
Start_Row = 1: Split_Row = 40: KEY_C = 4: key_n = 52: O_line = 50 'S_Line = 5000: O_line = 550:
Black_key = 1: White_key = 3:
M_line_MAX = 20:
Erase E:
For C_n = 0 To key_n
CB_n = C_n Mod 7
Oct_B = Int(C_n / 7) + 1
Select Case CB_n
Case 0: note_1 = Oct_B * 12 + 1 + 8: note_2 = Oct_B * 12 + 1 + 9
Case 1: note_1 = Oct_B * 12 + 1 + 10: note_2 = ""
Case 2: note_1 = Oct_B * 12 + 1 + 11: note_2 = Oct_B * 12 + 1 + 12
Case 3: note_1 = Oct_B * 12 + 1 + 13: note_2 = Oct_B * 12 + 1 + 14
Case 4: note_1 = Oct_B * 12 + 1 + 15: note_2 = ""
Case 5: note_1 = Oct_B * 12 + 1 + 16: note_2 = Oct_B * 12 + 1 + 17
Case 6: note_1 = Oct_B * 12 + 1 + 18: note_2 = Oct_B * 12 + 1 + 19
End Select
R1_d(note_1) = White_key: C1_d(note_1) = START_C + KEY_C * C_n + 2
Select Case note_2 = "": Case False:
R1_d(note_2) = Black_key: C1_d(note_2) = START_C + KEY_C * C_n + 4
End Select:
Next C_n
End Sub
Sub MIDI_LINE_past(Optional S_Line)
Select Case IsMissing(S_Line): Case True: S_Line = 16384: End Select
Application.ScreenUpdating = False
Application.StatusBar = False
oldStatusBar = Application.DisplayStatusBar
Application.StatusBar = True
For j = 218 To 1 Step -1:
Application.StatusBar = "MIDI_LINE_past ( Coloum# = " + Str(j) + " )":
DoEvents: DoEvents:
For i = 2 To S_Line:
Trk_P = Left(E(i, j), 1): Trk_dP = Left(E(i - 1, j), 1)
Select Case Trk_P:
Case "'", "-": 'E(i, j) = "":
Case "": Select Case Trk_dP:
Case "":
Case "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P":
E(i, j) = Trk_dP:
End Select:
End Select:
Next i:
Next j:
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.ScreenUpdating = True
End Sub
Sub MIDI_LINE_all()
Application.ScreenUpdating = False
Application.StatusBar = False
oldStatusBar = Application.DisplayStatusBar
Application.StatusBar = True
Start_P = 7: START_C = 3:
Call key_column_initialize
ActiveSheet.Select
Trk_MAX = 32: Tic128 = 2: HEX_2 = 3: Start = 4: end_L0 = 65536: end_L = 65536:
SD2 = Range(Cells(1, 221), Cells(end_L, 221 + Trk_MAX * 10 + 20)).Value
Tic_DD = SD2(2, 1): '分解能 ４分音符のTic数
Trk_MAX = SD2(1, 12):
Select Case Tic_DD: Case "", Empty: Tic_Div = 1: Case Else: Tic_Div = Tic_DD / 4: End Select: '16分音符区切り
For Trk_n = 1 To Trk_MAX
Application.StatusBar = "MIDI_Line_ALL ( MTrk# = " + Str(Trk_n) + " )":
DoEvents: DoEvents:
For rr = 4 To end_L0 - 1
RRR = SD2(rr, Tic128 + (Trk_n - 1) * 10)
Select Case IsEmpty(SD2(rr, Tic128 + (Trk_n - 1) * 10)):
Case True:
R_MAX = rr - 1: Exit For:
End Select:
Next rr:
Tic128D_MAX = SD2(R_MAX, Tic128 + (Trk_n - 1) * 10)
Tic128D_MAX = Round(Tic128D_MAX / Tic_Div):
Select Case Tic128D_MAX: Case Is > M_line_MAX: M_line_MAX = Tic128D_MAX: End Select:
end_L = R_MAX
For i = Start To end_L:
Tic_T = Round(SD2(i, Tic128 + (Trk_n - 1) * 10) / Tic_Div):
HEX_D = SD2(i, HEX_2 + (Trk_n - 1) * 10)
Select Case Tic_T: Case "": Exit For: End Select:
Call MIDI_LINE_set(Trk_n, Tic_T, HEX_D)
Next i:
DoEvents: DoEvents:
Next Trk_n
S_Line = M_line_MAX:
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.ScreenUpdating = True
Call MIDI_LINE_past(S_Line)
Cells.NumberFormatLocal = "@"
Set E_ALL = Range(Cells(Start_P, START_C), Cells(Start_P + S_Line, START_C + 216))
E_ALL.Value = E
E_ALL.RowHeight = 15
E_ALL.VerticalAlignment = xlTop
Set E_ALL = Nothing
Call MM_Format_Line(S_Line)
Call MM_FormatCondition_Line(S_Line)
End Sub
Private Sub H_FF51_Tempo_set(HEX_D) 'FF 51 03 tempo テンポ。 4分音符の長さをマイクロ秒単位で表現。
T0 = CLng("&H" + Mid(HEX_D, 7, 2)): T1 = CLng("&H" + Mid(HEX_D, 9, 2)): T2 = CLng("&H" + Mid(HEX_D, 11, 2)):
Select Case T0: Case Is > &H7F: Tempo1 = T0 - &H80: Case Else: Tempo1 = T0: End Select:
Select Case T1: Case Is > &H7F: Tempo2 = T1 - &H80: Case Else: Tempo2 = T1: End Select:
TEMPO_T = Tempo1 * &H4000 + Tempo2 * &H80 + T2:
TEMPO_C = Int(120 * 1000000 / TEMPO_T):
STR_D = "♪/2＝" + CStr(TEMPO_C):
End Sub
Sub MIDI_LINE_set(Trk_n, Tic_T, HEX_D)
Black_key = 1: White_key = 3:
Select Case IsMissing(HEX_D): Case True: Exit Sub: End Select:
Select Case Trk_n: Case Is > 16: Exit Sub: Case Is <= 0: Exit Sub: End Select:
Dim ch, note, velocity As Long
Tic_T = Int(Tic_T)
HDD = "": Trk_P = Chr(Trk_n + &H40)
H = Left(HEX_D, 1):
Select Case H:
Case "8": Ch_P = Chr(CLng("&H" + Mid(HEX_D, 2, 1)) + &H41):
HDD = "'-"
Case "9": Ch_P = Chr(CLng("&H" + Mid(HEX_D, 2, 1)) + &H41):
HDD = Ch_P:
' HDD = Trk_P:
vel = CLng("&H" + Mid(HEX_D, 5, 2)):
Select Case vel: Case 0: HDD = "'-": End Select:
Case "B": TTT = E(1 + Tic_T, C1_d(20 + Trk_n)):
Select Case Len(TTT):
Case Is > 0: Trk_P = TTT + vbLf + HEX_D:
Case Else: Trk_P = "X" + vbLf + HEX_D:
End Select:
E(1 + Tic_T, C1_d(20 + Trk_n)) = Trk_P:
Exit Sub:
Case "C": TTT = E(1 + Tic_T, C1_d(20 + Trk_n)):
Select Case Len(TTT):
Case Is > 0: Trk_P = TTT + vbLf + HEX_D:
Case Else: Trk_P = "T" + vbLf + HEX_D:
End Select:
E(1 + Tic_T, C1_d(20 + Trk_n)) = Trk_P:
Exit Sub:
Case "F":
H1 = Left(HEX_D, 4):
Select Case H1:
Case "FF51": TTT = E(1 + Tic_T, C1_d(20 + Trk_n)):
Select Case Len(TTT):
Case Is > 0: Trk_P = TTT + vbLf + HEX_D:
Case Else: Trk_P = "Z" + vbLf + HEX_D:
End Select:
E(1 + Tic_T, C1_d(20 + Trk_n)) = Trk_P:
Exit Sub:
Case Else: Exit Sub:
End Select:
Case Else: Exit Sub:
End Select:
' S = CLng("&H" + Left(HEX_D, 1))
ch = CLng("&H" + Mid(HEX_D, 2, 1))
note = CLng("&H" + Mid(HEX_D, 3, 2))
Select Case note: Case Is > 108: Exit Sub: Case Is < 21: Exit Sub: End Select:
Select Case R1_d(note):
Case Black_key: '
E(1 + Tic_T, C1_d(note) + 1) = HDD ' + vbLf + Ch_P:
Case White_key: '
' E(1 + Tic_T, C1_d(note) - 1) = HDD '+ vbLf + Ch_P:
E(1 + Tic_T, C1_d(note) + 1) = HDD '+ vbLf + Ch_P:
End Select:
TTA = E(1 + Tic_T, C1_d(note)):
Select Case Len(TTA): Case Is > 0: Trk_P = HDD + vbLf + TTA + vbLf + HEX_D
Case Else: Trk_P = HDD + vbLf + Ch_P + vbLf + HEX_D:
' Case Else: Trk_P = HDD + vbLf + HEX_D:
End Select:
E(1 + Tic_T, C1_d(note)) = Trk_P:
End Sub
Sub ReadBinaryFile()
Dim FileNum As Integer
Dim buffer() As Byte
Dim ASC_D() As String
Dim ASC_W() As String
Dim BUF1() As String
Dim HEX_D() As String
Dim TEMPO As Double
Dim FilePath As String
Sheets("Mid_Bin_解析").Select
Range("A1").Select
Cells.ClearContents
Cells.NumberFormatLocal = "@"
FilePath = Application.GetOpenFilename(Filefilter:="Midiファイル,*.mid,Excelブック,*.xlsx;*.xlsm,CSVファイル,*.csv,すべて,*.*")
Select Case FilePath: Case False: Exit Sub: End Select:
FileNum = FreeFile
Open FilePath For Binary As #FileNum
buffer_L = LOF(FileNum)
ReDim buffer(1 To LOF(FileNum)) ' ファイルサイズ分のバッファを確保
ReDim ASC_D(1 To LOF(FileNum) + 10) ' ファイルサイズ分のバッファを確保
ReDim ASC_W(1 To LOF(FileNum) + 10) ' ファイルサイズ分のバッファを確保
ReDim BUF1(1 To LOF(FileNum) + 10) ' ファイルサイズ分のバッファを確保
ReDim HEX_D(1 To LOF(FileNum) + 10) ' ファイルサイズ分のバッファを確保
Get #FileNum, , buffer
Close #FileNum
D_Len = Int(buffer_L / 3)
ReDim D(1 To D_Len + 64, 1 To 300) As Variant
D_No = Mid(FilePath, InStrRev(FilePath, "\") + 1)
D(31, 1) = FilePath
D_No = Mid(FilePath, InStrRev(FilePath, "\") + 1)
D(31, 1) = D_No:
' Set SD = Range(Cells(1, 1), Cells(D_Len, 300))
Dim LEN_D, Data As Variant
For i = 1 To UBound(buffer)
ASC_D(i) = Asc(buffer(i))
ASC_W(i) = AscW(buffer(i))
BUF1(i) = Chr(buffer(i))
P = CStr(Hex(buffer(i)))
Select Case Len(P): Case 1: pp = "0" + P: Case 2: pp = P: End Select:
HEX_D(i) = pp
Next i
For i = 1 To 200
' For i = 1 To UBound(buffer)
D(2, i) = i
D(3, i) = Chr(buffer(i))
P = CStr(Hex(buffer(i)))
Select Case Len(P): Case 1: pp = "0" + P: Case 2: pp = P: End Select:
D(4, i) = pp
' D(5, i) = p
D(5, i) = AscW(buffer(i))
D(6, i) = buffer(i)
Next i
' D(8, 1) = StrConv(ASC_W, vbUnicode)
'解析初期値
R_n = 1: C_n = 1 + 5: i = 1: j = 0: Magic_n = 31:
STR_D = BUF1(1) + BUF1(2) + BUF1(3) + BUF1(4): D(Magic_n, C_n) = "ﾏｼﾞｯｸ=":
Select Case STR_D: Case "MThd": D(Magic_n, C_n + 1) = STR_D: R_n = Magic_n: C_n = C_n + 2: Case Else: Exit Sub: End Select:
LEN_D = buffer(5) * &H1000000 + buffer(6) * &H10000 + buffer(7) * &H100 + buffer(8): D(R_n, C_n) = "ヘッダ長=":
D(R_n, C_n + 1) = LEN_D: R_n = R_n + 0: C_n = C_n + 2:
LEN_D = buffer(9) * &H100 + buffer(10): D(R_n, C_n) = "Fmt= ":
D(R_n, C_n + 1) = LEN_D: R_n = R_n + 0: C_n = C_n + 2:
LEN_D = buffer(11) * &H100 + buffer(12): D(R_n, C_n) = "Trk= ":
D(R_n, C_n + 1) = LEN_D: R_n = R_n + 0: C_n = C_n + 2:
Mtrk_Number = LEN_D:
' ReDim MTrk(1 To LEN_D, 1 To 65535)
LEN_D = buffer(13) * &H100 + buffer(14): D(R_n, C_n) = "分解能/♪♪":
D(R_n, C_n + 1) = LEN_D: R_n = R_n + 0: C_n = C_n + 2:
Tic_DD = LEN_D:
Dim TRACK(1 To 255, 1 To 2) '各トラックの1：先頭アドレス 2:長さByte
TRACK(1, 1) = 15: TRACK(1, 2) = 0: TRACK(2, 1) = TRACK(1, 1) + TRACK(1, 2):
i = 1 + 14: j = 1: Magic_n = 32: C_n = 2:
Tic_Total_MAX = 0:
R_n = Magic_n: C_n = 2:
D(R_n, C_n) = Tic_DD: '分解能 ４分音符のTic数
For Mtrk_n = 1 To Mtrk_Number:
'For Mtrk_n = 1 To 2:
i = TRACK(Mtrk_n, 1): R_n = Magic_n: C_n = 2 + 10 * (Mtrk_n - 1)
STR_D = BUF1(i) + BUF1(i + 1) + BUF1(i + 2) + BUF1(i + 3): D(R_n, C_n + 1) = "ﾏｼﾞｯｸ=":
Select Case STR_D: Case "MTrk": D(R_n, C_n + 2) = STR_D: D(R_n, C_n + 3) = Mtrk_n: R_n = R_n: C_n = C_n + 4: i = i + 4:
Case Else: Exit Sub:
End Select:
' LEN_D = buffer(i) * &H1000000 + buffer(i + 1) * &H10000 + buffer(i + 2) * &H100 + buffer(i + 3): D(R_n, C_n) = "Trk_L=":
LEN_D = CLng(buffer(i)) * &H1000000 + CLng(buffer(i + 1)) * &H10000 + CLng(buffer(i + 2)) * &H100 + CLng(buffer(i + 3)): D(R_n, C_n) = "Trk_L=":
Mtrk_L = LEN_D:
D(R_n, C_n + 2) = LEN_D: R_n = R_n + 0: C_n = C_n + 4: i = i + 4:
TRACK(Mtrk_n, 2) = Mtrk_L + 8: TRACK(Mtrk_n + 1, 1) = TRACK(Mtrk_n, 1) + TRACK(Mtrk_n, 2)
R_n = Magic_n + 2: C_n = 2 + 10 * (Mtrk_n - 1):
Tic_Div = Tic_DD / 8 '64分音符 96/4=24 960/4=240
Tic_Div = 1: '20250815 Tic Totalのままとする
D(R_n - 1, C_n) = "Tic": D(R_n - 1, C_n + 2) = "メッセージ": D(R_n - 1, C_n + 4) = "Len=": D(R_n - 1, C_n + 1) = "累積(Tic/" + Str(Tic_Div) + ")"
TRC_END = TRACK(Mtrk_n + 1, 1)
j0 = 0
For j = TRACK(Mtrk_n, 1) To TRACK(Mtrk_n, 1) + 200
Select Case j: Case Is > UBound(buffer): Exit For: End Select:
P = CStr(Hex(buffer(j)))
Select Case Len(P): Case 1: pp = "0" + P: Case 2: pp = P: End Select:
D(7 + Mtrk_n, 15 + j0) = pp: j0 = j0 + 1:
Next j
Run_D = "XX": Tic_Total_Clock = 0:
Do While i < TRC_END:
' Tic(可変長）
Dim Tic As Double
tic_d = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2) + HEX_D(i + 3): Tempo1 = 0: Tempo2 = 0:
Tic = 0: pp = 0: Do While pp < 10:
Select Case buffer(i + pp): Case Is >= &H80: Tic = (buffer(i + pp) - &H80 + Tic) * &H80: pp = pp + 1: Case Else: Tic = Tic + buffer(i + pp): Exit Do: End Select:
Loop: LEN_D = pp + 1:
Select Case Tic:
Case Is > 190000:
aaaa = i:
End Select:
D(R_n, C_n) = Tic: D(R_n, C_n + 1) = tic_d: i = i + LEN_D:
Tic_Total_Clock = Tic_Total_Clock + Tic: D(R_n, C_n + 1) = Round(Tic_Total_Clock / Tic_Div):
Select Case Tic_Total_Clock: Case Is > Tic_Total_MAX: Tic_Total_MAX = Round(Tic_Total_Clock): End Select
' Tic_Total_Clock = Tic_Total_Clock + Tic: D(R_n, C_n + 1) = Int(Tic_Total_Clock / Tic_Div):
' Select Case Tic_Total_Clock: Case Is > Tic_Total_MAX: Tic_Total_MAX = Int(Tic_Total_Clock): End Select
'MIDIイベント(3バイト)
Mid_E = Left(HEX_D(i), 1):
Select Case Mid_E:
Case "0", "1", "2", "3", "4", "5", "6", "7": 'ﾗﾆﾝｸﾞｽﾃｰﾀｽ 前のイベントデータを継続したデータ
D(R_n, C_n + 2) = Run_D + HEX_D(i) + HEX_D(i + 1): D(R_n, C_n + 3) = "[" + Run_D + "]": R_n = R_n + 1: i = i + 2:
Case "8": 'ﾉｰﾄｵﾌ 3Byte固定
Run_D = HEX_D(i): D(R_n, C_n + 2) = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2): R_n = R_n + 1: i = i + 3:
Case "9": 'ﾉｰﾄｵﾝ 3Byte固定
Run_D = HEX_D(i): D(R_n, C_n + 2) = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2): R_n = R_n + 1: i = i + 3:
Case "A": 'ﾎﾟﾘﾌｫﾆｯｸｷｰﾌﾟﾚｯｼｬｰ（ｱﾌﾀｰﾀｯﾁ）3Byte固定
Run_D = HEX_D(i): D(R_n, C_n + 2) = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2):
D(R_n, C_n + 5) = "ﾎﾟﾘﾌｫﾆｯｸｷｰﾌﾟﾚｯｼｬｰ（ｱﾌﾀｰﾀｯﾁ）": R_n = R_n + 1: i = i + 3:
Case "B": 'ｺﾝﾄﾛｰﾙﾁｪﾝｼﾞ 3Byte固定
Run_D = HEX_D(i): D(R_n, C_n + 2) = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2):
D(R_n, C_n + 5) = "ｺﾝﾄﾛｰﾙﾁｪﾝｼﾞ": R_n = R_n + 1: i = i + 3:
Case "C": 'ﾌﾟﾛｸﾞﾗﾑﾁｪﾝｼﾞ 2Byte固定
Run_D = HEX_D(i): D(R_n, C_n + 2) = HEX_D(i) + HEX_D(i + 1):
D(R_n, C_n + 5) = "ﾌﾟﾛｸﾞﾗﾑﾁｪﾝｼﾞ": R_n = R_n + 1: i = i + 2:
Case "D": 'ﾁｬﾈﾙｷｰﾌﾟﾚｯｼｬｰ（ｱﾌﾀｰﾀｯﾁ）3Byte固定
Run_D = HEX_D(i): D(R_n, C_n + 2) = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2):
D(R_n, C_n + 5) = "ﾁｬﾈﾙｷｰﾌﾟﾚｯｼｬｰ（ｱﾌﾀｰﾀｯﾁ）": R_n = R_n + 1: i = i + 3:
Case "E": 'ﾋﾟｯﾁﾍﾞﾝﾄﾞﾁｪﾝｼﾞ 3Byte固定
Run_D = HEX_D(i): D(R_n, C_n + 2) = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2):
D(R_n, C_n + 5) = "ﾋﾟｯﾁﾍﾞﾝﾄﾞﾁｪﾝｼﾞ": R_n = R_n + 1: i = i + 3:
'ｼｽﾃﾑｺﾓﾝﾒｯｾｰｼﾞ
Case "F": STR_D = HEX_D(i): dCn = 2:
Select Case STR_D:
Case "F0": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_SYS_Event:FO--F7":
pp = 1: Do While pp < 200:
Select Case HEX_D(i + pp): Case "F7": Exit Do: Case Else: pp = pp + 1: End Select:
Loop: LEN_D = 1 + pp: STR_D = Trim(StrConv(MidB(buffer, i, LEN_D), vbUnicode)):
R_n = R_n + 1: i = i + LEN_D:
Case "F1": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_MIDIﾀｲﾑｺｰﾄﾞｸｵｰﾀﾌﾚｰﾑ(2Byte):F1 xx": R_n = R_n + 1: i = i + 2
Case "F2": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ｿﾝｸﾞﾎﾟｼﾞｼｮﾝﾎﾟｲﾝﾀ(3Byte):F2 xxxx": R_n = R_n + 1: i = i + 2
Case "F3": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ｿﾝｸﾞｾﾚｸﾄ(2Byte):F3 xx": R_n = R_n + 1: i = i + 3
Case "F4": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_未定義(2Byte):F4 xx": R_n = R_n + 1: i = i + 2
Case "F5": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_未定義(2Byte):F5 xx": R_n = R_n + 1: i = i + 2
Case "F6": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ﾁｭｰﾝﾘｸｴｽﾄ(1Byte):F6": R_n = R_n + 1: i = i + 2
Case "F7": 'SYS_Event(可変長)
D(R_n, C_n + 2) = "SYS_Event(可変長F7)":
Select Case buffer(i + 1): Case Is > &H7F: S_LEN = (buffer(i) - &H80) * &H80 + buffer(i + 1): Case Else: S_LEN = buffer(i): End Select: R_n = R_n + 1: i = i + 1 + S_LEN:
'ｼｽﾃﾑﾘｱﾙﾀｲﾑﾒｯｾｰｼﾞ
Case "F8": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ﾀｲﾐﾝｸﾞｸﾛｯｸ": R_n = R_n + 1: i = i + 1:
Case "F9": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_未定義": R_n = R_n + 1: i = i + 1:
Case "FA": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ｽﾀｰﾄ": R_n = R_n + 1: i = i + 1:
Case "FB": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ｺﾝﾃｨﾆｭｰ": R_n = R_n + 1: i = i + 1:
Case "FC": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ｽﾄｯﾌﾟ": R_n = R_n + 1: i = i + 1:
Case "FD": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ｱｸﾃｨﾌﾞｾﾝｼﾝｸﾞ": R_n = R_n + 1: i = i + 1:
Case "FE": Run_D = HEX_D(i): D(R_n, C_n + dCn) = STR_D + "_ｼｽﾃﾑﾘｾｯﾄ": R_n = R_n + 1: i = i + 1:
Case "FF": 'メタイベント''''''''''''''''''''''''''''''
STR_D = HEX_D(i) + HEX_D(i + 1): STR_D1 = HEX_D(i + 1):
Select Case STR_D1:
Case "00": 'ｼｰｹﾝｽ番号 5Byte 固定(FF 00 02 ssss)
D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: 'FF 03 len text シーケンス名・トラック名
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = "ｼｰｹﾝｽ番号_" + CStr(buffer(i) * &H100 + buffer(i + 1)):
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "01", "02", "03", "04", "05", "06", "07": 'ﾃｷｽﾄ（S-JIS⇒Unicode）
Select Case STR_D1:
Case "01": TXT_D = "ｺﾒﾝﾄ_":
Case "02": TXT_D = "著作権他_":
Case "03": TXT_D = "ﾄﾗｯｸ名_":
Case "04": TXT_D = "楽器名_":
Case "05": TXT_D = "歌詞_":
Case "06": TXT_D = "ﾏｰｶ_:"
Case "07": TXT_D = "ｷｭｰﾎﾟｲﾝﾄ_":
End Select:
D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: 'FF 03 len text シーケンス名・トラック名
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = TXT_D + Trim(StrConv(MidB(buffer, i, LEN_D), vbUnicode)):
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "20": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: 'FF 20 01 cc MIDI チャンネルプレフィックス 4Byte 固定
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = HEX_D(i):
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "21": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: '???。
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = HEX_D(i):
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "51": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: 'FF 51 03 tempo テンポ。 4分音符の長さをマイクロ秒単位で表現。
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
Select Case buffer(i + 0): Case Is > &H7F: Tempo1 = (buffer(i + 0) - &H80): Case Else: Tempo1 = buffer(i): End Select:
Select Case buffer(i + 1): Case Is > &H7F: Tempo2 = (buffer(i + 1) - &H80): Case Else: Tempo2 = buffer(i): End Select:
TEMPO_T = Tempo1 * &H4000 + Tempo2 * &H80 + buffer(i + 3): TEMPO_C = Int(60 * 1000000 / TEMPO_T):
' TEMPO = &H10000 * buffer(i) + &H100 * buffer(i + 1) + buffer(i + 2)
' STR_D = "テンポ " + CStr(TEMPO) + "マイクロ秒":
STR_D2 = HEX_D(i - 1) + HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2):
D(R_n, C_n + 2) = STR_D + STR_D2:
STR_D = "(" + CStr(TEMPO_T / 1000) + " mS) ♪/2＝" + CStr(TEMPO_C):
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "52", "53", "54", "55", "56", "57": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: '???。
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = HEX_D(i) + HEX_D(i + 1) + HEX_D(i + 2):
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "58": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: 'FF 58 04 nn dd cc bb 拍子 nn=分子 4分の2拍子なら2 dd=分親 2のdd乗の値が分母となる。dd=2なら、2^2=4、dd=3なら、2^3=8 といった具合。 cc= メトロノームの音価。?=60 の?のことです。4分音符なら0x18 です。 しかし、テンポは上記で書いたとおり、4分音符の長さで表現するので、ここは0x18固定になる気がします。たぶん。 bb=四分音符あたりの三十二分音符の数
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
nn = buffer(i): dd = 2 ^ buffer(i + 1)
STR_D = " 拍子: " + CStr(nn) + " ／ " + CStr(dd):
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "59": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2:
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = "キー（調）を表わす":
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "7F": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2:
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = "7F_memo":
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + LEN_D:
Case "2F": D(R_n, C_n + 2) = STR_D: dCn = 4: i = i + 2: 'FF 2F 00 トラックチャンクの終わりを示す
LEN_D = buffer(i): D(R_n, C_n + dCn) = LEN_D: dCn = dCn + 1: i = i + 1:
STR_D = "FF2F トラックの終わり":
D(R_n, C_n + dCn) = STR_D: R_n = R_n + 1: C_n = C_n + 0: i = i + 0:
Exit Do:
Case Else:
End Select:
End Select: 'STR_D select
End Select: 'Mid_E select
Loop
Next Mtrk_n
Sheets("Mid_Bin_解析").Select
Range("A1").Select
Cells.ClearContents
Cells.NumberFormatLocal = "@"
Set SD = Range(Cells(1, 1), Cells(D_Len, 300))
SD.Value = D
Erase D
Set SD31 = Range(Cells(31, 1), Cells(D_Len + 32, 1 + Mtrk_Number * 10 + 10))
D31 = SD31.Value
Call S_New_PIANO_Sheet(D_No)
Cells.NumberFormatLocal = "@"
ActiveWindow.FreezePanes = False
Range("C6").Select
Start_P = Range("B1").Value
Select Case Start_P:
Case Is > 6:
Range("C6").Select:
Case Else:
Start_P = 6: Range("C4").Select:
End Select:
ActiveWindow.FreezePanes = True:
Range("WA7").Select
ActiveWindow.ScrollColumn = 39
R_n = 7: C_n = 220:
Set SD1_220 = Range(Cells(1, C_n), Cells(D_Len, C_n + Mtrk_Number * 10 + 10))
SD1_220.Value = D31
Columns("HL:SL").ColumnWidth = 1: Columns("HL:SL").Interior.Color = RGB(100, 200, 200):
Columns("HM:SL").EntireColumn.AutoFit
R_MAX = Range("A20").CurrentRegion.Rows.Count
Select Case R_MAX: Case Is > 5000: R_MAX = 5000: Case Is > 20:: Case Else: R_MAX = 20: End Select
S_Line = R_MAX
Select Case M_line_MAX: Case Is > 20: S_Line = M_line_MAX: End Select:
Cells.FormatConditions.Delete
Cells.NumberFormatLocal = "@"
DoEvents: DoEvents: Sleep (1000):
ActiveWorkbook.Save:
Call MIDI_LINE_all:
Range(Cells(8, 1), Cells(S_Line, 1)).Value = "♪/2"
DoEvents: DoEvents: Sleep (1000):
Range("A3").NumberFormatLocal = """%BPM=""##0"
Range("A3").HorizontalAlignment = xlGeneral
Range("A3").VerticalAlignment = xlBottom
Erase E:
ActiveWorkbook.Save
DoEvents: DoEvents: Sleep (1000):
End Sub
Private Sub S_New_PIANO_Sheet(Optional D_No)
ActiveSheet.Select: PPPP = ActiveSheet.Name:
Select Case ActiveSheet.Name Like "*Mid_Bin*": Case False:
msg = "作成するxx番号を選んで実行してください。": MsgBox (msg): Exit Sub:
End Select:
DENPYOU = "PIANO"
Select Case IsMissing(D_No): Case True: D_No = DENPYOU + "_1": Case False:: End Select:
ST_NAME = Left(D_No, 24):
For i = 1 To 99: Dmet = False:
For Each Ws In Worksheets: Select Case Ws.Name: Case ST_NAME: Dmet = True: End Select: Next Ws:
Select Case Dmet: Case True: ST_NEXT = Split(ST_NAME, "("): ST_NAME = ST_NEXT(0) + "(" + CStr(i) + ")": Case Else: Exit For: End Select:
Next i:
' Sheets(DENPYOU).Visible = True: Sheets(DENPYOU).Select: Range("A1").Select:
' Sheets(DENPYOU).Copy Before:=Sheets(PPPP)
Sheets(DENPYOU).Copy After:=Sheets(PPPP)
Sheets(DENPYOU + " (2)").Name = ST_NAME:
' Sheets(DENPYOU).Visible = False:
Sheets(ST_NAME).Select: Range("A1").Select:
End Sub
Sub PlayMIDIFile_Windows_Media_Player()
Dim Player As Object ' Windows Media Playerオブジェクト
Set Player = Me.OLEObjects("WindowsMediaPlayer1").Object ' コントロールの名前を適宜変更
Player.Url = "C:\path\to\your\midi_file.mid" ' MIDIファイルのパス
Player.Controls.Play
End Sub
0コメント