Tone generation

[Martin Waller]

Hello,

Does anyone know of any goods ways of generating tones of fixed frequency
for a given duration ?

Martin

[Howard Henry Schlunder]

I once wrote the code to do almost what you ask, except I didn't know how to generate a specific frequency. Someone else came along and refined it (search Google to find out who).

In a Form named frmMain, add two TextBoxes (txtFreq and txtBufferLength), one command button (cmdMakeSound), and one scroll bar (hsbVolume). Then add the following code to the form:

Option Explicit
Private Const PI As Double = 3.14159265358979

Private wavBuffer() As Integer

Private Sub cmdMakeSound_Click()
Dim wavFormat As WAVEFORMATEX
Dim wavHead As WAVEHDR
Dim hWaveOut As Long
Dim i As Long
Dim Frequency As Double
Dim FreqConst As Double

If ((Val(txtFreq.Text) > 0) Or (Val(txtBufferLength.Text) > 0)) Then
' Create the buffer:
ReDim wavBuffer(0 To 44100 * Val(txtBufferLength.Text) - 1)
' Setup the nessasary info for outputting CD quality sound:
With wavFormat
.wFormatTag = WAVE_FORMAT_PCM
.nChannels = 2
.wBitsPerSample = 16
.nSamplesPerSec = 44100
.nBlockAlign = 2
.nAvgBytesPerSec = 176400
End With
With wavHead
.lpData = VarPtr(wavBuffer(LBound(wavBuffer)))
.dwBufferLength = LenB(wavBuffer(LBound(wavBuffer))) * (UBound(wavBuffer) - LBound(wavBuffer) + 1)
End With
Call waveOutOpen(hWaveOut, WAVE_MAPPER, wavFormat, AddressOf waveOutProc, 0, CALLBACK_FUNCTION)
'Debug.Print "hWaveOut: " & Hex(hWaveOut)
Call waveOutPrepareHeader(hWaveOut, wavHead, LenB(wavHead))
FinishedPlaying = False
cmdMakeSound.Enabled = False
'Debug.Print "Filling buffer..."

' Increasing frequency:
' For i = LBound(wavBuffer) To UBound(wavBuffer)
' wavBuffer(i) = 32767 * Sin(i * Frequency)
' Frequency = Frequency + 0.000001
' Next i

' White noise:
' Randomize
' For i = LBound(wavBuffer) To UBound(wavBuffer)
' wavBuffer(i) = hsbVolume * Rnd
' Next i

' Specific frequency:
FreqConst = 44100 / (PI * 2) / Val(txtFreq.Text)
For i = LBound(wavBuffer) To UBound(wavBuffer)
wavBuffer(i) = hsbVolume.Value * Sin((i Mod 44100) / FreqConst)
Next i

' Start playing buffer contents
Call waveOutWrite(hWaveOut, wavHead, LenB(wavHead))
Do While Not FinishedPlaying
DoEvents
Loop
Call waveOutUnprepareHeader(hWaveOut, wavHead, LenB(wavHead))
Call waveOutClose(hWaveOut)
Erase wavBuffer
cmdMakeSound.Enabled = True
End If
End Sub

This add this to a BAS module:

