Startseite / Tipps / VB 5/6-Tipp 0511: Töne im RAM erzeugen

VB 5/6-Tipp 0511: Töne im RAM erzeugen

 von Klaus Langbein

'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: Textfeld "txtDuration"
' Steuerelement: Textfeld "txtF2"
' Steuerelement: Textfeld "txtF1"
' Steuerelement: Schaltfläche "cmdGen"
' Steuerelement: Schaltfläche "cmdPlay"
' Steuerelement: Beschriftungsfeld "Label2"
' 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....
'
' 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 Sub MemoryBmove Lib "kernel32" _
    Alias "RtlMoveMemory" (ByVal hpvDest As Any, ByVal hpvSource As Any, _
    ByVal cbCopy 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 Const pi = 3.14159265358979

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
End Type

Private Type wave_data_16bit
    R As Integer
    l As Integer
End Type

Dim mySound() As Byte

Private Sub BMOVE(ByVal adrSource As Long, ByVal adrDest As Long, _
    ByVal nBytes As Long)

    ' das gute alte BMOVE aus QBasic-Zeiten wiederbelebt...
    
    If nBytes <= 0 Then
        If nBytes < 0 Then
            MsgBox "Achtung negative Zahl von Bytes!"
        End If
        Exit Sub ' negative Werte verursachen Absturz
    End If
    
    If adrDest = 0 Then
        MsgBox "Achtung! Zieladresse ist 0"
        Exit Sub
    End If
    
    Call MemoryBmove(adrDest, ByVal adrSource, nBytes)
End Sub

Sub MakeSound(ByRef bArray() As Byte, ByVal Freq1 As Double, _
    ByVal freq2 As Double, ByVal Duration As Double)
    
    Dim Ton() As wave_data_16bit
    Dim Header As Standard_Wave_Header
    Dim i As Long
    
    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
                         ' für ungerade Werte >11
    sps = 44100
    nSamples = sps * Duration
    ReDim Ton(1 To nSamples)
    
    tStep = 1 / sps     ' Schrittweite für die Zeit
    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 = 55       ' 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
    
    
    For i = 1 To nSamples
        Ton(i).l = A * Sin(w1 * t) ^ n ' Amplitudenwert berechnen
        Ton(i).R = A * Cos(w2 * t) ^ n ' Cos erzeugt 90° Phasenverschiebung
                                       ' zwischen den beiden Kanälen
        t = t + tStep                  ' Zeit hochzählen
        A = A - aStep                  ' Amplitude erniedrigen
    Next i
    
    Call PrepareHeader(Header, nSamples, 2, sps, 16)
        
    ' Byte-Array vorbereiten
    ReDim bArray(1 To LenB(Header) + Header.Dl)
    
    ' Header ins Byte-Array kopieren
    BMOVE VarPtr(Header), VarPtr(bArray(1)), LenB(Header)
    
    ' Daten ins Byte-Array
    BMOVE VarPtr(Ton(1)), VarPtr(bArray(1)) + LenB(Header), Header.Dl
End Sub

Function PlayWavData(ByRef WaveData() As Byte, 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(LBound(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 cmdGen_Click()
    Call MakeSound(mySound(), _
                   Val(txtF1.Text), _
                   Val(txtF2.Text), _
                   Val(txtDuration.Text))
            
    cmdPlay.Enabled = True
    
    ' Durch einfaches Abspeichern im Binärmodus
    ' (Put #1, mySound()) könnte aus unserem Byte-Array
    ' eine Wav-Datei erzeugen.
End Sub

Private Sub cmdPlay_Click()
    If UBound(mySound) = 0 Then
        Call cmdGen_Click
    End If
     
    Dim ret
    ret = PlayWavData(mySound(), 1)
    
    ' Ist der Ton einmal erzeugt worden, so bleibt er im Speicher
    ' und kann beliebig oft abgespielt werden, ohne neu zu berechnen.
End Sub

Private Sub Form_Load()
    ReDim mySound(0)
End Sub

Private Sub txtDuration_Change()
    cmdPlay.Enabled = 0
End Sub

Private Sub txtF1_Change()
    cmdPlay.Enabled = 0
End Sub

Private Sub txtF2_Change()
    cmdPlay.Enabled = 0
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

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