UltimaSerial How to write a VB program to capture raw data from the microphone on your PC
Data logger
UltimaSerial

 

Windaq add-ons
Windaq Add-ons

 

Spectrogram
UltimaWaterfall

 

Ultimaserial XChart
XChart

 

FFT1024
FFT1024

 

Ultimaserial Classroom
Lessons

 

This is the in-depth study of the VB source codes of our original UltimaSound project. Due to copyright issue, the source of the latest version cannot be made public. If you wish to see the original version of UltimaSound, here it is

This project uses XChart, UltimaWaterfall, and FFT1024 controls, please check out XChart reference,  UltimaWaterfall reference, and FFT1024 reference for further info

It demonstrates how to use VB to call Windows Wave APIs to interface to any microphone on your PC to acquire raw data stream,  perform a FFT operation and display a spectrogram and waterfall spectrogram

This VB project contains two files, Sound.bas and Ultimasound.frm. 

  Sound.bas 

Sound.bas defines the prototypes of Windows Wave APIs and structures to be used in UltimaSound.frm. 

You may find difference in our definition and the one created by Visual BASIC's API viewer, but watch out, Visual BASIC's API viewer actually generates wrong definition for some of the APIs!

Public Const MAXPNAMELEN = 32 ' max product name length (including NULL)

Public Type WAVEHDR
      lpData As Long
      dwBufferLength As Long
      dwBytesRecorded As Long
      dwUser As Long
      dwFlags As Long
      dwLoops As Long
      lpNext As Long
      Reserved As Long
End Type

Public Type WAVEINCAPS
      wMid As Integer
      wPid As Integer
     vDriverVersion As Long
     szPname As String * MAXPNAMELEN
     dwFormats As Long
     wChannels As Integer
     dwSupport As Long
End Type


Public Type WAVEFORMAT
     wFormatTag As Integer
     nChannels As Integer
     nSamplesPerSec As Long
     nAvgBytesPerSec As Long
     nBlockAlign As Integer
     wBitsPerSample As Integer
     cbSize As Integer
End Type

Public Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInGetDevCaps Lib "winmm.dll" Alias "waveInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEINCAPS, ByVal uSize As Long) As Long
Public Declare Function waveInGetID Lib "winmm.dll" (ByVal hWaveIn As Long, lpuDeviceID As Long) As Long
Public Declare Function waveInGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function waveInOpen Lib "winmm.dll" (lphWaveIn As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMAT, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
Public Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
Public Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
Public Declare Function GetProcessHeap Lib "kernel32" () As Long

Public Declare Sub CopyMemoryRead Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)

Const WAVERR_BADFORMAT = 32 'unsupported wave format
Const WAVERR_STILLPLAYING = 33 'still something playing
Const WAVERR_UNPREPARED = 34 'header not prepared
Const WAVERR_SYNC = 35 'device is synchronous
Const WAVERR_LASTERROR = 36 'last error in range

Const MMSYSERR_NOERROR = 0

Ultimasound.frm. 

Besides interfacing to the microphone on your PC via Windows multimedia APIs, Ultimasound.frm also contains controls like XChart, UltimaWaterfall and FFT1024 to complete the software. Watch out for Windows' Wave APIs in bold red.

Here are the steps to acquire the sound bytes directly from the microphone:

  1. Call waveInGetNumDevs to determine the number of the sound input devices
  2. CallwaveInGetDevCaps so that the user can select a sound input device from the pool
  3. CallwaveInOpen to open the selected device and allocate user buffer using HeapAlloc
  4. Call waveInStart to start the device. At this point, the sound bytes will not reach your program
  5. CallwaveInPrepareHeader and  waveInAddBuffer to allow Windows to stream the sound bytes to your own buffer
  6. Copy the data to your user array usingCopyMemoryRead 
  7. Repeat 5) and 6) if necessary
  8. CallwaveInStop and waveInClose when you are done
  9. CallHeapFree to release the buffer allocated in 3) 

'Copyright 2008 www.ultimaserial.com

Option Explicit
Const WAVE_FORMAT_PCM = 1
Const CALLBACK_NULL = 0

Dim NbSmpl As Integer
Dim DevHandle As Long
Dim myWaveFormat As WAVEFORMAT
Dim DataPtr As Long
Dim myWaveinCaps As WAVEINCAPS

Dim waveform(0 To 1023) As Integer

Const MMSYSERR_NOERROR = 0 '/* no error */
Const WHDR_DONE = &H1 '/* done bit */

Dim Wave1 As WAVEHDR
Dim hHeap As Long


Private Sub Check1_Click()
If Check1.Value = 1 Then
UltimaWaterfall1.ChartType = uw3D
Option4.Enabled = False
Else
UltimaWaterfall1.ChartType = uw2D
Option4.Enabled = True
End If
End Sub

Private Sub Command1_Click()
Dim i As Integer

