Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0521: Midi-Töne erzeugen

VB 5/6-Tipp 0521: Midi-Töne erzeugen

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: midiOutOpen (MIDIOutOpen), midiOutClose, midiOutGetDevCapsA (midiOutGetDevCaps), midiOutGetErrorTextA (midiOutGetErrorText), midiOutGetNumDevs, midiOutGetVolume, midiOutSetVolume, midiOutShortMsg

Download: Download des Beispielprojektes [9,35 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'----------- Anfang Projektdatei Simple_midi.vbp  -----------
'--------- Anfang Formular "mainF" alias FORM1.FRM  ---------
' Steuerelement: Schaltfläche "Command8"
' Steuerelement: Textfeld "TxtNote"
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Listen-Steuerelement "lst_sound_list"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
'
' Autor: K. Langbein Klaus@ActiveVB.de

' Chronologie:
' Dieser Sourcecode basiert auf der Vorarbeit von M. Levoi
' mlevoi@modemss.brisnet.org.au. Die ursprünglichen Midi-Routinen wurden
' in MIDI_CMD zusammengefasst.

' Überarbeitet und kommentiert von Thomas Rodemer, Thomas@ActveVB.de

' Kleiner Hinweis: Falls das Programm über die IDE beendet wurde, während
' der Ausgabekanal noch offen war, kann beim Neustart der Midikanal nicht
' initialisiert werden. Daher wird bei jeder Initialisierung des Midi-Kanals
' (in midi_out_open) das entsprechende Handle in ein File geschrieben. Per
' Reset-Button können nach einem Neustart alle zuvor geöffneten Handles
' geschlossen werden.

Option Explicit

Private Sub fill_sound_list()

'Einlesen der Beispiel-Soundliste

    Dim s As String

    Open App.Path & "\genmidi.txt" For Input As #1
    Do While Not EOF(1)
        Line Input #1, s
        lst_sound_list.AddItem s
    Loop
    Close #1
    
End Sub

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    
    'Die Note C4 abspielen
    Call note_on(0, 60, vol)

End Sub

Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    
    'Alle Ton-Ausgaben abbrechen
    all_sounds_off
    
End Sub


Private Sub Command4_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    
    'Die Note des Textfeldes abspielen
    Dim A$
    A$ = TxtNote.Text
    Call play_note(A$, vol)
    
End Sub


Private Sub Command4_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    
    'Alle Ton-Ausgaben abbrechen
    all_sounds_off
    
End Sub


Private Sub Command8_Click()

    ' Der Reset-Knopf
    Call midi_out_close
    Call free_old_midi_handles(chop_slash(App.Path) + "\handles.log")
    sett = 1
    List1.ListIndex = 0
    sett = 0
    List1.ListIndex = 1
    
End Sub

Private Sub Form_Load()
                 
    Call midi_listoutdevs(List1)
    Call fill_sound_list

    List1.ListIndex = 1
    vol = 127
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' Den Ausgabekanal freigeben
    midi_out_close
    
End Sub



Private Sub List1_Click()

    ' Wird ein Item in List1 geklickt, den gewünschten Sound abspielen
    Dim x  As Integer
    If sett = 0 Then
        midi_out_close
        If List1.ListIndex > 0 Then
            x = midi_out_open(List1.ItemData(List1.ListIndex))
        End If
    End If
    
End Sub

Private Sub lst_sound_list_KeyDown(KeyCode As Integer, Shift As Integer)

    ' Wenn Enter-Taste gedrückt worden, den gewünschten Sound abspielen
    If KeyCode = 13 Then
        Call program_change(0, 0, lst_sound_list.ListIndex)
        Call note_on(0, 60, vol)
    End If
    
End Sub

Private Sub lst_sound_list_MouseDown(Button As Integer, _
    Shift As Integer, x As Single, Y As Single)
    
    ' Wird ein Item in List1 geklickt, den gewünschten Sound abspielen
    Call program_change(0, 0, lst_sound_list.ListIndex)
    Call note_on(0, 60, vol)
    
End Sub

Private Sub lst_sound_list_MouseUp(Button As Integer, _
    Shift As Integer, x As Single, Y As Single)
    
    'Alle Ton-Ausgaben abbrechen
    all_sounds_off
    
End Sub

'---------- Ende Formular "mainF" alias FORM1.FRM  ----------
'-------- Anfang Modul "MIDI_CMD" alias midi_cmd.bas --------
'
' Autor: K. Langbein Klaus@ActiveVB.de
'
' Chronologie:
' Dieser Sourcecode basiert auf der Vorarbeit von M. Levoi,
' mlevoi@modemss.brisnet.org.au. Die ursprünglichen Midi-Routinen wurden
' in MIDI_CMD.Bas zusammengefasst.
'
' MIDI_CMD.Bas History
' This Sample is based on the work of M. Levoi,
' http://www.modemss.brisnet.org.au/~mlevoi/index.html
' combined MIDI_CMD and MIDI_out to one file
' minor modifications (ie indentations changed)
' KL_midi relies on this module.
'

Dim m_hmidiout As Long

' **************************************************************************
'
'         Multimedia API Declares adapted from MMSYSTEM.H
'
'         Copyright (c) 1990-1993, Microsoft Corp.  All rights reserved.
'
' **************************************************************************

Global Const MIDIERR_BASE = 64

' ***************************************************************************

'                     General constants and data types

' ****************************************************************************/

'  general constants
Global Const MAXPNAMELEN = 32           '  max product name length (including NULL)
Global Const MAXERRORLENGTH = 128       '  max error text length (including NULL)


Global Const MM_MIM_OPEN = &H3C1                    '  MIDI input
Global Const MM_MIM_CLOSE = &H3C2
Global Const MM_MIM_DATA = &H3C3
Global Const MM_MIM_LONGDATA = &H3C4
Global Const MM_MIM_ERROR = &H3C5
Global Const MM_MIM_LONGERROR = &H3C6

Global Const MM_MOM_OPEN = &H3C7                    '  MIDI output
Global Const MM_MOM_CLOSE = &H3C8
Global Const MM_MOM_DONE = &H3C9

' ***************************************************************************

'                             MIDI audio support

' ****************************************************************************/

'  MIDI error return values
Global Const MIDIERR_UNPREPARED = (MIDIERR_BASE + 0)       '  header not prepared
Global Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1)     '  still something playing
Global Const MIDIERR_NOMAP = (MIDIERR_BASE + 2)            '  no current map
Global Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3)         '  hardware is still busy
Global Const MIDIERR_NODEVICE = (MIDIERR_BASE + 4)         '  port no longer connected
Global Const MIDIERR_INVALIDSETUP = (MIDIERR_BASE + 5)     '  invalid setup
Global Const MIDIERR_LASTERROR = (MIDIERR_BASE + 5)        '  last error in range

