Imports System.Runtime.InteropServices
 
Public Class Sound
 
    Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" ( _
      ByVal lpszSoundName As String, ByVal uFlags As Integer) As Integer
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal _
    hpvDest As IntPtr, ByVal hpvSource As IntPtr, ByVal cbCopy As Integer)
    Public Declare Function PlaySoundData Lib "winmm.dll" Alias "PlaySoundA" ( _
    ByVal lpData As IntPtr, ByVal hModule As Integer, ByVal dwFlags As Integer) _
    As Long
 
    Public Structure Standard_Wave_Header
        Public Riff As Integer
        Public Rl As Integer
        Public Typ As Integer
        Public Fmt As Integer
        Public CSize As Integer
        Public Tag As Short
        Public nChan As Short
        Public sps As Integer
        Public Bps As Integer
        Public Bla As Short
        Public Sl As Short
        Public Data As Integer
        Public Dl As Integer
    End Structure
    Public Structure Wave_Data_16Bit
        Public R As Short
        Public L As Short
    End Structure
 
    Public SoundData() As Byte
 
    Public Sub MakeSound(ByVal Freq1 As Double, ByVal freq2 As Double, ByVal _
      Duration As Double)
        Dim nSamples As Integer 
        Dim tStep As Double
        Dim t As Double
        Dim sps As Integer
        Dim w1 As Double
        Dim w2 As Double
        Dim A As Double
        Dim aStep As Double
        Dim n As Integer
        sps = 44100
        nSamples = sps * Duration
 
        tStep = 1.0 / CDbl(sps)
        w1 = 2 * Math.PI * Freq1
        w2 = 2 * Math.PI * freq2
        A = 32000
 
        n = 55
 
        aStep = A / nSamples
 
 
        Dim Ton(0 To (nSamples) - 1) As Wave_Data_16Bit
        For i As Integer = 0 To (nSamples - 1)
            Ton(i).L = A * (Math.Sin(w1 * t) ^ n)
            Ton(i).R = A * (Math.Cos(w2 * t) ^ n)
 
            t = t + tStep
            A = A - aStep
        Next i
        Dim Header As Standard_Wave_Header
        PrepareHeader(Header, nSamples, 2, sps, 16)
 
 
        ReDim Me.SoundData(0 To (Marshal.SizeOf(Header) + Header.Dl))
 
        Dim Addr_SoundData_GC As GCHandle = GCHandle.Alloc(Me.SoundData(0), _
          GCHandleType.Pinned)
        Dim Addr_SoundData As IntPtr = Addr_SoundData_GC.AddrOfPinnedObject
        Dim Addr_Header_GC As GCHandle = GCHandle.Alloc(Header, _
          GCHandleType.Pinned)
        Dim Addr_Header As IntPtr = Addr_Header_GC.AddrOfPinnedObject
 
        CopyMemory(Addr_Header, Addr_SoundData, Marshal.SizeOf(Header))
        'Hier kommt der Fehler: AccessViolationException
        '          Es wurde versucht in geschützten Speicher zu schreiben...
 
        Addr_Header_GC.Free()
        Dim Addr_Ton_GC As GCHandle = GCHandle.Alloc(Ton(0), _
          GCHandleType.Pinned)
        Dim Addr_Ton As IntPtr = Addr_Ton_GC.AddrOfPinnedObject.ToInt32
 
        CopyMemory(Addr_Ton, New IntPtr(Addr_SoundData.ToInt64() + CLng( _
          Marshal.SizeOf(Header))), Header.Dl)
 
        Addr_Ton_GC.Free()
        Addr_SoundData_GC.Free()
    End Sub
 
    Public Function PlayWavData(ByVal flag As Integer) As Integer
        PlaySoundData(SoundData(Me.SoundData.GetUpperBound(0)), 0, &H4
 Or flag)
    End Function
 
    Public Sub PrepareHeader(ByRef Header As Standard_Wave_Header, ByVal _
      nSamples As Integer, ByVal nChannels As Integer, ByVal SamplesPerSecond _
      As Integer, ByVal BitsPerSample As Integer)
        Dim DataLength As Integer
        Dim Rl As Integer    
 
        DataLength = (nSamples * nChannels * BitsPerSample) \ 8
 
        Rl = 16 + 4 + 4
 
        Rl = Rl + DataLength
        Rl = Rl + 4 + 4 + 4
 
        Header.Riff = 1179011410
        Header.Rl = Rl
        Header.Typ = 1163280727
        Header.Fmt = 544501094
        Header.CSize = 16
        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 Sub
 
    Public Sub Gen()
        MakeSound(500, 500, 100)
    End Sub
    Public Sub Play()
        If (Me.SoundData Is Nothing) Then Gen()
        PlayWavData(1)
    End Sub
End Class
Module Test
    Public Sub Main()
        Dim k As New Sound()
        k.Gen()
        k.Play()
        'Ex kommt kein Ton :-(
        Threading.Thread.Sleep(2000)
    End Sub
End Module