Audio recorder on visual basic (46553)

Посмотреть архив целиком














AUTOMATIC SYSTEM

AUDIO RECORDER ON VISUAL BASIC













Dushanbe, 2009


Main Interface



Source Code

Option Explicit

'Copyright: E. de Vries

'e-mail: eeltje@geocities.com

'This code can be used as freeware

Const AppName = "AudioRecorder"

Private Sub cmdSave_Click ()

Dim sName As String

If WaveMidiFileName = "" Then

sName = "Radio_from_" & CStr (WaveRecordingStartTime) & "_to_" & CStr (WaveRecordingStopTime)

sName = Replace (sName, ": ", "-")

sName = Replace (sName, " ", "_")

sName = Replace (sName, "/", "-")

Else

sName = WaveMidiFileName

sName = Replace (sName, "MID", "wav")

End If

CommonDialog1. FileName = sName

CommonDialog1. CancelError = True

On Error GoTo ErrHandler1

CommonDialog1. Filter = "WAV file (*. wav*) |*. wav"

CommonDialog1. Flags = &H2 Or &H400

CommonDialog1. ShowSave

sName = CommonDialog1. FileName

WaveSaveAs (sName)

Exit Sub

ErrHandler1:

End Sub

Private Sub cmdRecord_Click ()

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)

WaveReset

WaveSet

WaveRecord

WaveRecordingStartTime = Now

cmdStop. Enabled = True 'Enable the STOP BUTTON

cmdPlay. Enabled = False 'Disable the "PLAY" button

cmdSave. Enabled = False 'Disable the "SAVE AS" button

cmdRecord. Enabled = False 'Disable the "RECORD" button

End Sub

Private Sub cmdSettings_Click ()

Dim strWhat As String

' show the user entry form modally

strWhat = MsgBox ("If you continue your data will be lost!", vbOKCancel)

If strWhat = vbCancel Then

Exit Sub

End If

Slider1. Max = 10

Slider1. Value = 0

Slider1. Refresh

cmdRecord. Enabled = True

cmdStop. Enabled = False

cmdPlay. Enabled = False

cmdSave. Enabled = False

WaveReset

Rate = CLng (GetSetting ("AudioRecorder", "StartUp", "Rate", "110025"))

Channels = CInt (GetSetting ("AudioRecorder", "StartUp", "Channels", "1"))

Resolution = CInt (GetSetting ("AudioRecorder", "StartUp", "Resolution", "16"))

WaveFileName = GetSetting ("AudioRecorder", "StartUp", "WaveFileName", "C: \Radio. wav")

WaveAutomaticSave = GetSetting ("AudioRecorder", "StartUp", "WaveAutomaticSave", "True")

WaveRecordingImmediate = True

WaveRecordingReady = False

WaveRecording = False

WavePlaying = False

'Be sure to change the Value property of the appropriate button!!

'if you change the default values!

WaveSet

frmSettings. optRecordImmediate. Value = True

frmSettings. Show vbModal

End Sub

Private Sub cmdStop_Click ()

WaveStop

cmdSave. Enabled = True 'Enable the "SAVE AS" button

cmdPlay. Enabled = True 'Enable the "PLAY" button

cmdStop. Enabled = False 'Disable the "STOP" button

If WavePosition = 0 Then

Slider1. Max = 10

Else

If WaveRecordingImmediate And (Not WavePlaying) Then Slider1. Max = WavePosition

If (Not WaveRecordingImmediate) And WaveRecording Then Slider1. Max = WavePosition

End If

If WaveRecording Then WaveRecordingReady = True

WaveRecordingStopTime = Now

WaveRecording = False

WavePlaying = False

frmSettings. optRecordProgrammed. Value = False

frmSettings. optRecordImmediate. Value = True

frmSettings. lblTimes. Visible = False

End Sub

Private Sub cmdPlay_Click ()

WavePlayFrom (Slider1. Value)

WavePlaying = True

cmdStop. Enabled = True

cmdPlay. Enabled = False

End Sub

Private Sub cmdWeb_Click ()

Dim ret&

ret& = ShellExecute (Me. hwnd, "Open", "http://home. wxs. nl/~eeltjevr/", "", App. Path,

1)