Global Const MIDIPATCHSIZE = 128

'  MIDI callback messages
Global Const MIM_OPEN = MM_MIM_OPEN
Global Const MIM_CLOSE = MM_MIM_CLOSE
Global Const MIM_DATA = MM_MIM_DATA
Global Const MIM_LONGDATA = MM_MIM_LONGDATA
Global Const MIM_ERROR = MM_MIM_ERROR
Global Const MIM_LONGERROR = MM_MIM_LONGERROR
Global Const MOM_OPEN = MM_MOM_OPEN
Global Const MOM_CLOSE = MM_MOM_CLOSE
Global Const MOM_DONE = MM_MOM_DONE

'  device ID for MIDI mapper
Global Const MIDIMAPPER = (-1)
Global Const MIDI_MAPPER = (-1)

'  flags for wFlags parm of midiOutCachePatches(), midiOutCacheDrumPatches()
Global Const MIDI_CACHE_ALL = 1
Global Const MIDI_CACHE_BESTFIT = 2
Global Const MIDI_CACHE_QUERY = 3
Global Const MIDI_UNCACHE = 4
'  flags for wTechnology field of MIDIOUTCAPS structure
Global Const MOD_MIDIPORT = 1      '  output port
Global Const MOD_SYNTH = 2         '  generic internal synth
Global Const MOD_SQSYNTH = 3       '  square wave internal synth
Global Const MOD_FMSYNTH = 4       '  FM internal synth
Global Const MOD_MAPPER = 5        '  MIDI mapper

