Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0512: Schnelle Erzeugung und Ausgabe von Wavs via Soundkarte

 von 

Beschreibung 

Wenn man nur einfache Töne benötigt, reicht es aus eine sehr kurze Wavdatei im RAM zu erzeugen um diese dann mittels Loop-Flag belieg oft zu widerholen.
Das Beispiel demonstriert auch die Erzeugung der Frequenzen der Tonleiter und abspielen einer kleinen Melodie.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

PlaySoundA (PlaySound), PlaySoundA (PlaySoundData), sndPlaySoundA (sndPlaySound)

Download:

Download des Beispielprojektes [6,24 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 Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "txtMelody"
' Steuerelement: Schaltfläche "cmdStop"
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Textfeld "txtF2"
' Steuerelement: Textfeld "txtF1"
' Steuerelement: Schaltfläche "cmdPlay"
' Steuerelement: Beschriftungsfeld "Label1" (Index von 0 bis 1)
'
' ---------------------------------------------------------
'
' Wenn man weiß, wie der Header einer Wav-Datei aussieht
' (siehe Tipp zum Auslesen des Headers einer Wav-Datei),
' ist es recht einfach, eine Wav-Datei selbst zu schreiben.
' Im einfachsten Fall (8-Bit Mono) wird jedes Byte, was auf den
' Header folgt, als Amplitudenwert angesehen. Bei 16-Bit Stereodatein
' werden je 16 Bit (d.h. je ein Integer) abwechselnd fuer
' den rechten- u. linken Kanal geschrieben. In vorliegenden
' Beispiel beschränken wir uns auf dieses Format.
'
' Der einfachste Ton, ein Sinus, kann natürlich auch ohne
' Probleme über die Sin()-Funktion erzeugt werden. Die Tonhöhe
' ergibt sich aus der Abspielrate und der Schrittweite, mit welcher
' der Sinus berechnet wird. Ein einfacher Sinus klingt allerdings
' etwas dumpf. Wenns besser klingen soll, muss man schon etwas
' tiefer in die Trickkiste greifen....
'
' Um Töne quasi ohne Zeitverzögerung zu erzeugen beschränken wir uns
' hier auf die Generierung nur einer Periode. Der Ton wird dann
' mit dem Loop-Flag abgespielt (d.h er widerholt sich ständig), bis
' er angehalten wird. Hier muß man darauf achten, dass die Amplitudenwerte
' beider Kanäle am Anfang und Ende nahtlos aneinander passen.
'
' Autor: K. Langbein (E-Mail: Klaus@ActiveVB)

Option Explicit

Private Declare Function sndPlaySound Lib "winmm.dll" _
                Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
                ByVal uFlags As Long) As Long

Private Declare Function PlaySoundData Lib "winmm.dll" _
                 Alias "PlaySoundA" (lpData As Any, _
                 ByVal hModule As Long, _
                 ByVal dwFlags As Long) As Long
                 
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" _
                (ByVal lpszName As String, ByVal hModule As Long, _
                 ByVal dwFlags As Long) As Long


Const pi = 3.14159265358979

Private Type wave_data_16bit
    R As Integer
    l As Integer
End Type

Private Type Standard_Wave_Header

    Riff As Long       ' Sollte immer "RIFF" enthalten = 1179011410
    Rl As Long         ' Groesse des folgenden "Chunks"
    Typ As Long        ' Typinformation 4 byte "WAVE" = 1163280727
    Fmt As Long        ' Muss "fmt " enthalten = 544501094
    CSize As Long      ' Chunksize
    Tag As Integer     ' Meist unbenutzt
    nChan As Integer   ' Zahl der Kanäle
    sps As Long        ' Samples pro Sekunde
    Bps As Long        ' Bytes pro Sekunde
    Bla As Integer     ' Blockalign (Byte pro Sample)
    Sl As Integer      ' Samplelänge
    Data As Long       ' Muss "DATA" enthalten = 1096040772
    Dl As Long         ' Datenlänge
    Snd(1 To 5000) As wave_data_16bit ' Hier wird einfach ein genügend
    ' großes Feld vordimensioniert, was auch bei 10 Hz noch einen
    ' vollständigen Sinus aufnehmen kann. Dieses Feld muß nicht
    ' unbedingt vollgeschrieben werden, da man die Spieldauer ja über Dl
    ' festlegt.
    
