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

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