VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "WaveSoundRecorder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Dim lBytes As Long ' I'm using this as a global variable since several procedures need it
' declare the functions used in the winmm.dll library
Private Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long

Private Declare Function mciGetErrorString Lib "winmm.dll" _
Alias "mciGetErrorStringA" _
(ByVal dwError As Long, _
ByVal lpstrBuffer As String, _
ByVal uLength As Long) As Long
'________________________________________________

Public Function StartRecord(SoundFile As String, sChannels As String, sBits As String, sSamples As String) As Boolean
' this function gets called from a click of a button on the main form
' it passes the name of the wave file including the path,
' the number of channels (1 or 2),
' the number of bits (8 or 16),
' and the number of samples per second desired (standards are 11025, 22050, and 44100)
' the higher the sample number, the better the sound quality
' these are all passed as strings

' declare variables
Dim Result As Long
Dim errormsg As Integer
Dim ReturnString As String * 1024
Dim ErrorString As String * 1024
Dim mssg As String * 255
Dim i As Long
Dim BlockAlign As Integer
Dim sBytes As String
' make sure all working files in memory are closed
mciSendString "close all", 0, 0, 0
' open a ned working file in memory - recsound is my name for this working file
Result = mciSendString("open new Type waveaudio Alias recsound", ReturnString, Len(ReturnString), 0)
' this result check will be performed after EVERY mciSendString to make sure it does not
' generate any errors
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error"
End If
' set time format to milliseconds
Result = mciSendString("set recsound time format ms", ReturnString, 1024, 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (time format)"
End If
' set to pcm type wave file (Microsoft standard)
Result = mciSendString("set recsound format tag pcm", ReturnString, 1024, 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (format tag)"
End If

' in these next settings make sure there is a space between the setting and the setting variable
' set number of channels (1 or 2) - variable sChannels passed from calling procedure
Result = mciSendString("set recsound channels " & sChannels, ReturnString, 1024, 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (channels)"
End If

' set number of samples - variable sSamples passed from calling procedure
Result = mciSendString("set recsound samplespersec " & sSamples, ReturnString, 1024, 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (samples/sec)"
End If

' set number of bits (8 or 16) - - variable sBits passed from calling procedure
Result = mciSendString("set recsound bitspersample " & sBits, ReturnString, 1024, 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (bits/sample)"
End If

' set the block allignment - I don't think this is necessary but
' is included just in case, and for completeness
' formula to find block allignment
BlockAlign = CInt((CLng(sBits) / 8) * CLng(sChannels))
Result = mciSendString("set recsound alignment " & str$(BlockAlign), ReturnString, 1024, 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (block align)"
End If

' calculates OK but mciSendString does not put it in the wav file properly
' will always put 11025 regardless of what it is supposed to be
' this value is ONLY good for 1 channel, 8 bits, 11025 samples
' this is where WMP stumbles - we'll address this further on
' we'll include this anyway so you can see where the error actually lies

lBytes = CLng(sSamples) * ((CLng(sChannels) * CLng(sBits)) / 8)
sBytes = str$(lBytes)
' doesn't work correctly due to suspected bug in winmm.dll
' make sure this part of the code is commented out or you will get errors
' ************************************************
' Result= mciSendString("set recsound bytespersec " & sBytes, ReturnString, 1024, 0)
' If Not Result= 0 Then
' errormsg = mciGetErrorString(Result, ErrorString, 1024)
' MsgBox ErrorString, 0, "Error (bytes/sec)"
' End If

' start recording
Result = mciSendString("record recsound", ReturnString, Len(ReturnString), 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
End If
End Function
' __________________________________________________

Public Function StopRecord() As Boolean
' this function activated by stop command button on main form
Dim Result As Long
Dim errormsg As Integer
Dim ReturnString As String * 1024
Dim ErrorString As String * 1024
Dim mssg As String * 255
Dim i As Long

' stop the recording
Result = mciSendString("stop recsound", ReturnString, Len(ReturnString), 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (stop)"
End If

' save the wave file that is in memory
Result = mciSendString("save recsound " & mFilename, ReturnString, Len(ReturnString), 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (save)"
End If

' calls the procedure that will read back the values just recorded
' see these results to make the error show
Call GetRecStatus

' close the file in memory
Result = mciSendString("close recsound", ReturnString, 1024, 0)
If Not Result = 0 Then
errormsg = mciGetErrorString(Result, ErrorString, 1024)
MsgBox ErrorString, 0, "Error (close)"
End If

' make sure all files in memory are closed
mciSendString "close all", 0, 0, 0

' now call the procedure that fixes the file on your drive
Call FixWaveFile

End Sub
' _______________________________________________________

Private Sub GetRecStatus()
' read the status of the file in memory
' declare variables
Dim i As Long
Dim MSchan As String
Dim MSbits As String
Dim MSsamples As String
Dim MSbytes As String
Dim lChan As Long
Dim lBits As Long
Dim lSamples As Long
'Dim lBytes As Long declared as global
Dim sChan As String
Dim mssg As String * 255

' channel status
i = mciSendString("status recsound channels", mssg, 255, 0)
If str(mssg) = "1" Then
MSchan = "mono"
sChan = "1"
Else
MSchan = "stereo"
sChan = "2"
End If
MsgBox "channel =" & MSchan

' bits per sample
i = mciSendString("status recsound bitspersample", mssg, 255, 0)
MSbits = str(mssg)
MsgBox "bits per sample =" & MSbits

'samples
i = mciSendString("status recsound samplespersec", mssg, 255, 0)
MSsamples = str(mssg)
MsgBox "samples =" & MSsamples

' this reports 11025 regardless of how it was written! wrong! - fixed later
i = mciSendString("status recsound bytespersec", mssg, 255, 0)
MSbytes = str(mssg)
MsgBox "bytes per sec=" & MSbytes

' calculate the real bytes per sec value
' this value will be used to fix the file after it has been saved
lBytes = CLng(MSsamples) * ((CLng(sChan) * CLng(MSbits)) / 8)

End Sub

' ____________________________________________________

Public Sub FixWaveFile()
' this will fix the file so it is playable with WMP
' declare integers
Dim Indexnum As Integer
Dim x As Integer
Dim HexCode As String
Dim Hex1 As String
Dim Hex2 As String
Dim Hex3 As String
Dim lByteNum As Long ' byte number (29,30, & 31) in the wave file
Dim bByte As Byte ' will be hex byte to write

' get the hexadecimal for the lBytes value
HexCode = Hex(lBytes) ' lBytes calculated from previous formula
Do While Len(HexCode) < 6 ' make sure the hex code is 6 chars long
HexCode = "0" & HexCode ' if not, add a zero
Loop

' note: this value had to be written to the file in reverse order!
Hex1 = Right$(HexCode, 2) ' Endian small - reverse order - get last hex byte first
Hex2 = Mid$(HexCode, 3, 2) ' get middle hex byte
Hex3 = Left$(HexCode, 2) ' get first hex byte

'open the file
Indexnum = FreeFile ' get a free file number
Open mFilename For Binary Access Write As #Indexnum ' binary open file
lByteNum = 29 ' first byte to write is 29
bByte = CInt("&H" & Hex1) ' bByte = integer of hex Hex1
Put #Indexnum, lByteNum, bByte 'write bByte value to byte position lByteNum in file
bByte = CInt("&H" & Hex2) ' proceed to write remaining two bytes to consecutive positions
lByteNum = lByteNum + 1
Put #Indexnum, lByteNum, bByte ' note the Put command for writing bites to binary files
bByte = CInt("&H" & Hex3)
lByteNum = lByteNum + 1
Put #Indexnum, lByteNum, bByte
Close #1
End Sub