'  flags for dwSupport field of MIDIOUTCAPS structure
Global Const MIDICAPS_VOLUME = &H1               '  supports volume control
Global Const MIDICAPS_LRVOLUME = &H2             '  separate left-right volume control
Global Const MIDICAPS_CACHE = &H4


'  flags for dwFlags field of MIDIHDR structure
Global Const MHDR_DONE = &H1                     '  done bit
Global Const MHDR_PREPARED = &H2                 '  set if header prepared
Global Const MHDR_INQUEUE = &H4                  '  reserved for driver

' MIDI output device capabilities structure
Type MIDIOUTCAPS
    wMid As Integer                ' Manufacturer ID
    wPid As Integer                ' Product ID
    vDriverVersion As Long         ' Driver version
    szPname As String * 32         ' Product name (NULL terminated string)
    wTechnology As Integer         ' Device type
    wVoices As Integer             ' n. of voices (internal synth only)
    wNotes As Integer              ' max n. of notes (internal synth only)
    wChannelMask As Integer        ' n. of Midi channels (internal synth only)
    dwSupport As Long              ' Supported extra controllers (volume, etc)
End Type

'
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer

Private Declare Function midiOutGetDevCaps Lib "winmm.dll" _
                         Alias "midiOutGetDevCapsA" ( _
                         ByVal uDeviceID As Long, _
                         lpCaps As MIDIOUTCAPS, _
                         ByVal uSize As Long) As Long
                         
Private Declare Function midiOutGetVolume Lib "winmm.dll" ( _
                         ByVal uDeviceID As Long, _
                         lpdwVolume As Long) As Long
                         
Private Declare Function midiOutSetVolume Lib "winmm.dll" ( _
                         ByVal uDeviceID As Long, _
                         ByVal dwVolume As Long) As Long
                         
Private Declare Function midiOutGetErrorText Lib "winmm.dll" _
                         Alias "midiOutGetErrorTextA" ( _
                         ByVal err As Long, _
                         ByVal lpText As String, _
                         ByVal uSize As Long) As Long
                         
Private Declare Function MIDIOutOpen Lib "winmm.dll" _
                         Alias "midiOutOpen" ( _
                         lphMidiOut As Long, _
                         ByVal uDeviceID As Long, _
                         ByVal dwCallback As Long, _
                         ByVal dwInstance As Long, _
                         ByVal dwFlags As Long) As Long
                         
Public Declare Function midiOutClose Lib "winmm.dll" ( _
                        ByVal hMidiOut As Long) As Long
                        
Private Declare Function midiOutShortMsg Lib "winmm.dll" ( _
                         ByVal hMidiOut As Long, _
                         ByVal dwMsg As Long) As Long

Sub midi_listoutdevs(c As Control)

    ' must receive a list or combo control to take the list

    Dim i As Integer
    Dim x As Integer
    Dim midicaps As MIDIOUTCAPS

    c.Clear
    c.AddItem "No selection"
    ' Test for MIDI mapper
    If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then ' OK
        c.AddItem midicaps.szPname
        c.ItemData(c.NewIndex) = MIDIMAPPER ' Save dev_id in item data
    End If
    
    ' Add other devs
    For i = 0 To midiOutGetNumDevs() - 1
        If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then ' OK
            c.AddItem midicaps.szPname
            c.ItemData(c.NewIndex) = i ' Save dev_id
        End If
    Next
    
End Sub
Sub midi_out_close()
    
    Dim midi_error As Integer

    If m_hmidiout <> 0 Then
        midi_error = midiOutClose(m_hmidiout)
        If Not midi_error = 0 Then
            Call midi_outerr(midi_error)
        End If
        m_hmidiout = 0
    End If
    
End Sub

Function midi_out_open(ByVal dev_id As Integer) As Integer

    Dim midi_error As Integer

    midi_out_close ' just in case (And it dont hurt)
    midi_error = MIDIOutOpen(m_hmidiout, dev_id, 0, 0, 0)
    If Not midi_error = 0 Then
        Call midi_outerr(midi_error)
    End If
    If m_hmidiout <> 0 Then
        midi_out_open = -1
        x = write_handle(chop_slash(App.Path) + "\handles.log", "Midi-handle", m_hmidiout)
    Else
       
    End If
    
