VB6.0版本MIDI简谱播放器代码QZQ

Private Declare Function GetKeyState% Lib “user32” (ByVal nVirtKey As Long)
Private Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)
Private sudu As Integer
Private Const VK_LBUTTON& = &H1
Private isOgain As Boolean '是否重复按键
Private Sta As Integer

Private Declare Function midiOutGetDevCaps Lib “winmm.dll” Alias “midiOutGetDevCapsA” (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutGetNumDevs Lib “winmm” () As Integer
Private Declare Function MIDIOutOpen Lib “winmm.dll” Alias “midiOutOpen” (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function midiOutClose Lib “winmm.dll” (ByVal hMidiOut As Long) As Long
Private Declare Function midiOutShortMsg Lib “winmm.dll” (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Private Declare Function midiOutGetErrorText Lib “winmm.dll” Alias “midiOutGetErrorTextA” (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long

Private Const MAXERRORLENGTH = 128 ’ max error text length (including NULL)

Private Const MIDIMAPPER = (-1)
Private Const MIDI_MAPPER = (-1)
'MIDIOUTCAPS结构描述了Musical Instrument Digital Interface(MIDI)输入设备的性能
Private Type MIDIOUTCAPS
wMid As Integer
wPid As Integer ’ 产品 ID
vDriverVersion As Long ’ 设备版本
szPname As String * 32 ’ 设备 name
wTechnology As Integer ’ 设备类型
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type

Dim hMidi As Long

Private Function Midi_OutDevsToList(Obj As Control) As Boolean
Dim i As Integer
Dim midicaps As MIDIOUTCAPS
Dim isAdd As Boolean

Obj.Clear
isAdd = False
If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then    '若获取设备信息成功
      Obj.AddItem midicaps.szPname       '添加设备名称
      Obj.ItemData(Obj.NewIndex) = MIDIMAPPER   '这是默认设备ID  = -1
      isAdd = True
End If
    '添加其他设备
For i = 0 To midiOutGetNumDevs() - 1
    If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then
      Obj.AddItem midicaps.szPname
      Obj.ItemData(Obj.NewIndex) = i
      isAdd = True
    End If
Next
Midi_OutDevsToList = isAdd

End Function
Private Function MIDI_OutOpen(ByVal dev_id As Integer) As Integer
Dim midi_error As Integer

midi_error = MIDIOutOpen(hMidi, dev_id, 0, 0, 0)

MIDI_OutOpen = (hMidi <> 0)

End Function

Private Sub note_on(ch As Integer, ByVal kk As Integer, v As Integer)
Call midi_outshort(&H90 + ch, kk, v)
End Sub

Private Sub note_off(ch As Integer, ByVal kk As Integer)
Call midi_outshort(&H80 + ch, kk, 0)
End Sub

Private Sub midi_OutClose()
Dim midi_error As Integer

    midi_error = midiOutClose(hMidi)
    
    hMidi = 0

End Sub

Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)
Call midi_outshort(&HC0 + ch, pnr, 0)
End Sub

Sub midi_outshort(b1 As Integer, b2 As Integer, b3 As Integer)
Dim midi_error As Integer

midi_error = midiOutShortMsg(hMidi, b3 * &H10000 + b2 * &H100 + b1)

End Sub

Private Sub Combo1_Click()
Dim dl As Integer
dl = MIDI_OutOpen(Combo1.ItemData(Combo1.ListIndex))
Combo1.ListIndex = 0
End Sub

Private Sub Combo2_Click()
Call program_change(0, 0, Combo2.ListIndex)
End Sub

Private Sub Command1_Click()
Call MIDI_OutOpen

End Sub

Private Sub Command2_Click()
Call midi_OutClose
End Sub

Private Sub Form_Load()
Dim Retu As Boolean
Dim i As Integer

Retu = Midi_OutDevsToList(Combo1)
Combo1.ListIndex = 0
Call fill_sound_list

For i = 0 To 64
   Picture1(i).DragMode = 1
Next
HScroll1.Value = 36
HScroll2.Value = 100

End Sub

Private Sub fill_sound_list()
Dim s As String

    Combo2.AddItem "大钢琴（声学钢琴）0"
    Combo2.AddItem "明亮的钢琴1"
    Combo2.AddItem "电钢琴2"
    Combo2.AddItem "酒吧钢琴3"
    Combo2.AddItem "柔和的电钢琴4"
    Combo2.AddItem "加合唱效果的电钢琴5"
    Combo2.AddItem "羽管键琴（拨弦古钢琴）6"
    Combo2.AddItem "科拉维科特琴（击弦古钢琴）7"
    Combo2.AddItem "钢片琴8