End Type

Private Type Sound_Descriptor
    Name As String   ' C, D, E, F usw.
    Freq1 As Single  ' Freqenz links
    Freq2 As Single  '
    Duration As Long ' Dauer in ms
End Type


Private mySound As Standard_Wave_Header
Dim Ton() As Sound_Descriptor
Dim stopp As Long
Function bite$(tests$, delim$)

    ' Funktion zum abbeißen ;-)

    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
Public Function FrequencyOf(ByVal ix As Long, Optional ByVal Oktav = 1) As Double

'Notiz zur Frequenzberechnung:
'Folgende Berechnung gilt fuer die sog. physikalische Stimmung der
'chromatischen Tonleiter. Als Referenz wird der Ton A=440 HZ (Oktav=1)
'und seine Subharmonischen verwendet.
'
'Die Frequenz (F2) eines Tons errechnet sich aus der Frequenz (F1) des
' vorangegangenen mal der 12. Wurzel aus 2, d.h. F2 = F1*2^(1/12)
'
'Vorgehensweise:
'Zur Ermittlung des C wird erst die Subharmonische von A
'berechnet. Dh 1 Oktave unter der angegebenen Oktave.
'Basierend auf diesem A wird zunaechst hochgerechnet bis zum
'darauf folgenden C, d.h. 3 Toene weiter.
'    f= basef (zb basef=220)
'
'    For i = 10 To 12
'        f = f * 2 ^ (1 / 12)
'    Next i
'
'Von hier aus kann jetzt bist zum angegebenen Index weiter
'gerechnet werden:
'
'    For i = 2 To ix
'         f = f * 2 ^ (1 / 12)
'    Next i
'
'Beide Teilschleifen koennen auch zusammengefasst werden. Dh
'zur 2. Schleife werden 3 Schritte dazugerechnet.
'
'    For i = 1 To ix + 2
'         f = f * 2 ^ (1 / 12)
'    Next i
'
' Diese Schleife kann zusammengefasst werden zu
' f = f * (2^(1/12)) ^ (ix + 2)
'
'Beispiel: Ton 3, Oktav 1
'Als Grundfrequenz fuer Oktav 0 wird A=220 ermittelt.
'Fuer das darauf folgende C errechnet sich C=261.625565300599
'Von da wird bis zum 3. Ton = D = 293Hz weiter gerechnet.
    
    Dim f As Double
    Dim basef As Double
    Dim ff As Double
    
    basef = 13.75
    If Oktav <= -3 Then
        Oktav = -3
    End If
    
    Oktav = Oktav + 3
    basef = basef * 2 ^ Oktav
    
    ff = 2 ^ (1 / 12)
    f = basef * ff ^ (ix + 2)
    
    FrequencyOf = f

End Function


Function GetIndex(ByVal Name As String) As Long

    Dim i As Long
    For i = 1 To UBound(Ton)
        If Ton(i).Name = Name Then
            GetIndex = i
            Exit Function
        End If
        
    Next i

End Function