End Function

Sub midi_outerr(ByVal midi_error As Integer)

    Dim s As String
    Dim x As Integer

    s = Space(MAXERRORLENGTH)
    x = midiOutGetErrorText(midi_error, s, MAXERRORLENGTH)
    'If Not g_debug Then
        MsgBox s
    'End If
    
End Sub

Sub midi_outshort(b1 As Integer, b2 As Integer, b3 As Integer)

    Dim midi_error As Integer
    
    If m_hmidiout = 0 Then
        Exit Sub
    End If

    midi_error = midiOutShortMsg(m_hmidiout, packdword(0, b3, b2, b1))
    If Not midi_error = 0 Then
        Call midi_outerr(midi_error)
    End If
    
End Sub



Function packdword(i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer) As Long

    On Error Resume Next
    packdword = i2 * &H10000 + i3 * &H100 + i4
    
End Function


Sub all_sounds_off()

    Dim channel As Integer

    For channel = 0 To 15
        Call midi_outshort(&HB0 + channel, &H78, 0)
        Call midi_outshort(&HB0 + channel, &H7B, 0)
    Next
    
End Sub


Sub control_change(ch As Integer, ccnr As Integer, ByVal v As Integer)

    Call midi_outshort(&HB0 + ch, ccnr, v)
    
End Sub

Sub note_off(ch As Integer, ByVal kk As Integer)

    Call midi_outshort(&H90 + ch, kk, 0)
    
End Sub

Sub note_on(ch As Integer, ByVal kk As Integer, v As Integer)

    ch = ch + 0
    Call midi_outshort(&H90 + ch, kk, v)
    
End Sub


Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)

    Call midi_outshort(&HB0 + ch, cc0nr, 0)
    Call midi_outshort(&HC0 + ch, pnr, 0)
    
End Sub

'--------- Ende Modul "MIDI_CMD" alias midi_cmd.bas ---------
'--------- Anfang Modul "KL_MIDI" alias KL_midi.bas ---------
'
' Autor: K. Langbein Klaus@ActiveVB.de

Option Explicit

Global stopp As Long
Global key_on(255) As Long
Global sett As Long
Global vol As Integer

Function free_old_midi_handles(ByVal Fname As String)

    Dim f_in$, test$, fno1, fno2, ll, test1$, dat$, timm$, typ$, htype$
    Dim hand$, midi_error, ero$
    
    f_in$ = get_path(Fname$) + "\temp.log"
    test$ = Dir$(f_in$)
    If test$ <> "" Then
         Kill f_in$
    End If
    Name Fname$ As f_in$

    fno1 = FreeFile
    Open f_in$ For Input As #fno1
    
    fno2 = FreeFile
    Open Fname$ For Output As #fno2
    ll = LOF(fno1)

    Do
    
        Line Input #fno1, test1$
        test$ = test1$
        If test$ <> "" Then
            dat$ = bite(test$, " ")
        End If
        If test$ <> "" Then
            timm$ = bite(test$, " ")
        End If
        If test$ <> "" Then
            typ$ = bite(test$, " ")
        End If
        If test$ <> "" Then
            htype$ = bite(test$, " ")
        End If
        If test$ <> "" Then
            hand = Val(bite(test$, " "))
        End If
        
        If LCase(typ$) = "new" Then
            If LCase(htype$) = "midi-handle" Then
                If hand <> 0 Then
                    midi_error = midiOutClose(hand)
                    If midi_error <> 0 Then
                        ero$ = "Error: " + Format$(midi_error)
                    Else
                        ero$ = "No Error"
                    End If
                    test$ = dat$ + " " + timm$ + " " + "Released" + " " + htype$ + " " + _
                        Format$(hand) + " " + ero$ + " at " + Date$ + " " + Time$ + vbCrLf
                    Print #fno2, test$;
                Else
                    Print #fno2, test1$ + vbCrLf;
                End If
            Else
                Print #fno2, test1$ + vbCrLf;
            End If
        
        Else
            Print #fno2, test1$ + vbCrLf;

        End If
        
    
    Loop Until Seek(fno1) >= ll
    
    Close #fno1
    Close #fno2
 
