Tipp 0325 Melodien mit midiOut... erzeugen
Autor/Einsender:
Datum:
  Michael Werner
30.09.2007 (Update)
Entwicklungsumgebung:   VB 6
Mit Hilfe von 4 API-Funktionen der winmm.dll, midiOutOpen, midiOutShortMsg, midiOutReset und midiOutClose, können Einzeltöne des Notensystems abgespielt werden. Dabei sind die Parameter Tonhöhe, Stimmlage (Instrument), Lautstärke und Tondauer bestimmbar.
Dieser Tipp zeigt, wie man die Tastatur eines Klaviers nachbilden und auch ein Melodiespiel möglich machen kann. Zusätzlich wird der Parameter Stimmlage variiert, so dass eine Reihe von Instrumenten nachempfunden werden können.
Update zum 30.09.2007 von Henrik Ilgen
- Halbtöne können in höheren Oktaven und verlängert gespielt werden.
- Die Oktave kann beliebig oft erhöht werden.
- Töne können beliebig lange verlängert werden.
- Dreitöne können direkt gespielt werden.
Code im Codebereich des Moduls
 
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:
  MsgBox "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", vbExclamation, "Syntaxfehler"
End Sub

Public Sub PlayTritonus(Grundton As String, _
     TritonusType As Tritonus)

  Dim TonArray() As Variant
  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
 
Code im Codebereich der Form
 
Option Explicit

Private Sub chkTritonus_Click()
  cboTritonus.Enabled = (chkTritonus.Value = vbChecked)
End Sub

Private Sub Form_Load()
  With cboInstrument
    .AddItem "Konzertflügel"
    .AddItem "Klavier"
    .AddItem "Elektrischer Flügel"
    .AddItem "Honkytonk Piano"
    .AddItem "Rhodes E-Piano"
    .AddItem "Piano mit Chorus"
    .AddItem "Cembalo"
    .AddItem "Clavinet D6"
    .AddItem "Celesta"
    .AddItem "Glockenspiel"
    .AddItem "Music Box"
    .AddItem "Vibraphon"
    .AddItem "Marimba"
    .AddItem "Xylophon"
    .AddItem "Röhrenglocken"
    .AddItem "Dulcimer"
    .ListIndex = 0
  End With

  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 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 "Ungültige Eingabe!"
        Exit Sub
    End Select

    PlayTritonus Taste(Index).Tag, TritonusArt
  End If
End Sub

Private Sub Command2_Click()
  Screen.MousePointer = vbHourglass
  PlayMelody cboMelodie.Text, cboInstrument.ListIndex
  Screen.MousePointer = vbNormal
End Sub

Private Sub Command1_Click()
  Silence
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Silence
  CloseMIDI
End Sub
 

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (7,2 kB) Downloads bisher: [ 2746 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 25. September 2011