Private Sub MakeSound(Sound As Standard_Wave_Header, _
                      ByVal Freq1 As Double, _
                      ByVal Freq2 As Double)
    

    Dim nSamples As Long ' Zahl der Samples
    Dim tStep As Double  ' Schrittweite der Zeit in Sek.
    Dim t As Double      ' Zeit
    Dim sps As Long      ' Samples pro Sekunde
    Dim w1 As Double     ' Kreisfrequenz Omega
    Dim w2 As Double '
    Dim A As Double      ' Max. Amplitude (32000 für Integers)
    Dim aStep As Double  ' Schrittweite für Reduzierungder Aplitude
    Dim n As Long        ' Exponent (erzeugt Saitenähnlichen Klang
    Dim tau As Double
                         
    sps = 44100
    tStep = 1 / sps     ' Schrittweite für die Zeit
    tau = 1 / Freq1
    nSamples = tau / tStep
    
    w1 = 2 * pi * Freq1 ' Berechnung der Kreisfrequenz
    w2 = 2 * pi * Freq2 ' Leichte Unterschiede zw. den Frequenz der
                        ' beiden Kanäle erzeugen eine Schwebung.
    
    A = 32000    ' Maximale Amplitude. Wenns leiser sein soll,
                 ' kleinere Werte einsetzen
                 
    n = 101       ' Für einen reinen Sinus wird n=1 gesetzt
                 ' Hohe ungerade Werte erzeugen einen saitenählichen
                 ' Klang. Gerade Werte verdoppeln die Frequenz und
                 ' man erhält zB für n=2 einen klavierähnlichen Ton'
    
    aStep = A / nSamples ' Für konstanten Ton, aStep = 0 setzen
    
    If nSamples > UBound(Sound.Snd) Then
        nSamples = UBound(Sound.Snd)
    End If
    Call PrepareHeader(Sound, nSamples, 2, sps, 16)
    
    Dim i
    For i = 1 To nSamples
    
        mySound.Snd(i).l = A * Sin(w1 * t) ^ n ' Amplitudenwert berechnen
        mySound.Snd(i).R = A * Cos(w2 * t) ^ n ' Cos erzeugt 180° Phasenverschiebung
                                               ' zwischen den beiden Kanälen.
        t = t + tStep                          ' Zeit hochzählen
    
    Next i
    
    ' Das Umspeichern entfällt hier, da wir unseren einenen Typen
    ' an die PlaySoundData-API übergeben können.
    
    
End Sub

Sub Melody(ByVal Melo$)

    Dim t$, i, ret
    ' VB6-Benutzer können hier Replace verwenden
    Melo = ReplaceVB5(Melo, vbCrLf, " ")
    Do
        t$ = bite(Melo$, " ")
        If t$ = " " Then
            Goto skip
        End If
        i = GetIndex(t$)
        
        If i > 0 Then
            Call MakeSound(mySound, Ton(i).Freq1, Ton(i).Freq1)
            ret = PlayWavData(mySound, 8 Or 1)
        Else
            ' dann isses ne Pause
        End If
        Timer1.Interval = Ton(i).Duration
        Timer1.Enabled = -1
        Do
            DoEvents
        Loop Until Timer1.Enabled = 0
skip:
        
    Loop Until Melo$ = t$ Or stopp = 1

End Sub

Private Function PlayWavData(ByRef WaveData As Standard_Wave_Header, _
                 ByVal flag As Long) As Long
 
    ' spielt ein WAV aus Byte-Array im RAM
     
    On Error Resume Next
    Dim ret As Long
    Const SND_MEMORY = &H4
    ret = PlaySoundData(WaveData, 0, SND_MEMORY Or flag)
        
    
End Function

Private Function PrepareHeader(ByRef Header As Standard_Wave_Header, _
                               ByVal nSamples As Long, _
                               ByVal nChannels As Long, _
                               ByVal SamplesPerSecond As Long, _
                               ByVal BitsPerSample)
                               
    Dim DataLength As Long
    Dim Rl As Long         ' Länge der 'Riff'-Chunks

    DataLength = nSamples * nChannels * BitsPerSample / 8

    Rl = 16 + 4 + 4       ' Länge des Formatchunks + 4 Byte für "fmt " + 4
    Rl = Rl + DataLength  ' plus Datenlänge
    Rl = Rl + 4 + 4 + 4   '
    
    Header.Riff = 1179011410 ' Wir übereben ein Long welches der
                             ' die gleiche Bytefolge wie "RIFF" hat
    Header.Rl = Rl
    Header.Typ = 1163280727 ' = "WAVE"
    Header.Fmt = 544501094  ' = "fmt "
    Header.CSize = 16       ' Länge des folgenden Chunks
    Header.Tag = 1
    Header.nChan = nChannels
    Header.sps = SamplesPerSecond
    Header.Bla = nChannels * BitsPerSample / 8
    Header.Bps = Header.sps * Header.Bla
    Header.Sl = BitsPerSample
    Header.Data = 1635017060
    Header.Dl = DataLength
     
End Function

