VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frm3Dtest 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "BASS - 3D Test"
   ClientHeight    =   4005
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5415
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   4005
   ScaleWidth      =   5415
   StartUpPosition =   2  'CenterScreen
   Begin VB.Frame Frame6 
      Caption         =   "Doppler factor"
      Height          =   495
      Left            =   2640
      TabIndex        =   12
      Top             =   3360
      Width           =   2655
      Begin VB.HScrollBar ID_Doppler 
         Height          =   135
         Left            =   120
         Max             =   20
         TabIndex        =   14
         Top             =   240
         Value           =   10
         Width           =   2415
      End
   End
   Begin VB.Frame Frame5 
      Caption         =   "Rolloff factor"
      Height          =   495
      Left            =   2640
      TabIndex        =   11
      Top             =   2760
      Width           =   2655
      Begin VB.HScrollBar ID_Rolloff 
         Height          =   135
         Left            =   120
         Max             =   20
         TabIndex        =   13
         Top             =   240
         Value           =   10
         Width           =   2415
      End
   End
   Begin VB.Frame Frame4 
      Height          =   2655
      Left            =   2640
      TabIndex        =   3
      Top             =   0
      Width           =   2655
      Begin VB.PictureBox picDisplay 
         FillStyle       =   0  'Solid
         Height          =   2295
         Left            =   120
         ScaleHeight     =   149
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   157
         TabIndex        =   4
         Top             =   240
         Width           =   2415
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "Channels (sample/music)"
      Height          =   2295
      Left            =   120
      TabIndex        =   2
      Top             =   0
      Width           =   2415
      Begin VB.Timer tmr3D 
         Enabled         =   0   'False
         Interval        =   50
         Left            =   1800
         Top             =   840
      End
      Begin MSComDlg.CommonDialog DLG 
         Left            =   1800
         Top             =   360
         _ExtentX        =   847
         _ExtentY        =   847
         _Version        =   393216
      End
      Begin VB.CommandButton cmdStop 
         Caption         =   "Stop"
         Enabled         =   0   'False
         Height          =   300
         Left            =   1320
         TabIndex        =   9
         Top             =   1920
         Width           =   975
      End
      Begin VB.CommandButton cmdPlay 
         Caption         =   "Play"
         Enabled         =   0   'False
         Height          =   300
         Left            =   120
         TabIndex        =   8
         Top             =   1920
         Width           =   975
      End
      Begin VB.CommandButton cmdRemove 
         Caption         =   "Remove"
         Enabled         =   0   'False
         Height          =   300
         Left            =   1320
         TabIndex        =   7
         Top             =   1560
         Width           =   975
      End
      Begin VB.CommandButton cmdAdd 
         Caption         =   "Add ..."
         Height          =   300
         Left            =   120
         TabIndex        =   6
         Top             =   1560
         Width           =   975
      End
      Begin VB.ListBox lstChannels 
         Height          =   1230
         Left            =   120
         TabIndex        =   5
         Top             =   240
         Width           =   2175
      End
   End
   Begin VB.Frame Frame2 
      Caption         =   "Movement"
      ClipControls    =   0   'False
      Height          =   765
      Left            =   120
      TabIndex        =   1
      Top             =   2280
      Width           =   2415
      Begin VB.CommandButton btnReset 
         Caption         =   "reset"
         Enabled         =   0   'False
         Height          =   255
         Left            =   1680
         TabIndex        =   19
         Top             =   310
         Width           =   615
      End
      Begin VB.TextBox txtX 
         Enabled         =   0   'False
         Height          =   285
         Left            =   360
         MaxLength       =   2
         TabIndex        =   16
         Top             =   300
         Width           =   375
      End
      Begin VB.TextBox txtZ 
         Enabled         =   0   'False
         Height          =   285
         Left            =   1080
         MaxLength       =   2
         TabIndex        =   15
         Top             =   300
         Width           =   375
      End
      Begin VB.Label lblZ 
         AutoSize        =   -1  'True
         Caption         =   "z:"
         Height          =   195
         Left            =   840
         TabIndex        =   18
         Top             =   310
         Width           =   120
      End
      Begin VB.Label lblX 
         AutoSize        =   -1  'True
         Caption         =   "x:"
         Height          =   195
         Left            =   120
         TabIndex        =   17
         Top             =   310
         Width           =   120
      End
   End
   Begin VB.Frame Frame3 
      Caption         =   "EAX Environment"
      ClipControls    =   0   'False
      Height          =   735
      Left            =   120
      TabIndex        =   0
      Top             =   3120
      Width           =   2415
      Begin VB.ComboBox cmbEAX 
         BackColor       =   &H00FFFFFF&
         Enabled         =   0   'False
         Height          =   315
         Left            =   120
         Style           =   2  'Dropdown List
         TabIndex        =   10
         Top             =   240
         Width           =   2175
      End
   End
