home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / bass / vb / RecTest / modRecTest.bas < prev    next >
Encoding:
BASIC Source File  |  2005-09-21  |  8.3 KB  |  240 lines
  1. Attribute VB_Name = "modRecTest"
  2. '////////////////////////////////////////////////////////////////////////////////
  3. ' modRecTest.bas - Copyright (c) 2002-2005 (: JOBnik! :) [Arthur Aminov, ISRAEL]
  4. '                                                        [http://www.jobnik.org]
  5. '                                                        [  jobnik@jobnik.org  ]
  6. '
  7. ' Other source: frmRecTest.frm
  8. '
  9. ' BASS Recording example
  10. ' Originally translated from - rectest.c - Example of Ian Luck
  11. '////////////////////////////////////////////////////////////////////////////////
  12.  
  13. Option Explicit
  14.  
  15. 'MEMORY
  16. Public Const GMEM_FIXED = &H0
  17. Public Const GMEM_MOVEABLE = &H2
  18. Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  19. Public Declare Function GlobalReAlloc Lib "kernel32" (ByVal hMem As Long, ByVal dwBytes As Long, ByVal wFlags As Long) As Long
  20. Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  21. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  22.  
  23. 'FILE
  24. Const OFS_MAXPATHNAME = 128
  25. Const OF_CREATE = &H1000
  26. Const OF_READ = &H0
  27. Const OF_WRITE = &H1
  28.  
  29. Private Type OFSTRUCT
  30.         cBytes As Byte
  31.         fFixedDisk As Byte
  32.         nErrCode As Integer
  33.         Reserved1 As Integer
  34.         Reserved2 As Integer
  35.         szPathName(OFS_MAXPATHNAME) As Byte
  36. End Type
  37.  
  38. Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
  39. Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
  40. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  41.  
  42. 'WAV Header
  43. Private Type WAVEHEADER_RIFF  '12 bytes
  44.     RIFF As Long                '"RIFF" = &H46464952
  45.     riffBlockSize As Long       'reclen - 8
  46.     riffBlockType As Long       '"WAVE" = &H45564157
  47. End Type
  48.  
  49. Private Type WAVEFORMAT     '24 bytes
  50.     wfBlockType As Long         '"fmt " = &H20746D66
  51.     wfBlockSize As Long
  52.     '--- block size begins from here = 16 bytes
  53.     wFormatTag As Integer
  54.     nChannels As Integer
  55.     nSamplesPerSec As Long
  56.     nAvgBytesPerSec As Long
  57.     nBlockAlign As Integer
  58.     wBitsPerSample As Integer
  59. End Type
  60.  
  61. Private Type WAVEHEADER_data  '8 bytes
  62.    dataBlockType As Long        '"data" = &H61746164
  63.    dataBlockSize As Long        'reclen - 44
  64. End Type
  65.  
  66. Dim wr As WAVEHEADER_RIFF
  67. Dim wf As WAVEFORMAT
  68. Dim wd As WAVEHEADER_data
  69.  
  70. Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
  71.  
  72. Public BUFSTEP As Long        'memory allocation unit
  73. Public input_ As Long         'current input source
  74. Public recPTR As Long         'a recording pointer to a memory location
  75. Public reclen As Long         'buffer length
  76.  
  77. Public rchan As Long          'recording channel
  78. Public chan As Long           'playback channel
  79.  
  80. 'display error messages
  81. Public Sub Error_(ByVal es As String)
  82.     Call MessageBox(frmRecTest.hwnd, es & vbCrLf & vbCrLf & "error code: " & BASS_ErrorGetCode, "Error", vbExclamation)
  83. End Sub
  84.  
  85. 'buffer the recorded data
  86. Public Function RecordingCallback(ByVal handle As Long, ByVal buffer As Long, ByVal length As Long, ByVal user As Long) As Long
  87.     'increase buffer size if needed
  88.     If ((reclen Mod BUFSTEP) + length >= BUFSTEP) Then
  89.         recPTR = GlobalReAlloc(ByVal recPTR, ((reclen + length) / BUFSTEP + 1) * BUFSTEP, GMEM_MOVEABLE)
  90.         If recPTR = 0 Then
  91.             rchan = 0
  92.             Call Error_("Out of memory!")
  93.             frmRecTest.btnRecord.Caption = "Record"
  94.             RecordingCallback = BASSFALSE 'stop recording
  95.             Exit Function
  96.         End If
  97.     End If
  98.     'buffer the data
  99.     Call CopyMemory(ByVal recPTR + reclen, ByVal buffer, length)
  100.     reclen = reclen + length
  101.     RecordingCallback = BASSTRUE 'continue recording
  102. End Function
  103.  
  104. Public Sub StartRecording()
  105.     'free old recording
  106.     If (recPTR) Then
  107.         Call BASS_StreamFree(chan)
  108.         Call GlobalFree(ByVal recPTR)
  109.         recPTR = 0
  110.         chan = 0
  111.         frmRecTest.btnPlay.Enabled = False
  112.         frmRecTest.btnSave.Enabled = False
  113.     End If
  114.  
  115.     'allocate initial buffer and make space for WAVE header
  116.     recPTR = GlobalAlloc(GMEM_FIXED, BUFSTEP)
  117.     reclen = 44
  118.  
  119.     'fill the WAVE header
  120.     wf.wFormatTag = 1
  121.     wf.nChannels = 2
  122.     wf.wBitsPerSample = 16
  123.     wf.nSamplesPerSec = 44100
  124.     wf.nBlockAlign = wf.nChannels * wf.wBitsPerSample / 8
  125.     wf.nAvgBytesPerSec = wf.nSamplesPerSec * wf.nBlockAlign
  126.  
  127.     'Set WAV "fmt " header
  128.     wf.wfBlockType = &H20746D66      '"fmt "
  129.     wf.wfBlockSize = 16
  130.  
  131.     'Set WAV "RIFF" header
  132.     wr.RIFF = &H46464952             '"RIFF"
  133.     wr.riffBlockSize = 0             'after recording
  134.     wr.riffBlockType = &H45564157    '"WAVE"
  135.  
  136.     'set WAV "data" header
  137.     wd.dataBlockType = &H61746164    '"data"
  138.     wd.dataBlockSize = 0             'after recording
  139.  
  140.     'copy WAV Header to Memory
  141.     Call CopyMemory(ByVal recPTR, wr, LenB(wr))        '"RIFF"
  142.     Call CopyMemory(ByVal recPTR + 12, wf, LenB(wf))   '"fmt "
  143.     Call CopyMemory(ByVal recPTR + 36, wd, LenB(wd))   '"data"
  144.  
  145.     'start recording @ 44100hz 16-bit stereo
  146.     rchan = BASS_RecordStart(44100, 2, 0, AddressOf RecordingCallback, 0)
  147.  
  148.     If (rchan = 0) Then
  149.         Call Error_("Couldn't start recording")
  150.         Call GlobalFree(ByVal recPTR)
  151.         recPTR = 0
  152.         Exit Sub
  153.     End If
  154.     frmRecTest.btnRecord.Caption = "Stop"
  155. End Sub
  156.  
  157. Public Sub StopRecording()
  158.     Call BASS_ChannelStop(rchan)
  159.     rchan = 0
  160.     frmRecTest.btnRecord.Caption = "Record"
  161.  
  162.     'complete the WAVE header
  163.     wr.riffBlockSize = reclen - 8
  164.     wd.dataBlockSize = reclen - 44
  165.  
  166.     Call CopyMemory(ByVal recPTR + 4, wr.riffBlockSize, LenB(wr.riffBlockSize))
  167.     Call CopyMemory(ByVal recPTR + 40, wd.dataBlockSize, LenB(wd.dataBlockSize))
  168.  
  169.     'create a stream from the recording
  170.     chan = BASS_StreamCreateFile(BASSTRUE, recPTR, 0, reclen, 0)
  171.     If (chan) Then
  172.         'enable "play" & "save" buttons
  173.         frmRecTest.btnPlay.Enabled = True
  174.         frmRecTest.btnSave.Enabled = True
  175.     End If
  176. End Sub
  177.  
  178. 'write the recorded data to disk
  179. Public Sub WriteToDisk()
  180.     On Local Error Resume Next    'if Cancel pressed...
  181.  
  182.     With frmRecTest.cmd
  183.         .CancelError = True
  184.         .flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly
  185.         .DialogTitle = "Save As..."
  186.         .Filter = "WAV files|*.wav|All files|*.*"
  187.         .DefaultExt = "wav"
  188.         .ShowSave
  189.  
  190.         'if cancel was pressed, exit the procedure
  191.         If Err.Number = 32755 Then Exit Sub
  192.  
  193.         'create a file .WAV, directly from Memory location
  194.         Dim FileHandle As Long, ret As Long, OF As OFSTRUCT
  195.  
  196.         FileHandle = OpenFile(.FileName, OF, OF_CREATE)
  197.  
  198.         If (FileHandle = 0) Then
  199.             Call Error_("Can't create the file")
  200.             Exit Sub
  201.         End If
  202.  
  203.         Call WriteFile(FileHandle, ByVal recPTR, reclen, ret, ByVal 0&)
  204.         Call CloseHandle(FileHandle)
  205.     End With
  206. End Sub
  207.  
  208. Public Sub UpdateInputInfo()
  209.     Dim it As Long
  210.     it = BASS_RecordGetInput(input_)  'get info on the input
  211.     frmRecTest.sldInputLevel.value = LoWord(it)  'set the level slider
  212.     
  213.     Dim type_ As String
  214.     Select Case (it And BASS_INPUT_TYPE_MASK)
  215.         Case BASS_INPUT_TYPE_DIGITAL:
  216.             type_ = "digital"
  217.         Case BASS_INPUT_TYPE_LINE:
  218.             type_ = "line-in"
  219.         Case BASS_INPUT_TYPE_MIC:
  220.             type_ = "microphone"
  221.         Case BASS_INPUT_TYPE_SYNTH:
  222.             type_ = "midi synth"
  223.         Case BASS_INPUT_TYPE_CD:
  224.             type_ = "analog cd"
  225.         Case BASS_INPUT_TYPE_PHONE:
  226.             type_ = "telephone"
  227.         Case BASS_INPUT_TYPE_SPEAKER:
  228.             type_ = "pc speaker"
  229.         Case BASS_INPUT_TYPE_WAVE:
  230.             type_ = "wave/pcm"
  231.         Case BASS_INPUT_TYPE_AUX:
  232.             type_ = "aux"
  233.         Case BASS_INPUT_TYPE_ANALOG:
  234.             type_ = "analog"
  235.         Case Else:
  236.             type_ = "undefined"
  237.     End Select
  238.     frmRecTest.lblInputType.Caption = type_ 'display the type
  239. End Sub
  240.