Code:
Option Explicit
'Name length Constant
Const MAXPNAMELEN = 32
'Midi Note format
Const KeyOn = &H90 'Simulates Key Press
Const KeyOff = &H80 'Simulates Key Release
Private Type MidiMsg
status As Byte 'Key On or Off
Note As Byte 'Note - 60 is middle C each increment is a half step
Velocity As Byte 'Simulates how hard key was struck 0 - 127
Data3 As Byte 'Not used in this example
End Type
'Holds in formation about device (Port)
Private Type MIDIOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
wTechnology As Integer
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type
'Callback routed to form - not used but necessary
Private Const CALLBACK_WINDOW = &H10000
'Send note to Midi Device (Port)
Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
'Close Port
Private Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
'Open a specific Midi Port
Private 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
'Get how Many Ports are available
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
'Get info from specific port
Private Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
'Used to convert Note Message to an unsigned Long Integer for API compatibility
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Dim hMidi As Long ' Holds Midi Port Handle to reference aspecific opened port
Private Sub Combo1_Click()
'Close any open ports
midiOutClose hMidi
'Open Port indicated in Combo Box
midiOutOpen hMidi, Combo1.ListIndex, Me.hWnd, 0, CALLBACK_WINDOW
End Sub
Private Sub Command1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim msg As MidiMsg, ml As Long
'set up note info
msg.status = KeyOn
msg.Velocity = 64
msg.Data3 = 0
'choose note accroding to key pressed
msg.Note = Choose(Index + 1, 60, 62, 64, 65, 67, 69, 71)
CopyMemory ml, msg, 4 'copy to unsigned long integer
midiOutShortMsg hMidi, ml 'send note
'send next note
msg.Note = Choose(Index + 1, 64, 65, 67, 69, 71, 72, 74)
CopyMemory ml, msg, 4
midiOutShortMsg hMidi, ml
'send third note in triad
msg.Note = Choose(Index + 1, 67, 69, 71, 72, 74, 76, 77)
CopyMemory ml, msg, 4
midiOutShortMsg hMidi, ml
End Sub
Private Sub Command1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim msg As MidiMsg, ml As Long
'if Right mouse button pressed, sustain note
If Button = 2 Then Exit Sub
'set up note off
msg.status = KeyOff
msg.Velocity = 64
msg.Data3 = 0
'shut off first note
msg.Note = Choose(Index + 1, 60, 62, 64, 65, 67, 69, 71)
CopyMemory ml, msg, 4
midiOutShortMsg hMidi, ml
'shut off next note
msg.Note = Choose(Index + 1, 64, 65, 67, 69, 71, 72, 74)
CopyMemory ml, msg, 4
midiOutShortMsg hMidi, ml
'shut off last note in triad
msg.Note = Choose(Index + 1, 67, 69, 71, 72, 74, 76, 77)
CopyMemory ml, msg, 4
midiOutShortMsg hMidi, ml
End Sub
Private Sub Form_Load()
Dim i As Long, caps As MIDIOUTCAPS
Me.ScaleMode = vbPixels
Me.Caption = "Diatonic Chords,Mouse Button: Left-Staccato, Right-Legato"
Combo1.Left = 0
Combo1.Top = 0
'Get number of devices and load names into combo box
For i = 0 To midiOutGetNumDevs() - 1
midiOutGetDevCaps i, caps, Len(caps)
Combo1.AddItem caps.szPname, i
Next
Combo1.ListIndex = 0
For i = 0 To 6
Command1(0).Width = Me.ScaleWidth / 7
If i > 0 Then Load Command1(i)
With Command1(i)
.Left = Me.ScaleWidth / 7 * i
.Visible = True
.Top = Me.ScaleHeight / 2 - .Height / 2
.Caption = Choose(i + 1, "C", "Dm", "Em", "F", "G", "Am", "B")
End With
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Close Port
midiOutClose hMidi
End Sub
Reply With Quote