frm3dtest.frm

bass player system api c++

        .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, 0)
    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