End
Attribute VB_Name = "frm3Dtest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'/////////////////////////////////////////////////////////////
' BASS 3D test,  copyright (c) 1999 Adam Hoult.
'
' Updated: 2003-2007 by (: JOBnik! :) [Arthur Aminov, ISRAEL]
'                                     [http://www.jobnik.org]
'                                     [  jobnik@jobnik.org  ]
'
' Other source: frmDevice.frm
'
' Originally translated from - 3dtest.c - example of Ian Luck
'/////////////////////////////////////////////////////////////

Option Explicit

' channel (sample/music) info structure
Private Type channel
    channel As Long         ' the channel
    pos As BASS_3DVECTOR    ' position
    vel As BASS_3DVECTOR    ' velocity
End Type

Dim chans() As channel      ' array of channels
Dim chanc As Long           ' number of Channels
Dim chan As Long            ' current Channel

Const TIMERPERIOD = 50      ' timer period (ms)
Const MAXDIST = 50          ' maximum distance of the channels (m)
Const SPEED = 12            ' speed of the channels' movement (m/s)

' display error messages
Sub Error_(ByVal es As String)
    Call MsgBox(es & vbCrLf & vbCrLf & "error code: " & BASS_ErrorGetCode, vbExclamation, "Error")
End Sub

Private Sub Form_Load()
    ' change and set the current path, to prevent from VB not finding BASS.DLL
    ChDrive App.Path
    ChDir App.Path
    
    ' check the correct BASS was loaded
    If (HiWord(BASS_GetVersion) <> BASSVERSION) Then
        Call MsgBox("An incorrect version of BASS.DLL was loaded", vbCritical)
        End
    End If
    
    With cmbEAX
        .AddItem "Off"
        .AddItem "Generic"
        .AddItem "Padded Cell"
        .AddItem "Room"
        .AddItem "Bathroom"
        .AddItem "Living Room"
        .AddItem "Stone Room"
        .AddItem "Auditorium"
        .AddItem "Concert Hall"
        .AddItem "Cave"
        .AddItem "Arena"
        .AddItem "Hangar"
        .AddItem "Carpeted Hallway"
        .AddItem "Hallway"
        .AddItem "Stone Corridor"
        .AddItem "Alley"
        .AddItem "Forest"
        .AddItem "City"
        .AddItem "Mountains"
        .AddItem "Quarry"
        .AddItem "Plain"
        .AddItem "Parking Lot"
        .AddItem "Sewer Pipe"
        .AddItem "Under Water"
        .AddItem "Drugged"
        .AddItem "Dizzy"
        .AddItem "Psychotic"
        .ListIndex = 0
    End With
    
    chanc = 0
    chan = -1

    ' Show the main window
    Me.Show

    ' Initialize the default output device with 3D support
    If (BASS_Init(-1, 44100, BASS_DEVICE_3D, Me.hWnd, 0) = 0) Then
        Call Error_("Can't initialize output device")
        End
    End If

    ' Use meters as distance unit, real world rolloff, real doppler effect
    Call BASS_Set3DFactors(1, 1, 1)

    ' Turn EAX off (volume=0), if error then EAX is not supported
    If BASS_SetEAXParameters(-1, 0, -1, -1) Then cmbEAX.Enabled = True

    Call UpdateButtons
    tmr3D.Enabled = True
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call BASS_Free
    Erase chans
End Sub

