' © Äàíèë Áåëÿåâ [outen@mail.ru]
' Ôîðìàò © Äàíèë Áåëÿåâ

Option Explicit
Public Event Tact(Lng_Event_Tact As Long)
Public Event List(Lng_Event_List As Long, Lng_Event_Count As Long)
Public Event Note(Lng_Event_Note As Long)
Private Enum XO_Stub
    XO_Stub_None
    XO_Stub_Note
    XO_Stub_Tact
End Enum
Private Enum XO_Mode
    XO_Mode_Stop
    XO_Mode_Play
End Enum
Private Const MAXNAMELEN As Long = 32
Private Type MIDIOUTCAPS
    Int_Mid     As Integer
    Int_Pid     As Integer
    Lng_Version As Long
    Str_Name    As String * MAXNAMELEN
    Int_Tech    As Integer
    Int_Voice   As Integer
    Int_Note    As Integer
    Int_Mask    As Integer
    Lng_Support As Long
End Type
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
Private Declare Function midiOutGetDevCaps Lib "winmm" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutClose Lib "winmm" (ByVal hMidiOut As Long) As Long
Private Declare Function midiOutOpen Lib "winmm" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function midiOutShortMsg Lib "winmm" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Private Declare Function timeGetTime Lib "winmm" () As Long
Private Lng_Out    As Long
Private Lng_Time   As Long
Private Lng_Temp   As Long
Private Lng_Note   As Long
Private Str_Play() As String
Private Str_List() As String
Private Str_Wave() As String
Private Lng_Wave   As Long
Private Lng_List   As Long
Private Str_Note   As String
Private Lng_Loud   As Long
Private Lng_Mode   As Long
Private Byt_Note() As Byte
Private Lng_Dev    As Long
Private CAP        As MIDIOUTCAPS
Private Lng_Event  As Long
Public Function XO_Init(Lng_Dev As Long, Lng_Init_Event As Boolean) As Long
    Call XO_Close
    XO_Init = midiOutOpen(Lng_Out, Lng_Dev, 0, App.hInstance, 0)
    Lng_Event = Lng_Init_Event
End Function
Public Sub XO_Close()
    Call XO_Stop
    DoEvents
    Call midiOutClose(Lng_Out)
End Sub
Public Property Get XO_Dev_Count() As Long
    XO_Dev_Count = midiOutGetNumDevs - 1
End Property
Public Property Get XO_Dev(Lng_New As Long) As String
    Call midiOutGetDevCaps(Lng_New, CAP, Len(CAP))
    XO_Dev = CAP.Str_Name
End Property
Public Property Let XO_Dev(Lng_New As Long, Str_New As String)
    Lng_Dev = Lng_New
End Property
Private Sub XO_Note(Byt_Out As Byte, Byt_Note As Byte, Byt_Vol As Byte)
    Call midiOutShortMsg(Lng_Out, ("&H9" & Byt_Out) Or (Byt_Note * &H100) Or (Byt_Vol * &H10000))
    If Lng_Event Then RaiseEvent Note(CLng(Byt_Note))
End Sub
Private Sub XO_Stub(Byt_Out As Byte, Byt_Note As Byte)
    Call midiOutShortMsg(Lng_Out, ("&H8" & Byt_Out) Or (Byt_Note * &H100))
End Sub
Private Sub XO_Tool(Byt_Out As Byte, Byt_Note As Byte)
    Call midiOutShortMsg(Lng_Out, ("&HC" & Byt_Out) Or (Byt_Note * &H100))
