Private Declare Function FindFirstFile& Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _
As WIN32_FIND_DATA)
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Private Const MAX_PATH = 260
Private Type FILETIME ' 8 Bytes
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA ' 318 Bytes
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReservedЇ As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
Private Function FileExist (strFileName As String) As Boolean
Dim lpFindFileData As WIN32_FIND_DATA
Dim hFindFirst As Long
hFindFirst = FindFirstFile (strFileName, lpFindFileData)
If hFindFirst > 0 Then
FindClose hFindFirst
FileExist = True
Else
FileExist = False
End If
End Function
Public Function GetShortName (ByVal sLongFileName As String) As String
Dim lRetVal As Long, sShortPathName As String, iLen As Integer
'Set up buffer area for API function call return
sShortPathName = Space (255)
iLen = Len (sShortPathName)
'Call the function
lRetVal = GetShortPathName (sLongFileName, sShortPathName, iLen)
If lRetVal = 0 Then 'The file does not exist, first create it!
Open sLongFileName For Random As #1
Close #1
'Now another try!
Kill (sLongFileName)
'Delete file now!
'Strip away unwanted characters.
GetShortName = Left (sShortPathName, lRetVal)
Private Function Has_Space (sName As String) As Boolean
Dim b As Boolean
Dim i As Long
b = False 'not yet any spaces found
i = InStr (sName, " ")
If i <> 0 Then b = True
Has_Space = b
Public Sub WaveReset ()
Dim rtn As String
rtn = Space$ (260)
'Close any MCI operations from previous VB programs
i = mciSendString ("close all", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Closing all MCI operations failed!")
'Open a new WAV with MCI Command...
i = mciSendString ("open new type waveaudio alias capture", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Opening new wave failed!")
End Sub
Public Sub WaveSet ()
Dim settings As String
Dim Alignment As Integer
Alignment = Channels * Resolution / 8
settings = "set capture alignment " & CStr (Alignment) & " bitspersample " & CStr (Resolution) & " samplespersec " & CStr (Rate) & " channels " & CStr (Channels) & " bytespersec " & CStr (Alignment * Rate)
'Samples Per Second that are supported:
'11025 low quality
'22050 medium quality
'44100 high quality (CD music quality)
'Bits per sample is 16 or 8
'Channels are 1 (mono) or 2 (stereo)
i = mciSendString ("seek capture to start", rtn, Len (rtn), 0) 'Always start at the beginning
If i <> 0 Then MsgBox ("Starting recording failed!")
'You can use at least the following combinations
' i = mciSendString ("set capture alignment 4 bitspersample 16 samplespersec 44100 channels 2 bytespersec 176400", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 2 bitspersample 16 samplespersec 44100 channels 1 bytespersec 88200", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 4 bitspersample 16 samplespersec 22050 channels 2 bytespersec 88200", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 2 bitspersample 16 samplespersec 22050 channels 1 bytespersec 44100", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 4 bitspersample 16 samplespersec 11025 channels 2 bytespersec 44100", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 2 bitspersample 16 samplespersec 11025 channels 1 bytespersec 22050", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 2 bitspersample 8 samplespersec 11025 channels 2 bytespersec 22050", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 1 bitspersample 8 samplespersec 11025 channels 1 bytespersec 11025", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 2 bitspersample 8 samplespersec 8000 channels 2 bytespersec 16000", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 1 bitspersample 8 samplespersec 8000 channels 1 bytespersec 8000", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 2 bitspersample 8 samplespersec 6000 channels 2 bytespersec 12000", rtn, Len (rtn), 0)
' i = mciSendString ("set capture alignment 1 bitspersample 8 samplespersec 6000 channels 1 bytespersec 6000", rtn, Len (rtn), 0)
i = mciSendString (settings, rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Settings for recording not consistent")
' If the combination is not supported you get an error!
Public Sub WaveRecord ()
Dim msg As String
If WaveMidiFileName <> "" Then
If WaveRecordingImmediate Then MsgBox ("Midi file " & WaveMidiFileName & " will be recorded")
i = mciSendString ("open " & WaveMidiFileName & " type sequencer alias midi", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Opening midi file failed!")
i = mciSendString ("play midi", rtn, Len (rtn), 0) 'Start the recording
If i <> 0 Then MsgBox ("Playing midi file failed!")
i = mciSendString ("record capture", rtn, Len (rtn), 0) 'Start the recording
If i <> 0 Then MsgBox ("Recording not possible, please restart your computer... ")
Public Sub WaveSaveAs (sName As String)
'If file already exists then remove it
If FileExist (sName) Then
Kill (sName)
'The mciSendString API call doesn't seem to like'
'long filenames that have spaces in them, so we
'will make another API call to get the short
'filename version.
'This is accomplished by the function GetShortName
'MCI command to save the WAV file
If Has_Space (sName) Then
WaveShortFileName = GetShortName (sName)
WaveLongFileName = sName
WaveRenameNecessary = True
' These are necessary in order to be able to rename file
i = mciSendString ("save capture " & WaveShortFileName, rtn, Len (rtn), 0)
i = mciSendString ("save capture " & sName, rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Saving file failed, file name was: " & sName)
Public Sub WaveStop ()
i = mciSendString ("stop capture", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Stopping recording failed!")
i = mciSendString ("stop midi", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Stopping playing midi file failed!")
Public Sub WavePlay ()
i = mciSendString ("play capture from 0", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Start playing failed!")
Public Sub WaveStatus ()
WaveStatusMsg = Space (255)
i = mciSendString ("status capture mode", WaveStatusMsg, 255, 0)
If i <> 0 Then MsgBox ("Failure getting wave status... ")
WaveStatusMsg = "AudioRecorder: " & WaveStatusMsg
Public Sub WaveStatistics ()
Dim mssg As String * 255
i = mciSendString ("set capture time format ms", 0&, 0, 0)
If i <> 0 Then MsgBox ("Setting time format in milliseconds failed!")
i = mciSendString ("status capture length", mssg, 255, 0)
mssg = CStr (CLng (mssg) / 1000)
If i <> 0 Then MsgBox ("Finding length recording in milliseconds failed!")
WaveStatisticsMsg = "Length recording " & Str (mssg) & " s"
i = mciSendString ("set capture time format bytes", 0&, 0, 0)
If i <> 0 Then MsgBox ("Setting time format in bytes failed!")
If i <> 0 Then MsgBox ("Finding length recording in bytes failed!")
WaveStatisticsMsg = WaveStatisticsMsg & " (" & Str (mssg) & " bytes)" & vbCrLf
i = mciSendString ("status capture channels", mssg, 255, 0)
If i <> 0 Then MsgBox ("Finding number of channels failed!")
If Str (mssg) = 1 Then
WaveStatisticsMsg = WaveStatisticsMsg & "Mono - "
ElseIf Str (mssg) = 2 Then
WaveStatisticsMsg = WaveStatisticsMsg & "Stereo - "
i = mciSendString ("status capture bitspersample", mssg, 255, 0)
If i <> 0 Then MsgBox ("Finding resolution failed!")
WaveStatisticsMsg = WaveStatisticsMsg & Str (mssg) & " bits - "
i = mciSendString ("status capture samplespersec", mssg, 255, 0)
If i <> 0 Then MsgBox ("Finding sample rate failed!")
WaveStatisticsMsg = WaveStatisticsMsg & Str (mssg) & " samples per second " & vbCrLf & vbCrLf
Public Sub WaveClose ()
i = mciSendString ("close capture", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Closing MCI failed!")
Public Function WavePosition () As Long
Dim pos As String
rtn = Space (255)
pos = Space (255)
i = mciSendString ("set capture time format ms", rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Setting format in milliseconds failed!")
i = mciSendString ("status capture position", pos, 255, 0)
If i <> 0 Then MsgBox ("Finding position failed!")
If i <> 0 Then MsgBox ("Error in position")
WavePosition = CLng (pos)
Public Sub WavePlayFrom (Position As Long)
pos = CStr (Position)
i = mciSendString ("play capture from " & pos, rtn, Len (rtn), 0)
If i <> 0 Then MsgBox ("Playing from indicated position failed!")
If i <> 0 Then MsgBox ("Play from position doesn't work... ")
Interface in Action
Страницы: 1, 2, 3