Option Explicit

Sub Main()
  DSoundModule.InitializeDS (frmMain.hWnd)
  frmMain.Show
End Sub

Sub ExitProgramm()
  DSoundModule.SoundTerminate
End Sub

Option Explicit

Private Type FILEHEADER
  intNumFiles As Integer
  lngFileSize As Long
End Type

Private Type INFOHEADER
  lngFileSize As Long
  lngFileStart As Long
  strFileName As String * 16
End Type
Public InfoHead() As INFOHEADER

Private Type WAVETYPE
  strHead As String * 12
  strFormatID As String * 4
  lngChunkSize As Long
  intFormat As Integer
  intChannels As Integer
  lngSamplesPerSec As Long
  lngAvgBytesPerSec As Long
  intBlockAlign As Integer
  intBitsPerSample As Integer
End Type

Global gudtHeader As WAVETYPE
Global glngChunkSize As Long
Global gbytData() As Byte

Function OpenBinFile(strFile As String) As Boolean
  Dim intBinaryFile As Integer
  Dim FileHead As FILEHEADER

  On Local Error GoTo ErrOut

  intBinaryFile = FreeFile
  Open App.Path & strFile _
        For Binary Access Read Lock Write As intBinaryFile

  Get intBinaryFile, 1, FileHead

  If LOF(intBinaryFile) <> FileHead.lngFileSize Then
    MsgBox "This is not a valid file format.", vbOKOnly, _
          "Invalid File"
    OpenBinFile = False
    Exit Function
  End If

  ReDim InfoHead(FileHead.intNumFiles - 1)
  Get intBinaryFile, , InfoHead
  Close intBinaryFile

  OpenBinFile = True
  Exit Function

ErrOut:
  OpenBinFile = False
  Close intBinaryFile
  MsgBox "Unable to decode binary file.", vbOKOnly, "Error"
End Function

Sub ExtractWaveData(strFileName As String, lngOffset As Long)
  Dim intWAVFile As Integer
  Dim i As Long
  Dim strTemp As String * 4
  Dim blnFound As Boolean

  intWAVFile = FreeFile()
  Open strFileName For Binary Access Read Lock Write As intWAVFile
    Get intWAVFile, lngOffset, gudtHeader

    For i = lngOffset To LOF(intWAVFile)
      Get intWAVFile, i, strTemp
      If strTemp = "data" Then
        blnFound = True
        Exit For
      End If
    Next i

    If blnFound = False Then
      MsgBox "Invalid wave data.", vbCritical, "Invalid Wave"
      Close intWAVFile
      Exit Sub
    End If

    Get intWAVFile, , glngChunkSize
    ReDim gbytData(glngChunkSize)
    Get intWAVFile, , gbytData
  Close intWAVFile
End Sub

Private Function FileSize(lngWidth As Long, lngHeight As Long) _
      As Long
  If lngWidth Mod 4 > 0 Then
    FileSize = ((lngWidth \ 4) + 1) * 4 * lngHeight - 1
  Else
    FileSize = lngWidth * lngHeight - 1
  End If
End Function

Option Explicit

Public dx As New DirectX7
Public DS As DirectSound
Public dsPrimaryBuffer As DirectSoundBuffer
Public dsSound1 As DirectSoundBuffer
Public dsSound2 As DirectSoundBuffer

Public Sub InitializeDS(WindowHandle As Long)
  Dim dsBDesc As DSBUFFERDESC
  Dim bdesc As DSBUFFERDESC

  Set DS = dx.DirectSoundCreate("")
  DS.SetCooperativeLevel WindowHandle, DSSCL_NORMAL
  With bdesc
    .lFlags = DSBCAPS_PRIMARYBUFFER Or DSBCAPS_CTRLPAN
  End With

  Dim s As WAVEFORMATEX
  Set dsPrimaryBuffer = DS.CreateSoundBuffer(bdesc, s)
End Sub

Public Sub GetSound()
  LoadSound dsSound1, InfoHead(0).lngFileStart
  LoadSound dsSound2, InfoHead(1).lngFileStart
End Sub