End Sub

Private Sub cmdReset_Click ()

Slider1. Max = 10

Slider1. Value = 0

Slider1. Refresh

cmdRecord. Enabled = True

cmdStop. Enabled = False

cmdPlay. Enabled = False

cmdSave. Enabled = False

WaveReset

Rate = CLng (GetSetting ("AudioRecorder", "StartUp", "Rate", "110025"))

Channels = CInt (GetSetting ("AudioRecorder", "StartUp", "Channels", "1"))

Resolution = CInt (GetSetting ("AudioRecorder", "StartUp", "Resolution", "16"))

WaveFileName = GetSetting ("AudioRecorder", "StartUp", "WaveFileName", "C: \Radio. wav")

WaveAutomaticSave = GetSetting ("AudioRecorder", "StartUp", "WaveAutomaticSave", "True")

WaveRecordingImmediate = True

WaveRecordingReady = False

WaveRecording = False

WavePlaying = False

WaveMidiFileName = ""

'Be sure to change the Value property of the appropriate button!!

'if you change the default values!

WaveSet

If WaveRenameNecessary Then

Name WaveShortFileName As WaveLongFileName

WaveRenameNecessary = False

WaveShortFileName = ""

End If

End Sub

Private Sub Form_Load ()

WaveReset

Rate = CLng (GetSetting ("AudioRecorder", "StartUp", "Rate", "110025"))

Channels = CInt (GetSetting ("AudioRecorder", "StartUp", "Channels", "1"))

Resolution = CInt (GetSetting ("AudioRecorder", "StartUp", "Resolution", "16"))

WaveFileName = GetSetting ("AudioRecorder", "StartUp", "WaveFileName", "C: \Radio. wav")

WaveAutomaticSave = GetSetting ("AudioRecorder", "StartUp", "WaveAutomaticSave", "True")

WaveRecordingImmediate = True

WaveRecordingReady = False

WaveRecording = False

WavePlaying = False

'Be sure to change the Value property of the appropriate button!!

'if you change the default values!

WaveSet

WaveRecordingStartTime = Now + TimeSerial (0, 15, 0)

WaveRecordingStopTime = WaveRecordingStartTime + TimeSerial (0, 15, 0)

WaveMidiFileName = ""

WaveRenameNecessary = False

End Sub

Private Sub Form_Unload (Cancel As Integer)

WaveClose

Call SaveSetting ("AudioRecorder", "StartUp", "Rate", CStr (Rate))

Call SaveSetting ("AudioRecorder", "StartUp", "Channels", CStr (Channels))

Call SaveSetting ("AudioRecorder", "StartUp", "Resolution", CStr (Resolution))

Call SaveSetting ("AudioRecorder", "StartUp", "WaveFileName", WaveFileName)

Call SaveSetting ("AudioRecorder", "StartUp", "WaveAutomaticSave", CStr (WaveAutomaticSave))

If WaveRenameNecessary Then

Name WaveShortFileName As WaveLongFileName

WaveRenameNecessary = False

WaveShortFileName = ""

End If

End

End Sub

Private Sub Timer2_Timer ()

Dim RecordingTimes As String

Dim msg As String

RecordingTimes = "Start time: " & WaveRecordingStartTime & vbCrLf _

& "Stop time: " & WaveRecordingStopTime

WaveStatistics

If Not WaveRecordingImmediate Then

WaveStatisticsMsg = WaveStatisticsMsg & "Programmed recording"

If WaveAutomaticSave Then

WaveStatisticsMsg = WaveStatisticsMsg & " (automatic save)"

Else

WaveStatisticsMsg = WaveStatisticsMsg & " (manual save)"

End If

WaveStatisticsMsg = WaveStatisticsMsg & vbCrLf & vbCrLf & RecordingTimes

End If

StatisticsLabel. Caption = WaveStatisticsMsg

WaveStatus

If WaveStatusMsg <> AudioRecorder. Caption Then AudioRecorder. Caption = WaveStatusMsg

If InStr (AudioRecorder. Caption, "stopped") > 0 Then

cmdStop. Enabled = False

cmdPlay. Enabled = True

End If

