模块
Option Explicit

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

Private Const MIDIMAPPER = (-1)
Private Const MIDI_MAPPER = (-1)
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

Public 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
Public Function MIDI_OutOpen(ByVal dev_id As Integer) As Integer
Dim midi_error As Integer

midi_OutClose
midi_error = MIDIOutOpen(hMidi, dev_id, 0, 0, 0)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
MIDI_OutOpen = (hMidi <> 0)
End Function
Public Sub midi_OutClose()
Dim midi_error As Integer

If hMidi <> 0 Then
midi_error = midiOutClose(hMidi)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
hMidi = 0
End If
End Sub
Public Sub note_on(ch As Integer, ByVal kk As Integer, v As Integer)
Call midi_outshort(&H90 + ch, kk, v)
End Sub

Public Sub note_off(ch As Integer, ByVal kk As Integer)
Call midi_outshort(&H80 + ch, kk, 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)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
End Sub
Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)
Call control_change(ch, 0, cc0nr)
Call midi_outshort(&HC0 + ch, pnr, 0)
End Sub
Sub control_change(ch As Integer, ccnr As Integer, ByVal v As Integer)
Call midi_outshort(&HB0 + ch, ccnr, v)
End Sub

Sub midisetrpn(ch As Integer, pmsb As Integer, plsb As Integer, msb As Integer, lsb As Integer)
Call midi_outshort(ch, &H65, pmsb)
Call midi_outshort(ch, &H64, plsb)
Call midi_outshort(ch, &H6, msb)
Call midi_outshort(ch, &H26, lsb)
End Sub
Sub midi_outerr(ByVal midi_error As Integer)
Dim s As String
Dim x As Integer

s = Space(MAXERRORLENGTH)
x = midiOutGetErrorText(midi_error, s, MAXERRORLENGTH)
MsgBox s

End Sub

窗体
Option Explicit

Private Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)
Private sudu As Integer
Private Const VK_LBUTTON& = &H1
Private Sta As Integer
Dim i As Integer
Dim j As String
Private Sub ComDevies_Click()
Dim dl As Integer
dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End Sub

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub ComSounds_Click()
Call program_change(0, 0, ComSounds.ListIndex)
End Sub

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

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

For i = 0 To 64
Picture1(i).DragMode = 1
Next
HScroll1.Value = 36
HScroll2.Value = 127
End Sub
Private Sub fill_sound_list()
Dim s As String

Open App.Path & "\genmidi.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, s
ComSounds.AddItem s
Loop
ComSounds.ListIndex = 0
Close #1
End Sub

Private Sub Form_Unload(Cancel As Integer)
midi_OutClose
End
End Sub

Private Sub HScroll1_Change()
Sta = HScroll1.Value
Label2.Caption = Diao(Sta Mod 12)
End Sub

Private Sub HScroll2_Change()
sudu = HScroll2.Value
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Dim i As Integer
For i = 0 To 64 '关闭所有的发音
Call note_off(0, i + Sta)
Next
End Sub

Private Sub mnu_Close_Click()
Unload Me
End Sub

Private Sub Option1_Click()
If Option1.Value = True Then
Text1.Enabled = True
Text1.SetFocus
End If
End Sub

Private Sub Option2_Click()
If Option2.Value = True Then
Text1.Enabled = False
End If
End Sub

Private Sub Picture1_DragOver(Index As Integer, Source As Control, x As Single, Y As Single, State As Integer)
Static OldNote As Integer
Call note_off(0, OldNote + Sta)
Call note_on(0, Index + Sta, sudu)
OldNote = Index
End Sub

Private Sub Text1_Change()
Text1.Text = j
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
Text1.Text = ""
If KeyCode = 37 Then i = 17: j = "L 1"
If KeyCode = 40 Then i = 19: j = "L 2"
If KeyCode = 39 Then i = 21: j = "L 3"
If KeyCode = 38 Then i = 23: j = "L 4"
If KeyCode = 96 Then i = 24: j = "L 5"
If KeyCode = 110 Then i = 26: j = "L 6"
If KeyCode = 13 Then i = 28: j = "L 7"
If KeyCode = 97 Then i = 29: j = "M 1"
If KeyCode = 98 Then i = 31: j = "M 2"
If KeyCode = 99 Then i = 33: j = "M 3"
If KeyCode = 100 Then i = 35: j = "M 4"
If KeyCode = 101 Then i = 36: j = "M 5"
If KeyCode = 102 Then i = 38: j = "M 6"
If KeyCode = 103 Then i = 40: j = "M 7"
If KeyCode = 104 Then i = 41: j = "H 1"
If KeyCode = 105 Then i = 43: j = "H 2"
If KeyCode = 107 Then i = 45: j = "H 3"
If KeyCode = 144 Then i = 47: j = "H 4"
If KeyCode = 111 Then i = 48: j = "H 5"
If KeyCode = 106 Then i = 50: j = "H 6"
If KeyCode = 109 Then i = 52: j = "H 7"
Text1.Text = j
Static OldNote As Integer
Call note_off(0, OldNote + Sta)
Call note_on(0, i + Sta, sudu)
OldNote = i
End Sub

Private Function Diao(i As Integer) As String
Select Case i
Case 0
Diao = "C"
Case 1
Diao = "C#"
Case 2
Diao = "D"
Case 3
Diao = "D#"
Case 4
Diao = "E"
Case 5
Diao = "F"
Case 6
Diao = "F#"
Case 7
Diao = "G"
Case 8
Diao = "G#"
Case 9
Diao = "A"
Case 10
Diao = "A#"
Case 11
Diao = "B"
End Select
End Function

[此贴子已经被作者于2007-5-13 10:46:18编辑过]