www.pudn.com > sound_cap.zip > Form1.frm
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{F5BE8BC2-7DE6-11D0-91FE-00C04FD701A5}#2.0#0"; "agentctl.dll"
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "Capture and Save to File Sample"
ClientHeight = 5250
ClientLeft = 150
ClientTop = 720
ClientWidth = 4110
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5250
ScaleWidth = 4110
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdStandard
Caption = "标准发音"
Height = 375
Left = 2280
TabIndex = 8
Top = 1800
Width = 1455
End
Begin VB.TextBox Text1
Height = 2295
Left = 360
MultiLine = -1 'True
TabIndex = 7
Text = "Form1.frx":000C
Top = 2760
Width = 3375
End
Begin MSComDlg.CommonDialog svFile
Left = 240
Top = 840
_ExtentX = 847
_ExtentY = 847
_Version = 393216
Flags = 4
End
Begin VB.CommandButton cmdStopPlaying
Caption = "停止回放"
Height = 375
Left = 2280
TabIndex = 4
Top = 1200
Width = 1455
End
Begin VB.CommandButton cmdSaveToFile
Caption = "保存到文件"
Height = 375
Left = 360
TabIndex = 3
Top = 1800
Width = 1455
End
Begin VB.CommandButton cmdPlayRec
Caption = "录音回放"
Height = 375
Left = 360
TabIndex = 2
Top = 1200
Width = 1455
End
Begin VB.CommandButton cmdStopRec
Caption = "停止录音"
Height = 375
Left = 2280
TabIndex = 1
Top = 600
Width = 1455
End
Begin VB.Timer tmrCount
Left = 840
Top = 840
End
Begin VB.CommandButton cmdStartRec
Caption = "开始录音"
Height = 375
Left = 360
TabIndex = 0
Top = 600
Width = 1455
End
Begin AgentObjectsCtl.Agent Agent1
Left = 2760
Top = 2400
End
Begin VB.Label Label1
Caption = "输入文本"
Height = 255
Left = 360
TabIndex = 9
Top = 2460
Width = 1695
End
Begin VB.Label lblLTime
Alignment = 1 'Right Justify
Caption = "剩余时间:"
Height = 255
Left = 360
TabIndex = 6
Top = 120
Width = 795
End
Begin VB.Label lblTIME
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 255
Left = 1200
TabIndex = 5
Top = 120
Width = 1035
End
Begin VB.Menu mnuFile
Caption = "文件[&F]"
Begin VB.Menu mnuExit
Caption = "退出[&X]"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim dx As New DirectX7
Dim ds As DirectSound
Dim dsb As DirectSoundBuffer
Dim dsd As DSBUFFERDESC
Dim dsc As DirectSoundCapture
Dim dscb As DirectSoundCaptureBuffer
Dim dscd As DSCBUFFERDESC
Dim CaptureWave As WAVEFORMATEX
Dim capCURS As DSCURSORS
Dim ByteBuffer() As Integer
Dim CNT As Integer
Dim cCaps As DSCCAPS
Dim gfPlay As Boolean
Dim Genie As IAgentCtlCharacterEx
Private Sub cmdPlayRec_Click()
'将音频捕捉缓冲转换为声音缓冲
ConvertToSBuffer
'判断声音缓冲是否建立成功。
If dsb Is Nothing Then
Exit Sub
Else
dsb.Play DSBPLAY_DEFAULT
tmrCount.Enabled = True
CNT = 0
lblTIME.Caption = vbNullString
If gfPlay Then cmdStopPlaying.Enabled = True
End If
End Sub
Private Sub cmdSaveToFile_Click()
On Error Resume Next
Dim FileLocal As String
ConvertToSBuffer
If dsb Is Nothing Then Exit Sub
cmdStopPlaying.Enabled = False
tmrCount.Enabled = False
lblTIME.Caption = vbNullString
CNT = 0
If dsb Is Nothing Then
MsgBox "你需要首先执行录音操作"
Exit Sub
End If
svFile.Filter = "*.wav"
svFile.DialogTitle = "保存音频文件"
svFile.ShowSave
If Right(svFile.FileName, 4) <> ".wav" And svFile.FileName <> vbNullString Then
FileLocal = svFile.FileName
FileLocal = FileLocal & ".wav"
Else
FileLocal = svFile.FileName
End If
If FileLocal = vbNullString Then Exit Sub
If Mid(FileLocal, 2, 1) <> ":" Then Exit Sub
If Right(FileLocal, 3) <> "wav" Then
MsgBox "请输入音频文件的正确名字，例如 something.wav", vbApplicationModal
Exit Sub
End If
dsb.SaveToFile FileLocal
End Sub
Private Sub cmdStandard_Click()
If Text1.Text = "" Then
MsgBox "你必须在文本框中输入语句", vbCritical, "错误"
Exit Sub
End If
If Genie Is Nothing Then
Agent1.Connected = True
Agent1.Characters.Load "Genie"
Set Genie = Agent1.Characters("Genie")
If Genie Is Nothing Then End
Genie.LanguageID = &H409
Genie.SoundEffectsOn = True
End If
Genie.Show True
Genie.Speak Text1.Text
End Sub
Private Sub cmdStartRec_Click()
Set dscb = Nothing
Call InitCapture
dscb.start DSCBSTART_DEFAULT
tmrCount.Interval = 1000
tmrCount.Enabled = True
cmdStopRec.Enabled = True
cmdStartRec.Enabled = False
End Sub
Private Sub cmdStopPlaying_Click()
If dsb Is Nothing Then Exit Sub
Dim l_st As Long
Dim l_soundStatus As Long
'检测音频捕捉缓冲是否在处于运行状态。
l_st = dscb.GetStatus()
If (l_st And DSCBSTATUS_CAPTURING) Then
dscb.Stop
End If
'检测音频捕捉是否处于播放状态
l_soundStatus = dsb.GetStatus()
If (l_soundStatus And DSBSTATUS_PLAYING) Then
dsb.Stop
dsb.SetCurrentPosition 0
End If
tmrCount.Enabled = False
CNT = 0
lblTIME.Caption = vbNullString
cmdStopPlaying.Enabled = False
End Sub
Private Sub cmdStopRec_Click()
Dim l_bufferS As Long
If dscb Is Nothing Then Exit Sub
cmdSaveToFile.Enabled = True
If gfPlay Then cmdPlayRec.Enabled = True
l_bufferS = dscb.GetStatus()
If (l_bufferS And DSCBSTATUS_CAPTURING) Then
dscb.Stop
End If
tmrCount.Enabled = False
CNT = 0
lblTIME.Caption = vbNullString
cmdStartRec.Enabled = True
cmdStopRec.Enabled = False
End Sub
Private Sub Form_Load()
On Local Error GoTo errOut
Set dsc = dx.DirectSoundCaptureCreate(vbNullString)
On Error Resume Next
Set ds = dx.DirectSoundCreate(vbNullString)
If Err.Number = DSERR_ALLOCATED Then '声卡不支持全双工工作
gfPlay = False
MsgBox "声卡不支持全双工工作，但是仍然可以录音。", _
vbOKOnly Or vbInformation, "不支持全双工"
Else
gfPlay = True
ds.SetCooperativeLevel Me.hWnd, DSSCL_NORMAL
End If
On Local Error GoTo errOut
'初始化音频捕捉
InitCapture
cmdSaveToFile.Enabled = False
cmdPlayRec.Enabled = False
cmdStopPlaying.Enabled = False
cmdStopRec.Enabled = False
lblTIME.Caption = vbNullString
Text1.Text = ""
Exit Sub
errOut:
MsgBox "无法初始化声卡，退出程序", vbOKOnly Or vbCritical
End
End Sub
Private Sub ConvertToSBuffer()
Dim l_captureS As Long
l_captureS = dscb.GetStatus()
If (l_captureS And DSCBSTATUS_CAPTURING) Then
dscb.Stop
End If
'获得音频捕捉信息
dscb.GetCurrentPosition capCURS
dsd.lBufferBytes = capCURS.lWrite * dscd.fxFormat.nBlockAlign
dsd.lFlags = DSBCAPS_CTRLVOLUME Or DSBCAPS_STATIC
'无法写入
If capCURS.lWrite = 0 Then
Exit Sub
End If
Set dsb = ds.CreateSoundBuffer(dsd, dscd.fxFormat)
ReDim ByteBuffer(capCURS.lWrite * dscd.fxFormat.nBlockAlign + 1)
dscb.ReadBuffer 0, capCURS.lWrite * dscd.fxFormat.nBlockAlign, ByteBuffer(0), _
DSCBLOCK_DEFAULT
dsb.WriteBuffer 0, capCURS.lWrite * dscd.fxFormat.nBlockAlign, ByteBuffer(0), _
DSBLOCK_DEFAULT
End Sub
Private Function WaveEx(Hz As Long, Channels As Integer, BITS As Integer) As WAVEFORMATEX
WaveEx.nFormatTag = WAVE_FORMAT_PCM
WaveEx.nChannels = Channels
WaveEx.lSamplesPerSec = Hz
WaveEx.nBitsPerSample = BITS
WaveEx.nBlockAlign = Channels * BITS / 8
WaveEx.lAvgBytesPerSec = WaveEx.lSamplesPerSec * WaveEx.nBlockAlign
WaveEx.nSize = 0
End Function
Private Sub InitCapture()
'设置音频捕捉缓冲
dsc.GetCaps cCaps
'设置采样频率以及精度
If cCaps.lFormats And WAVE_FORMAT_2M08 Then
CaptureWave = WaveEx(22050, 1, 8)
ElseIf cCaps.lFormats And WAVE_FORMAT_1M08 Then
CaptureWave = WaveEx(11025, 1, 8)
Else
MsgBox "你的声卡不支持音频捕捉！", vbApplicationModal
End
End If
dscd.fxFormat = CaptureWave
dscd.lBufferBytes = CaptureWave.lAvgBytesPerSec * 20
dscd.lFlags = DSCBCAPS_WAVEMAPPED
Set dscb = dsc.CreateCaptureBuffer(dscd)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call CleanUp
End
End Sub
Private Sub CleanUp()
'清除全部对象
Set dx = Nothing
Set ds = Nothing
Set dsb = Nothing
Set dsc = Nothing
Set dscb = Nothing
Set Genie = Nothing
Agent1.Connected = False
Erase ByteBuffer
End Sub
Private Sub mnuExit_Click()
Unload Me
End Sub
Private Sub tmrCount_Timer()
On Error Resume Next
CNT = CNT + 1
If CNT = 19 Then
dscb.Stop
lblTIME.Caption = "Full"
frmMain.Refresh
tmrCount.Enabled = False
cmdSaveToFile.Enabled = True
If gfPlay Then cmdPlayRec.Enabled = True
If gfPlay Then cmdStopPlaying.Enabled = True
Exit Sub
End If
lblTIME.Caption = CNT
'检测音频捕捉缓冲状态
Dim l_sBs As Long
If Not (dsb Is Nothing) Then
l_sBs = dsb.GetStatus()
If (l_sBs And DSBSTATUS_PLAYING) Then
Else
If cmdStartRec.Enabled = True Then
tmrCount.Enabled = False
CNT = 1
lblTIME.Caption = vbNullString
cmdStopPlaying.Enabled = False
End If
End If
End If
End Sub