home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / bass / vb / RecTest / frmRecTest.frm (.txt) next >
Encoding:
Visual Basic Form  |  2005-09-22  |  6.8 KB  |  205 lines
  1. VERSION 5.00
  2. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
  3. Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
  4. Begin VB.Form frmRecTest 
  5.    BorderStyle     =   3  'Fixed Dialog
  6.    Caption         =   "BASS recording test"
  7.    ClientHeight    =   990
  8.    ClientLeft      =   600
  9.    ClientTop       =   990
  10.    ClientWidth     =   4965
  11.    LinkTopic       =   "Form1"
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    ScaleHeight     =   990
  15.    ScaleWidth      =   4965
  16.    StartUpPosition =   2  'CenterScreen
  17.    Begin MSComctlLib.Slider sldInputLevel 
  18.       Height          =   255
  19.       Left            =   120
  20.       TabIndex        =   5
  21.       Top             =   720
  22.       Width           =   1455
  23.       _ExtentX        =   2566
  24.       _ExtentY        =   450
  25.       _Version        =   393216
  26.       Max             =   100
  27.       SelectRange     =   -1  'True
  28.       TickStyle       =   3
  29.    End
  30.    Begin VB.ComboBox cmbInput 
  31.       Height          =   315
  32.       Left            =   120
  33.       Style           =   2  'Dropdown List
  34.       TabIndex        =   3
  35.       Top             =   160
  36.       Width           =   1455
  37.    End
  38.    Begin MSComDlg.CommonDialog cmd 
  39.       Left            =   4440
  40.       Top             =   480
  41.       _ExtentX        =   847
  42.       _ExtentY        =   847
  43.       _Version        =   393216
  44.    End
  45.    Begin VB.Timer tmrRecTest 
  46.       Enabled         =   0   'False
  47.       Interval        =   200
  48.       Left            =   3960
  49.       Top             =   480
  50.    End
  51.    Begin VB.CommandButton btnSave 
  52.       Caption         =   "Save"
  53.       Enabled         =   0   'False
  54.       Height          =   300
  55.       Left            =   4080
  56.       TabIndex        =   2
  57.       Top             =   170
  58.       Width           =   735
  59.    End
  60.    Begin VB.CommandButton btnPlay 
  61.       Caption         =   "Play"
  62.       Enabled         =   0   'False
  63.       Height          =   300
  64.       Left            =   3120
  65.       TabIndex        =   1
  66.       Top             =   170
  67.       Width           =   855
  68.    End
  69.    Begin VB.CommandButton btnRecord 
  70.       Caption         =   "Record"
  71.       Height          =   300
  72.       Left            =   1680
  73.       TabIndex        =   0
  74.       Top             =   170
  75.       Width           =   1335
  76.    End
  77.    Begin VB.Label lblPos 
  78.       Alignment       =   2  'Center
  79.       BorderStyle     =   1  'Fixed Single
  80.       Height          =   285
  81.       Left            =   1680
  82.       TabIndex        =   6
  83.       Top             =   600
  84.       Width           =   3135
  85.    End
  86.    Begin VB.Label lblInputType 
  87.       Alignment       =   2  'Center
  88.       Height          =   195
  89.       Left            =   120
  90.       TabIndex        =   4
  91.       Top             =   480
  92.       Width           =   1440
  93.    End
  94. Attribute VB_Name = "frmRecTest"
  95. Attribute VB_GlobalNameSpace = False
  96. Attribute VB_Creatable = False
  97. Attribute VB_PredeclaredId = True
  98. Attribute VB_Exposed = False
  99. '////////////////////////////////////////////////////////////////////////////////
  100. ' frmRecTest.frm - Copyright (c) 2002-2005 (: JOBnik! :) [Arthur Aminov, ISRAEL]
  101. '                                                        [http://www.jobnik.org]
  102. '                                                        [  jobnik@jobnik.org  ]
  103. ' Other source: modRecTest.bas
  104. ' BASS Recording example
  105. ' Originally translated from - rectest.c - Example of Ian Luck
  106. '////////////////////////////////////////////////////////////////////////////////
  107. Option Explicit
  108. Private Sub Form_Load()
  109.     'change and set the current path
  110.     'so VB won't ever tell you that "bass.dll" isn't found
  111.     ChDrive App.Path
  112.     ChDir App.Path
  113.     'check if "bass.dll" is exists
  114.     If (Not FileExists(RPP(App.Path) & "bass.dll")) Then
  115.         Call MsgBox("BASS.DLL does not exists", vbCritical, "BASS.DLL")
  116.         End
  117.     End If
  118.     'Check that BASS 2.2 was loaded
  119.     If (BASS_GetVersion <> MakeLong(2, 2)) Then
  120.         Call MsgBox("BASS version 2.2 was not loaded", vbCritical, "Incorrect BASS.DLL")
  121.         End
  122.     End If
  123.     'setup recording and output devices (using default devices)
  124.     If (BASS_RecordInit(-1) = 0) Or (BASS_Init(-1, 44100, 0, Me.hwnd, 0) = 0) Then
  125.         Call Error_("Can't initialize device")
  126.         End
  127.     Else
  128.         'get list of inputs
  129.         Dim c As Integer
  130.         input_ = -1
  131.         While BASS_RecordGetInputName(c)
  132.             cmbInput.AddItem VBStrFromAnsiPtr(BASS_RecordGetInputName(c))
  133.             If (BASS_RecordGetInput(c) And BASS_INPUT_OFF) = 0 Then
  134.                 cmbInput.ListIndex = c  'this 1 is currently "on"
  135.                 input_ = c
  136.                 Call UpdateInputInfo    'display info
  137.             End If
  138.             c = c + 1
  139.         Wend
  140.     End If
  141.     tmrRecTest.Enabled = True   'timer to update the position display (200ms)
  142.     recPTR = 0
  143.     reclen = 0
  144.     BUFSTEP = 200000    'memory allocation unit
  145. End Sub
  146. Private Sub Form_Unload(Cancel As Integer)
  147.     'release all BASS stuff
  148.     Call GlobalFree(ByVal recPTR)
  149.     Call BASS_RecordFree
  150.     Call BASS_Free
  151. End Sub
  152. 'input selection changed
  153. Private Sub cmbInput_Click()
  154.     input_ = cmbInput.ListIndex 'get the selection
  155.     'enable the selected input
  156.     Dim i As Integer
  157.     For i = 0 To cmbInput.ListCount - 1
  158.         Call BASS_RecordSetInput(i, BASS_INPUT_OFF) '1st disable all inputs, then...
  159.     Next i
  160.     Call BASS_RecordSetInput(input_, BASS_INPUT_ON) 'enable the selected input
  161.     Call UpdateInputInfo
  162. End Sub
  163. Private Sub btnPlay_Click()
  164.     Call BASS_ChannelPlay(chan, BASSFALSE)  'play the recorded data
  165. End Sub
  166. Private Sub btnRecord_Click()
  167.     If (rchan = 0) Then
  168.         Call StartRecording
  169.     Else
  170.         Call StopRecording
  171.     End If
  172. End Sub
  173. Private Sub btnSave_Click()
  174.     Call WriteToDisk
  175. End Sub
  176. 'set input source level
  177. Private Sub sldInputLevel_Scroll()
  178.     Dim level As Long
  179.     level = sldInputLevel.value
  180.     Call BASS_RecordSetInput(input_, BASS_INPUT_LEVEL Or level)
  181. End Sub
  182. Private Sub tmrRecTest_Timer()
  183.     'update the recording/playback counter
  184.     If (rchan) Then 'recording/encoding
  185.         lblPos.Caption = BASS_ChannelGetPosition(rchan)
  186.     ElseIf (chan) Then
  187.         If (BASS_ChannelIsActive(chan)) Then 'playing
  188.             lblPos.Caption = BASS_ChannelGetPosition(chan) & " / " & BASS_ChannelGetLength(chan)
  189.         Else
  190.             lblPos.Caption = BASS_ChannelGetLength(chan)
  191.         End If
  192.     End If
  193. End Sub
  194. '--------------------------
  195. ' some useful functions :)
  196. '--------------------------
  197. 'check if any file exists
  198. Public Function FileExists(ByVal fp As String) As Boolean
  199.     FileExists = (Dir(fp) <> "")
  200. End Function
  201. 'RPP = Return Proper Path
  202. Function RPP(ByVal fp As String) As String
  203.     RPP = IIf(Mid(fp, Len(fp), 1) <> "\", fp & "\", fp)
  204. End Function
  205.