Global gDX As New DirectX8
Global gDSC As DirectSoundCapture8
Global gDSCB As DirectSoundCaptureBuffer8
Global gDSCBD As DSCBUFFERDESC
Public eventid( 1 ) As Long
Public EVNT( 1 ) As DSBPOSITIONNOTIFY
Public MEM() As Byte
Global f%
Public WaveF1 As WAVEFORMATEX
Public Buffer() As Byte
Public cur As DSCURSORS

Private fFile_1%, fFile_2%, File_1Holder() As Byte
Private bFlag As Boolean


'----------------------------------------
'Wave header info
'----------------------------------------
Private Type FileHeader
    dwRiff As Long
    dwFileSize As Long
    dwWave As Long
    dwFormat As Long
    dwFormatLength As Long
    wFormatTag As Integer
    nChannels As Integer
    nSamplesPerSec As Long
    nAvgBytesPerSec As Long
    nBlockAlign As Integer
    wBitsPerSample As Integer
    dwData As Long
    dwDataLength As Long
End Type

'-------------------------------------
'init the capture buffer
'-------------------------------------
Public Sub Init(guid As String)

    'Creating the sound buffer succeeds depending on the wave format.  We try
    'both 16-bit Linear PCM @ 8Khz (default) and 8-bit Linear PCM @ 8Khz, both
    'mono of course.
    With WaveF1
        .nFormatTag = WAVE_FORMAT_PCM
        .nChannels =  1 
        .lSamplesPerSec =  8000 
        .nBitsPerSample =  16 
        .nBlockAlign = _
            .nBitsPerSample /  8  * .nChannels
        .lAvgBytesPerSec = _
            .lSamplesPerSec * .nBlockAlign
        .nSize =  0   ' Ignored for WAVE_FORMAT_PCM.
    End With
    
    'capture buffer
    On Error GoTo ErrorOut:
    Set gDSC = gDX.DirectSoundCaptureCreate(guid)
    
    On Error GoTo  0  'Resume normal error handling
    Err.Clear
    
    With gDSCBD
        'Set DSBCAPS_GLOBALFOCUS or we pause capturing if we lose window focus!
        .lFlags = DSCBCAPS_WAVEMAPPED Or DSBCAPS_GLOBALFOCUS
        .lBufferBytes = WaveF1.lAvgBytesPerSec *  2 
        .fxFormat = WaveF1
    End With
    
    On Error GoTo Format8
    Set gDSCB = gDSC.CreateCaptureBuffer(gDSCBD)
    
    Debug.Print "Using 16-Bit PCM"
    Exit Sub
    
Format8:
    'Didn't like 16-bit PCM, we will try 8-bit
    
    'Redundant settings are commented out but left for documentation
    With WaveF1
'        .nFormatTag = WAVE_FORMAT_PCM
'        .nChannels = 1
'        .lSamplesPerSec = 8000
        .nBitsPerSample =  8 
        .nBlockAlign = _
            .nBitsPerSample /  8  * .nChannels
        .lAvgBytesPerSec = _
            .lSamplesPerSec * .nBlockAlign
'        .nSize = 0  ' Ignored for WAVE_FORMAT_PCM.
    End With
    
    With gDSCBD
        'Set DSBCAPS_GLOBALFOCUS or we pause capturing if we lose window focus!
'        .lFlags = DSCBCAPS_WAVEMAPPED  Or DSBCAPS_GLOBALFOCUS
        .lBufferBytes = WaveF1.lAvgBytesPerSec *  2 
        .fxFormat = WaveF1
    End With
    
    Set gDSCB = gDSC.CreateCaptureBuffer(gDSCBD)
    
    Debug.Print "Using 8-Bit PCM"
    
    Exit Sub
    
ErrorOut:
    Debug.Print Err.Description & Err.Number
    Err.Raise Err
End Sub

'--------------------------------------
'Close the open files
'--------------------------------------
Public Sub CloseFiles()
    On Local Error Resume Next
    Close #fFile_1
    Close #fFile_2
    Close #f
End Sub

'--------------------------------------
'Delete the temp file
'--------------------------------------
Public Sub KillTempFile()
    On Local Error Resume Next
    Close #f
    Kill App.Path + "\tmp.tmp"
