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

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