Public Sub LoadSound(objBuffer As DirectSoundBuffer, _
      lngLocation As Long)
  Dim udtBufferDesc As DSBUFFERDESC
  Dim udtFormat As WAVEFORMATEX

  ExtractWaveData App.Path & "\Sound.dat", lngLocation

  With udtFormat
    .nFormatTag = gudtHeader.intFormat
    .nChannels = gudtHeader.intChannels
    .lSamplesPerSec = gudtHeader.lngSamplesPerSec
    .nBitsPerSample = gudtHeader.intBitsPerSample
    .nBlockAlign = gudtHeader.intBlockAlign
    .lAvgBytesPerSec = gudtHeader.lngAvgBytesPerSec
  End With

  udtBufferDesc.lBufferBytes = glngChunkSize
  Set objBuffer = DS.CreateSoundBuffer(udtBufferDesc, udtFormat)
 
  objBuffer.WriteBuffer _
       0, glngChunkSize, gbytData(0), DSBLOCK_ENTIREBUFFER
End Sub

Public Sub SoundTerminate()
  Set dsSound1 = Nothing
  Set dsSound2 = Nothing
  Set DS = Nothing
End Sub

Option Explicit

Private Type FILEHEADER
  intNumFiles As Integer
  lngFileSize As Long
End Type

Private Type INFOHEADER
  lngFileSize As Long
  lngFileStart As Long
  strFileName As String * 16
End Type

Const DatFileName As String = "Sound.DAT"

Dim strFiles(2) As String

Private Sub Command1_Click()
  Dim intSample1File As Integer
  Dim intBinaryFile As Integer
  Dim bytSample1Data() As Byte
  Dim FileHead As FILEHEADER
  Dim InfoHead() As INFOHEADER
  Dim lngFileStart As Long
  Dim i As Single

  If Dir(App.Path & "\Sound.DAT", vbNormal) <> "" Then
      Kill App.Path & "\Sound.DAT"
  End If

  On Local Error GoTo ErrOut

  Me.MousePointer = vbHourglass

  strFiles(1) = "Sound1.wav"
  strFiles(2) = "Sound2.wav"

  FileHead.intNumFiles = 2

  FileHead.lngFileSize = (6) + (FileHead.intNumFiles * 24)

  ReDim InfoHead(FileHead.intNumFiles - 1)
  lngFileStart = (6) + (FileHead.intNumFiles * 24) + 1

  For i = 1 To FileHead.intNumFiles
    intSample1File = FreeFile
    Open App.Path & "\" & strFiles(i) _
          For Binary Access Read Lock Write As intSample1File

    ReDim bytSample1Data(LOF(intSample1File) - 1)
    Get intSample1File, 1, bytSample1Data
    Close intSample1File

    FileHead.lngFileSize = _
          FileHead.lngFileSize + (UBound(bytSample1Data) + 1)

    InfoHead(i - 1).lngFileSize = UBound(bytSample1Data) + 1
    InfoHead(i - 1).lngFileStart = lngFileStart
    lngFileStart = lngFileStart + InfoHead(i - 1).lngFileSize
    InfoHead(i - 1).strFileName = strFiles(i)
  Next i

  intBinaryFile = FreeFile
  Open App.Path & "\" & DatFileName _
        For Binary Access Write Lock Write As intBinaryFile

  Put intBinaryFile, 1, FileHead
  Put intBinaryFile, , InfoHead

  For i = 1 To FileHead.intNumFiles
    intSample1File = FreeFile
    Open App.Path & "\" & strFiles(i) _
          For Binary Access Read Lock Write As intSample1File
    ReDim bytSample1Data(LOF(intSample1File) - 1)
    Get intSample1File, 1, bytSample1Data
    Put intBinaryFile, , bytSample1Data
    Close intSample1File
  Next i

  Close intBinaryFile

  Me.MousePointer = vbNormal
  MsgBox "Binärdatei wurde erstellt!"
  Command2.Enabled = True

  Exit Sub

ErrOut:
  MsgBox "Binärdatei konnte nicht erstellt werden.", _
        vbOKOnly, "Fehler"
End Sub

Private Sub Command2_Click()
  If OpenBinFile("\Sound.DAT") Then
    MsgBox "Wav-Files werden nun in den SoundBuffer geschrieben."
    DSoundModule.GetSound
    frmPlaySound.Show vbModal
  End If
End Sub

Private Sub cmd_Beenden_Click()
  ExitProgramm
  End
End Sub

Option Explicit

Private Sub Command1_Click()
  dsSound1.Play DSBPLAY_DEFAULT
End Sub

Private Sub Command2_Click()
  dsSound2.Play DSBPLAY_DEFAULT
End Sub

Private Sub Command3_Click()
  Unload Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, _
      UnloadMode As Integer)
  Me.Hide
End Sub