Visual
Basic VB 2012 Piano und Musiksoftware Synthesizer
programmieren
Author D.Selzer-McKenzie
Video: http://youtu.be/ZBrtkd7iDwo
Hier zeige ich Ihnen, wie Sie eine komplette
Musiksoftware einschliesslich eines
funktionstüchtigen Pianos programmieren
können.
Den Quell-Code (nur für das Piano und deren Tonausgabe) können Sie im
Oder bei http://www.Outbackbrumby.de
finden.
Imports
System.IO
Imports
System.Diagnostics
Imports
System.Drawing.Imaging
Imports
System.Runtime.InteropServices
Imports
System.Drawing.Drawing2D
Imports
System.Threading
Public Class frmMusikSoftware
'Code im Internet
am 15.1.2015 geladen bei www.vb-fun.de
'Option Explicit
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
Private Declare Function midiOutShortMsg
Lib "winmm.dll" ( _
ByVal hMidiOut As Long, ByVal dwMsg
As Long) As Long
Private Declare Function midiOutReset Lib
"winmm.dll" ( _
ByVal hMidiOut As Long) As Long
Private Declare Function midiOutClose Lib
"winmm.dll" ( _
ByVal hMidiOut As Long) As Long
Private Const MIDI_MAPPER = -1
Private hMidiOut As Long
Private Const NOTE_OFF = &H80
Private Const NOTE_ON = &H90
Private Const PROGRAM_CHANGE = &HC0
Private Const MOD_WHEEL = 1
Private Const BREATH_CONTROLLER = 2
Private Const FOOT_CONTROLLER = 4
Private Const PORTAMENTO_TIME = 5
Private Const MAIN_VOLUME = 7
Private Const BALANCE = 8
Private Const PAN = 10
Private Const EXPRESS_CONTROLLER = 11
Private Const DAMPER_PEDAL = 64
Private Const PORTAMENTO = 65
Private Const SOSTENUTO = 66
Private Const SOFT_PEDAL = 67
Private Const HOLD_2 = 69
Private Const EXTERNAL_FX_DEPTH = 91
Private Const TREMELO_DEPTH = 92
Private Const CHORUS_DEPTH = 93
Private Const DETUNE_DEPTH = 94
Private Const PHASER_DEPTH = 95
Private Const DATA_INCREMENT = 96
Private Const DATA_DECREMENT = 97
Private Const CALLBACK_NULL = &H0
Private Const CALLBACK_WINDOW = &H10000
Private Const CALLBACK_TASK = &H20000
Private Const CALLBACK_FUNCTION =
&H30000
Private Const CALLBACK_TYPEMASK =
&H70000
Private Const MM_MOM_CLOSE = &H3C8
Private Const MM_MOM_DONE = &H3C9
Private Const MM_MOM_OPEN = &H3C7
Private Const MM_MOM_POSITIONCB = &H3CA
Private Const MOM_CLOSE = MM_MOM_CLOSE
Private Const MOM_DONE = MM_MOM_DONE
Private Const MOM_OPEN = MM_MOM_OPEN
Private Const MOM_POSITIONCB =
MM_MOM_POSITIONCB
Private Const MIDIERR_BASE = 64
Private Const MIDIERR_NODEVICE =
(MIDIERR_BASE + 4)
Private Const MMSYSERR_ALLOCATED = 4
Private Const MMSYSERR_BADDEVICEID = 2
Private Const MMSYSERR_INVALPARAM = 11
Private Const MMSYSERR_NOMEM = 7
Public Enum Tritonus
Dur
Moll
Übermäßig
Vermindert
End Enum
Public Sub OpenMIDI()
Dim midiOpenError As Long
Dim strMsg As String
midiOpenError& =
midiOutOpen(hMidiOut, MIDI_MAPPER, 0, 0, CALLBACK_NULL)
If midiOpenError Then
strMsg =
"Der MIDI Mapper kann nicht geöffnet werden. "
strMsg =
strMsg & "Er wird entweder bereits verwendet oder "
strMsg =
strMsg & "ist nicht korrekt installiert." & vbCrLf
strMsg =
strMsg & "Fehler " & midiOpenError
MsgBox(strMsg, 48, "Fehler bei OpenMIDI")
CloseMIDI()
End
End If
End Sub
Public Sub CloseMIDI()
midiOutClose(hMidiOut)
hMidiOut = 0
End Sub
Public Sub SendMidiOut(ByVal midiData1 As
Long, ByVal midiData2 _
As Long, ByVal midiMessageOut As
Long, ByVal Kanal As Integer)
Dim midiMessage As Long
Dim Res As Integer
midiMessage = Kanal + midiMessageOut +
midiData1 * &H100 + _
midiData2 * &H10000
Res = midiOutShortMsg(hMidiOut, midiMessage)
End Sub
Public Sub PlayNote(Ton As Long, Optional
Stimme As Long = -1, _
Optional Laut As
Long = 100, Optional Dauer As Long = 100)
Dim ReClose As Integer
Dim Pause As Single
'Dim t As Single
If hMidiOut = 0 Then
OpenMIDI()
ReClose = True
End If
If Stimme >= 0 Then
SendMidiOut(Stimme, 0,
PROGRAM_CHANGE, 0)
End If
'DoEvents()
SendMidiOut(Ton, Laut, NOTE_ON, 0)
If ReClose Then
Pause = Dauer / 1000
't = Timer
'Do
'Loop Until Timer > t + Pause
CloseMIDI()
End If
End Sub
Public Sub Silence()
midiOutReset(hMidiOut)
End Sub
Public Sub PlayMelody(ByVal Melody As
String,
Optional Stimme As Long = -1,
Optional Octave As Long = 5,
Optional Laut As Long = 100, Optional
Dauer As Long = 200)
Dim ReClose As Boolean
Dim IsHalbton As Boolean
Dim TonFertig As Boolean
Dim Pause As Single
Dim TFak As Single
Dim t As Single
Dim n As Long
Dim Ton As Long
Dim memOctave As Long
memOctave = Octave
If hMidiOut = 0 Then
OpenMIDI()
ReClose = True
End If
If Stimme >= 0 Then
SendMidiOut(Stimme, 0,
PROGRAM_CHANGE, 0)
End If
Pause = Dauer / 1000
TFak = 1
Ton = -1
For n = 1 To Len(Melody)
If Not "CDEFGAH" Like
"*" & UCase(Mid(Melody, n, 1)) & "*" Then
'weiter machen...
'Pause?
If UCase(Mid(Melody, n, 1)) =
"P" Then
't = Timer
'Do
'Loop Until Timer > t +
Pause
'Oktave höher?
'ElseIf Mid(Melody, n, 1) =
"'" Then
Octave = Octave + 1
'Langer Ton?
ElseIf Mid(Melody, n, 1) =
"." Then
TFak = TFak * 2
End If
Else
Select Case UCase(Mid(Melody,
n, 1))
Case "C" : Ton =
0
Case "D" : Ton =
2
Case "E" : Ton = 4
Case "F" : Ton =
5
Case "G" : Ton =
7
Case "A" : Ton =
9
Case "B",
"H" : Ton = 11
End Select
End If
'Wenn
Halbton, dann um 1 erhöhen
If LCase(Mid(Melody, n, 2)) =
"is" Then
Ton = Ton + 1
n = n + 1
End If
'Fängt mit dem nächsten
Zeichen ein neuer Ton an?
If "CDEFGAH" Like
"*" & UCase(Mid(Melody, n + _
IIf(LCase(Mid(Melody, n, 2)) =
"is", 2, 1), 1)) & "*" Then
'MIDI-Ton abspielen
SendMidiOut(Ton + 12 * Octave,
Laut, NOTE_ON, 0)
'Ggf. Taste drücken...
On Error GoTo 0
On Error Resume Next
If Octave - memOctave <= 3
And Octave - memOctave >= 0 Then
'frmMain.Taste(Ton + 12 *
(Octave - memOctave)).SetFocus()
End If
On Error GoTo 0
On Error GoTo ErrHandle
'Und
warten...
't = Timer
'Do
'Loop Until Timer > t +
Pause * TFak
'Werte zurücksetzen...
Ton =
-1
TFak =
1
Octave
= memOctave
End If
'DoEvents()
Next n
If ReClose Then CloseMIDI()
Exit Sub
ErrHandle: 'sehr
lange MsgBox
'MsgBox.Show =
"Bei der Eingabe des Tones liegt ein Syntaxfehler vor!" _
'&
vbNewLine & "Die Tonhöhe liegt möglicherweise nicht im hier
berücksichtigen Bereich C bis C''" _
'&
vbNewLine & "Außerdem sind die Kombinationen von . und ', sowie von
Cis und() ' bzw. Cis und ." _
'&
vbNewLine & "in diesem Tipp nicht implementiert." _
'&
vbNewLine & vbNewLine & " Syntax Melodiespiel:" _
'&
vbNewLine & " C D E F G A H
(B) = Noten" & vbNewLine _
'&
" C' = um 1 Oktav erhöhter Ton"
& vbNewLine _
'&
" C. = verlängerter Ton" &
vbNewLine _
'& " Cis
= Halbton"
End Sub
Public Sub PlayTritonus(Grundton As String,
_
TritonusType As Tritonus)
'Dim TonArray() As Object
'Dim TonFolge As String
' Dim n As Long, Step1 As Long, Step2
As Long
Dim Success As Boolean
'Alle Töne in ein Array packen...
'TonArray = Array("C",
"Cis", "D", "Dis", "E", "F",
"Fis", "G", "Gis", "A",
"Ais", "H")
Select Case TritonusType
Case Tritonus.Dur : Step1 = 4 :
Step2 = 3
Case Tritonus.Moll : Step1 = 3 :
Step2 = 4
Case Tritonus.Übermäßig : Step1 = 4
: Step2 = 4
Case Tritonus.Vermindert : Step1 =
3 : Step2 = 3
End Select
'Grundton im Array finden...
' For n = LBound(TonArray) To
UBound(TonArray)
'If TonArray(n) = Grundton Then
'Success = True
'Exit For
'End If
'Next n
If Not Success Then
MsgBox("Es wurde ein ungültiger Grundton übergeben!", _
vbExclamation, "Ungültige Eingabe")
Exit Sub
End If
'TonFolge =
TonArray(n)
'zweiten Ton
finden
'If n + Step1 > UBound(TonArray)
Then
'TonFolge = TonFolge & TonArray(n +
Step1 - UBound(TonArray)) & "'"
'Else
'TonFolge = TonFolge & TonArray(n +
Step1)
'End If
'dritten Ton finden
'If n + Step1 + Step2 >
UBound(TonArray) Then
'TonFolge = TonFolge & TonArray(n +
Step1 + Step2 - UBound(TonArray)) & "'"
'Else
'TonFolge = TonFolge & TonArray(n +
Step1 + Step2)
'End If
'und abspielen
'PlayMelody TonFolge
'frmMain.cboMelodie.AddItem TonFolge
End Sub
Private Sub chkTritonus_Click()
'cboTritonus.Enabled =
(chkTritonus.Value = vbChecked)
End Sub
'Private Sub Taste_Click(Index As Integer)
Dim TritonusArt As Tritonus
'If Not chkTritonus.Value = vbChecked Then
'PlayNote(CLng(Index) + 60,
cboInstrument.ListIndex)
'Else
'Select Case StrConv(cboTritonus.Text,
vbProperCase)
'Case "Dur" : TritonusArt = Dur
'Case "Moll" : TritonusArt = Moll
'Case "Übermäßig" :
TritonusArt = Übermäßig
'Case
"Vermindert" : TritonusArt = Vermindert
'Case Else
'MsgBox.Show =
"Ungültige Eingabe!"
'Exit Sub
'End Select
'PlayTritonus(Taste(Index).Tag,
TritonusArt)
'End If
'End Sub
'Private Sub Command2_Click()
'MousePointer = vbHourglass
'PlayMelody(cboMelodie.Text,
cboInstrument.ListIndex)
'MousePointer = vbNormal
'End Sub
'Private Sub Command1_Click()
'Silence()
'End Sub
'Private Sub Form_Unload(Cancel As Integer)
'Silence()
'CloseMIDI()
'End Sub
'With cboMelodie
'.AddItem
"C.D.E.F.G.A.H.C'C'HAGFEDCCCisDDisEFFisGGisAAisH" &
"C'D'E'F'G'A'H'C''C''H'A'G'F'E'D'C'HAGFEDC"
'.AddItem "CDEFG.G.AAAAG..AAAAG..FFFFE.E.GGGGC."
'.ListIndex = 0
'End With
'OpenMIDI()
'End Sub
Private Sub Taste1_Click(sender As Object,
e As EventArgs) Handles Taste1.Click
'Button1_Click(Button1, New
System.EventArgs())
Taste1.BackColor = Color.Blue
'Button1_Click(Button1, New
System.EventArgs())
'Thread.Sleep(3000)
'Taste1.BackColor = Color.Red
End Sub
Private Sub frmMusikSoftware_Load(sender As
Object, e As EventArgs) Handles MyBase.Load
SEL = "SelMcKenzie®" &
Space$(3) & "SelWave®" & Space$(3) &
"WaveTrader®" & Space$(3) & "Selzer-McKenzie®"
Me.Text = SEL
With ComboBoxAuswahlMusikGenre.Items
.Add("Konzertflügel")
.Add("Klavier")
.Add("Elektrischer Flügel")
.Add("Honkytonk Piano")
.Add("Rhodes E-Piano")
.Add("Piano mit Chorus")
.Add("Cembalo")
.Add("Clavinet D6")
.Add("Celesta")
.Add("Glockenspiel")
.Add("Music Box")
.Add("Vibraphon")
.Add("Marimba")
.Add("Xylophon")
.Add("Röhrenglocken")
.Add("Dulcimer")
End With
End Sub
Keine Kommentare:
Kommentar veröffentlichen
Hinweis: Nur ein Mitglied dieses Blogs kann Kommentare posten.