Option Explicit

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 WAVEFORMATEX
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 waveOutOpen Lib "winmm.dll" (ByRef lphWaveOut As Long, ByVal uDeviceID As Long, ByRef lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, ByRef lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, ByRef lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, ByRef lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long

Public Const WAVE_MAPPER = -1&
Public Const WAVE_FORMAT_PCM = 1

Public Const CALLBACK_TYPEMASK = &H70000 ' callback type mask
Public Const CALLBACK_NULL = &H0 ' no callback
Public Const CALLBACK_WINDOW = &H10000 ' dwCallback is a HWND
Public Const CALLBACK_TASK = &H20000 ' dwCallback is a HTASK
Public Const CALLBACK_FUNCTION = &H30000 ' dwCallback is a FARPROC
'#ifdef _WIN32
Public Const CALLBACK_THREAD = (CALLBACK_TASK) ' thread ID replaces 16 Bit task
Public Const CALLBACK_EVENT = &H50000 ' dwCallback is an EVENT Handle
'#endif
Public Const WAVE_FORMAT_QUERY = &H1
Public Const WAVE_ALLOWSYNC = &H2
'#if(WINVER >= &H0400)
Public Const WAVE_MAPPED = &H4
Public Const WAVE_FORMAT_DIRECT = &H8
Public Const WAVE_FORMAT_DIRECT_QUERY = (WAVE_FORMAT_QUERY Or WAVE_FORMAT_DIRECT)
'#endif /* WINVER >= 0x0400 */

' flags for dwFlags field of WAVEHDR
Public Const WHDR_DONE = &H1 ' done bit
Public Const WHDR_PREPARED = &H2 ' set if this header has been prepared
Public Const WHDR_BEGINLOOP = &H4 ' loop start block
Public Const WHDR_ENDLOOP = &H8 ' loop end block
Public Const WHDR_INQUEUE = &H10 ' reserved for driver

Public Const MM_WOM_OPEN = &H3BB ' waveform output
Public Const MM_WOM_CLOSE = &H3BC
Public Const MM_WOM_DONE = &H3BD

Public Const MM_WIM_OPEN = &H3BE ' waveform input
Public Const MM_WIM_CLOSE = &H3BF
Public Const MM_WIM_DATA = &H3C0

' wave callback messages
Public Const WOM_OPEN = MM_WOM_OPEN
Public Const WOM_CLOSE = MM_WOM_CLOSE
Public Const WOM_DONE = MM_WOM_DONE

Public Const WIM_OPEN = MM_WIM_OPEN
Public Const WIM_CLOSE = MM_WIM_CLOSE
Public Const WIM_DATA = MM_WIM_DATA

' general error return values
Public Const MMSYSERR_BASE = 0
Public Const MMSYSERR_NOERROR = 0 ' no error
Public Const MMSYSERR_ERROR = (MMSYSERR_BASE + 1) ' unspecified Error
Public Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' device ID out of range
Public Const MMSYSERR_NOTENABLED = (MMSYSERR_BASE + 3) ' driver failed enable
Public Const MMSYSERR_ALLOCATED = (MMSYSERR_BASE + 4) ' device already allocated
Public Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' device handle is invalid
Public Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Public Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' memory allocation Error
Public Const MMSYSERR_NOTSUPPORTED = (MMSYSERR_BASE + 8) ' function isn 't supported
Public Const MMSYSERR_BADERRNUM = (MMSYSERR_BASE + 9) ' error value out of range
Public Const MMSYSERR_INVALFLAG = (MMSYSERR_BASE + 10) ' invalid flag passed
Public Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Public Const MMSYSERR_HANDLEBUSY = (MMSYSERR_BASE + 12) ' handle being used simultaneously on another thread (eg callback) */
Public Const MMSYSERR_INVALIDALIAS = (MMSYSERR_BASE + 13) ' specified alias Not found
Public Const MMSYSERR_BADDB = (MMSYSERR_BASE + 14) ' bad registry Database
Public Const MMSYSERR_KEYNOTFOUND = (MMSYSERR_BASE + 15) ' registry Key Not found
Public Const MMSYSERR_READERROR = (MMSYSERR_BASE + 16) ' registry read Error
Public Const MMSYSERR_WRITEERROR = (MMSYSERR_BASE + 17) ' registry write error
Public Const MMSYSERR_DELETEERROR = (MMSYSERR_BASE + 18) ' registry Delete Error
Public Const MMSYSERR_VALNOTFOUND = (MMSYSERR_BASE + 19) ' registry Value Not found
Public Const MMSYSERR_NODRIVERCB = (MMSYSERR_BASE + 20) ' driver does not call DriverCallback
Public Const MMSYSERR_MOREDATA = (MMSYSERR_BASE + 21) ' more data to be returned
Public Const MMSYSERR_LASTERROR = (MMSYSERR_BASE + 21) ' last error in range

' waveform audio error return values
Public Const WAVERR_BASE = 32
Public Const WAVERR_BADFORMAT = (WAVERR_BASE + 0) ' unsupported wave format
Public Const WAVERR_STILLPLAYING = (WAVERR_BASE + 1) ' still something playing
Public Const WAVERR_UNPREPARED = (WAVERR_BASE + 2) ' header not prepared
Public Const WAVERR_SYNC = (WAVERR_BASE + 3) ' device is synchronous
Public Const WAVERR_LASTERROR = (WAVERR_BASE + 3) ' last error in range

Public FinishedPlaying As Boolean

Public Sub waveOutProc(ByVal hWaveOut As Long, ByVal uMsg As Long, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
If (uMsg = WOM_DONE) Then
Debug.Print "Sample finished playing"
FinishedPlaying = True
End If
End Sub

Howard Henry Schlunder

"Martin Waller" <Martin...@beeb.net> wrote in message news:eQbu7TBpBHA.2196@tkmsftngp07...

[Allan]

Put this in a module and call it from a form

Public Declare Function Beep Lib "kernel32" Alias "Beep"
(ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

eh voila!

>.
>

[Max Bolingbroke]

Only on NT kernel OSes.

Max Bolingbroke

"Allan" <allt...@hotmail.com> wrote in message
news:e41401c1ab06$100c9ca0$a5e62ecf@tkmsftngxa07...