'//////////////////////////////
'// Date: 13/06/2016 //
'// Programmed by LEKIM //
'//////////////////////////////
Option Strict On
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.Security
Public Class Form1
Dim lblMuscKey(61) As Label
Dim lblInstruments(127) As Label
Dim lblOctave(5) As Label
Dim FlLayPanel As FlowLayoutPanel
Dim lblTitle As New Label
Dim ttip As New ToolTip
Dim numKeysBlack() As Integer = _
{2, 4, 7, 9, 11, 14, 16, 19, 21, 23, 26, 28, 31, _
33, 35, 38, 40, 43, 45, 47, 50, 52, 55, 57, 59}
Dim numKeysWhite() As Integer = _
{1, 3, 5, 6, 8, 10, 12, 13, 15, 17, 18, 20, 22, _
24, 25, 27, 29, 30, 32, 34, 36, 37, 39, 41, 42, _
44, 46, 48, 49, 51, 53, 54, 56, 58, 60, 61}
Dim hMidiOut As IntPtr
Dim intMsg As Integer
Dim Msg As NativeMethods.MidiMsg
Dim Octave As Byte = 1 'Octave from where begins the first key of the musical keyboard
Dim ListKeyPress As New List(Of Integer)
Dim VolumeKey As Byte = 127 'min=0; max=127
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
CreateMusicalKeyBoard()
CreatePanelInstruments()
CreateOctaveButtons()
With lblTitle
.Text = "Standard MIDI Patch Assignments"
.BackColor = Color.Transparent
.ForeColor = Color.WhiteSmoke
.Font = New Font("Arial", 20, FontStyle.Bold)
.TextAlign = ContentAlignment.MiddleLeft
.Size = CType(New Point(470, 40), Drawing.Size)
.Location = New Point(5, 5)
End With
With Me
.Controls.Add(lblTitle)
.KeyPreview = True
.BackColor = System.Drawing.Color.FromArgb(40, 40, 40)
.Size = CType(New Point(835, 440), Drawing.Size)
.Text = "Demo Musical Keyboard"
.MaximizeBox = False
.FormBorderStyle = System.Windows.Forms.FormBorderStyle.FixedSingle
.StartPosition = FormStartPosition.CenterScreen
.SetBounds(CInt((Screen.PrimaryScreen.Bounds.Width - .Width) / 2),
CInt((Screen.PrimaryScreen.Bounds.Height - .Height) / 2) - 50,
.Width, .Height)
End With
'Show a tooltip message
ttip.AutoPopDelay = 2000
ttip.InitialDelay = 1000
ttip.ReshowDelay = 500
For I As Integer = 1 To 5
ttip.SetToolTip(Me.lblOctave(I), "Octave")
Next
NativeMethods.midiOutOpen(hMidiOut, _
NativeMethods.MIDI_MAPPER, CType(0, IntPtr), _
CType(0, IntPtr), NativeMethods.CALLBACK_NULL)
End Sub
Private Sub Form1_KeyDown(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles Me.KeyDown
If ListKeyPress.Contains(e.KeyCode) = True Then Exit Sub ' Key is already pressed
If Key(e.KeyCode) = 0 Then Exit Sub
PlayMusicalNote(CByte(Key(e.KeyCode)), VolumeKey, Octave)
ListKeyPress.Add(e.KeyCode)
End Sub
Private Sub Form1_KeyUp(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles Me.KeyUp
OffMusicalNote(CByte(Key(e.KeyCode)), Octave)
ListKeyPress.Remove(e.KeyCode)
Try
If numKeysWhite.Contains(Msg.Note) Then
lblMuscKey(Msg.Note).BackColor = Color.White
Else
lblMuscKey(Msg.Note).BackColor = Color.Black
End If
Catch ex As Exception
End Try
End Sub
#Region "Octave Buttons"
Sub CreateOctaveButtons()
Dim pOct As New Point(30, 265)
Dim inc As Integer = 0
For I = 1 To 5
lblOctave(I) = New Label
With lblOctave(I)
.Text = CStr(I)
.Font = New Font("Arial", 10, FontStyle.Bold)
.Size = CType(New Point(20, 20), Drawing.Size)
.BorderStyle = BorderStyle.FixedSingle
.Location = New Point(pOct.X + inc, pOct.Y)
.ForeColor = System.Drawing.Color.FromArgb(120, 120, 120)
.BackColor = System.Drawing.Color.FromArgb(20, 20, 20)
.TextAlign = ContentAlignment.MiddleCenter
AddHandler .MouseDown, AddressOf lblOctave_MouseDown
AddHandler .MouseEnter, AddressOf lblOctave_MouseEnter
AddHandler .MouseLeave, AddressOf lblOctave_MouseLeave
End With
inc = inc + 19
Me.Controls.Add(lblOctave(I))
Next
lblOctave(1).BackColor = System.Drawing.Color.FromArgb(150, 150, 150)
lblOctave(1).ForeColor = System.Drawing.Color.FromArgb(10, 10, 10)
End Sub
Private Sub lblOctave_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs)
Dim Index As Integer = Array.IndexOf(lblOctave, sender)
For I As Integer = 1 To 5
lblOctave(I).BackColor = System.Drawing.Color.FromArgb(20, 20, 20)
lblOctave(I).ForeColor = System.Drawing.Color.FromArgb(120, 120, 120)
Next
lblOctave(Index).BackColor = System.Drawing.Color.FromArgb(150, 150, 150)
lblOctave(Index).ForeColor = System.Drawing.Color.FromArgb(10, 10, 10)
Octave = CByte(Index)
End Sub
Private Sub lblOctave_MouseEnter(ByVal sender As Object, ByVal e As System.EventArgs)
Dim Index As Integer = Array.IndexOf(lblOctave, sender)
Cursor = Cursors.Hand
End Sub
Private Sub lblOctave_MouseLeave(ByVal sender As Object, ByVal e As System.EventArgs)
Dim Index As Integer = Array.IndexOf(lblOctave, sender)
Cursor = Cursors.Default
End Sub
#End Region
#Region "Panel of Instruments"
''' <summary>
''' Create a panel of instruments
''' </summary>
''' <remarks></remarks>
Public Sub CreatePanelInstruments()
FlLayPanel = New FlowLayoutPanel
With FlLayPanel
.AutoScroll = True
.VerticalScroll.Visible = False
.BorderStyle = BorderStyle.FixedSingle
.Size = CType(New Point(808, 205), Drawing.Size)
.Location = New Point(5, 50)
.FlowDirection = FlowDirection.TopDown
.BackColor = System.Drawing.Color.FromArgb(10, 10, 10)
End With
Me.Controls.Add(FlLayPanel)
For I As Integer = 0 To lblInstruments.Count - 1
lblInstruments(I) = New Label
With lblInstruments(I)
.Width = 155
.Font = New Font("Arial", 8, FontStyle.Bold)
.ForeColor = System.Drawing.Color.FromArgb(120, 120, 120)
.BorderStyle = BorderStyle.FixedSingle
.TextAlign = ContentAlignment.MiddleLeft
End With
FlLayPanel.Controls.Add(lblInstruments(I))
Next (I)
'Standard MIDI Patch Assignments
Dim strInstruments() As String = _
{"000 Acoustic grand piano", "001 Bright acoustic piano", "002 Electric grand piano", "003 Honky-tonk piano",
"004 Rhodes(piano)", "005 Chorused(piano)", "006 Harpsichord", "007 Clavinet", "008 Celesta",
"009 Glockenspiel", "010 Music(box)", "011 Vibraphone", "012 Marimba", "013 Xylophone", "014 Tubular(bells)",
"015 Dulcimer", "016 Hammond(organ)", "017 Percussive(organ)", "018 Rock(organ)", "019 Church(organ)",
"020 Reed(organ)", "021 Accordion", "022 Harmonica", "023 Tango(accordion)", "024 Acoustic guitar (nylon)",
"025 Acoustic(guitar(steel))", "026 Electric(guitar(jazz))", "027 Electric(guitar(clean))",
"028 Electric(guitar(muted))", "029 Overdriven(guitar)", "030 Distortion(guitar)", "031 Guitar(harmonics)",
"032 Acoustic bass", "033 Electric bass (finger)", "034 Electric bass (pick)", "035 Fretless bass",
"036 Slap bass 1", "037 Slap bass 2", "038 Synth bass 1", "039 Synth bass 2", "040 Violin",
"041 Viola", "042 Cello", "043 Contrabass", "044 Tremolo strings", "045 Pizzicato strings", "046 Orchestral harp",
"047 Timpani", "048 String ensemble 1", "049 String ensemble 2", "050 Synth.strings(1)", "051 Synth.strings(2)",
"052 Choir(Aahs)", "053 Voice(Oohs)", "054 Synth(voice)", "055 Orchestra(hit)", "056 Trumpet", "057 Trombone",
"058 Tuba", "059 Muted(trumpet)", "060 French(horn)", "061 Brass(section)", "062 Synth.brass(1)",
"063 Synth.brass(2)", "064 Soprano sax", "065 Alto sax", "066 Tenor sax", "067 Baritone sax", "068 Oboe",
"069 English horn", "070 Bassoon", "071 Clarinet", "072 Piccolo", "073 Flute", "074 Recorder",
"075 Pan flute", "076 Bottle blow", "077 Shakuhachi", "078 Whistle", "079 Ocarina", "080 Lead 1 (square)",
"081 Lead 2 (sawtooth)", "082 Lead 3 (calliope lead)", "083 Lead 4 (chiff lead)", "084 Lead 5 (charang)",
"085 Lead 6 (voice)", "086 Lead 7 (fifths)", "087 Lead 8 (brass + lead)", "088 Pad 1 (new age)",
"089 Pad 2 (warm)", "090 Pad 3 (polysynth)", "091 Pad 4 (choir)", "092 Pad 5 (bowed)", "093 Pad 6 (metallic)",
"094 Pad 7 (halo)", "095 Pad 8 (sweep)", "096 FX 1 (rain)", "097 FX 2 (soundtrack)", "098 FX 3 (crystal)",
"099 FX 4 (atmosphere)", "100 FX 5 (brightness)", "101 FX 6 (goblins)", "102 FX 7 (echoes)", "103 FX 8 (sci-fi)",
"104 Sitar", "105 Banjo", "106 Shamisen", "107 Koto", "108 Kalimba", "119 Bagpipe", "110 Fiddle", "111 Shanai2",
"112 Tinkle Bell", "113 Agogo", "114 Steel Drums", "115 Woodblock", "116 Taiko Drum", "117 Melodic Tom",
"118 Synth Drum2", "119 Reverse Cymbal", "120 Guitar fret noise", "121 Breath noise", "122 Seashore",
"123 Bird tweet", "124 Telephone ring", "125 Helicopter", "126 Applause", "127 Gunshot"}
For I = 0 To 127
lblInstruments(I).Text = strInstruments(I)
Next
For I As Integer = 0 To lblInstruments.Count - 1
AddHandler lblInstruments(I).MouseDown, AddressOf lblInstruments_MouseDown
Next
End Sub
Private Sub lblInstruments_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs)
Dim Index As Integer = Array.IndexOf(lblInstruments, sender)
For I = 0 To lblInstruments.Count - 1
lblInstruments(I).BackColor = Color.Transparent
lblInstruments(I).ForeColor = System.Drawing.Color.FromArgb(120, 120, 120)
Next
lblInstruments(Index).BackColor = System.Drawing.Color.FromArgb(150, 150, 150)
lblInstruments(Index).ForeColor = System.Drawing.Color.FromArgb(0, 0, 0)
ChangeInstrument(Index)
End Sub
#End Region
#Region "Musical Keyboard"
''' <summary>
''' Create the keys of the musical keyboard
''' </summary>
''' <remarks></remarks>
Sub CreateMusicalKeyBoard()
Dim wKeyWhite As New Point(22, 80)
Dim wKeyBlack As New Point(12, 50)
Dim PosKeyWhite As New Point(30, 300)
Dim PosKeyBlack As New Point(25, 300)
For Index As Integer = 1 To lblMuscKey.Count - 1
lblMuscKey(Index) = New Label
With lblMuscKey(Index)
.BorderStyle = BorderStyle.FixedSingle
Dim incWhiteKeyPosX As Integer
'White keys
If numKeysWhite.Contains(Index) Then
.Size = New Size(wKeyWhite)
.BackColor = Color.White
.Location = _
New Point(PosKeyWhite.X + incWhiteKeyPosX, PosKeyWhite.Y)
incWhiteKeyPosX = incWhiteKeyPosX + 21
.SendToBack() 'send to back
End If
'Black keys
If numKeysBlack.Contains(Index) Then
.BackColor = Color.Black
.Size = New Size(wKeyBlack)
.Location = _
New Point(PosKeyBlack.X + incWhiteKeyPosX, PosKeyBlack.Y)
End If
Me.Controls.Add(lblMuscKey(Index))
If numKeysBlack.Contains(Index) Then
lblMuscKey(Index).BringToFront()
End If
AddHandler .MouseDown, AddressOf lblMuscKey_MouseDown
AddHandler .MouseUp, AddressOf lblMuscKey_MouseUp
AddHandler .MouseMove, AddressOf lblMuscKey_MouseMove
AddHandler .MouseLeave, AddressOf lblMuscKey_MouseLeave
End With
Next
End Sub
Private Sub lblMuscKey_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs)
Dim Index As Integer = Array.IndexOf(lblMuscKey, sender)
lblMuscKey(Index).BackColor = Color.Gray 'Change color of the key
PlayMusicalNote(CByte(Index), VolumeKey, Octave)
End Sub
Private Sub lblMuscKey_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs)
Dim Index As Integer = Array.IndexOf(lblMuscKey, sender)
If numKeysWhite.Contains(Index) Then
lblMuscKey(Index).BackColor = Color.White 'Change color of the key
Else
lblMuscKey(Index).BackColor = Color.Black 'Change color of the key
End If
OffMusicalNote(Index, Octave)
End Sub
Private Sub lblMuscKey_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs)
Dim Index As Integer = Array.IndexOf(lblMuscKey, sender)
Dim mPoint As New Point(Me.PointToClient(Cursor.Position).X, Me.PointToClient(Cursor.Position).Y)
Dim X As Integer = mPoint.X
Cursor = Cursors.Hand
If X < CInt(lblMuscKey(Index).Left) Or
X > (CInt(lblMuscKey(Index).Left) + _
CInt(lblMuscKey(Index).Width)) Then
EventoUp()
EventoDown()
End If
End Sub
Private Sub lblMuscKey_MouseLeave(ByVal sender As Object, ByVal e As System.EventArgs)
Cursor = Cursors.Default
End Sub
#End Region
#Region "Play Sounds Functions"
''' <summary>
''' Play a musical note
''' </summary>
''' <param name="Note">Value of musical note</param>
''' <param name="Volume">Volume musical note</param>
''' <param name="bOct">Octave</param>
''' <returns></returns>
Public Function PlayMusicalNote(ByVal Note As Integer, ByVal Volume As Byte, ByVal bOct As Byte) As Boolean
Note += 23 + (12 * bOct)
intMsg = CInt(Volume * Convert.ToInt32(CStr(10000), 16) _
+ Note * Convert.ToInt32(CStr(100), 16) + NativeMethods.KeyOn)
Return CBool(NativeMethods.midiOutShortMsg(hMidiOut, intMsg))
End Function
''' <summary>
''' Off a musical note
''' </summary>
''' <param name="Note">Value of musical note</param>
''' <param name="bOct">Octave</param>
''' <returns></returns>
''' <remarks></remarks>
Public Function OffMusicalNote(ByVal Note As Integer, ByVal bOct As Integer) As Boolean
Note += 23 + (12 * bOct)
intMsg = Note * Convert.ToInt32(CStr(100), 16) + NativeMethods.KeyOff
Return CBool(NativeMethods.midiOutShortMsg(hMidiOut, intMsg))
End Function
''' <summary>
''' Change the instrument
''' </summary>
''' <param name="instCode"></param>
''' <returns></returns>
''' <remarks></remarks>
Public Function ChangeInstrument(ByVal instCode As Integer) As Boolean
intMsg = instCode * Convert.ToInt32(CStr(100), 16) + NativeMethods.Instruments
Return CBool(NativeMethods.midiOutShortMsg(hMidiOut, intMsg))
Return Nothing
End Function
#End Region
#Region "Computer keyboard keys"
''' <summary>
''' Assigning Computer keyboard keys
''' </summary>
''' <param name="keycode"></param>
''' <returns></returns>
''' <remarks></remarks>
Public Function Key(ByVal keycode As Integer) As Integer
Dim BlackHalfKey() As Keys = {Keys.W, Keys.E, Keys.T, Keys.Y, Keys.U}
Dim WhiteHalfKey() As Keys = {Keys.A, Keys.S, Keys.D, Keys.F, Keys.G, Keys.H, Keys.J, Keys.K}
Dim BassKey() As Keys = {Keys.Z, Keys.X, Keys.C, Keys.V, Keys.B, Keys.N, Keys.M, Keys.Oemcomma}
Dim AltoKey() As Keys = {Keys.D1, Keys.D2, Keys.D3, Keys.D4, Keys.D5, Keys.D6, Keys.D7, Keys.D8}
If BlackHalfKey.Contains(CType(keycode, Keys)) Or _
WhiteHalfKey.Contains(CType(keycode, Keys)) Or _
BassKey.Contains(CType(keycode, Keys)) Or _
AltoKey.Contains(CType(keycode, Keys)) Then
For I As Integer = 10 To 14
If keycode = BlackHalfKey(I - 10) Then Msg.Note = CByte(numKeysBlack(I))
Next
For I As Integer = 14 To 21
If keycode = WhiteHalfKey(I - 14) Then Msg.Note = CByte(numKeysWhite(I))
Next
For I As Integer = 0 To 7
If keycode = BassKey(I) Then Msg.Note = CByte(numKeysWhite(I))
Next
For I As Integer = 28 To 35
If keycode = AltoKey(I - 28) Then Msg.Note = CByte(numKeysWhite(I))
Next
lblMuscKey(Msg.Note).BackColor = Color.Gray
Return Msg.Note
Else
Return 0
End If
End Function
#End Region
End Class
Module MouseEvents
''' <summary>
''' Simulate MouseDown the left mouse button
''' </summary>
''' <remarks></remarks>
Public Sub EventoDown()
NativeMethods.mouse_event(NativeMethods.MouseEventFlags.MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
End Sub
''' <summary>
''' Simulate MouseUp the left mouse button
''' </summary>
''' <remarks></remarks>
Public Sub EventoUp()
NativeMethods.mouse_event(NativeMethods.MouseEventFlags.MOUSEEVENTF_MIDDLEUP, 0, 0, 0, 0)
End Sub
End Module
<SuppressUnmanagedCodeSecurity()>
Friend NotInheritable Class NativeMethods
Inherits Attribute
Private Sub New()
End Sub
#Region "API MIDI message"
<DllImport("winmm.dll")>
Public Shared Function midiOutOpen(ByRef lphMidiOut As IntPtr,
ByVal uDeviceID As Integer,
ByVal dwCallback As IntPtr,
ByVal dwInstance As IntPtr,
ByVal dwFlags As UInteger) As UInteger
End Function
<DllImport("winmm.dll")>
Public Shared Function midiOutShortMsg(ByVal hMidiOut As IntPtr,
ByVal dwMsg As Integer) As UInteger
End Function
<DllImport("winmm.dll")>
Public Shared Function midiOutClose(ByVal hMidiOut As IntPtr) As Integer
End Function
<StructLayout(LayoutKind.Auto)> _
Public Structure MidiMsg
Dim status As Byte
Dim Note As Byte
Dim Volume As Byte
Dim Data3 As Byte
End Structure
Public Const MIDI_MAPPER As Int32 = -1
Public Const CALLBACK_NULL = &H0
Public Const KeyOn As Integer = &H90
Public Const KeyOff As Integer = &H80
Public Const Instruments As Integer = &HC0
#End Region
#Region "API Mouse Events"
<DllImport("user32.dll", CharSet:=CharSet.Auto)> _
Friend Shared Sub mouse_event(ByVal dwFlags As UInteger, _
ByVal dx As UInteger, _
ByVal dy As UInteger, _
ByVal dwData As UInteger, _
ByVal dwExtraInfo As Integer)
End Sub
<Flags()> _
Public Enum MouseEventFlags As UInteger
MOUSEEVENTF_ABSOLUTE = &H8000
MOUSEEVENTF_LEFTDOWN = &H2
MOUSEEVENTF_LEFTUP = &H4
MOUSEEVENTF_MIDDLEDOWN = &H20
MOUSEEVENTF_MIDDLEUP = &H40
MOUSEEVENTF_MOVE = &H1
MOUSEEVENTF_RIGHTDOWN = &H8
MOUSEEVENTF_RIGHTUP = &H10
MOUSEEVENTF_XDOWN = &H80
MOUSEEVENTF_XUP = &H100
MOUSEEVENTF_WHEEL = &H800
MOUSEEVENTF_HWHEEL = &H1000
End Enum
#End Region
End Class