editor/bass-sys/bass24/vb/Synth/frmSynth.frm
2021-01-05 04:17:41 -06:00

175 lines
6.2 KiB
Text

VERSION 5.00
Begin VB.Form frmSynth
BorderStyle = 3 'Fixed Dialog
Caption = "BASS Simple Sinewave Synth"
ClientHeight = 3375
ClientLeft = 45
ClientTop = 435
ClientWidth = 4350
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 177
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 225
ScaleMode = 3 'Pixel
ScaleWidth = 290
StartUpPosition = 2 'CenterScreen
Begin VB.Label lblWinTxt
Height = 855
Left = 0
TabIndex = 0
Top = 2520
Width = 4335
End
End
Attribute VB_Name = "frmSynth"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'//////////////////////////////////////////////////////////////////////////////
' frmSynth.frm - Copyright (c) 2006-2007 (: JOBnik! :) [Arthur Aminov, ISRAEL]
' [http://www.jobnik.org]
' [ jobnik@jobnik.org ]
'
' Other source: modSynth.bas
'
' BASS Simple Synth
' Originally translated from - synth.c - Example of Ian Luck
'//////////////////////////////////////////////////////////////////////////////
Option Explicit
Dim str As Long
Dim fx(9) As Long ' effect handles
Dim r As Long, buflen As Long
Dim fxname As Variant
' 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
fxname = Array("CHORUS", "COMPRESSOR", "DISTORTION", "ECHO", "FLANGER", "GARGLE", "I3DL2REVERB", "PARAMEQ", "REVERB")
keys = Array("Q", "2", "W", "3", "E", "R", "5", "T", "6", "Y", "7", "U", "I", "9", "O", "0", "P", 219, 187, 221)
' check the correct BASS was loaded
If (HiWord(BASS_GetVersion()) <> BASSVERSION) Then
Call Error_("An incorrect version of BASS.DLL was loaded")
End
End If
' 10ms update period
Call BASS_SetConfig(BASS_CONFIG_UPDATEPERIOD, 10)
' setup output - get latency
If (BASS_Init(-1, 44100, BASS_DEVICE_LATENCY, 0, 0) = 0) Then
Call Error_("Can't initialize device")
End
End If
' build sine table
For r = 0 To TABLESIZE - 1
sinetable(r) = CLng(Sin(2# * PI * CDbl(r) / TABLESIZE) * 7000#)
Next r
Call BASS_GetInfo(info)
' default buffer size = update period + 'minbuf'
Call BASS_SetConfig(BASS_CONFIG_BUFFER, 10 + info.minbuf)
buflen = BASS_GetConfig(BASS_CONFIG_BUFFER)
' if the device's output rate is unknown default to 44100 Hz
If (info.freq = 0) Then info.freq = 44100
' create a stream, stereo so that effects sound nice
str = BASS_StreamCreate(info.freq, 2, 0, AddressOf WriteStream, 0)
Me.AutoRedraw = True
Me.KeyPreview = True
Print "device latency: " & info.latency & "ms"
Print "device minbuf : " & info.minbuf & "ms"
Print "ds version: " & info.dsver & " (effects " & IIf(info.dsver < 8, "disabled", "enabled") & ")"
Print "press these keys to play:" & vbCrLf
Print " 2 3 5 6 7 9 0 ="
Print " Q W ER T Y UI O P[ ]" & vbCrLf
Print "press -/+ to de/increase the buffer"
Print "press spacebar to quit" & vbCrLf
If (info.dsver >= 8) Then ' DX8 effects available
Print "press F1-F9 to toggle effects" & vbCrLf
End If
lblWinTxt.Caption = "using a " & buflen & "ms buffer"
Call BASS_ChannelPlay(str, BASSFALSE)
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = vbKeySpace) Then Call Unload(Me)
If (KeyCode = vbKeySubtract Or KeyCode = vbKeyAdd) Then
' recreate stream with smaller/larger buffer
Call BASS_StreamFree(str)
If (KeyCode = vbKeySubtract) Then
Call BASS_SetConfig(BASS_CONFIG_BUFFER, buflen - 1) ' smaller buffer
Else
Call BASS_SetConfig(BASS_CONFIG_BUFFER, buflen + 1) ' larger buffer
End If
buflen = BASS_GetConfig(BASS_CONFIG_BUFFER)
lblWinTxt.Caption = "using a " & buflen & "ms buffer"
str = BASS_StreamCreate(info.freq, 2, 0, AddressOf WriteStream, 0)
' set effects on the new stream
For r = 0 To 9
If (fx(r)) Then fx(r) = BASS_ChannelSetFX(str, BASS_FX_DX8_CHORUS + r, 0)
Next r
Call BASS_ChannelPlay(str, BASSFALSE)
End If
If (KeyCode >= vbKeyF1 And KeyCode <= vbKeyF9) Then
r = KeyCode - vbKeyF1
If (fx(r)) Then
Call BASS_ChannelRemoveFX(str, fx(r))
fx(r) = 0
lblWinTxt.Caption = "effect " & fxname(r) & " = OFF"
Else
' set the effect, not bothering with parameters (use defaults)
fx(r) = BASS_ChannelSetFX(str, BASS_FX_DX8_CHORUS + r, 0)
If (fx(r)) Then lblWinTxt.Caption = "effect " & fxname(r) & " = ON"
End If
End If
Dim key As Long
For key = 0 To KEYS_ - 1
If (KeyCode = keys(key) Or KeyCode = Asc(keys(key))) Then Exit For
Next key
If (key <> KEYS_) Then
If (KeyCode And (vol(key) <> MAXVOL)) Then
pos(key) = 0
vol(key) = MAXVOL ' start key
ElseIf ((KeyCode = 0) And vol(key)) Then
vol(key) = vol(key) - 1 ' trigger key fadeout
End If
End If
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
Dim key As Long
For key = 0 To KEYS_ - 1
If (KeyCode = keys(key) Or KeyCode = Asc(keys(key))) Then Exit For
Next key
If (key <> KEYS_) Then vol(key) = vol(key) - 1 ' trigger key fadeout
End Sub
Private Sub Form_Unload(Cancel As Integer)
BASS_Free
End Sub