Private Sub cmdPlay_MouseDown(Button As Integer, Shift As Integer, _
                              X As Single, Y As Single)
    Dim ret
    Call MakeSound(mySound, Val(txtF1.Text), Val(txtF2.Text))
    ret = PlayWavData(mySound, 8 Or 1)
    
End Sub


Private Sub cmdPlay_MouseMove(Button As Integer, Shift As Integer, _
                              X As Single, Y As Single)

    If X < 0 Or Y < 0 Then
        Call cmdStop_Click
    End If
    If X > cmdPlay.Width Or Y > cmdPlay.Height Then
        Call cmdStop_Click
    End If
    
End Sub


Private Sub cmdPlay_MouseUp(Button As Integer, Shift As Integer, _
                            X As Single, Y As Single)
    Call cmdStop_Click
End Sub

Private Sub cmdStop_Click()
    Call PlaySound(vbNullString, 0, 1)
    stopp = 1
End Sub


Private Sub Command1_Click()
    stopp = 0
    Call Melody(txtMelody.Text)
End Sub

Private Sub Form_Load()

    Dim i As Long
    ReDim Ton(0 To 12)
    Ton(1).Name = "C"
    Ton(2).Name = "Cis"
    Ton(3).Name = "D"
    Ton(4).Name = "Dis"
    Ton(5).Name = "E"
    Ton(6).Name = "F"
    Ton(7).Name = "Fis"
    Ton(8).Name = "G"
    Ton(9).Name = "Gis"
    Ton(10).Name = "A"
    Ton(11).Name = "B"
    Ton(12).Name = "C"
    
    For i = 1 To 12
        Ton(i).Duration = 300
        Ton(i).Freq1 = FrequencyOf(i)
        Ton(i).Freq2 = Ton(i).Freq1
    Next i
    
    Ton(0).Duration = 100 ' Dummyton als Pause
    
End Sub

Private Sub Timer1_Timer()
    Call PlaySound(vbNullString, 0, 1)
    Timer1.Enabled = 0
End Sub

Function ReplaceVB5$(ByVal test$, str1$, str2$)
    
    Dim pos As Long
    Dim nestr$
    Dim newstr$
    
    pos = 1
    newstr$ = ""

    Do
        pos = InStr(1, test$, str1$, 0)
        If pos > 0 Then
            newstr$ = newstr$ + Left$(test$, pos - 1) + str2$
            test$ = Right$(test$, Len(test$) - pos - Len(str1$) + 1)
        Else
            newstr$ = newstr$ + test$
        End If

    Loop Until pos = 0

    ReplaceVB5$ = newstr$

End Function

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 3 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.

Kommentar von Rene Jungmann am 23.12.2006 um 01:30

Hallo,

das ist genau das, was ich gesucht habe. Leider funktioniert es bei mir unter vb.net nicht. Ok, ich weiß, dass es für eine ältere VB-Version geschrieben wurde, aber das Programm lässt sich problemlos ausführen, nur ist leider nichts zu hören.

Grüße

René

Kommentar von Hermann Sereinig am 20.10.2005 um 08:55

Ich wäre ihnen sehr dankbar, wenn sie mir Informationen geben könnten, die es mir ermöglichen (einfache) Töne und sogenannte Doppeltöne (wie die Töne einer Telefontastatur) mit variabler Frequenz und Dauer mit der Sondkarte des PC's mittels VB zu erzeugen.

Ich hoffe Sie helfen mir - vielen Dank
Hermann Sereinig


Kommentar von Matthias Elser am 11.07.2003 um 12:31

Hi!
Leider bekomme ich bei der Überprüfung der ausgegebenen Sin-Waves mittels eines Frequenzmessgerätes seltsame Werte!
Wie genau wird die Frequenz hier ausgegeben?
Durch die durchgehende Verwendung von Doubles müßte doch auch die Eingabe von Kommawerten (z.B. 440,21) im Beispielproj. möglich sein? Oder nimmt die Val-Funktion eine Typauswertung vor?
Ich bräuchte die Ausgabe sehr genauer Frequenzen zu Untersuchungszwecken an historischen Stimmungen von Tasteninstrumenten.
Würde mich sehr über weitere Hilfe freuen!
Gruß,
Matthias E.