End Sub
Private Sub XO_Wave()
    Dim Str_Plus() As String
    Dim Str_More   As String
    If Lng_List > UBound(Str_List) Then
        XO_Mode = XO_Mode_Stop
    Else
        Str_Plus = Split(Str_List(Lng_List), "+"
        If Lng_Event Then RaiseEvent List(Lng_List, UBound(Str_Plus) + 1)
        For Lng_Wave = 0 To UBound(Str_Plus)
            If Lng_Wave = UBound(Str_Plus) Then
                Str_More = Str_More & Str_Play(Str_Plus(Lng_Wave))
            Else
                Str_More = Str_More & Str_Play(Str_Plus(Lng_Wave)) & vbNewLine
            End If
        Next
        Str_Wave = Split(Str_More, vbNewLine)
        ReDim Byt_Note(UBound(Str_Wave))
        For Lng_Wave = 0 To UBound(Str_Wave)
            Call XO_Tool("&H" & Left(Str_Wave(Lng_Wave), 1), "&H" & Mid(Str_Wave(Lng_Wave), 2, 2))
        Next
        Lng_List = Lng_List + 1
    End If
End Sub
Private Sub XO_Tact()
    If Lng_Event Then RaiseEvent Tact((Lng_Note - 6) / 2)
    For Lng_Wave = 0 To UBound(Str_Wave)
        If Mid(Str_Wave(Lng_Wave), 4, 1) = XO_Stub_Tact Then
            Call XO_Stub("&H" & Left(Str_Wave(Lng_Wave), 1), Byt_Note(Lng_Wave))
        End If
        Str_Note = Mid(Str_Wave(Lng_Wave), Lng_Note, 2)
        If Not Str_Note = ".." Then
            If Mid(Str_Wave(Lng_Wave), 4, 1) = XO_Stub_Note Then
                Call XO_Stub("&H" & Left(Str_Wave(Lng_Wave), 1), Byt_Note(Lng_Wave))
            End If
            Call XO_Note("&H" & Left(Str_Wave(Lng_Wave), 1), "&H" & Str_Note, CByte(Lng_Loud))
            Byt_Note(Lng_Wave) = "&H" & Str_Note
        End If
    Next
    Lng_Note = Lng_Note + 2
    If Lng_Note >= Len(Str_Wave(0)) Then
        Call XO_Wave
        Lng_Note = 6
    End If
End Sub
Public Sub XO_Play()
    Lng_List = 0
    Call XO_Wave
    XO_Mode = XO_Mode_Play
    Lng_Note = 6
    Lng_Time = timeGetTime
    Do While XO_Mode
        While timeGetTime - Lng_Time <= XO_Temp
            DoEvents
        Wend
        Call XO_Tact
        Lng_Time = timeGetTime
    Loop
End Sub
Public Sub XO_Stop()
    XO_Mode = XO_Mode_Stop
End Sub
Public Property Get XO_Temp() As Long
    XO_Temp = Lng_Temp
End Property
Public Property Let XO_Temp(Lng_New As Long)
    Lng_Temp = Lng_New
End Property
Public Property Get XO_Mode() As Long
    XO_Mode = Lng_Mode
End Property
Public Property Let XO_Mode(Lng_New As Long)
    Lng_Mode = Lng_New
End Property
Public Property Get XO_Loud() As Long
    XO_Loud = Lng_Loud
End Property
Public Property Let XO_Loud(Lng_New As Long)
    Lng_Loud = Lng_New
End Property
Public Property Get XO_List() As Long
    XO_List = Lng_List
End Property
Public Sub XO_Load(Str_Load_List As String, Str_Load_Data As String)
    Str_List = Split(Str_Load_List, ","
    Str_Play = Split(Str_Load_Data, vbNewLine & vbNewLine)
End Sub

0,1+2,1+2,1+2,1+2,0+2,0+2,0+2,0+2,1+2,1+2,1+2,1+2,0
0001:2d..2f..30..2d..2f..30..32..2f..30..32..34..30..32..34..35..32..

1071:15..21..15..21..13..1f..13..1f..11..1d..11..1d..10..1c..10..1c..

9000:24......24......24......24......24......24......24......24......
9000:........26..............26..............26..............26......
9000:....2a......2a......2a......2a......2a......2a......2a......2a..