FreeBasic

Данную программу конечно можно было написать проще с помощью высокоуровневой функции mciSendString , но мы не ищем легких путей :)
Это простая по возможностям программа, которая умеет записывать одноканальный звук со звукового устройства с предустановленной частотой дискретизации 11000 гц и максимально возможным временем записи 2 часа. Конечно изменить эти величины возможно в коде. Так же программа воспроизводит записанный звук и при желании сохраняет на диск в формате WAV.

Платформа: Windows
Автор: Станислав Будинов

#INCLUDE "windows.bi"
#INCLUDE "win/mmsystem.bi"

Const As Integer Lenght = 7200 ' maximum 2 hours

Type WaveFileHeader
    riff(3) As Byte = {82,73,70,70}
    Len_ As  Integer
    cWavFmt(7) As Byte = {87,65,86,69,102,109,116,32}
    dwHdrLen As Integer = 16
    wFormat As Short = 1
    wNumChannels As Short = 1
    dwSampleRate As Integer = 11000
    dwBytesPerSec As Integer = 22000
    wBlockAlign As Short = 4
    wBitsPerSample As Short = 16
    cData(3) As Byte = {100,97,116,97}
    dwDataLen As Integer
End Type

Type Sound
    As HWND hw
    As HWND StaticTime,ButtonRec,ButtonPlay,ButtonSave
    As WAVEHDR hdr
    As HWAVEIN hWaveIn
    As HWAVEOUT hWaveOut
    As WAVEFORMATEX wfx
    As WaveFileHeader Wavehdr
    As Byte buffer(11000*Lenght*2)
    As MSG msg
    As WNDCLASSEX wc
    As String NameClass="MyClass"
    As HINSTANCE Hinst=GetModuleHandle(0)
    As Double Tsec,SaveRecTime
    As BOOL Frec,Fplay,playtrue
    Declare Function init() As BOOL
    Declare Function Rec() As BOOL
    Declare Sub RecStop()
    Declare Function Play() As BOOL
    Declare Sub PlayStop()
    Declare Sub SaveSound()
    Declare Static Function wndproc(hwnd As HWND, msg As Uinteger,_
    wparam As WPARAM, lparam As LPARAM) As Integer
End Type

Dim Shared obj As Sound
obj.init

Function Sound.init() As BOOL
    With wc
        .cbSize=SizeOf(WNDCLASSEX)
        .style=CS_HREDRAW Or CS_VREDRAW
        .lpfnWndProc=@WndProc
        .hInstance=Hinst
        .hIcon=LoadIcon(0,IDI_WINLOGO)
        .hCursor=LoadCursor(0,IDC_ARROW)
        .hbrBackground=Cast(HBRUSH,COLOR_WINDOWFRAME)
        .lpszClassName=StrPtr(NameClass)
        .hIconSm=.hIcon
    End With
    If RegisterClassEx(@wc)=0 Then
        Print "Register error, press any key"
        Sleep
        End
    Endif
    hw=CreateWindowEx(0,NameClass,"Simple Recorder",_
    WS_VISIBLE Or WS_OVERLAPPEDWINDOW,100,100,235,110,0,0,Hinst,0)
    SetTimer(hw,1,1000,0)
    ' Цикл сообщений
    While GetMessage(@msg,0,0,0)
        TranslateMessage(@msg)
        DispatchMessage(@msg)
    Wend
    Return TRUE
End Function

Sub Sound.SaveSound()
    Var Hfile=CreateFile("SoundTest.wav",GENERIC_WRITE Or GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE,0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL,0)
    Dim buff As Integer
    WriteFile(Hfile,Cast(LPCVOID,@Wavehdr),Sizeof(WaveFileHeader),@buff,0)
    WriteFile(Hfile,Cast(LPCVOID,@buffer(0)),Wavehdr.dwDataLen,@buff,0)
    CloseHandle(Hfile)
End Sub

Function Sound.Rec() As BOOL
    ZeroMemory(@buffer(0),Ubound(buffer)+1)
    With wfx
        .wFormatTag = WAVE_FORMAT_PCM
        .nChannels = 1
        .nSamplesPerSec = 11000
        .wBitsPerSample = 16
        .nBlockAlign = .nChannels * (.wBitsPerSample \ 8)
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
        .cbSize = Sizeof(WAVEFORMATEX)
    End With
    With hdr
        .lpData = @buffer(0)
        .dwBufferLength = Ubound(buffer)+1
    End With
    If waveInOpen(@hWaveIn, Cast(Uinteger, -1), @wfx, 0, 0, CALLBACK_NULL)<> MMSYSERR_NOERROR Then
        MessageBox(0,"Unable to mount device","Error",0)
        Return FALSE
    Endif
    waveInPrepareHeader(hWaveIn, @hdr, Sizeof(WAVEHDR))
    waveInAddBuffer(hWaveIn, @hdr, Sizeof(WAVEHDR))

    If waveInStart(hWaveIn)<> MMSYSERR_NOERROR Then
        MessageBox(0,"A bad start recording","Error",0)
        Return FALSE
    Endif
    Return TRUE