If RecordingTimes <> frmSettings. lblTimes. Caption Then frmSettings. lblTimes. Caption = RecordingTimes

If (Now > WaveRecordingStartTime) _

And (Not WaveRecordingReady) _

And (Not WaveRecordingImmediate) _

And (Not WaveRecording) Then

WaveReset

WaveSet

WaveRecord

WaveRecording = True

cmdStop. Enabled = True 'Enable the STOP BUTTON

cmdPlay. Enabled = False 'Disable the "PLAY" button

cmdSave. Enabled = False 'Disable the "SAVE AS" button

cmdRecord. Enabled = False 'Disable the "RECORD" button

End If

If (Now > WaveRecordingStopTime) And (Not WaveRecordingReady) And (Not WaveRecordingImmediate) Then

WaveStop

cmdSave. Enabled = True 'Enable the "SAVE AS" button

cmdPlay. Enabled = True 'Enable the "PLAY" button

cmdStop. Enabled = False 'Disable the "STOP" button

If WavePosition > 0 Then

Slider1. Max = WavePosition

Else

Slider1. Max = 10

End If

WaveRecording = False

WaveRecordingReady = True

If WaveAutomaticSave Then

WaveFileName = "Radio_from_" & CStr (WaveRecordingStartTime) & "_to_" & CStr (WaveRecordingStopTime)

WaveFileName = Replace (WaveFileName, ": ", ". ")

WaveFileName = Replace (WaveFileName, " ", "_")

WaveFileName = WaveFileName & ". wav"

WaveSaveAs (WaveFileName)

msg = "Recording has been saved" & vbCrLf

msg = msg & "Filename: " & WaveFileName

MsgBox (msg)

Else

msg = "Recording is ready" & vbCrLf

msg = msg & "Don't forget to save recording..."

MsgBox (msg)

End If

frmSettings. optRecordProgrammed. Value = False

frmSettings. optRecordImmediate. Value = True

End If

End Sub

Option Explicit

Private Sub cmdFileName_Click ()

WaveFileName = InputBox ("Filename: ", "Filename for automatic saving", WaveFileName)

End Sub

Private Sub cmdMidi_Click ()

CommonDialog2. CancelError = True

On Error GoTo ErrHandler1

CommonDialog2. Filter = "Midi file (*. mid*) |*. mid"

CommonDialog2. Flags = &H2 Or &H400

CommonDialog2. ShowOpen

WaveMidiFileName = CommonDialog2. FileName

WaveMidiFileName = GetShortName (WaveMidiFileName)

ErrHandler1:

End Sub

Private Sub cmdOke_Click ()

Unload Me

End Sub

Private Sub cmdStartTime_Click ()

Dim wrst As String

wrst = WaveRecordingStartTime

wrst = InputBox ("Enter start time recording", "Start time", wrst)

If wrst = "" Then Exit Sub

If Not IsDate (wrst) Then

MsgBox ("The date/time you entered was not valid!")

Else

' String returned from InputBox is a valid time,

' so store it as a date/time value in WaveRecordingStartTime.

If CDate (wrst) < Now Then

MsgBox ("Recording events in the past is not possible... ")

WaveRecordingStartTime = Now + TimeSerial (0, 15, 0)

Else

WaveRecordingStartTime = CDate (wrst)

End If

If WaveRecordingStopTime < WaveRecordingStartTime Then WaveRecordingStopTime = WaveRecordingStartTime + TimeSerial (0, 15, 0)

End If

End Sub

Private Sub cmdStopTime_Click ()

Dim wrst As String

wrst = WaveRecordingStopTime

If wrst < WaveRecordingStartTime Then wrst = WaveRecordingStartTime + TimeSerial (0, 15, 0)

wrst = InputBox ("Enter stop time recording", "Stop time", wrst)

If wrst = "" Then Exit Sub

If Not IsDate (wrst) Then

MsgBox ("The time you entered was not valid!")

Else

' String returned from InputBox is a valid time,

' so store it as a date/time value in WaveRecordingStartTime.

If CDate (wrst) < WaveRecordingStartTime Then

MsgBox ("The stop time has to be later then the start time!")

WaveRecordingStopTime = WaveRecordingStartTime + TimeSerial (0, 5, 0)

Else