Sub Update()
    Dim c As Integer, X As Integer, Y As Integer, cx As Integer, cy As Integer

    cx = picDisplay.ScaleWidth / 2
    cy = picDisplay.ScaleHeight / 2

    ' Clear the display
    picDisplay.Cls

    ' Draw Center Circle
    picDisplay.FillColor = RGB(100, 100, 100)
    picDisplay.Circle (cx - 4, cy - 4), 4, RGB(0, 0, 0)

    For c = 0 To chanc - 1
        ' If the channel is playing, then update it's position
        If BASS_ChannelIsActive(chans(c).channel) = BASS_ACTIVE_PLAYING Then
            ' Check if channel has reached the max distance
            If chans(c).pos.z >= MAXDIST Or chans(c).pos.z <= -MAXDIST Then chans(c).vel.z = -chans(c).vel.z
            If chans(c).pos.X >= MAXDIST Or chans(c).pos.X <= -MAXDIST Then chans(c).vel.X = -chans(c).vel.X
            
            ' Update channel position
            chans(c).pos.z = chans(c).pos.z + chans(c).vel.z * TIMERPERIOD / 1000
            chans(c).pos.X = chans(c).pos.X + chans(c).vel.X * TIMERPERIOD / 1000
            Call BASS_ChannelSet3DPosition(chans(c).channel, chans(c).pos, 0, chans(c).vel)
        End If
        ' Draw the channel position indicator
        X = cx + Int((cx - 7) * chans(c).pos.X / MAXDIST)
        Y = cy - Int((cy - 7) * chans(c).pos.z / MAXDIST)

        If chan = c Then
            picDisplay.FillColor = RGB(255, 0, 0)
        Else
            picDisplay.FillColor = RGB(150, 0, 0)
        End If
        picDisplay.Circle (X - 4, Y - 4), 4, RGB(0, 0, 0)
    Next c

    ' Apply 3d changes
    Call BASS_Apply3D
End Sub

' Update the button states
Sub UpdateButtons()
    ' Disable/enable controls depending on chanc
    cmdRemove.Enabled = IIf(chan = -1, False, True)
    cmdPlay.Enabled = IIf(chan = -1, False, True)
    cmdStop.Enabled = IIf(chan = -1, False, True)
    txtX.Enabled = IIf(chan = -1, False, True)
    txtZ.Enabled = IIf(chan = -1, False, True)
    btnReset.Enabled = IIf(chan = -1, False, True)

    If (chan <> -1) Then
        txtX.Text = Abs(Int(chans(chan).vel.X))
        txtZ.Text = Abs(Int(chans(chan).vel.z))
    End If
End Sub

Private Sub cmbEAX_Click()
    ' Change the EAX Environment depending on which is selected
    Select Case cmbEAX.ListIndex
        Case 0: BASS_SetEAXParameters -1, 0, -1, -1
        Case 1: BASS_SetEAXPreset EAX_ENVIRONMENT_GENERIC
        Case 2: BASS_SetEAXPreset EAX_ENVIRONMENT_PADDEDCELL
        Case 3: BASS_SetEAXPreset EAX_ENVIRONMENT_ROOM
        Case 4: BASS_SetEAXPreset EAX_ENVIRONMENT_BATHROOM
        Case 5: BASS_SetEAXPreset EAX_ENVIRONMENT_LIVINGROOM
        Case 6: BASS_SetEAXPreset EAX_ENVIRONMENT_STONEROOM
        Case 7: BASS_SetEAXPreset EAX_ENVIRONMENT_AUDITORIUM
        Case 8: BASS_SetEAXPreset EAX_ENVIRONMENT_CONCERTHALL
        Case 9: BASS_SetEAXPreset EAX_ENVIRONMENT_CAVE
        Case 10: BASS_SetEAXPreset EAX_ENVIRONMENT_ARENA
        Case 11: BASS_SetEAXPreset EAX_ENVIRONMENT_HANGAR
        Case 12: BASS_SetEAXPreset EAX_ENVIRONMENT_CARPETEDHALLWAY
        Case 13: BASS_SetEAXPreset EAX_ENVIRONMENT_HALLWAY
        Case 14: BASS_SetEAXPreset EAX_ENVIRONMENT_STONECORRIDOR
        Case 15: BASS_SetEAXPreset EAX_ENVIRONMENT_ALLEY
        Case 16: BASS_SetEAXPreset EAX_ENVIRONMENT_FOREST
        Case 17: BASS_SetEAXPreset EAX_ENVIRONMENT_CITY
        Case 18: BASS_SetEAXPreset EAX_ENVIRONMENT_MOUNTAINS
        Case 19: BASS_SetEAXPreset EAX_ENVIRONMENT_QUARRY
        Case 20: BASS_SetEAXPreset EAX_ENVIRONMENT_PLAIN
        Case 21: BASS_SetEAXPreset EAX_ENVIRONMENT_PARKINGLOT
        Case 22: BASS_SetEAXPreset EAX_ENVIRONMENT_SEWERPIPE
        Case 23: BASS_SetEAXPreset EAX_ENVIRONMENT_UNDERWATER
        Case 24: BASS_SetEAXPreset EAX_ENVIRONMENT_DRUGGED
        Case 25: BASS_SetEAXPreset EAX_ENVIRONMENT_DIZZY
        Case 26: BASS_SetEAXPreset EAX_ENVIRONMENT_PSYCHOTIC
    End Select
End Sub