End Sub


'--------------------------------------
'Open a temp file for output
'--------------------------------------
Public Sub StreamToTempFile()
    'open a temp file for streaming input
    f% = FreeFile
    Open App.Path + "\tmp.tmp" For Binary Access Write As #f
End Sub

'******************************************************************************
'StartCapture
'
'Start streaming all bits into our temporary file
'******************************************************************************
Public Sub StartCapture()
    bFlag = True
    Call StreamToTempFile
    gDSCB.Start DSCBSTART_LOOPING
End Sub

'******************************************************************************
''send the buffer data to a file
'******************************************************************************
Public Sub CopyBuffer(part As Integer)
    Dim lBufSize As Integer
    
    'Need to ignore first event, we just started nothing to write yet
    If bFlag = True Then
        bFlag = False
        Exit Sub
    End If
    
    On Error GoTo Failure:
    
    lBufSize = (gDSCBD.lBufferBytes \  2 )
    
    ReDim Buffer(lBufSize -  1 )
    
    'We are using a single circular buffer for recording.  We get events when
    'the the DirectSound buffer pointer is at the beginning of the buffer
    'and when it is at the middle.  So if part = 1 we got a middle event,
    'and we read from the beginning to the middle of the buffer.  Else we
    'read from the middle to the end of the buffer
    If part =  1  Then
        gDSCB.ReadBuffer  0 , lBufSize, Buffer( 0 ), DSCBLOCK_DEFAULT
    Else
        gDSCB.ReadBuffer lBufSize, lBufSize, Buffer( 0 ), DSCBLOCK_DEFAULT
    End If
    
    
    Put #f, , Buffer
    
    Erase Buffer
    
Exit Sub

Failure:
    Debug.Print "Failure in CopyBuffer"
End Sub

'--------------------------------------------------
'Save the whole thing to a file
'--------------------------------------------------
Public Sub SaveToFileAsStream(sName As String)
    
    Dim fh As FileHeader, Status As Long
    Dim WF As WAVEFORMATEX
    
    On Error Resume Next
    Status = gDSCB.GetStatus

    If (Status And DSCBSTATUS_CAPTURING) Then gDSCB.Stop
    On Error GoTo  0  'Resume normal error handling
    
    'get the wave data from the tmp file
    fFile_1% = FreeFile
    
    Open App.Path + "\tmp.tmp" For Binary Access Read As #fFile_1
    ReDim File_1Holder(LOF(fFile_1%) +  1 )
    
    Get #fFile_1, , File_1Holder
    
    Close #fFile_1
    
    WF = WaveF1
        
    fFile_2% = FreeFile
    
    Open sName For Binary Access Write As #fFile_2
    
    'Setup the .wav file header.
    fh.dwRiff = &H46464952            '                // RIFF
    fh.dwWave = &H45564157            '                // WAVE
    fh.dwFormat = &H20746D66          '                // fmt_chnk
    fh.dwFormatLength =  16 
    fh.wFormatTag = WAVE_FORMAT_PCM
    fh.nChannels = WF.nChannels
    fh.nSamplesPerSec = WF.lSamplesPerSec
    fh.wBitsPerSample = WF.nBitsPerSample
    fh.nBlockAlign = fh.wBitsPerSample /  8  * fh.nChannels
    fh.nAvgBytesPerSec = fh.nSamplesPerSec * fh.nBlockAlign
    fh.dwData = &H61746164            '                // data_chnk
    fh.dwDataLength = UBound(File_1Holder)
    fh.dwFileSize = UBound(File_1Holder) + Len(fh)
    
    'add the info to the second file
    Put #fFile_2, , fh
    Put #fFile_2, , File_1Holder
    
    Close #fFile_2
    
    Call KillTempFile
    
End Sub

[/SRC][SRC vba]

