让你的键盘会唱歌 vb代码

先建立一个模块,命名为MidiOut,代码如下:

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 ' max error text length (including NULL)

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
再建立一个form,命名为Form1,代码如下:

Option Explicit

Const MAX_TOOLTIP As Integer = 32
Const NIF_ICON = &H2 '删除图标
Const NIF_MESSAGE = &H1
Const NIF_TIP = &H4
Const NIM_ADD = &H0 '添加图标到任务栏提示区
Const NIM_DELETE = &H2
Const WM_MOUSEMOVE = &H200
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const WM_LBUTTONDBLCLK = &H203
Const WM_RBUTTONDOWN = &H204
Const WM_RBUTTONUP = &H205
Const WM_RBUTTONDBLCLK = &H206
Const SW_RESTORE = 9
Const SW_HIDE = 0
Private Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
ucallbackMessage As Long
hIcon As Long
szTip As String * 32
End Type

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Private nfIconData As NOTIFYICONDATA

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Dim lFreq As Long
Dim iLoop As Integer

Private Sub ComDevies_Change()
Dim dl As Integer
dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End Sub

Private Sub ComDevies_Click()
Dim dl As Integer
dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End Sub

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

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

Private Sub Form_Load()
Dim Parm As String
Parm = Command
If InStr(Parm, "h") <> 0 Then Label2_Click
Call Midi_OutDevsToList(ComDevies)

Vol.Value = GetSetting("KeySoundII", "Value", "Vol", 100)
diao.ListIndex = GetSetting("KeySoundII", "Value", "Stage", 0)
ComDevies.ListIndex = GetSetting("KeySoundII", "Value", "Devies", 0)
ComSounds.ListIndex = GetSetting("KeySoundII", "Value", "Tools", 0)
ComDevies_Click
ComSounds_Click
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Dim lMsg As Single
lMsg = x / Screen.TwipsPerPixelX
If lMsg = WM_RBUTTONUP Then Call Shell_NotifyIcon(NIM_DELETE, nfIconData): Me.Show
If lMsg = WM_LBUTTONUP Then Call Shell_NotifyIcon(NIM_DELETE, nfIconData): Me.Show

End Sub

Private Sub Form_Unload(Cancel As Integer)

SaveSetting "KeySoundII", "Value", "Devies", ComDevies.ListIndex
SaveSetting "KeySoundII", "Value", "Tools", ComSounds.ListIndex
SaveSetting "KeySoundII", "Value", "Vol", Vol.Value
SaveSetting "KeySoundII", "Value", "Stage", diao.ListIndex

Call Shell_NotifyIcon(NIM_DELETE, nfIconData)
midi_OutClose
End
End Sub

Private Sub Label2_Click()
nfIconData.hwnd = Me.hwnd
nfIconData.uId = Me.Icon
nfIconData.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
nfIconData.ucallbackMessage = WM_MOUSEMOVE
nfIconData.hIcon = Me.Icon.Handle
nfIconData.szTip = "KeySound 1.0 " & vbCrLf
nfIconData.cbSize = Len(nfIconData)
Call Shell_NotifyIcon(NIM_ADD, nfIconData)
Me.Hide
End Sub

Private Sub Timer1_Timer()
Static Oldk As Integer
Dim Rn As Integer
Rn = Int(Rnd * 10)
For iLoop = 3 To 127
If GetAsyncKeyState(iLoop) <> 0 Then
Dim i As Integer
i = iLoop
If iLoop < 50 Then i = iLoop + 50
If iLoop > 90 Then i = iLoop - 30
'If (Oldk <> i) Then
'Call note_off(0, Oldk + (diao.ListIndex + 1) * 5)
Call note_on(0, i + (diao.ListIndex + 1) * 5, Vol.Value + Rn) '参数分别为通道编号，音调，速度
Debug.Print iLoop
Oldk = i
'End If
End If
Next
End Sub

Private Sub Label2_Click() nfIconData.hwnd = Me.hwnd nfIconData.uId = Me.Icon nfIconData.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP nfIconData.ucallbackMessage = WM_MOUSEMOVE nfIconData.hIcon = Me.Icon.Handle nfIconData.szTip = "KeySound 1.0 " & vbCrLf nfIconData.cbSize = Len(nfIconData) Call Shell_NotifyIcon(NIM_ADD, nfIconData) Me.Hide End Sub