VB6.0版本MIDI钢琴3音轨简谱播放器源代码QZQ-2024-9-5-13.zip

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 Dim s As String 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 Combo3_Click() Call program_change(0, 0, Combo3.ListIndex) End Sub Private Sub Command1_Click() Dim selectedDeviceID As Integer '假设你从某个地方获取了设备 ID，这里只是示例，实际情况可能需要根据你的程序逻辑进行修改。 selectedDeviceID = Combo1.ItemData(Combo1.ListIndex) Call midi_OutOpen(selectedDeviceID) End Sub Private Sub Command2_Click() Call midi_OutClose End Sub Private Sub Command3_Click() Dim s1 As String Dim s2 As String Dim s3 As String Dim i As Integer Dim midiNote1 As Integer Dim midiNote2 As Integer Dim midiNote3 As Integer Dim note1 As String Dim note2 As String Dim note3 As String Dim k As Integer k = Int(Text3.Text) s1 = Text1.Text s2 = Text2.Text '假设第二个文本框的名称为 Text2 s3 = Text4.Text '假设第二个文本框的名称为 Text2 For i = 1 To Len(s1) Or Len(s2) Or Len(s3) '取两个字符串长度中的较大值作为循环次数 If i <= Len(s1) Then note1 = Mid(s1, i, 1) Else note1 = "" '如果第一个字符串结束了，设置为空字符串 End If If i <= Len(s2) Then note2 = Mid(s2, i, 1) Else note2 = "" '如果第二个字符串结束了，设置为空字符串 End If If i <= Len(s3) Then note3 = Mid(s3, i, 1) Else note3 = "" '如果第二个字符串结束了，设置为空字符串 End If Select Case note1 Case "-" midiNote1 = 0 Case "1...." midiNote1 = 1 Case "2...." midiNote1 = 2 Case "3...." midiNote1 = 3 Case "4...." midiNote1 = 4 Case "5...." midiNote1 = 5 Case "6...." midiNote1 = 6 Case "7...." midiNote1 = 7 Case "1..." midiNote1 = 8 Case "2..." midiNote1 = 9 Case "3..." midiNote1 = 10 Case "4..." midiNote1 = 11 Case "5..." midiNote1 = 12 Case "6..." midiNote1 = 13 Case "7..." midiNote1 = 14 Case "1.." midiNote1 = 15 Case "2.." midiNote1 = 16 Case "3.." midiNote1 = 17 Case "4.." midiNote1 = 18 Case "5.." midiNote1 = 19 Case "6.." midiNote1 = 20 Case "7.." midiNote1 = 21 Case "1." midiNote1 = 22 Case "2." midiNote1 = 23 Case "3." midiNote1 = 24 Case "4." midiNote1 = 25 Case "5." midiNote1 = 26 Case "6." midiNote1 = 27 Case "7." midiNote1 = 28 Case "1" midiNote1 = 29 Case "2" midiNote1 = 30 Case "3" midiNote1 = 31 Case "4" midiNote1 = 32 Case "5" midiNote1 = 33 Case "6" midiNote1 = 34 Case "7" midiNote1 = 35 Case "1'" midiNote1 = 36 Case "2'" midiNote1 = 37 Case "3'" midiNote1 = 38 Case "4'" midiNote1 = 39 Case "5'" midiNote1 = 40 Case "6'" midiNote1 = 41 Case "7'" midiNote1 = 42 Case "1''" midiNote1 = 43 Case "2''" midiNote1 = 44 Case "3''" midiNote1 = 45 Case "4''" midiNote1 = 46 Case "5''" midiNote1 = 47 Case "6''" midiNote1 = 48 Case "7''"