Public Function GetLegacyWaveIDAsDXDeviceGUID(line As Integer, strWave As String)

    Dim lMediaID As Integer
    Dim lCount As Long
    Dim dsEnum As DirectSoundEnum8
    Dim strMatch As String
    
    'Assume failure
    GetLegacyWaveIDAsDXDeviceGUID = vbNullString
    
    lMediaID = GetDeviceId(line, strWave)
    
    If lMediaID = - 1  Then Exit Function
    
    On Error GoTo FailedEnum
    
    'dsEnum.GetName returns, for our purposes, a string like "WaveOut 0" or
    '"WaveIn 0" the trailing numerical part matches exactly with our legacy
    'wave id!
    If strWave = "wave/out" Then
        Set dsEnum = gDX.GetDSEnum
        strMatch = "WaveOut " & lMediaID
    Else
        Set dsEnum = gDX.GetDSCaptureEnum
        strMatch = "WaveIn " & lMediaID
    End If
    
    'Enumerate all the DXSound(Render/Capture) devices and look for a match
    For lCount =  1  To dsEnum.GetCount

        If strMatch = dsEnum.GetName(lCount) Then
            'Found it!
            GetLegacyWaveIDAsDXDeviceGUID = dsEnum.GetGuid(lCount)
            Exit For
        End If
        
    Next
    
FailedEnum: 'We fall through this, we will return vbNullString if we failed

    Set dsEnum = Nothing
    Err.Clear
    
End Function

Public Function GetDeviceId(line As Integer, strWave As String)
Dim oVar As varString
Dim nError As Long
Dim lVersion As Long
Dim lParams As LINEINITIALIZEEXPARAMS
Dim hLine As Long
Dim lUnused As Long
Dim lMediaID As Long
Dim hTAPI As Long
Dim lNumLines As Long

    lVersion = TAPIVERSION
    
    lParams.dwTotalSize = Len(oVar)
    lParams.dwOption =  1 
    
    'Assume failure
    GetDeviceId = - 1 

    nError = lineInitializeExA(hTAPI, App.hInstance, _
                AddressOf LineCallBack,  0 , lNumLines, lVersion, lParams)
                
    If nError <>  0  Then
        MsgBox "Can not init TAPI 2.1"
        Exit Function
    End If

    'VB starts at one for lines, TAPI C code is zero based, subtract 1 from line
    nError = lineOpen(hTAPI, line -  1 , hLine, lVersion, lUnused, lUnused, _
        LINECALLPRIVILEGE_MONITOR, LINEMEDIAMODE_AUTOMATEDVOICE,  0 )
        
    If nError <>  0  Then
        MsgBox "Can not open legacy line " & line
        lineShutdown hTAPI
        Exit Function
    End If

    oVar.dwTotalSize = Len(oVar)

    nError = lineGetID(hLine,  0 ,  0 ,  1 , oVar, strWave)
    
    If nError =  0  Then
        If oVar.dwStringOffset =  0  Then 'Nothing to get!
            MsgBox "Can not get device id for " & strWave
            lineShutdown hTAPI
            Exit Function
        End If
        Dim sTemp As String
        sTemp = Trim(Left(oVar.bBytes( 0 ), oVar.dwStringSize))
        lMediaID = sTemp
        GetDeviceId = lMediaID
    End If
    
    lineShutdown hTAPI
    
End Function
Private Function StartListen() As Boolean
Dim objCollAddresses As ITCollection
Dim m_Card As String
    StartListen = False
    
    If gobjTapi Is Nothing Then Call InitTAPI
    
    m_Card = GetSetting("Cuckoo", "Settings", "DeviceName", "")
    
    Set objCollAddresses = gobjTapi.Addresses
    
    m_device = GetDeviceByName(m_Card, objCollAddresses)
    
    If m_device = - 1  Then
        MsgBox "Can not find selected device, choose Settings"
        Exit Function
    End If
    
    'pick up the "N"-th address - the address on which
    'you want to register for receiving calls
    Set gobjAddress = objCollAddresses.Item(m_device)
    Set objCollAddresses = Nothing    'no more needed, release
        
    RegisterForNotification
    
    'Set our DirectSound device GUID's
    m_recGuid = GetLegacyWaveIDAsDXDeviceGUID(m_device, "wave/in") ' Guid устройство для записи
    m_playGuid = GetLegacyWaveIDAsDXDeviceGUID(m_device, "wave/out")' Guid устройство для воспроизведения
    
    StartListen = True
End Function