Option Explicit
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function midiOutClose Lib "winmm.dll" ( _
ByVal hMidiOut As LongPtr) As Long
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
Dim hMidiOut As LongPtr
Dim hTimerMel As LongPtr, hTimerBeg As LongPtr
Dim iZeileMel As Long, iZeileBeg As Long, iAnz As Integer
Sub StartBeide()
iAnz = 0
StartMelodie
StartBegleitung
End Sub
Sub StartMelodie()
iZeileMel = 1
iAnz = iAnz + 1
If hMidiOut = 0 Then midiOutOpen hMidiOut, 0, 0, 0, 0
hTimerMel = SetTimer(0&, 0&, 10, AddressOf MelodieProc) ' Melodie-Timer setzen
End Sub
Sub StartBegleitung()
iZeileBeg = 1
iAnz = iAnz + 1
If hMidiOut = 0 Then midiOutOpen hMidiOut, 0, 0, 0, 0
hTimerBeg = SetTimer(0&, 0&, 10, AddressOf BegleitungProc) ' Begleitungstimer-Timer setzen
End Sub
Sub MelodieProc()
KillTimer 0&, hTimerMel: hTimerMel = 0 ' Melodie-Timer löschen
iZeileMel = iZeileMel + 1
With ThisWorkbook.Sheets("Midi")
If iZeileMel > .Cells(.Rows.Count, "A").End(xlUp).Row Then
iAnz = iAnz - 1
If iAnz < 1 Then midiOutClose hMidiOut: hMidiOut = 0
Exit Sub
End If
If iZeileMel > 2 Then _
PlayMIDI .Cells(iZeileMel - 1, 1).Value, .Cells(iZeileMel - 1, 2).Value, 0
PlayMIDI .Cells(iZeileMel, 1).Value, .Cells(iZeileMel, 2).Value, .Cells(iZeileMel, 4).Value
hTimerMel = SetTimer(0&, 0&, .Cells(iZeileMel, 3).Value, AddressOf MelodieProc)
End With
End Sub
Sub BegleitungProc()
KillTimer 0&, hTimerBeg: hTimerBeg = 0 ' Begelitungs-Timer löschen
iZeileBeg = iZeileBeg + 1
With ThisWorkbook.Sheets("Midi")
If iZeileBeg > .Cells(.Rows.Count, "F").End(xlUp).Row Then
iAnz = iAnz - 1
If iAnz < 1 Then midiOutClose hMidiOut: hMidiOut = 0
Exit Sub
End If
PlayMIDI .Cells(iZeileBeg, 6).Value, .Cells(iZeileBeg, 7).Value, .Cells(iZeileBeg, 9).Value
hTimerBeg = SetTimer(0&, 0&, .Cells(iZeileBeg, 8).Value, AddressOf BegleitungProc)
End With
End Sub
Sub PlayMIDI(iVoiceNum As Integer, vNoteNum As Variant, Optional iVolume As Integer = 127)
Dim i As Integer, vArr As Variant
If hMidiOut = 0 Then Exit Sub ' Kein Handle=>raus
If iVoiceNum > 0 Then _
midiOutShortMsg hMidiOut, (256 * iVoiceNum) + 192 ' Instrument wählen
vArr = Split(vNoteNum, ",") ' Noten zusamenstellen
For i = 0 To UBound(vArr)
midiOutShortMsg hMidiOut, RGB(144, vArr(i), iVolume) '144 = h90
Next i
DoEvents
End Sub