myWaveFormat.wFormatTag = WAVE_FORMAT_PCM
myWaveFormat.nChannels = 1
myWaveFormat.nSamplesPerSec = Val(Combo1.Text)
myWaveFormat.wBitsPerSample = 16
myWaveFormat.nBlockAlign = myWaveFormat.nChannels * 
(myWaveFormat.wBitsPerSample / 8)
myWaveFormat.nAvgBytesPerSec = myWaveFormat.nSamplesPerSec * 
myWaveFormat.nBlockAlign
myWaveFormat.cbSize = 0
Label4.Caption = Format$(Val(Combo1.Text) / 2) + " Hz"

i = waveInOpen(DevHandle, Val(List1.Text), myWaveFormat, 0, 0, CALLBACK_NULL)
If i <> MMSYSERR_NOERROR Then
MsgBox "Failed to open sound input device!"
Exit Sub
End If

i = waveInStart(DevHandle)
If i <> MMSYSERR_NOERROR Then
MsgBox "Failed to start!"
Exit Sub
End If
Timer1.Enabled = True

Wave1.lpData = DataPtr
Wave1.dwBufferLength = NbSmpl
Wave1.dwFlags = 0

i = waveInPrepareHeader(DevHandle, Wave1, Len(Wave1))
If i <> MMSYSERR_NOERROR Then
MsgBox "Failed to prepare buffer!"
Exit Sub
End If

i = waveInAddBuffer(DevHandle, Wave1, Len(Wave1))
If i <> MMSYSERR_NOERROR Then
MsgBox "Failed to add buffer!"
Exit Sub
End If

End Sub

Private Sub Command2_Click()
Timer1.Enabled = False
Dim i As Integer
i = waveInStop(DevHandle)
i = waveInClose(DevHandle)
Call waveInUnprepareHeader(DevHandle, Wave1, Len(Wave1))
If i <> 0 Then
MsgBox "Error stopping wav input device " + Format$(i)
End If
End Sub

Private Sub Command3_Click()
XChart1.CopyToClipboard
End Sub

Private Sub Command4_Click()
UltimaWaterfall1.Copy2Clipboard
End Sub


Private Sub Form_Load()
Dim i As Integer
Dim j As Integer

XChart1.Ymin(0) = 0
XChart1.SumWaveforms = False
XChart1.Lock = True
XChart1.DoubleActiveTrace = False
XChart1.ScrollMode = False

NbSmpl = 1024
i = waveInGetNumDevs()
If i <= 0 Then
MsgBox "No microphone detected!"
End If

For j = 1 To i
Call waveInGetDevCaps(j - 1, myWaveinCaps, Len(myWaveinCaps))
If j = 1 Then
List1.Text = Format$(j - 1) + " " + myWaveinCaps.szPname
End If
List1.AddItem Format$(j - 1) + " " + myWaveinCaps.szPname
Next



hHeap = GetProcessHeap()

DataPtr = HeapAlloc(hHeap, 0, NbSmpl * 2)
If DataPtr = 0 Then
MsgBox "Failed to allocate memory for sound input device!"
Exit Sub
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

HeapFree GetProcessHeap(), 0, DataPtr

End Sub

Private Sub Option1_Click()
UltimaWaterfall1.ChartDirection = uwB2T
End Sub

Private Sub Option2_Click()
UltimaWaterfall1.ChartDirection = uwNSlope
End Sub

Private Sub Option3_Click()
UltimaWaterfall1.ChartDirection = uwSlope
End Sub

Private Sub Option4_Click()
UltimaWaterfall1.ChartDirection = uwR2L
End Sub

Private Sub Option5_Click()
UltimaWaterfall1.ChartDirection = uwT2B
End Sub

Private Sub Timer1_Timer()
Dim i As Integer

Do
Loop Until ((Wave1.dwFlags And WHDR_DONE) = WHDR_DONE) Or DevHandle = 0

CopyMemoryRead waveform(0), DataPtr, 2048

'Add buffer for next cycle
Wave1.lpData = DataPtr
Wave1.dwBufferLength = NbSmpl
Wave1.dwFlags = 0

i = waveInPrepareHeader(DevHandle, Wave1, Len(Wave1))
If i <> MMSYSERR_NOERROR Then
MsgBox "Failed to prepare header!"
Exit Sub
End If

i = waveInAddBuffer(DevHandle, Wave1, Len(Wave1))
If i <> MMSYSERR_NOERROR Then
MsgBox "Failed to add buffer!"
Exit Sub
End If

'Perform FFT on current waveform
FFT10241.waveform waveform

XChart1.Chart FFT10241.Power
UltimaWaterfall1.Chart FFT10241.Power


End Sub


Private Sub XChart1_CrossHair(ByVal Offset As Long)
Label5.Caption = Format$(Val(Combo1.Text) * Offset / 1024#, "0")
End Sub

.

 

 

Last update: 02/29/12

Copyright: 2000-2008  www.UltimaSerial.com