قسمت اول - ماژول
Option Explicit
Public Const MAXPNAMELEN = 32 ' Maximum product name length
' Error values for functions used in this sample. See the function for more information
Public Const MMSYSERR_BASE = 0
Public Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' device ID out of range
Public Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Public Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Public Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' memory allocation error
Public Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' device handle is invalid
Public Const MIDIERR_BASE = 64
Public Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1) ' still something playing
Public Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3) ' hardware is still busy
Public Const MIDIERR_BADOPENMODE = (MIDIERR_BASE + 6) ' operation unsupported w/ open mode
Type MIDIOUTCAPS
wMid As Integer ' Manufacturer identifier of the device driver for the MIDI output device
' For a list of identifiers, see the Manufacturer Indentifier topic in the
' Multimedia Reference of the Platform SDK.
wPid As Integer ' Product Identifier Product of the MIDI output device. For a list of
' product identifiers, see the Product Identifiers topic in the Multimedia
' Reference of the Platform SDK.
vDriverVersion As Long ' Version number of the device driver for the MIDI output device.
' The high-order byte is the major version number, and the low-order byte is
' the minor version number.
szPname As String * MAXPNAMELEN ' Product name in a null-terminated string.
wTechnology As Integer ' One of the following that describes the MIDI output device:
' MOD_FMSYNTH-The device is an FM synthesizer.
' MOD_MAPPER-The device is the Microsoft MIDI mapper.
' MOD_MIDIPORT-The device is a MIDI hardware port.
' MOD_SQSYNTH-The device is a square wave synthesizer.
' MOD_SYNTH-The device is a synthesizer.
wVoices As Integer ' Number of voices supported by an internal synthesizer device. If the
' device is a port, this member is not meaningful and is set to 0.
wNotes As Integer ' Maximum number of simultaneous notes that can be played by an internal
' synthesizer device. If the device is a port, this member is not meaningful
' and is set to 0.
wChannelMask As Integer ' Channels that an internal synthesizer device responds to, where the least
' significant bit refers to channel 0 and the most significant bit to channel
' 15. Port devices that transmit on all channels set this member to 0xFFFF.
dwSupport As Long ' One of the following describes the optional functionality supported by
' the device:
' MIDICAPS_CACHE-Supports patch caching.
' MIDICAPS_LRVOLUME-Supports separate left and right volume control.
' MIDICAPS_STREAM-Provides direct support for the midiStreamOut function.
' MIDICAPS_VOLUME-Supports volume control.
'
' If a device supports volume changes, the MIDICAPS_VOLUME flag will be set
' for the dwSupport member. If a device supports separate volume changes on
' the left and right channels, both the MIDICAPS_VOLUME and the
' MIDICAPS_LRVOLUME flags will be set for this member.
End Type
Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
قسمت دوم - كد فرم
Option Explicit
Const INVALID_NOTE = -1 ' Code for keyboard keys that we don't handle
Dim numDevices As Long ' number of midi output devices
Dim curDevice As Long ' current midi device
Dim hmidi As Long ' midi output handle
Dim rc As Long ' return code
Dim midimsg As Long ' midi output message buffer
Dim channel As Integer ' midi output channel
Dim volume As Integer ' midi volume
Dim baseNote As Integer ' the first note on our "piano"
' Set the value for the starting note of the piano
Private Sub base_Click()
Dim s As String
Dim i As Integer
s = InputBox("Enter the new base note for the keyboard (0 - 111)", "Base note", CStr(baseNote))
If IsNumeric(s) Then
i = CInt(s)
If (i >= 0 And i < 112) Then
baseNote = i
End If
End If
End Sub
' Select the midi output channel
Private Sub chan_Click(Index As Integer)
chan(channel).Checked = False
channel = Index
chan(channel).Checked = True
End Sub
' Open the midi device selected in the menu. The menu index equals the
' midi device number + 1.
Private Sub device_Click(Index As Integer)
device(curDevice + 1).Checked = False
device(Index).Checked = True
curDevice = Index - 1
rc = midiOutClose(hmidi)
rc = midiOutOpen(hmidi, curDevice, 0, 0, 0)
If (rc <> 0) Then
MsgBox "Couldn't open midi out, rc = " & rc
End If
End Sub
' If user presses a keyboard key, start the corresponding midi note
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
StartNote NoteFromKey(KeyCode)
End Sub
' If user lifts a keyboard key, stop the corresponding midi note
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
StopNote NoteFromKey(KeyCode)
End Sub
Private Sub Form_Load()
Dim i As Long
Dim caps As MIDIOUTCAPS
' Set the first device as midi mapper
device(0).Caption = "MIDI Mapper"
device(0).Visible = True
device(0).Enabled = True
' Get the rest of the midi devices
numDevices = midiOutGetNumDevs()
For i = 0 To (numDevices - 1)
midiOutGetDevCaps i, caps, Len(caps)
device(i + 1).Caption = caps.szPname
device(i + 1).Visible = True
device(i + 1).Enabled = True
Next
' Select the MIDI Mapper as the default device
device_Click (0)
' Set the default channel
channel = 0
chan(channel).Checked = True
' Set the base note
baseNote = 60
' Set volume range
volume = 127
vol.Min = 127
vol.Max = 0
vol.Value = volume
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Close current midi device
rc = midiOutClose(hmidi)
End Sub
' Start a note when user click on it
Private Sub key_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
StartNote (Index)
End Sub
' Stop the note when user lifts the mouse button
Private Sub key_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
StopNote (Index)
End Sub
' Press the button and send midi start event
Private Sub StartNote(Index As Integer)
If (Index = INVALID_NOTE) Then
Exit Sub
End If
If (key(Index).Value = 1) Then
Exit Sub
End If
key(Index).Value = 1
midimsg = &H90 + ((baseNote + Index) * &H100) + (volume * &H10000) + channel
midiOutShortMsg hmidi, midimsg
End Sub
' Raise the button and send midi stop event
Private Sub StopNote(Index As Integer)
If (Index = INVALID_NOTE) Then
Exit Sub
End If
key(Index).Value = 0
midimsg = &H80 + ((baseNote + Index) * &H100) + channel
midiOutShortMsg hmidi, midimsg
End Sub
' Get the note corresponding to a keyboard key
Private Function NoteFromKey(key As Integer)
NoteFromKey = INVALID_NOTE
Select Case key
Case vbKeyZ
NoteFromKey = 0
Case vbKeyS
NoteFromKey = 1
Case vbKeyX
NoteFromKey = 2
Case vbKeyD
NoteFromKey = 3
Case vbKeyC
NoteFromKey = 4
Case vbKeyV
NoteFromKey = 5
Case vbKeyG
NoteFromKey = 6
Case vbKeyB
NoteFromKey = 7
Case vbKeyH
NoteFromKey = 8
Case vbKeyN
NoteFromKey = 9
Case vbKeyJ
NoteFromKey = 10
Case vbKeyM
NoteFromKey = 11
Case 188 ' comma
NoteFromKey = 12
Case vbKeyL
NoteFromKey = 13
Case 190 ' period
NoteFromKey = 14
Case 186 ' semicolon
NoteFromKey = 15
Case 191 ' forward slash
NoteFromKey = 16
End Select
End Function
' Set the volume
Private Sub vol_Change()
volume = vol.Value
End Sub
