令和７年１０月５日 三島神社の例大祭が盛大に行われました。
今年は、神輿改修３０年の節目の年です。神輿会の皆様、盛大なる神輿渡御ありがとうございます。
令和６年年越し準備（しめ縄作り）を行いました。
今年は太く立派なしめ縄ができました。氏子の皆様ありがとうごございます。
令和６年１０月６日 三島神社 例大祭 神輿渡御を行いました。
Sub PIANO_MAKE_Columns()
START_C = 3
Start_Row = 1001
Start_Row = 1
Split_Row = 40
KEY_C = 4
' 音楽記号 ♪ ?????♪??
key_n = 52
ActiveWindow.FreezePanes = False
Range(Cells(Start_Row, START_C), Cells(Start_Row + 4, START_C + key_n * KEY_C + 5 * KEY_C)).Select
' Selection.EntireRow.Delete
Selection.Delete Shift:=xlToLeft
DoEvents: DoEvents:
Range("A5").Select: Range("A3") = "テンポ": Range("A4") = "(BPM)": Select Case Range("A5").Value = "": Case True: Range("A5") = "♪/2=500": End Select
Range("A1") = "Start_P=": Range("B3") = "コード" + vbLf + "休符" + vbLf + "Timber=11": Range("B4") = "Am,C": Range("B5") = "■":
Range(Columns(START_C), Columns(START_C + key_n * KEY_C + KEY_C)).ColumnWidth = 0.9
Range(Rows(Start_Row), Rows(Start_Row + 2)).RowHeight = 50
' Range(Rows(Start_Row), Rows(Start_Row + 4)).NumberFormatLocal = "@"
Range(Rows(Start_Row), Rows(Start_Row + 4)).NumberFormatLocal = "G/標準"
R_MAX = Range("A20").CurrentRegion.Rows.Count
Select Case R_MAX: Case Is > 1500: R_MAX = 1500: Case Is > 20:: Case Else: R_MAX = 20: End Select
S_Line = R_MAX
' Application.ScreenUpdating = False
For C_n = 0 To key_n
Set KEYBOAD = Range(Cells(Start_Row, START_C + KEY_C * C_n), Cells(Start_Row + 2, START_C + KEY_C * C_n + KEY_C - 1))
KEYBOAD.Borders(xlDiagonalDown).LineStyle = xlNone
KEYBOAD.Borders(xlDiagonalDown).LineStyle = xlNone
KEYBOAD.Borders(xlDiagonalUp).LineStyle = xlNone
With KEYBOAD.Borders(xlEdgeLeft): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
With KEYBOAD.Borders(xlEdgeTop): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
With KEYBOAD.Borders(xlEdgeBottom): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
With KEYBOAD.Borders(xlEdgeRight): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
KEYBOAD.Borders(xlInsideVertical).LineStyle = xlNone
KEYBOAD.Borders(xlInsideHorizontal).LineStyle = xlNone
KEYBOAD.Interior.Color = RGB(200, 255, 255)
CB_n = C_n Mod 7
Oct_B = Int(C_n / 7) + 1
Select Case CB_n
Case 0: note = "A" + Str(Oct_B - 1) + vbLf + Str(Oct_B * 12 + 1 + 8): note_1 = Oct_B * 12 + 1 + 8: note_2 = Oct_B * 12 + 1 + 9: Set KEY_A = Range(Cells(Start_Row, START_C + KEY_C * C_n + 1), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C - 1 - 1))
Case 1: note = "B" + Str(Oct_B - 1) + vbLf + Str(Oct_B * 12 + 1 + 10): note_1 = Oct_B * 12 + 1 + 10: note_2 = "": Set KEY_A = Range(Cells(Start_Row, START_C + KEY_C * C_n + 1), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C - 1 - 0))
Case 2: note = "C" + Str(Oct_B - 0) + vbLf + Str(Oct_B * 12 + 1 + 11): note_1 = Oct_B * 12 + 1 + 11: note_2 = Oct_B * 12 + 1 + 12: Set KEY_A = Range(Cells(Start_Row, START_C + KEY_C * C_n + 0), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C - 1 - 1))
Case 3: note = "D" + Str(Oct_B - 0) + vbLf + Str(Oct_B * 12 + 1 + 13): note_1 = Oct_B * 12 + 1 + 13: note_2 = Oct_B * 12 + 1 + 14: Set KEY_A = Range(Cells(Start_Row, START_C + KEY_C * C_n + 1), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C - 1 - 1))
Case 4: note = "E" + Str(Oct_B - 0) + vbLf + Str(Oct_B * 12 + 1 + 15): note_1 = Oct_B * 12 + 1 + 15: note_2 = "": Set KEY_A = Range(Cells(Start_Row, START_C + KEY_C * C_n + 1), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C - 1 - 0))
Case 5: note = "F" + Str(Oct_B - 0) + vbLf + Str(Oct_B * 12 + 1 + 16): note_1 = Oct_B * 12 + 1 + 16: note_2 = Oct_B * 12 + 1 + 17: Set KEY_A = Range(Cells(Start_Row, START_C + KEY_C * C_n + 0), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C - 1 - 1))
Case 6: note = "G" + Str(Oct_B - 0) + vbLf + Str(Oct_B * 12 + 1 + 18): note_1 = Oct_B * 12 + 1 + 18: note_2 = Oct_B * 12 + 1 + 19: Set KEY_A = Range(Cells(Start_Row, START_C + KEY_C * C_n + 1), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C - 1 - 1))
End Select
KEY_A.MergeCells = True: 'KEY_A.HorizontalAlignment = xlCenter: KEY_A.VerticalAlignment = xlCenter:
KEY_A.Value = note_1: KEY_A.Orientation = 90: KEY_A.Font.Color = RGB(0, 0, 0)
Set KEY_D = Range(Cells(Start_Row + 2, START_C + KEY_C * C_n), Cells(Start_Row + 2, START_C + KEY_C * C_n + KEY_C - 1))
KEY_D.MergeCells = True: KEY_D.HorizontalAlignment = xlCenter: KEY_D.VerticalAlignment = xlBottom: KEY_D.Value = note
Set KEY_D = Range(Cells(Start_Row + 3, START_C + KEY_C * C_n), Cells(Start_Row + 3, START_C + KEY_C * C_n + KEY_C - 1))
KEY_D.MergeCells = True: KEY_D.HorizontalAlignment = xlCenter: KEY_D.VerticalAlignment = xlCenter: KEY_D.Value = note_1
KEY_D.Font.Color = RGB(0, 0, 0): KEY_D.Interior.Color = RGB(100, 155, 155)
Set KEY_D1 = Range(Cells(Start_Row + 4, START_C + KEY_C * C_n + 2), Cells(Start_Row + 4, START_C + KEY_C * C_n + KEY_C + 1))
Set KEY_B1 = Range(Cells(Start_Row + 0, START_C + KEY_C * C_n + 3), Cells(Start_Row + 1, START_C + KEY_C * C_n + KEY_C + 0))
Select Case C_n < key_n: Case True:
Select Case note_2 <> "": Case True:
KEY_D1.MergeCells = True: KEY_D1.HorizontalAlignment = xlCenter: KEY_D1.VerticalAlignment = xlCenter: KEY_D1.Value = note_2
KEY_D1.Font.Color = RGB(250, 250, 250): KEY_D1.Interior.Color = RGB(150, 150, 150)
KEY_B1.MergeCells = True: KEY_B1.HorizontalAlignment = xlCenter: KEY_B1.VerticalAlignment = xlCenter: KEY_B1.Value = note_2
KEY_B1.Font.Color = RGB(250, 250, 250): KEY_B1.Interior.Color = RGB(150, 150, 150): KEY_B1.Orientation = 90:
End Select:
End Select:
Next C_n
For C_n = 0 To key_n - 1
CB_n = C_n Mod 7
Select Case CB_n
' Case 0, 2, 3, 4, 6
Case 0, 2, 3, 5, 6
Set KEYBOAD = Range(Cells(Start_Row, START_C + KEY_C - 1 + KEY_C * C_n), Cells(Start_Row + 1, START_C + KEY_C + KEY_C * C_n))
KEYBOAD.Borders(xlDiagonalDown).LineStyle = xlNone
KEYBOAD.Borders(xlDiagonalUp).LineStyle = xlNone
With KEYBOAD.Borders(xlEdgeLeft): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
With KEYBOAD.Borders(xlEdgeTop): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
With KEYBOAD.Borders(xlEdgeBottom): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
With KEYBOAD.Borders(xlEdgeRight): .LineStyle = xlContinuous: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
KEYBOAD.Borders(xlInsideVertical).LineStyle = xlNone
KEYBOAD.Borders(xlInsideHorizontal).LineStyle = xlNone
KEYBOAD.Interior.Color = RGB(0, 0, 0)
End Select
Next C_n
Set KEYBOAD = Nothing:
Application.ScreenUpdating = True
' Call FormatConditionMacro
Call WorkArea_Line(S_Line)
ActiveWindow.FreezePanes = False
Range("C6").Select
ActiveWindow.FreezePanes = True
Range("W6").Select
ActiveWindow.ScrollColumn = 23
End Sub
Sub MM_FormatCondition_Line(Optional S_Line)
Select Case IsMissing(S_Line): Case True: S_Line = 1000: End Select
' Call WorkArea_Line_Clear(S_Line)
Cells.FormatConditions.Delete
Set M_Line = Range(Rows(6), Rows(S_Line + 10))
M_Line.RowHeight = 15
M_Line.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(COLUMN(),4)=1"
M_Line.FormatConditions(M_Line.FormatConditions.Count).SetFirstPriority
With M_Line.FormatConditions(1).Borders(xlLeft): .LineStyle = xlDashDot: .Weight = xlThin: .Color = RGB(150, 100, 100): End With
M_Line.FormatConditions(1).StopIfTrue = False
Range("EY14").Activate
M_Line.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(COLUMN(),4)=3"
M_Line.FormatConditions(M_Line.FormatConditions.Count).SetFirstPriority
With M_Line.FormatConditions(1).Borders(xlLeft): .LineStyle = xlDashDotDot: .Weight = xlThin: .Color = RGB(0, 150, 150): End With
M_Line.FormatConditions(1).StopIfTrue = False
M_Line.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),4)=3"
M_Line.FormatConditions(M_Line.FormatConditions.Count).SetFirstPriority
With M_Line.FormatConditions(1).Borders(xlBottom): .LineStyle = xlContinuous: .Weight = xlThin: .Color = RGB(150, 100, 100): End With
M_Line.FormatConditions(1).StopIfTrue = False
M_Line.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),4)=1"
M_Line.FormatConditions(M_Line.FormatConditions.Count).SetFirstPriority
With M_Line.FormatConditions(1).Borders(xlBottom): .LineStyle = xlDashDot: .Weight = xlThin: .Color = RGB(200, 100, 100): End With
M_Line.FormatConditions(1).StopIfTrue = False
Set M_Line = Nothing
End Sub
Private Sub FormatConditionMacro()
START_C = 3: Start_Row = 1: Split_Row = 40: KEY_C = 4: key_n = 52:
Cells.FormatConditions.Delete
Set KEY_D = Range(Cells(Start_Row + 3, START_C), Cells(Start_Row + 3, START_C + KEY_C * key_n + KEY_C - 1))
KEY_D.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=0"
KEY_D.FormatConditions(1).Interior.Color = RGB(100, 155, 155):
KEY_D.FormatConditions(1).StopIfTrue = False:
With KEY_D.FormatConditions(1).Borders(xlLeft): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
With KEY_D.FormatConditions(1).Borders(xlRight): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
With KEY_D.FormatConditions(1).Borders(xlTop): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
With KEY_D.FormatConditions(1).Borders(xlBottom): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
KEY_D.FormatConditions(1).Font.Color = RGB(250, 250, 250)
Set KEY_D = Nothing
Set KEY_D1 = Range(Cells(Start_Row + 4, START_C), Cells(Start_Row + 4, START_C + KEY_C * key_n + KEY_C + 1))
KEY_D1.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=0"
KEY_D1.FormatConditions(1).Interior.Color = RGB(150, 150, 150):
KEY_D1.FormatConditions(1).StopIfTrue = False:
With KEY_D1.FormatConditions(1).Borders(xlLeft): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
With KEY_D1.FormatConditions(1).Borders(xlRight): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
With KEY_D1.FormatConditions(1).Borders(xlTop): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
With KEY_D1.FormatConditions(1).Borders(xlBottom): .LineStyle = xlContinuous: .TintAndShade = 0: .Weight = xlThin: End With
KEY_D1.FormatConditions(1).Font.Color = RGB(250, 250, 250)
Set KEY_D1 = Nothing
End Sub
Sub WorkArea_Line(Optional ByRef S_Line As Variant)
Select Case IsMissing(S_Line): Case True: S_Line = 1000: End Select:
START_C = 3: Start_Row = 1: Split_Row = 40: KEY_C = 4: key_n = 52: O_line = 50 'S_Line = 5000: O_line = 550:
Call WorkArea_Line_Clear(S_Line)
Set TEMPO = Range(Cells(Start_Row + 5, 1), Cells(O_line, 1))
For Each Rng In TEMPO
Select Case Rng.Value: Case Empty: Rng.Value = "♪/2": End Select:
Next:
Set TEMPO = Nothing
Dim C_d(1 To 128) As Variant
Dim R_d(1 To 128) As Variant
Black_key = 1: White_key = 3:
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
R_d(note_1) = White_key: C_d(note_1) = START_C + KEY_C * C_n
Select Case note_2 = "": Case False:
R_d(note_2) = Black_key: C_d(note_2) = START_C + KEY_C * C_n + 3
End Select:
Next C_n
Call MM_FormatCondition_Line(S_Line)
End Sub
Sub WorkArea_Line_Clear(Optional ByRef S_Line As Variant)
Select Case IsMissing(S_Line): Case True: S_Line = 1000: End Select:
START_C = 3: Start_Row = 1: Split_Row = 40: KEY_C = 4: key_n = 52: 'S_Line = 5000: O_line = 550:
Set WorkArea = Range(Rows(START_C + 2), Rows(S_Line))
WorkArea.Borders(xlDiagonalDown).LineStyle = xlNone
WorkArea.Borders(xlDiagonalUp).LineStyle = xlNone
WorkArea.Borders(xlEdgeLeft).LineStyle = xlNone
WorkArea.Borders(xlEdgeTop).LineStyle = xlNone
WorkArea.Borders(xlEdgeBottom).LineStyle = xlNone
WorkArea.Borders(xlEdgeRight).LineStyle = xlNone
WorkArea.Borders(xlInsideVertical).LineStyle = xlNone
WorkArea.Borders(xlInsideHorizontal).LineStyle = xlNone
Set WorkArea = Nothing
End Sub
'MIDI API
Private Declare PtrSafe Function midiOutGetNumDevs Lib "winmm" () As Integer
Private Declare PtrSafe Function midiOutOpen Lib "winmm.dll" (lphMidiOut As LongPtr, ByVal uDeviceID As Long, ByVal dwCallback As LongPtr, ByVal dwInstance As LongPtr, ByVal dwflags As Long) As Long
Private Declare PtrSafe Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As LongPtr, ByVal dwMsg As Long) As Long
Private Declare PtrSafe Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As LongPtr) As Long
Dim Handle As LongPtr
'Sleep API
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
' PianoPlaying Flug
Dim PianoPlaying
Dim C_d(0 To 128) As Variant
Dim R_d(0 To 128) As Variant
Dim S_d(0 To 128) As Boolean '
Dim startTime As Double
Dim currentTime As Double
Dim interval As Double
Dim nextMoleTime As Double
Dim n_BPN As Long
Dim currentTicClock As Long
Dim nextTicTime As Double
Dim nextMtrkTic(0 To 32) As Long
Dim nextMtrkTime(1 To 32) As Double
Dim nextMtrkRow(1 To 32) As Long
Sub PIANO_Play()
'MIDI出力デバイス取得
Dim Ret As Long
Ret = midiOutGetNumDevs
Dim i As Long
Dim msg As Long
Dim BaseMsg1 As Long
'MIDIデバイスを開く
If Ret = 0 Then
MsgBox "MIDI音源が無いため利用できません。"
Exit Sub
Else
Ret = midiOutOpen(Handle, -1, 0, 0, 0)
End If
' Msg = BaseMsg1 + &H0 * &H100: Call midiOutShortMsg(Handle, Msg) 'MIDIメッセージを送る(=音を鳴らす)
DoEvents: DoEvents:
' Sleep (3000)
' Dim C_d(1 To 128) As Variant
' Dim R_d(1 To 128) As Variant
R_MAX = Range("A20").CurrentRegion.Rows.Count
Select Case R_MAX: Case Is > 16384: R_MAX = 16384: Case Is > 20:: Case Else: R_MAX = 20: End Select
S_Line = R_MAX
' Range("HM6").Select
' Range("AM6").Select
Application.ScreenUpdating = False
' Cells.FormatConditions.Delete
START_C = 3
Start_Row = 1001
Start_Row = 1
Split_Row = 40
KEY_C = 4
' 音楽記号 ♪ ?????♪??
key_n = 52
Tempo_Def = 250 ' : ♪=240 =60/240
T_p = InStr(Cells(5, 1), "=")
Select Case T_p:
Case Is > 0: TEMPO = CLng(Mid(Cells(5, 1), T_p + 1)): Tempo_Def = 60 / TEMPO
End Select
SLeep_ms = Tempo_Def
interval = SLeep_ms
Speed = 1 '
n_BPN = 100: Select Case Cells(3, 1).Value: Case Is < 50: Case "": Case Is > 200: Case Else: n_BPN = Cells(3, 1).Value: End Select:
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
R_d(note_1) = 3: C_d(note_1) = START_C + KEY_C * C_n
Select Case note_2 = "": Case False:
R_d(note_2) = 1: C_d(note_2) = START_C + KEY_C * C_n + 3
End Select:
Next C_n
For note = 21 To 110
Call Hitkey(R_d(note), C_d(note), False):
S_d(note) = False:
Next note
Call Setkey_all:
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 = 7: Call WorkArea_Line_Clear(S_Line): Call FormatCondition_Line(S_Line): Range("C4").Select:
End Select:
ActiveWindow.FreezePanes = True:
Range("W6").Select:
' Range("DA6").Select:
ActiveWindow.ScrollColumn = 39
Application.ScreenUpdating = True
Application.Calculation = xlManual
velocity = 100 ' 音の強さ
channel = 1 ' channel
Timber = 0 '0:Acoustic Grand Piano :5 Electric Piano_ 1 25:Acoustic Guitar (nylon) 28: Electric Guitar (clean) 11:Music box
Call Change_Timber(Timber, channel)
Trk_MAX = 32: Tic128 = 2: HEX_2 = 3: Start = 4: end_L = 65536:
C2 = Range(Cells(1, 1), Cells(S_Line + 10, 220)):
SD2 = Range(Cells(1, 221), Cells(end_L, 221 + Trk_MAX * 10 + 10)).Value
Tic_DD = SD2(2, 1): '分解能 ４分音符のTic数
Trk_MAX = SD2(1, 12):
Select Case IsEmpty(Tic_DD): Case True: Tic_Div = 1: Tic_DD = 1: Case Else: Tic_Div = Tic_DD / 4: End Select: '16分音符区切り
''''Tic_intervalのTic=0実行''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
currentTicClock = 0: nextMtrkTic(0) = 0:
For mm = 1 To Trk_MAX:
nextMtrkTime(mm) = startTime:
nextMtrkRow(mm) = Start:
Next mm:
For mm = 1 To Trk_MAX:
' Exit For
tic_d = 0: nextMtrkTic(mm) = 0: nextMtrkRow(mm) = Start:
' tic_d = SD2(nextMtrkRow(mm) + 1, 1 + (mm - 1) * 10):
tic_d = SD2(nextMtrkRow(mm), 1 + (mm - 1) * 10):
Select Case IsEmpty(tic_d):
Case True: nextMtrkTic(mm) = 720000:
Case Else: nextMtrkTic(mm) = nextMtrkTic(mm) + tic_d:
End Select:
Do While nextMtrkTic(mm) < 1
tic_d = SD2(nextMtrkRow(mm) + 1, 1 + (mm - 1) * 10):
Select Case IsEmpty(tic_d):
Case True: nextMtrkTic(mm) = 7200000:
Case Else: nextMtrkTic(mm) = nextMtrkTic(mm) + tic_d:
HEX_D = SD2(nextMtrkRow(mm), HEX_2 + (mm - 1) * 10):
Select Case Len(HEX_D): Case Is > 3:
Select Case Left(HEX_D, 1):
Case "8": Call H_8x_note_off(HEX_D):
Case "9": Call H_9x_note_on(HEX_D):
Case "B": Call H_Bx_chChange_c_val(HEX_D):
Case "C": Call H_Cx_chChange_Timber(HEX_D):
Case "F": Select Case Left(HEX_D, 4):
Case "FF51": Call H_FF51_interval_Change(HEX_D): ' Cells(n, 1).Value = "♪/2：:" + CStr(Int(60 / interval)):
End Select:
End Select:
End Select:
nextMtrkRow(mm) = nextMtrkRow(mm) + 1:
End Select:
Loop:
Next mm:
''''Tic_intervalのTic=0実行''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.StatusBar = False:
oldStatusBar = Application.DisplayStatusBar
Application.StatusBar = True:
startTime = Timer
startTime = Timer:
nextMoleTime = startTime:
nextTicTime = startTime:
n = Start_P:
Tic_interval = interval / Tic_Div:
Do While Timer - startTime < 1440 ' 1440秒間ゲームを実行
currentTime = Timer
Do While currentTime > nextTicTime:
nextTicTime = nextTicTime + Tic_interval:
currentTicClock = currentTicClock + 1
''''Tic_intervalでの演奏''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Tic_interval = interval / Tic_Div:
For mm = 1 To Trk_MAX:
' Exit For
Do While currentTicClock >= nextMtrkTic(mm)
tic_d = SD2(nextMtrkRow(mm) + 1, 1 + (mm - 1) * 10):
Select Case IsEmpty(tic_d):
Case True: nextMtrkTic(mm) = 7200000:
Case Else: nextMtrkTic(mm) = nextMtrkTic(mm) + tic_d:
HEX_D = SD2(nextMtrkRow(mm), HEX_2 + (mm - 1) * 10):
Select Case Len(HEX_D): Case Is > 3:
Select Case Left(HEX_D, 1):
Case "8": Call H_8x_note_off(HEX_D):
Case "9": Call H_9x_note_on(HEX_D):
Case "B": Call H_Bx_chChange_c_val(HEX_D):
Case "C": Call H_Cx_chChange_Timber(HEX_D):
Case "E": Call H_Ex_Pitch_Change(HEX_D):
Case "F": Select Case Left(HEX_D, 4):
Case "FF51": Call H_FF51_interval_Change(HEX_D): ' Cells(n, 1).Value = "♪/2：:" + CStr(Int(60 / interval)):
End Select:
End Select:
End Select:
nextMtrkRow(mm) = nextMtrkRow(mm) + 1:
End Select:
Loop:
Next mm:
Loop:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' currentTime = Timer
Select Case currentTime >= nextMoleTime: Case True:
' nextMoleTime = currentTime + interval / Speed
nextMoleTime = nextMoleTime + interval / Speed
T_p = InStr(Cells(n, 1), "=")
Select Case T_p: Case Is > 0: TEMPO = Val(Mid(Cells(n, 1), T_p + 1)): interval = 60 / TEMPO
End Select
Timber_P = InStr(Cells(n, 2), "=")
Select Case Timber_P > 1: Case True: Timber = Mid(Cells(n, 2).Value, Timber_P + 1): Call Change_Timber(Timber, channel): End Select:
Application.StatusBar = "| currentTicClock = " + Str(currentTicClock) + " | Sline = " + Str(n) + " / " + Str(S_Line) + " | ♪/2：" + CStr(Int(60 / interval)) + " | %BPN：" + CStr(n_BPN)
For c = 3 To 211:
Select Case WorksheetFunction.IsText(C2(n, c)):
'''''NOTE数字での演奏''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Case False: 'NOTE数字での演奏
Select Case WorksheetFunction.IsText(C2(n - 1, c)): Case False: 'NOTE数字での演奏
D_n_1 = C2(n - 1, c): note_1 = Abs(D_n_1):
D_n = C2(n, c): note = D_n:
Select Case D_n_1:
Case Is < -120: Case Is < -20:
msg = &H10000 + note_1 * &H100 + &H80 + channel: Call midiOutShortMsg(Handle, msg):
Call Hitkey(R_d(note_1), C_d(note_1), False):
End Select
Select Case D_n:
Case Is > 120: Case Is > 20:
' Select Case D_n.Value: Case Is < 36: velocity = 100: Case Is < 60: velocity = 115: Case Else: velocity = 127:: End Select
msg = velocity * &H10000 + note * &H100 + &H90 + channel: Call midiOutShortMsg(Handle, msg):
Loss = Loss + 0
Call Hitkey(R_d(note), C_d(note), True):
Select Case C2(n, 2): Case "■": msg = &H10000 + note * &H100 + &H90 + channel: Call midiOutShortMsg(Handle, msg): End Select:
Case Empty:
Select Case D_n_1: Case Is > 120: Case Is > 20:
msg = &H10000 + D_n_1 * &H100 + &H80 + channel: Call midiOutShortMsg(Handle, msg):
Call Hitkey(R_d(note_1), C_d(note_1), False):
End Select:
End Select
End Select:
''''''HEX_Dでの演奏''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Case True: 'HEX_Dでの演奏
D_H0 = C2(n, c):
D_H = Split(D_H0, vbLf):
For hh = LBound(D_H) To UBound(D_H):
Exit For:
Select Case Len(D_H(hh)): Case Is > 3:
HEX_D = Mid(D_H(hh), InStrRev(D_H(hh), vbLf) + 1):
Select Case Left(HEX_D, 1):
Case "8": Call H_8x_note_off(HEX_D):
Case "9": Call H_9x_note_on(HEX_D):
Case "B": Call H_Bx_chChange_c_val(HEX_D):
Case "C": Call H_Cx_chChange_Timber(HEX_D):
Case "F":
Select Case Left(HEX_D, 4):
Case "FF51": Call H_FF51_interval_Change(HEX_D): ' Cells(n, 1).Value = "♪/2::" + CStr(Int(60 / interval)):
End Select:
End Select:
End Select:
Next hh:
''''''HEX_Dでの演奏''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Select:
Next c:
ActiveWindow.ScrollRow = n:
n = n + 1
Select Case n: Case Is > R_MAX: Exit Do: End Select:
Select Case Range("B2"): Case "stop": Ret = midiOutClose(Handle): Exit Do: End Select
End Select:
' Call Setkey_all:
DoEvents: DoEvents: ' ユーザー操作を受け付ける
Loop
Erase SD2: Erase C2:
Application.Calculation = xlAutomatic
Select Case Start_P:
Case Is > 6:
Case Else: Start_P = 6: Call WorkArea_Line(S_Line): Range("W6").Select: End Select:
ActiveWindow.ScrollColumn = 39
Cells.FormatConditions.Delete
Call MM_FormatCondition_Line(S_Line)
'MIDIデバイスを閉じる
Ret = midiOutClose(Handle)
' MsgBox "正常に終了しました。"
Application.StatusBar = False:
oldStatusBar = Application.DisplayStatusBar
End Sub
Private Sub H_Ex_Pitch_Change(HEX_D)
Dim msg As Long
S = CLng("&H" + Mid(HEX_D, 1, 2)): note = CLng("&H" + Mid(HEX_D, 3, 2)): vel = CLng("&H" + Mid(HEX_D, 5, 2)): 'ch = CLng("&H" + Mid(HEX_D, 2, 1)):
msg = vel * &H10000 + note * &H100 + S: Call midiOutShortMsg(Handle, msg):
End Sub
Private Sub H_8x_note_off(HEX_D)
Dim msg As Long
S = CLng("&H" + Mid(HEX_D, 1, 2)): note = CLng("&H" + Mid(HEX_D, 3, 2)): vel = CLng("&H" + Mid(HEX_D, 5, 2)): 'ch = CLng("&H" + Mid(HEX_D, 2, 1)):
msg = vel * &H10000 + note * &H100 + S: Call midiOutShortMsg(Handle, msg):
'Exit Sub:
S_d(note) = False: 'Call Hitkey(R_d(note), C_d(note), False):
End Sub
Private Sub H_9x_note_on(HEX_D)
Dim msg As Long
S = CLng("&H" + Mid(HEX_D, 1, 2)): note = CLng("&H" + Mid(HEX_D, 3, 2)): vel = CLng("&H" + Mid(HEX_D, 5, 2)): 'ch = CLng("&H" + Mid(HEX_D, 2, 1)):
msg = vel * &H10000 + note * &H100 + S: Call midiOutShortMsg(Handle, msg):
'Exit Sub:
Select Case vel:
Case 0: S_d(note) = False: 'Call Hitkey(R_d(note), C_d(note), False):
Case Else: S_d(note) = True: 'Call Hitkey(R_d(note), C_d(note), True):
End Select:
End Sub
Private Sub H_Bx_chChange_c_val(HEX_D)
Dim msg As Long
S = CLng("&H" + Mid(HEX_D, 1, 2)): c_No = CLng("&H" + Mid(HEX_D, 3, 2)): c_val = CLng("&H" + Mid(HEX_D, 5, 2)): 'ch = CLng("&H" + Mid(HEX_D, 2, 1)):
msg = c_val * &H10000 + c_No * &H100 + S: Call midiOutShortMsg(Handle, msg):
End Sub
Private Sub H_Cx_chChange_Timber(HEX_D)
Dim msg As Long
S = CLng("&H" + Mid(HEX_D, 1, 2)): Timber = CLng("&H" + Mid(HEX_D, 3, 2)): 'ch = CLng("&H" + Mid(HEX_D, 2, 1)): vel = CLng("&H" + Mid(HEX_D, 5, 2)):
msg = Timber * &H100 + S: Call midiOutShortMsg(Handle, msg):
End Sub
Private Sub H_FF51_interval_Change(HEX_D):
T1 = CLng("&H" + Mid(HEX_D, 7, 2)): T2 = CLng("&H" + Mid(HEX_D, 9, 2)): T3 = CLng("&H" + Mid(HEX_D, 11, 2)):
Select Case T1: Case Is > &H7F: Tempo1 = (T1 - &H80): Case Else: Tempo1 = T1: End Select:
Select Case T2: Case Is > &H7F: Tempo2 = (T2 - &H80): Case Else: Tempo2 = T2: End Select:
Select Case T3: Case Is > &H7F: Tempo2 = (T3 - &H80): Case Else: tempo3 = T3: End Select:
TEMPO_T = Tempo1 * &H4000 + Tempo2 * &H80 + tempo3: TEMPO_C = Int(60 * 1000000 / TEMPO_T):
STR_D = "(" + CStr(TEMPO_T / 1000) + " mS) ♪/2＝" + CStr(TEMPO_C):
interval = 60 / TEMPO_C / n_BPN * 100
End Sub
Private Sub Setkey_all()
Black_key = 1: White_key = 3:
For note = 21 To 110:
Select Case R_d(note):
Case Black_key: Set D = Cells(1, C_d(note)):
Select Case S_d(note): Case True: D.Interior.Color = RGB(255, 200, 200)
Case False: D.Interior.Color = RGB(0, 0, 0):
End Select:
Case White_key: Set D = Cells(3, C_d(note)): Set D1 = Range(Cells(1, C_d(note)), Cells(1, C_d(note) + 1))
Select Case S_d(note): Case True: D.Interior.Color = RGB(0, 255, 255): D1.Interior.Color = RGB(0, 255, 255)
Case False: D.Interior.Color = RGB(200, 255, 255): D1.Interior.Color = RGB(200, 255, 255):
End Select:
End Select:
Next note:
End Sub
Private Sub Hitkey(R_d As Variant, C_d As Variant, ON_set As Boolean)
Select Case R_d: Case 3: Call Hitkey_C3(C_d, ON_set): Case 1: Call Hitkey_F1(C_d, ON_set): End Select:
End Sub
Private Sub Hitkey_C3(Column As Variant, ON_set As Boolean)
Select Case Column: Case 0: Exit Sub: End Select:
Set D = Cells(3, Column)
Set D1 = Range(Cells(1, Column), Cells(1, Column + 1))
Select Case ON_set: Case True:
D.Interior.Color = RGB(0, 255, 255)
D1.Interior.Color = RGB(0, 255, 255)
Case False:
D.Interior.Color = RGB(200, 255, 255)
D1.Interior.Color = RGB(200, 255, 255)
End Select
End Sub
Private Sub Hitkey_F1(Column As Variant, ON_set As Boolean)
Select Case Column: Case 0: Exit Sub: End Select:
Set D = Cells(1, Column)
Select Case ON_set: Case True:
D.Interior.Color = RGB(255, 200, 200)
Case False: D.Interior.Color = RGB(0, 0, 0):
End Select
End Sub
Private Sub FormatCondition_Line(Optional ByRef S_Line As Variant)
START_C = 3: Start_Row = 1: Split_Row = 40: KEY_C = 4: key_n = 52:
Cells.FormatConditions.Delete
R_MAX = Range("A20").CurrentRegion.Rows.Count
Select Case R_MAX: Case Is > 16384: R_MAX = 16384: Case Is > 20:: Case Else: R_MAX = 20: End Select
Select Case S_Line: Case Is > 20: S_Line = R_MAX: End Select:
Select Case M_line_MAX: Case Is > 20: S_Line = M_line_MAX: End Select:
' Set KEY_D = Range(Rows(Start_Row + 5), Rows(S_Line + 50))
Set KEY_D = Range(Rows(6), Rows(S_Line))
KEY_D.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="="""""
KEY_D.FormatConditions(1).Interior.Color = RGB(10, 10, 10):
Set M_Line = Range(Rows(6), Rows(S_Line + 10))
M_Line.RowHeight = 15
End Sub
Private Sub Change_Timber(Timber, channel)
Dim msg As Long
msg = Timber * &H100 + &HC0 + channel:
Call midiOutShortMsg(Handle, msg):
End Sub
Sub PIANO_key()
Dim note As Variant
Dim Ret As Long
Dim i As Long
Dim msg As Long
Dim BaseMsg1 As Long
note = ActiveCell.Value
Select Case IsError(note): Case True: Exit Sub: End Select
note_p = InStr(note, vbLf):
Select Case note_p: Case Is > 0: note = Val(Mid(note, note_p + 1)): End Select
Select Case note
Case Is > 111: Exit Sub:
Case Is < 21: Exit Sub:
Case Is > 20:
Ret = midiOutGetNumDevs
Select Case Ret:
Case 0: MsgBox "MIDI音源が無いため利用できません。": Exit Sub:
Case Else: Ret = midiOutOpen(Handle, -1, 0, 0, 0)
End Select
Case Else: Exit Sub:
End Select
For i = 1 To 2
velocity = 127 ' 音の強さ
channel = 1 '
msg = velocity * &H10000 + note * &H100 + &H90 + channel:
Call midiOutShortMsg(Handle, msg):
Sleep (2000)
Next i
msg = velocity * &H10000 + note * &H100 + &H80 + channel:
Call midiOutShortMsg(Handle, msg):
DoEvents: DoEvents:
Ret = midiOutClose(Handle)
End Sub
'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
令和6年４月２４日 御神木伐採後の跡片付けを行います。
参加いただける方は三島神社境内に集合してください。
３月末に２日がかりで行った御神木伐採はほぼ予定通り進めることができました。
ご協力いただいた方々に感謝いたします。
令和６年４月8日
【三島神社】氏子連絡網 のチャット招待を始めます。
匿名で参加でき、個人のアカウントを公開したくない方も参加できます。
お手数をおかけしますが、何卒よろしくお願いいたします。
ホームページに三島神社＿氏子スケジュールを追加しました。
令和６年３月３０日～３１日
朝から氏子総代・協力者・プロが集合し樹木伐採を行いました。