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 LongPrivate 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 TypeDim hMidi As LongPublic 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 SubPublic Sub note_off(ch As Integer, ByVal kk As Integer)
Call midi_outshort(&H80 + ch, kk, 0)
End SubSub 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 SubSub 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 sEnd 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 TypePrivate Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As LongPrivate nfIconData As NOTIFYICONDATA
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As IntegerPrivate Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Dim lFreq As Long
Dim iLoop As IntegerPrivate Sub ComDevies_Change()
Dim dl As Integer
dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End SubPrivate Sub ComDevies_Click()
Dim dl As Integer
dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End SubPrivate Sub ComSounds_Change()
Call program_change(0, 0, ComSounds.ListIndex)
End SubPrivate Sub ComSounds_Click()
Call program_change(0, 0, ComSounds.ListIndex)
End SubPrivate 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 SubPrivate 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 SubPrivate 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.ListIndexCall Shell_NotifyIcon(NIM_DELETE, nfIconData)
midi_OutClose
End
End SubPrivate 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