Option Explicit

Dim DX As New DirectX7
Dim DS As DirectSound
Dim dsWavDatei As DirectSoundBuffer

Dim CurrentVolume As Long
Dim AvgBytesPerSec As Long

Private Sub Form_Load()
  On Local Error GoTo ErrorHandler

  Set DS = DX.DirectSoundCreate("")
  DS.SetCooperativeLevel Me.hWnd, DSSCL_NORMAL

  Me.Show

  Exit Sub
ErrorHandler:
  MsgBox "Direct Sound Objekt konnte nicht initialisiert " & _
         "werden." & vbCrLf & "Prüfe ob eine SoundKarte " & _
         "installiert ist und ob sie funktioniert." & vbCr & _
         Err.Number & "/" & Err.Description
  End
End Sub

Private Sub cmd_Load_Click()
  Dim dsBDesc As DSBUFFERDESC
  Dim WavLen As Long

  On Error GoTo ErrorHandler

  With dsBDesc
      .lFlags = DSBCAPS_STATIC Or DSBCAPS_CTRLVOLUME Or _
          DSBCAPS_CTRLPAN Or DSBCAPS_CTRLFREQUENCY
  End With

  Dim s As WAVEFORMATEX
  Set dsWavDatei = DS.CreateSoundBufferFromFile _
        (App.Path & "\vbfun.wav", dsBDesc, s)

  HS_Volume.Value = dsWavDatei.GetVolume
  lbl_Volume.Caption = "Lautstärke: Absenkung in " & _
        HS_Volume.Value & " hundertstel dB"

  HS_Balance.Value = dsWavDatei.GetPan
  lbl_Balance.Caption = "Balance: Links/Rechts in " & _
        HS_Balance.Value & " hundertstel dB"

  HS_Frequenz.Value = (dsWavDatei.GetFrequency \ 10)
  lbl_Frequenz.Caption = _
        "Frequenz: " & (CLng(HS_Frequenz.Value) * 10) & " Hz"

  dsWavDatei.GetFormat s

  lbl_Channels.Caption = "Anzahl der Kanäle : " & _
        s.nChannels & " (1=Mono/2=Stereo)"

  lbl_SamplesPerSec.Caption = "Samplingrate : " & _
        Format(s.lSamplesPerSec, "##,###") & " Hz"

  lbl_BitsPerSample.Caption = _
        "Bitbreite : " & s.nBitsPerSample & " Bit"

  lbl_BlockAlign.Caption = _
        "Anzahl Bytes pro Block : " & s.nBlockAlign

  lbl_AvgBytesPerSec.Caption = _
        "Bytes pro Sekunde : " & s.lAvgBytesPerSec

  WavLen = dsBDesc.lBufferBytes
  lbl_FileLen.Caption = "Dateigröße : " & WavLen & " Bytes " & _
      "(" & Format((WavLen / s.lAvgBytesPerSec), "#0.000") & _
      " Sekunden)"
  Slider1.Max = Int((WavLen / s.lAvgBytesPerSec) * 1000)
  HS_Cursor.Max = Slider1.Max
  AvgBytesPerSec = s.lAvgBytesPerSec

  cmd_Load.Enabled = False
  cmd_Play.Enabled = True
  Timer1.Enabled = True

  Exit Sub
ErrorHandler:
  MsgBox "Fehler beim Laden der Wav-Datei." & vbCr & _
      Err.Number & "/" & Err.Description
  End
End Sub

Private Sub cmd_Play_Click()
  Dim Pos As Long

  If HS_Cursor.Value > 0 Then
    Pos = CLng((HS_Cursor.Value / 1000) * AvgBytesPerSec)
  End If
  dsWavDatei.SetCurrentPosition Pos

  If chk_Loop.Value = 0 Then
    dsWavDatei.Play DSBPLAY_DEFAULT
  Else
    dsWavDatei.Play DSBPLAY_LOOPING
  End If

  cmd_Play.Enabled = False
  chk_Loop.Enabled = False
End Sub
 
Private Sub cmd_Stop_Click()
  dsWavDatei.Stop

  dsWavDatei.SetCurrentPosition 0
  Slider1.Value = 0
  cmd_Play.Enabled = True
  chk_Loop.Enabled = True
End Sub

Private Sub HS_Balance_Change()
  lbl_Balance.Caption = "Balance: Links/Rechts in " & _
        HS_Balance.Value & " hundertstel dB"
  dsWavDatei.SetPan CLng(HS_Balance.Value)
End Sub

Private Sub HS_Frequenz_Change()
  lbl_Frequenz.Caption = _
        "Frequenz: " & (CLng(HS_Frequenz.Value) * 10) & " Hz"
  dsWavDatei.SetFrequency (CLng(HS_Frequenz.Value) * 10)
End Sub

Private Sub HS_Volume_Change()
  lbl_Volume.Caption = "Lautstärke: Absenkung in " & _
        HS_Volume.Value & " hundertstel dB"
  dsWavDatei.SetVolume CLng(HS_Volume.Value)
End Sub

Private Sub Timer1_Timer()
  Dim dsstat As CONST_DSBSTATUSFLAGS
  Dim dsc As DSCURSORS
  Dim Pos As Long

  dsstat = dsWavDatei.GetStatus

  If dsstat = DSBSTATUS_PLAYING Or _
        dsstat = (DSBSTATUS_PLAYING + DSBSTATUS_LOOPING) Then
    cmd_Stop.Enabled = True
  Else
    cmd_Stop.Enabled = False
    cmd_Play.Enabled = True
    chk_Loop.Enabled = True
    Slider1.Value = 0
  End If

  dsWavDatei.GetCurrentPosition dsc
  If dsc.lPlay > 0 Then
    Pos = Int((dsc.lPlay / AvgBytesPerSec) * 1000)
    Slider1.Value = Pos
  End If
End Sub

Private Sub cmd_Close_Click()
  Set dsWavDatei = Nothing
  Set DS = Nothing
  Set DX = Nothing
  End
End Sub