Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Hier kann man beliebige Töne im RAM erzeugen lassen. Man kann
unter anderem "Duration" und die Frequenz des Stereotons selbst bestimmen.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

RtlMoveMemory (MemoryBmove), PlaySoundA (PlaySoundData), sndPlaySoundA (sndPlaySound)

Download:

Download des Beispielprojektes [4,53 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: 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-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 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.

Kommentar von Alfred Hellmüller am 06.08.2008 um 21:14

Hallo Klaus

Habe einen bösen (schlafenden) Bug entdeckt:
Private Sub cmdPlay_Click()
If UBound(mySound) = 0 Then <------ !

.....

Das gibt einen Laufzeitfehler; ein nicht initialisiertes (leeres) Array kennt keinen UBound; Absturz. Dynamische Arrays haben ihre Tücken...

Lösung:
Private Sub cmdPlay_Click()
If IsInitialized(mySound) Then
....

_____________________________________________________
Private Function IsInitialized(ByRef vArray As Variant) As Boolean
On Error Resume Next
IsInitialized = IsNumeric(UBound(vArray))
On Error GoTo 0
End Function
_______________________________________________________


Gruss
Alfred

Kommentar von Alfred Hellmüller am 05.08.2008 um 22:30

Vielen Dank für diese tolle Arbeit! Sauber konzipiert, programmiert und perfekt dokumentiert. Und das Beste: Es läuft ohne rülpsen und ächzen!

Gut gemacht, Kompliment!

Kommentar von Alfred Hellmüller am 05.08.2008 um 20:55

Vielen Dank für diese tolle Arbeit! Sauber konzipiert, programmiert und perfekt dokumentiert. Und das Beste: Es läuft ohne rülpsen und ächzen!

Gut gemacht, Kompliment!

Kommentar von willibald limbrunner am 31.01.2008 um 11:48

Habe lange auf so ein Programm gewartet. Klänge(nicht nur einen Sinuston) in beliebiger Frequenz erzeugen zu können war ein für mich ungelöstes Problem gewesen.

Ich freue mich sehr über diesen Tipp 511

Gruß Willibald

Kommentar von Jonathan am 30.01.2008 um 16:30

Ich habe mir den Tipp 0511 Töne im Ram erzeugen rontergeladen. Ich möchte gerne fragen, wiso es immer so lange dauert, bis der Computer den Klang ausgeben kann.
Bitte Antworten sie mir. Übrigens: Ich finde dieses Programm sehr gut.

Kommentar von Willibald Limbeunner am 16.01.2006 um 14:28

wie kann ich mehrere Töne in mehreren Kanälen ausgeben um auch Akkorde mit 3 oder 4 Klängen gleichzeitig erklingen zu lassen?

mfg
Willibald Limbrunner

Kommentar von Peterfarge am 10.11.2004 um 13:13

Also bei mir funktioniert es nicht: VB6 mit SP5, WinXp mit SP2. auch die vorkompilierte Exe stürzt mit einem Fehler ab. Die IDE reißt es sonst auch vollkommen in den Tod...

Mir persönlich ist es nicht wichtig das der Tip funzt. Dann nerv ich den User in der Aboutbox halt mit was Anderem;-)

Kommentar von Karl Baumann am 25.04.2004 um 11:46

Ich bin sehr begeistert von euren tipps.

Kommentar von Clemens am 26.03.2004 um 14:11

Sehr netter Tipp, die erzeugte Datei lässt sich mit z.B.:

Open App.Path & "\test.wav" For Binary As #1
Put #1, , mySound()
Close #1

einfach abspeichern.

Grüße
Clemens

Kommentar von Sepp am 10.02.2004 um 15:13

Wie kann ich verschiedene Instrumentklänge erzeugen.
Habe versucht ein Spektrum mit Obertönen zu erzeugen.
0.1*Sin(x)+0.1*Sin(2x)+0.1*Sin(3x)...0.1*Sin(6x)
Das klingt äußerst bescheiden.
Der Exponent n bringt auch nicht viel.

mfg Willi

Kommentar von markus am 28.09.2003 um 18:57

Vielen Dank,

funktioniert sehr gut, allerdings würde ich mir ebenfalls gerne den "Tipp wie man Header einer wave-Datei ausliest" anschauen.
Wo finde ich diesen Tipp ?

gruss
markus

Kommentar von RinnerA am 25.09.2003 um 21:27

Zu tipp0511:
Wie kann ich das file lauter generieren!?! den wert 32000 kann ich nicht vergrößern(->fehlermeldung)!Laut der anzeige auf meiner stereoanlage (egal bei welchen frequenzen) geht es noch lauter!

Kommentar von Andreas am 27.04.2003 um 21:26

Folgender Verweis ärgert mich:

' Wenn man weiß, wie der Header einer Wav-Datei aussieht
' (siehe Tipp zum Auslesen des Headers einer Wav-Datei),
----
Den Tipp könnte ich dringend gebrauchen, aber wo ist er?

Gruß,
Andreas

Kommentar von blak_x am 07.11.2002 um 17:35

Funktioniert!!! Aber das hat ja verd... lange bis der Ton berechnet ist!