End Function

Sub Sound.RecStop()
    waveInReset(hWaveIn)
    waveInUnprepareHeader(hWaveIn, @hdr, Sizeof(WAVEHDR))
    waveInClose(hWaveIn)
End Sub

Function Sound.Play() As BOOL
    If waveOutOpen(@hWaveOut, Cast(Uinteger, -1), @wfx, 0, 0, CALLBACK_NULL)<> MMSYSERR_NOERROR Then
        MessageBox(0,"Unable to mount device","Error",0)
        Return FALSE
    Endif
    waveOutPrepareHeader(hWaveOut, @hdr, Sizeof(WAVEHDR))
    waveOutWrite(hWaveOut, @hdr, Sizeof(WAVEHDR))
    Return TRUE
End Function

Sub Sound.PlayStop()
    waveOutReset(hWaveOut)
    waveOutUnprepareHeader(hWaveOut, @hdr, Sizeof(WAVEHDR))
    waveOutClose(hWaveOut)
End Sub

Function Sound.wndproc(hwnd As HWND, msg As Uinteger,_
    wparam As WPARAM, lparam As LPARAM) As Integer
    Select Case msg
        Case WM_CREATE
            obj.ButtonRec  = CreateWindowEx(0,"button","Record",WS_CHILD Or WS_VISIBLE,10,10,60,20,hwnd,Cast(HMENU,1),0,0)
            obj.StaticTime = CreateWindowEx(0,"Static","0:00",WS_CHILD Or WS_VISIBLE Or SS_CENTER Or SS_CENTERIMAGE,80,10,60,20,hwnd,Cast(HMENU,2),0,0)
            obj.ButtonPlay = CreateWindowEx(0,"button","Play",WS_CHILD Or WS_VISIBLE,150,10,60,20,hwnd,Cast(HMENU,3),0,0)
            obj.ButtonSave = CreateWindowEx(0,"button","Save",WS_CHILD Or WS_VISIBLE,70,40,80,20,hwnd,Cast(HMENU,4),0,0)
        Case WM_TIMER
            If obj.Frec = 1 Or obj.Fplay = 1 Then
                Dim As Integer m = (Timer()- obj.Tsec)\60,s = (Timer()- obj.Tsec) Mod 60
                If obj.SaveRecTime<=Timer()- obj.Tsec And obj.Fplay = 1 Then
                    SendMessage(hwnd,WM_COMMAND,Makelparam(3,0),0)
                Endif
                If s<10 Then
                    SetWindowText(obj.StaticTime,m & ":" & "0" & s)
                Else
                    SetWindowText(obj.StaticTime,m & ":"  & s)
                Endif
            Endif
        Case WM_COMMAND
            Select Case Loword(WPARAM)
                Case 1
                    If obj.Frec = 0 Then
                        obj.Frec = 1
                        SetWindowText(obj.ButtonRec,"Stop")                     
                        obj.Tsec = Timer()
                        EnableWindow(obj.ButtonPlay,FALSE)
                        EnableWindow(obj.ButtonSave,FALSE)
                        obj.rec()
                    Else
                        obj.Frec = 0
                        SetWindowText(obj.ButtonRec,"Record")                   
                        obj.Tsec = Timer()- obj.Tsec
                        obj.RecStop()
                        obj.SaveRecTime = obj.Tsec
                        EnableWindow(obj.ButtonPlay,TRUE)
                        EnableWindow(obj.ButtonSave,TRUE)
                        obj.Wavehdr.dwDataLen = 11000*obj.Tsec*2
                    Endif
                    obj.playtrue= TRUE
                Case 3
                    If obj.playtrue= TRUE Then                      
                        If obj.Fplay = 0 Then
                            obj.Fplay = 1
                            SetWindowText(obj.ButtonPlay,"Stop")
                            obj.Play()
                            EnableWindow(obj.ButtonRec,FALSE)
                            EnableWindow(obj.ButtonSave,FALSE)
                            obj.Tsec = Timer()
                        Else
                            obj.Fplay = 0
                            SetWindowText(obj.ButtonPlay,"Play")
                            obj.PlayStop()
                            EnableWindow(obj.ButtonRec,TRUE)
                            EnableWindow(obj.ButtonSave,TRUE)
                        Endif
                    Endif
                Case 4
                    obj.SaveSound()
                    MessageBox(0,"SoundTest.wav file saved in a folder with the program","",0)
            End Select
        Case WM_DESTROY
            PostQuitMessage(0)
    End Select
    Return DefWindowProc(hwnd,msg,wparam,lparam)
End Function