End Function

Function play_note(ByVal A$, ByVal vv As Integer) As Long

    ' Diese Funktion spielt den gewünschten Sound ab.
    ' Die einzelnen Töne werden in die entsprechenden
    ' Werte geändert, mit einer Pause versehen und
    ' anschließend ausgegeben.
    
    Dim note As Integer
    Dim okt As Integer
    Dim i As Long
    Dim j As Long
    Dim kk As Long
    Dim n$
    Dim k$
    Dim ch
    Dim off As Long
    Dim num$
    
    For i = 1 To Len(A$)
        k$ = Mid$(A$, i, 1)
        kk = Asc(k$)
        If (kk < 65) Then
            j = i
            Exit For
        End If
        
    Next i
    
    If j > 0 Then
        If j - 1 < Len(A$) Then
            n$ = Left$(A$, j - 1)
            num$ = Right$(A$, Len(A$) - Len(n$))
            okt = Val(num$) - 1
        End If
    Else
        n$ = A$
    End If
        
    Select Case n$
    
    Case "c"
        off = 0
    Case "cis"
        off = 1
    Case "d"
        off = 2
    Case "dis"
        off = 3
    Case "e"
        off = 4
    Case "f"
        off = 5
    Case "fis"
        off = 6
    Case "g"
        off = 7
    Case "gis"
        off = 8
    Case "a"
        off = 9
    Case "ais"
        off = 10
    Case "h"
        off = 11
        
    Case "p"
        Call pause(okt * 0.1, 0)
        okt = 0
        
    End Select
    
    If n$ <> "p" Then
        note = 60 + okt * 12 + off
        Call midi_outshort(&H90 + ch, note, vv)
        play_note = note
    End If
    
End Function


Function write_handle(ByVal Fname$, ByVal htype$, ByVal hand As Long) As Long

    ' Schreibt in die Log-Datei
    Dim fno, test$
    
    fno = FreeFile
    Open Fname$ For Append As #fno
    If LOF(fno) > 0 Then
        Seek #fno, LOF(fno) + 1
    End If
    
    test$ = Date$ + " " + Time$ + " New " + htype$ + " " + Format$(hand) + vbCrLf
    
    Print #fno, test$;
    Close #fno

End Function


'---------- Ende Modul "KL_MIDI" alias KL_midi.bas ----------
'------- Anfang Modul "Functions" alias Functions.bas -------
'
' Autor: K. Langbein Klaus@ActiveVB.de
Option Explicit

Function get_path(fnam$) As String

    ' Pfaddatei auslesen
    Dim Pos As Integer
    Dim t$

    For Pos = Len(fnam$) To 1 Step -1

        t$ = Mid$(fnam$, Pos, 1)
        If t$ = "\" Then
            Exit For
        End If

    Next Pos
    
    If Pos > 0 Then
        t$ = Left$(fnam$, Pos - 1)
    Else
        t$ = fnam$
    End If
    
    get_path = UCase(t$)


End Function

Function chop_slash(ByVal test$) As String

    If Right$(test$, 1) = "\" Then
        test$ = Left$(test$, Len(test$) - 1)
    End If
    chop_slash = test$
    
End Function
 Function bite$(tests$, delim$)
    
    ' Die Variable test$ wird verändert und zurückgegeben

    Dim Pos As Integer
    Dim bit$

    Pos = InStr(1, tests$, delim$, 1)
    If Pos > 0 Then
        bit$ = Left$(tests$, Pos - 1)
        tests$ = Right$(tests$, Len(tests$) - Len(bit$) - Len(delim$))
    Else
        bit$ = tests$
    End If
    
    bite$ = bit$

End Function

Sub pause(ByVal pau As Single, ByVal doev As Integer)

    Dim t As Single
    t = Timer

    Do
        If doev = 1 Then
            DoEvents
        End If

    Loop Until (Timer - t) >= pau

End Sub

'-------- Ende Modul "Functions" alias Functions.bas --------
'------------ Ende Projektdatei Simple_midi.vbp  ------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 5 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.