WaveRecordingStopTime = CDate (wrst)

End If

End If

End Sub

Private Sub Form_Load ()

Select Case Rate

Case 44100

optRate44100. Value = True

Case 22050

optRate22050. Value = True

Case 11025

optRate11025. Value = True

Case 8000

optRate8000. Value = True

Case 6000

optRate6000. Value = True

End Select

Select Case Channels

Case 1

optMono. Value = True

Case 2

optStereo. Value = True

End Select

Select Case Resolution

Case 8

opt8bits. Value = True

Case 16

opt16bits. Value = True

End Select

If WaveRecordingImmediate Then

optRecordImmediate. Value = True

Else

optRecordProgrammed. Value = True

End If

If WaveAutomaticSave Then

Option11. Value = True

Else

Option10. Value = True

End If

End Sub

Private Sub optRate11025_Click ()

Rate = 11025

optRate11025. Value = True

End Sub

Private Sub optRate44100_Click ()

Rate = 44100

optRate44100. Value = True

End Sub

Private Sub Option10_Click ()

WaveAutomaticSave = False

End Sub

Private Sub Option11_Click ()

WaveAutomaticSave = True

End Sub

Private Sub optRate22050_Click ()

Rate = 22050

optRate22050. Value = True

End Sub

Private Sub optRate8000_Click ()

Rate = 8000

optRate8000. Value = True

End Sub

Private Sub optRate6000_Click ()

Rate = 6000

optRate6000. Value = True

End Sub

Private Sub optMono_Click ()

Channels = 1

optMono. Value = True

End Sub

Private Sub optStereo_Click ()

Channels = 2

optStereo. Value = True

End Sub

Private Sub opt8bits_Click ()

Resolution = 8

opt8bits. Value = True

End Sub

Private Sub opt16bits_Click ()

Resolution = 16

opt16bits. Value = True

End Sub

Private Sub optRecordImmediate_Click ()

WaveRecordingImmediate = True

frmManualAuto. Visible = False

frmTimes. Visible = False

lblTimes. Visible = False

AudioRecorder. cmdRecord. Enabled = True

End Sub

Private Sub optRecordProgrammed_Click ()

WaveRecordingImmediate = False

frmManualAuto. Visible = True

frmTimes. Visible = True

lblTimes. Visible = True

AudioRecorder. cmdRecord. Enabled = False

If WaveRecordingStartTime < Now Then

WaveRecordingStartTime = Now + TimeSerial (0, 15, 0)

WaveRecordingStopTime = WaveRecordingStartTime + TimeSerial (0, 15, 0)

End If

End Sub

Option Explicit

Public Declare Function ShellExecute Lib "shell32. dll" Alias _

"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As _

String, ByVal lpFile As String, ByVal lpParameters As String, _

ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Option Explicit

Public Rate As Long

Public Channels As Integer

Public Resolution As Integer

Public WaveStatusMsg As String * 255

Public WaveStatisticsMsg As String

Public WaveRecordingImmediate As Boolean

Public WaveRecordingStartTime As Date

Public WaveRecordingStopTime As Date

Public WaveRecordingReady As Boolean

Public WaveRecording As Boolean

Public WavePlaying As Boolean

Public WaveAutomaticSave As Boolean

Public WaveFileName As String

Public WaveMidiFileName As String

Public WaveLongFileName As String

Public WaveShortFileName As String

Public WaveRenameNecessary As Boolean

'These were the public variables

'=====================================================

Private Declare Function mciSendString Lib "winmm. dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrrtning As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Declare Function GetShortPathName Lib "kernel32" _

Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _

ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

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

End Type

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

lRetVal = GetShortPathName (sLongFileName, sShortPathName, iLen)

'Now another try!

Kill (sLongFileName)

'Delete file now!

End If

'Strip away unwanted characters.

GetShortName = Left (sShortPathName, lRetVal)

End Function

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

End Function

Public Sub WaveReset ()

Dim rtn As String

Dim i As Long

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 rtn As String

Dim i As Long

Dim settings As String

Dim Alignment As Integer

rtn = Space$ (260)

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!")


Случайные файлы

Файл
12828.rtf
9663-1.rtf
178327.rtf
16080.doc
33645.rtf