Private Sub cmdAdd_Click()
    On Local Error Resume Next

    DLG.filename = ""
    DLG.CancelError = True
    DLG.flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly
    DLG.Filter = "wav/aif/mo3/xm/mod/s3m/it/mtm/umx|*.wav;*.aif;*.mo3;*.xm;*.mod;*.s3m;*.it;*.mtm;*.umx|All Files (*.*)|*.*|"
    DLG.ShowOpen
    
    ' if cancel was pressed, exit the procedure
    If Err.Number = 32755 Then Exit Sub
    
    Dim newchan As Long

    ' Load a music or sample from "DLG.FileName"
    newchan = BASS_MusicLoad(BASSFALSE, StrPtr(DLG.filename), 0, 0, BASS_MUSIC_RAMP Or BASS_MUSIC_LOOP Or BASS_SAMPLE_3D, 1)
    If newchan = 0 Then newchan = BASS_SampleLoad(BASSFALSE, StrPtr(DLG.filename), 0, 0, 1, BASS_SAMPLE_LOOP Or BASS_SAMPLE_3D)

    If newchan Then
        ReDim Preserve chans(chanc) As channel
        chans(chanc).channel = newchan
        lstChannels.AddItem GetFileName(DLG.filename)
        Call BASS_SampleGetChannel(newchan, BASSFALSE) ' initialize sample channel
        chanc = chanc + 1
    Else
        Call Error_("Can't load file (note samples must be mono)")
    End If
End Sub

' Play the select sample/music
Private Sub cmdPlay_Click()
    Call BASS_ChannelPlay(chans(chan).channel, BASSFALSE)
End Sub

Private Sub cmdRemove_Click()
    Call BASS_SampleFree(chans(chan).channel)
    Call BASS_MusicFree(chans(chan).channel)

    ' remove the item from the array
    Dim TempChans() As channel, Counter As Integer
    ReDim TempChans(chanc) As channel

    Counter = 0

    Dim i As Integer

    For i = 0 To chanc - 1
        If i <> chan Then
            TempChans(Counter) = chans(i)
            Counter = Counter + 1
        End If
    Next i

    chanc = chanc - 1

    ReDim chans(chanc) As channel

    For i = 0 To chanc - 1
        chans(i) = TempChans(i)
    Next i

    Erase TempChans

    lstChannels.RemoveItem lstChannels.ListIndex
    chan = -1
    Call UpdateButtons
End Sub

' stop playing music/sample
Private Sub cmdStop_Click()
    Call BASS_ChannelPause(chans(chan).channel)
End Sub

' Change the rolloff factor
Private Sub ID_Rolloff_Scroll()
    Call BASS_Set3DFactors(-1#, 2# ^ ((ID_Rolloff.value - 10) / 5#), -1#)
End Sub

' Change the doppler factor
Private Sub ID_Doppler_Scroll()
    Call BASS_Set3DFactors(-1#, -1#, 2# ^ ((ID_Doppler.value - 10) / 5#))
End Sub

' Change the selected channel
Private Sub lstChannels_Click()
    chan = lstChannels.ListIndex
    Call UpdateButtons
End Sub

' X velocity
Private Sub txtX_Change()
    Dim v As Integer
    v = Val(txtX.Text)
    If (Abs(Int(chans(chan).vel.X)) <> v) Then chans(chan).vel.X = v
End Sub

Private Sub txtX_KeyPress(keyascii As Integer)
    keyascii = numbersOnly(keyascii)
End Sub

' Z velocity
Private Sub txtZ_Change()
    Dim v As Integer
    v = Val(txtZ.Text)
    If (Abs(Int(chans(chan).vel.z)) <> v) Then chans(chan).vel.z = v
End Sub

Private Sub txtZ_KeyPress(keyascii As Integer)
    keyascii = numbersOnly(keyascii)
End Sub

Private Sub tmr3D_Timer()
    Call Update
End Sub

' reset the position and velocity to 0
Private Sub btnReset_Click()
    Dim tmp As BASS_3DVECTOR    ' VB's default value is 0 ;)
    chans(chan).pos = tmp
    chans(chan).vel = tmp
    Call UpdateButtons
End Sub

'--------------------
' useful function :)
'--------------------

' get file name from file path
Public Function GetFileName(ByVal fp As String) As String
    GetFileName = Mid(fp, InStrRev(fp, "\") + 1)
End Function

' checks if keyascii is a number or a backspace
Public Function numbersOnly(ByVal keyascii As Integer) As Integer
    If (keyascii < vbKey0 Or keyascii > vbKey9) Then keyascii = IIf(keyascii = vbKeyBack, keyascii, 0)
    numbersOnly = keyascii
End Function