test PIano Play

 '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

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

' Call FormatCondition_Black_key

Start_C = 3

Start_Row = 1001

Start_Row = 1

Split_Row = 40

KEY_C = 4

' 音楽記号　♪　?????♪??

key_n = 52

Tempo_Def = 250 ' : ♪=240 =60*1000/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 = 60000 / Tempo

End Select

SLeep_ms = Tempo_Def

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

ActiveWindow.FreezePanes = False

Range("C6").Select

ActiveWindow.FreezePanes = True

Range("AM6").Select

velocity = 127 ' 音の強さ

channel = 1 ' channel

Timber = 1 '0:Acoustic Grand Piano :5 Electric Piano_ 1 25:Acoustic Guitar (nylon) 28: Electric Guitar (clean) 11:Music box

Call Change_Timber(Timber, channel)

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

Range("AAM6").Select

Range("AM6").Select

For n = 5 + 1 To R_MAX

Loss = 0

' Select Case n Mod 4: Case 1: Range("C3:HC3").Interior.Color = RGB(200, 255, 255): Loss = Loss + 50: End Select

' Select Case n Mod 4: Case 0: Range("C1:HC1").Value = Empty: Loss = Loss + 50: End Select

T_p = InStr(Cells(n, 1), "=")

Select Case T_p:

Case Is > 0: Tempo = Val(Mid(Cells(n, 1), T_p + 1)): SLeep_ms = 60000 / Tempo

Case Else: SLeep_ms = Tempo_Def:

End Select

Timber_p = InStr(Cells(n, 2), "Timber=")

Select Case Timber_p:

Case Is > 0: Timber = Val(Mid(Cells(n, 2), Timber_p + 7)): Call Change_Timber(Timber, channel):

End Select

For c = 3 To 3 * 110

Set D_n = Cells(n, c): Set D_k = Range(Cells(3, c), Cells(3, c + 2)):

Select Case D_n.Value > 30

Case True:

Select Case D_n.Value: Case Is < 36: velocity = 100: Case Is < 60: velocity = 115: Case Else: velocity = 127:: End Select

note = D_n.Value: Msg = velocity * &H10000 + note * &H100 + &H90 + channel: Call midiOutShortMsg(Handle, Msg):

Loss = Loss + 2

' Call Hitkey(R_d(note), C_d(note), True):

End Select

Select Case D_n.Value < -30

Case True

note = Abs(D_n.Value): Msg = &H10000 + note * &H100 + &H80 + channel: Call midiOutShortMsg(Handle, Msg):

Loss = Loss + 2

' Call Hitkey(R_d(note), C_d(note), False):

End Select

Next c

DoEvents: DoEvents: Sleep (SLeep_ms - Loss)

ActiveWindow.ScrollRow = n

Select Case Range("B2"): Case "stop": Exit For: End Select

Next n

Range("C6").Select

'MIDIデバイスを閉じる

Ret = midiOutClose(Handle)

' MsgBox "正常に終了しました。"

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)

Select Case ON_set: Case True:

D.Interior.Color = RGB(0, 255, 255)

' With D.Interior: .Pattern = xlPatternRectangularGradient: .Gradient.RectangleLeft = 0.5: .Gradient.RectangleRight = 0.5: .Gradient.RectangleTop = 0.5: .Gradient.RectangleBottom = 0.5: .Gradient.ColorStops.Clear: End With

' With D.Interior.Gradient.ColorStops.Add(0): .ThemeColor = xlThemeColorDark1: .TintAndShade = 0: End With

' With D.Interior.Gradient.ColorStops.Add(1): .ThemeColor = xlThemeColorAccent1: .TintAndShade = 0: End With

Case False: D.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.Value = 1

' With D.Interior: .Pattern = xlPatternRectangularGradient: .Gradient.RectangleLeft = 0.5: .Gradient.RectangleRight = 0.5: .Gradient.RectangleTop = 0.5: .Gradient.RectangleBottom = 0.5: .Gradient.ColorStops.Clear: End With

' With D.Interior.Gradient.ColorStops.Add(0): .ThemeColor = xlThemeColorDark1: .TintAndShade = 0: End With

' With D.Interior.Gradient.ColorStops.Add(1): .ThemeColor = xlThemeColorLight1: TintAndShade = 5.09659108249153E-02: End With

Case False: D.Interior.Color = RGB(0, 0, 0): D.Value = "":

End Select

End Sub

Private Sub FormatCondition_Black_key()

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, Start_C), Cells(Start_Row, 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(200, 150, 150):

KEY_D.FormatConditions(1).Font.Color = RGB(200, 150, 150):

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

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