www.pudn.com > 一个酷酷的录音程序.rar > frmMain.frm
VERSION 5.00
Object = "{6BF52A50-394A-11D3-B153-00C04F79FAA6}#1.0#0"; "wmp.dll"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain
BorderStyle = 0 'None
Caption = "Sound Recorder"
ClientHeight = 11520
ClientLeft = 0
ClientTop = 0
ClientWidth = 9810
LinkTopic = "Form1"
Picture = "frmMain.frx":0000
ScaleHeight = 11520
ScaleWidth = 9810
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton cmdBrowse
Caption = "..."
Height = 255
Left = 2760
TabIndex = 12
Top = 10200
Width = 495
End
Begin VB.TextBox txtOpen
Height = 885
Left = 480
MultiLine = -1 'True
TabIndex = 10
Top = 9840
Width = 2175
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 4680
Top = 6120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.TextBox txtStatus
Height = 1095
Left = 7080
Locked = -1 'True
MultiLine = -1 'True
TabIndex = 9
Top = 1200
Width = 2055
End
Begin VB.Timer tmrStatus
Enabled = 0 'False
Interval = 1000
Left = 4320
Top = 5520
End
Begin VB.CommandButton cmdStop
Caption = "停止录音(&S)"
Enabled = 0 'False
Height = 495
Left = 4800
TabIndex = 8
Top = 9240
Width = 1335
End
Begin VB.CommandButton cmdHelp
Caption = "帮助(&H)"
Height = 495
Left = 5040
TabIndex = 7
Top = 2160
Width = 855
End
Begin VB.CommandButton cmdOptions
Caption = "选项(&O)"
Height = 495
Left = 7320
TabIndex = 6
Top = 5520
Width = 1215
End
Begin VB.CommandButton cmdSaveAs
Caption = "另存为(&A)..."
Enabled = 0 'False
Height = 495
Left = 3840
TabIndex = 5
Top = 10680
Width = 1455
End
Begin VB.CommandButton cmdRecord
Caption = "开始录音(&R)"
Height = 495
Left = 3420
TabIndex = 0
Top = 9240
Width = 1275
End
Begin VB.CommandButton cmdPlay
Caption = "播放录音(&P)"
Enabled = 0 'False
Height = 495
Left = 5400
TabIndex = 4
Top = 10680
Width = 1215
End
Begin VB.CommandButton cmdOpen
Caption = "打开文件录制"
Height = 495
Left = 480
TabIndex = 3
Top = 10800
Width = 1575
End
Begin VB.CommandButton cmdClose
Caption = "关闭(&C)"
Height = 375
Left = 6720
TabIndex = 1
Top = 120
Width = 975
End
Begin VB.Label lblStatus
Caption = "状态:"
Height = 255
Left = 7080
TabIndex = 13
Top = 960
Width = 615
End
Begin VB.Label lblOpen
Caption = "文件位置:"
Height = 255
Left = 480
TabIndex = 11
Top = 9480
Width = 975
End
Begin WMPLibCtl.WindowsMediaPlayer WindowsMediaPlayer1
Height = 3015
Left = 2280
TabIndex = 2
Top = 6000
Width = 3615
URL = ""
rate = 1
balance = 0
currentPosition = 0
defaultFrame = ""
playCount = 1
autoStart = -1 'True
currentMarker = 0
invokeURLs = -1 'True
baseURL = ""
volume = 50
mute = 0 'False
uiMode = "full"
stretchToFit = 0 'False
windowlessVideo = 0 'False
enabled = -1 'True
enableContextMenu= -1 'True
fullScreen = 0 'False
SAMIStyle = ""
SAMILang = ""
SAMIFilename = ""
captioningID = ""
enableErrorDialogs= 0 'False
_cx = 6376
_cy = 5318
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/08
'描 述：一个很酷的简单录音源码示例
'网 站：http://www.mndsoft.com/
'e-mail：mnd@mndsoft.com
'OICQ : 88382850
'****************************************************************************
Option Explicit
Private Declare Function SetWindowRgn Lib "user32.dll" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32.dll" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Dim down As Boolean
Dim t As Integer
Dim w As Integer
Private Type POINTAPI
x As Long
Y As Long
End Type
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1 'bring to top and stay there
Private Const SWP_NOMOVE = &H2 'don't move window
Private Const SWP_NOSIZE = &H1 'don't size window
Private Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
Private Sub cmdBrowse_Click()
On Error GoTo Error_Handler
CommonDialog1.CancelError = True
CommonDialog1.Filter = "All Supported Media Files|*.*"
CommonDialog1.Flags = &H2 Or &H400
CommonDialog1.ShowOpen
txtOpen.Text = CommonDialog1.FileName
Error_Handler:
End Sub
Private Sub cmdClose_Click()
End
End Sub
Private Sub cmdOpen_Click()
Dim i As Integer
On Error GoTo Error_Handler
WindowsMediaPlayer1.URL = txtOpen.Text
WindowsMediaPlayer1.Controls.play
cmdRecord_Click
'MCI command to save the WAV file
i = mciSendString("save capture " & CommonDialog1.FileName, 0&, 0, 0)
Error_Handler:
End Sub
Private Sub cmdOptions_Click()
frmOptions.Show vbModeless, Me
Me.Enabled = False
End Sub
Private Sub cmdPlay_Click()
Dim i As Integer
i = mciSendString("play capture from 0", 0&, 0, 0)
End Sub
Private Sub cmdRecord_Click()
Dim i As Integer
'Close any MCI operations from previous VB programs
i = mciSendString("close all", 0&, 0, 0)
'Open a new WAV with MCI Command...
i = mciSendString("open new type waveaudio alias capture", 0&, 0, 0)
'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("set capture channels 2", 0&, 0, 0) ' 2 channels for stereo
'start at begining
i = mciSendString("seek capture to start", 0&, 0, 0) 'Always start at the beginning
i = mciSendString("set capture samplespersec 44100", 0&, 0, 0) 'CD Quality
i = mciSendString("set capture bitspersample 16", 0&, 0, 0) '16 bits for better sound
i = mciSendString("record capture", 0&, 0, 0) 'Start the recording
cmdStop.Enabled = True 'Enable the STOP BUTTON
cmdPlay.Enabled = False 'Disable the "PLAY" button
cmdSaveAs.Enabled = False 'Disable the "SAVE AS" button
cmdRecord.Caption = "录音中..."
cmdRecord.Enabled = False
tmrStatus.Enabled = True
End Sub
Private Sub cmdSaveAs_Click()
Dim i As Integer
CommonDialog1.CancelError = True
On Error GoTo ErrHandler1
CommonDialog1.Filter = "声音文件 (*.wav*)|*.wav"
CommonDialog1.Flags = &H2 Or &H400
CommonDialog1.InitDir = GetSetting(App.EXEName, App.EXEName, "Default Path")
CommonDialog1.FileName = GetSetting(App.EXEName, App.EXEName, "Default Filename")
CommonDialog1.ShowSave
'If file already exists then remove it
If Len(Dir$(CommonDialog1.FileName)) > 0 Then
Kill CommonDialog1.FileName
End If
'MCI command to save the WAV file
i = mciSendString("save capture " & """" & CommonDialog1.FileName & """", 0&, 0, 0)
ErrHandler1:
End Sub
Private Sub cmdStop_Click()
Dim i As Integer
i = mciSendString("stop capture", 0&, 0, 0)
cmdSaveAs.Enabled = True 'Enable the "SAVE AS" button
cmdPlay.Enabled = True 'Enable the "PLAY" button
cmdRecord.Enabled = True
cmdRecord.Caption = "开始录音(&R)"
cmdStop.Enabled = False
tmrStatus.Enabled = True
End Sub
Private Sub Form_Load()
Dim i As Integer
Me.Width = Me.Picture.Width
Me.Height = Me.Picture.Height
Me.Left = 0
Me.Top = Screen.Height - Me.ScaleHeight + 200
down = False
MakeShape Me.hWnd
Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
'Close any MCI operations from previous VB programs
i = mciSendString("close all", 0&, 0, 0)
'Open a new WAV with MCI Command...
i = mciSendString("open new type waveaudio alias capture", 0&, 0, 0)
WindowsMediaPlayer1.settings.volume = 100
WindowsMediaPlayer1.Controls.play
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim i As Integer
i = mciSendString("close capture", 0&, 0, 0)
End Sub
Private Function MakeShape(MHWND As Long)
Dim point(52) As POINTAPI
point(0).x = 1.995
point(0).Y = 458.8675
point(1).x = 17.955
point(1).Y = 450.895
point(2).x = 50.8975
point(2).Y = 433.9125
point(3).x = 70.8575
point(3).Y = 424.935
point(4).x = 86.7825
point(4).Y = 420.945
point(5).x = 126.6825
point(5).Y = 395.01
point(6).x = 210.51
point(6).Y = 373.065
point(7).x = 234.4125
point(7).Y = 368.0775
point(8).x = 254.3625
point(8).Y = 362.0925
point(9).x = 266.3325
point(9).Y = 359.1
point(10).x = 284.2875
point(10).Y = 331.17
point(11).x = 305.235
point(11).Y = 302.2425
point(12).x = 321.195
point(12).Y = 264.3375
point(13).x = 324.1875
point(13).Y = 208.4775
point(14).x = 322.1925
point(14).Y = 171.57
point(15).x = 325.185
point(15).Y = 146.6325
point(16).x = 338.1525
point(16).Y = 96.7575
point(17).x = 362.0925
point(17).Y = 58.8525
point(18).x = 389.025
point(18).Y = 33.915
point(19).x = 430.92
point(19).Y = 17.955
point(20).x = 461.8425
point(20).Y = 10.9725
point(21).x = 504.735
point(21).Y = 8.9775
point(22).x = 533.6625
point(22).Y = 19.95
point(23).x = 564.585
point(23).Y = 34.9125
point(24).x = 590.52
point(24).Y = 57.855
point(25).x = 615.4575
point(25).Y = 96.7575
point(26).x = 623.4375
point(26).Y = 110.7225
point(27).x = 633.4125
point(27).Y = 145.635
point(28).x = 644.385
point(28).Y = 203.49
point(29).x = 640.395
point(29).Y = 229.425
point(30).x = 639.3975
point(30).Y = 261.345
point(31).x = 628.425
point(31).Y = 299.25
point(32).x = 615.4575
point(32).Y = 322.1925
point(33).x = 607.4775
point(33).Y = 322.1925
point(34).x = 591.5175
point(34).Y = 361.095
point(35).x = 577.5525
point(35).Y = 385.035
point(36).x = 564.585
point(36).Y = 422.94
point(37).x = 558.6
point(37).Y = 424.935
point(38).x = 551.6175
point(38).Y = 443.8875
point(39).x = 535.6575
point(39).Y = 452.865
point(40).x = 511.7175
point(40).Y = 450.87
point(41).x = 476.805
point(41).Y = 436.905
point(42).x = 459.8475
point(42).Y = 457.8525
point(43).x = 480.795
point(43).Y = 487.7775
point(44).x = 484.785
point(44).Y = 513.7125
point(45).x = 480.795
point(45).Y = 538.65
point(46).x = 473.8125
point(46).Y = 556.605
point(47).x = 482.79
point(47).Y = 592.515
point(48).x = 488.775
point(48).Y = 636.405
point(49).x = 492.765
point(49).Y = 666.33
point(50).x = 491.7675
point(50).Y = 680.295
point(51).x = 487.7775
point(51).Y = 800.2775
point(52).x = 0.9975
point(52).Y = 800.2775
SetWindowRgn MHWND, CreatePolygonRgn(point(0), 53, 1), True
End Function
Private Sub tmrStatus_Timer()
Dim mssg As String * 255
Dim msg As String
Dim i As Integer
i = mciSendString("set capture time format ms", 0&, 0, 0)
i = mciSendString("status capture length", mssg, 255, 0)
msg = "毫秒 = " & Str(mssg) & vbCrLf
i = mciSendString("set capture time format bytes", 0&, 0, 0)
i = mciSendString("status capture length", mssg, 255, 0)
msg = msg & "字节 = " & Str(mssg) & vbCrLf
i = mciSendString("status capture channels", mssg, 255, 0)
If Str(mssg) = 1 Then
msg = msg & "通道 = 1 (单声)" & vbCrLf
ElseIf Str(mssg) = 2 Then
msg = msg & "通道 = 2 (立体声)" & vbCrLf
End If
i = mciSendString("status capture bitspersample", mssg, 255, 0)
msg = msg & "位采样 = " & Str(mssg) & vbCrLf
i = mciSendString("status capture bytespersec", mssg, 255, 0)
msg = msg & "秒字节 = " & Str(mssg) & vbCrLf
txtStatus.Text = msg
End Sub
Private Sub WindowsMediaPlayer1_MediaError(ByVal pMediaObject As Object)
cmdStop_Click
WindowsMediaPlayer1.Close
tmrStatus.Enabled = False
txtStatus.Text = "Error"
End Sub
Private Sub WindowsMediaPlayer1_PlayStateChange(ByVal NewState As Long)
On Error GoTo Error_Handler
If NewState = 1 Then
cmdStop_Click
WindowsMediaPlayer1.Close
tmrStatus.Enabled = False
End If
Error_Handler:
End Sub