Sub PIANO_MAKE_Columns()
Start_C = 3
Start_Row = 1001
Start_Row = 1
Split_Row = 40
KEY_C = 4
' key_n = Int(96 / 12 * 7) - 1 '現在 key_n = 55 正しくは 52
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)": Range("A5") = "":
Range("B3") = "コード" + vbLf + "休符": Range("B4") = "Am,C": Range("B5") = "■":
Range(Columns(Start_C), Columns(Start_C + key_n * KEY_C + KEY_C)).ColumnWidth = 0.8
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/標準"
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
Case 1: note = "B" + Str(Oct_B - 1) + vbLf + Str(Oct_B * 12 + 1 + 10): note_1 = Oct_B * 12 + 1 + 10: note_2 = ""
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
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
Case 4: note = "E" + Str(Oct_B - 0) + vbLf + Str(Oct_B * 12 + 1 + 15): note_1 = Oct_B * 12 + 1 + 15: note_2 = ""
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
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
End Select
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))
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)
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)
KEYBOAD.MergeCells = True:
End Select
Next C_n
ActiveWindow.FreezePanes = False
Range("C6").Select
ActiveWindow.FreezePanes = True
For i = 5 + 4 To 100 Step 4
Set S_line = Range(Cells(i, 1), Cells(i, key_n * KEY_C))
' With S_line.Borders(xlEdgeBottom): .LineStyle = xlDot: .ColorIndex = 0: .TintAndShade = 0: .Weight = xlThin: End With:
S_line.Interior.Color = RGB(150, 150, 255)
Next i
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)
Private Sub MIDI(key As Double)
Dim Msg As Long
Dim BaseMsg1 As Long
BaseMsg1 = &H7F3C90 '基準の音(ド) 3C:noteC = 60
Select Case key
Case 1: Msg = BaseMsg1 + 0 * 256 'ド
Case 1.5: Msg = BaseMsg1 + 1 * 256 'ド#
Case 2: Msg = BaseMsg1 + 2 * 256 'レ
Case 2.5: Msg = BaseMsg1 + 3 * 256 'レ#
Case 3: Msg = BaseMsg1 + 4 * 256 'ミ
Case 4: Msg = BaseMsg1 + 5 * 256 'ファ
Case 4.5: Msg = BaseMsg1 + 6 * 256 'ファ#
Case 5: Msg = BaseMsg1 + 7 * 256 'ソ
Case 5.5: Msg = BaseMsg1 + 8 * 256 'ソ#
Case 6: Msg = BaseMsg1 + 9 * 256 'ラ
Case 6.5: Msg = BaseMsg1 + 10 * 256 'ラ#
Case 7: Msg = BaseMsg1 + 11 * 256 'シ
Case 8: Msg = BaseMsg1 + 12 * 256 'ド
End Select
Call midiOutShortMsg(Handle, Msg) 'MIDIメッセージを送る(=音を鳴らす)
End Sub
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 noteC As Integer ' ドの音
' Dim noteE As Integer ' ミの音
' Dim noteG As Integer ' ソの音
Dim velocity As Integer ' 音の強さ
noteC = 60 ' ドのMIDIノート番号
noteE = 64 ' ミのMIDIノート番号
noteG = 67 ' ソのMIDIノート番号
velocity = 127 ' 音の強さ
channel = 1 '
R_MAX = Range("B2:AA60").CurrentRegion.Rows.Count
Range("C6").Select
For n = 5 + 1 To 124 + 4
For c = 2 To 3 * 110
Set D_n = Cells(n, c): Set D_k = Range(Cells(3, c), Cells(3, c + 2)):
Select Case IsNumeric(D_n)
Case True:
Select Case D_n: Case Is < 36: velocity = 80: Case Is < 60: velocity = 80: Case Else: velocity = 127:: End Select
note = D_n.Value: Msg = velocity * &H10000 + note * &H100 + &H90 + channel: Call midiOutShortMsg(Handle, Msg):
End Select
Next c
DoEvents: DoEvents: Sleep (200)
' ActiveWindow.SmallScroll Down:=-1
ActiveWindow.ScrollRow = n
Next n
Range("C6").Select
'MIDIデバイスを閉じる
Ret = midiOutClose(Handle)
' MsgBox "正常に終了しました。"
End Sub
0コメント