dcsimg
Results 1 to 18 of 18

Thread: [VB6] - Vocoder.

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    [VB6] - Vocoder.

    Hello everyone. Creating music, I've seen a lot of different virtual instruments and effects. One of the most interesting effects is the vocoder, which allows you to modulate his voice and make it look like a voice for example a robot or something like that. Vocoder was originally used to compress the voice data, and then it began to be used in the music industry. Because I had free time, I decided to write something like this for the sake of the experiment and describe in detail the stages of development for VB6.
    So, take a look at the simplest scheme vocoder:

    The signal from the microphone (speech) is fed to a bank of bandpass filters, each of which passes only a small part of the frequency band of the speech signal. The greater the number of filters - the better speech intelligibility. At the same time, the carrier signal (e.g. ramp) is also passed through the same filter bank. Filter output speech signal is fed to envelope detectors which control modulators and outputs a filter carrier signal passes to the other input of the modulator. As a result, each band speech signal adjusts the level of the corresponding band carrier (modulates it). Further, output signals from all modulators are mixed and sent to the output. Further, all signal modulators are mixed and sent to the output. In order to improve speech intelligibility also apply additional blocks, such as the detector "sizzling" sound. So, to begin development necessary to determine the source signals, where they will take. It is possible for example to capture data from a file or directly processed in real-time from a microphone or line input. To test very easy to use file, so we will do and so and so. As the carrier will use an external file looped in a circle, to adjust the tone simply add the ability to change the playback speed, which will change the tone. To capture the sound of the file will use Audio Compression Manager (ACM), with it very convenient to make conversion between formats (because the file can be in any format, you would have to write some functions to different formats). It may be that to convert to the desired format will not correct ACM drivers, then play this file will not be available (although you can try to do it in 2 stages). As input files will use the wav - files, because to work with them in the system has special features to facilitate retrieving data from them.

  2. #2

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    clsTrickWavConverter.cls:
    Code:
    ' // clsTrickWavConverter.cls - class for wav conversion using ACM
    ' //  Krivous Anatoly Anatolevich (The trick), 2014
    
    Option Explicit
    
    Private Type WAVEFORMATEX
        wFormatTag      As Integer
        nChannels       As Integer
        nSamplesPerSec  As Long
        nAvgBytesPerSec As Long
        nBlockAlign     As Integer
        wBitsPerSample  As Integer
        cbSize          As Integer
    End Type
    
    Private Type ACMSTREAMHEADER
        cbStruct        As Long
        fdwStatus       As Long
        lpdwUser        As Long
        lppbSrc         As Long
        cbSrcLength     As Long
        cbSrcLengthUsed As Long
        lpdwSrcUser     As Long
        lppbDst         As Long
        cbDstLength     As Long
        cbDstLengthUsed As Long
        lpdwDstUser     As Long
        dwDriver(9)     As Long
    End Type
    
    Private Type MMCKINFO
        ckid            As Long
        ckSize          As Long
        fccType         As Long
        dwDataOffset    As Long
        dwFlags         As Long
    End Type
    
    Private Declare Function acmStreamClose Lib "msacm32" (ByVal has As Long, ByVal fdwClose As Long) As Long
    Private Declare Function acmStreamConvert Lib "msacm32" (ByVal has As Long, ByRef pash As ACMSTREAMHEADER, ByVal fdwConvert As Long) As Long
    Private Declare Function acmStreamMessage Lib "msacm32" (ByVal has As Long, ByVal uMsg As Long, ByVal lParam1 As Long, ByVal lParam2 As Long) As Long
    Private Declare Function acmStreamOpen Lib "msacm32" (phas As Any, ByVal had As Long, pwfxSrc As WAVEFORMATEX, pwfxDst As WAVEFORMATEX, pwfltr As Any, dwCallback As Any, dwInstance As Any, ByVal fdwOpen As Long) As Long
    Private Declare Function acmStreamPrepareHeader Lib "msacm32" (ByVal has As Long, ByRef pash As ACMSTREAMHEADER, ByVal fdwPrepare As Long) As Long
    Private Declare Function acmStreamReset Lib "msacm32" (ByVal has As Long, ByVal fdwReset As Long) As Long
    Private Declare Function acmStreamSize Lib "msacm32" (ByVal has As Long, ByVal cbInput As Long, ByRef pdwOutputBytes As Long, ByVal fdwSize As Long) As Long
    Private Declare Function acmStreamUnprepareHeader Lib "msacm32" (ByVal has As Long, ByRef pash As ACMSTREAMHEADER, ByVal fdwUnprepare As Long) As Long
    
    Private Declare Function mmioClose Lib "winmm.dll" (ByVal hmmio As Long, ByVal uFlags As Long) As Long
    Private Declare Function mmioDescend Lib "winmm.dll" (ByVal hmmio As Long, lpck As MMCKINFO, lpckParent As Any, ByVal uFlags As Long) As Long
    Private Declare Function mmioOpen Lib "winmm.dll" Alias "mmioOpenA" (ByVal szFileName As String, lpmmioinfo As Any, ByVal dwOpenFlags As Long) As Long
    Private Declare Function mmioRead Lib "winmm.dll" (ByVal hmmio As Long, pch As Any, ByVal cch As Long) As Long
    Private Declare Function mmioStringToFOURCC Lib "winmm.dll" Alias "mmioStringToFOURCCA" (ByVal sz As String, ByVal uFlags As Long) As Long
    Private Declare Function mmioAscend Lib "winmm.dll" (ByVal hmmio As Long, lpck As MMCKINFO, ByVal uFlags As Long) As Long
    
    Private Const MMIO_READ                     As Long = &H0
    Private Const MMIO_FINDCHUNK                As Long = &H10
    Private Const MMIO_FINDRIFF                 As Long = &H20
    Private Const ACM_STREAMOPENF_QUERY         As Long = &H1
    Private Const ACM_STREAMSIZEF_DESTINATION   As Long = &H1&
    Private Const ACM_STREAMSIZEF_SOURCE        As Long = &H0&
    Private Const ACM_STREAMCONVERTF_BLOCKALIGN As Long = &H4
    Private Const ACM_STREAMCONVERTF_START      As Long = &H10
    
    Private mInpFmt     As WAVEFORMATEX     ' // Input format is defined by file
    Private mOutFmt     As WAVEFORMATEX     ' // Output format is defined by user
    Private mDataSize   As Long             ' // Size of data in bytes
    Private bufIdx      As Long             ' // Current position in input buffer
    Private buffer()    As Byte             ' // Buffer
    Private hStream     As Long             ' // Handle of ACM stream
    Private mInit       As Boolean          ' // Whether ACM is initialized
    
    ' // Input format
    Public Property Get InputNumOfChannels() As Integer
        InputNumOfChannels = mInpFmt.nChannels
    End Property
    Public Property Get InputSamplesPerSecond() As Integer
        InputSamplesPerSecond = mInpFmt.nSamplesPerSec
    End Property
    Public Property Get InputBitPerSample() As Integer
        InputBitPerSample = mInpFmt.wBitsPerSample
    End Property
    
    ' // Size of input data
    Public Property Get InputDataSize() As Long
        InputDataSize = mDataSize
    End Property
    
    ' // Current position in samples
    Public Property Get InputCurrentPosition() As Long
        InputCurrentPosition = bufIdx / mInpFmt.nBlockAlign
    End Property
    Public Property Let InputCurrentPosition(ByVal Value As Long)
        Dim index As Long
        
        index = Value * mInpFmt.nBlockAlign
        
        If index >= mDataSize Or index < 0 Then
            
            err.Raise 5
            Exit Property
            
        End If
        
        bufIdx = index
    End Property
    
    ' // Output format
    Public Property Get OutputNumOfChannels() As Integer
        OutputNumOfChannels = mOutFmt.nChannels
    End Property
    Public Property Get OutputSamplesPerSecond() As Integer
        OutputSamplesPerSecond = mOutFmt.nSamplesPerSec
    End Property
    Public Property Get OutputBitPerSample() As Integer
        OutputBitPerSample = mOutFmt.wBitsPerSample
    End Property
    
    ' // Determines relation of output size with input size
    Public Property Get Rate() As Single
        Dim outLen  As Long
        ' // Initialization check
        If Not mInit Then
            If Not Init() Then Exit Property
        End If
        acmStreamSize hStream, mDataSize, outLen, ACM_STREAMSIZEF_SOURCE
        Rate = outLen / mDataSize
    End Property
    
    ' // Set output format
    Public Function SetFormat(ByVal NumOfChannels As Integer, ByVal SamplesPerSecond As Long, ByVal BitPerSample As Integer) As Boolean
        Dim outFmt  As WAVEFORMATEX
        Dim ret     As Long
        ' // Check format by ACM
        With outFmt
            .wFormatTag = 1
            .nChannels = NumOfChannels
            .nSamplesPerSec = SamplesPerSecond
            .wBitsPerSample = BitPerSample
            .nBlockAlign = .wBitsPerSample \ 8 * .nChannels
            .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
        End With
        ' // Only if file already has been opened
        If mDataSize Then
            ' // Query to ACM can it convert input format to specified output format
            ret = acmStreamOpen(ByVal 0&, 0, mInpFmt, outFmt, ByVal 0&, ByVal 0&, ByVal 0&, ACM_STREAMOPENF_QUERY)
            If ret Then Exit Function
            ' // Close stream
            If hStream Then acmStreamClose hStream, 0
            mInit = False
        End If
    
        mOutFmt = outFmt
        SetFormat = True
        
    End Function
    
    ' // Read a wave file and check possibility of conversion to output format
    Public Function ReadWaveFile(strFileName As String) As Boolean
        Dim hIn     As Long
        Dim inf     As MMCKINFO
        Dim sInf    As MMCKINFO
        Dim inpFmt  As WAVEFORMATEX
        Dim ret     As Long
        ' // Read file
        hIn = mmioOpen(strFileName, ByVal 0, MMIO_READ)
        If (hIn = 0) Then
            MsgBox "Error opening file"
            Exit Function
        End If
        ' // Seek WAVE chunk
        inf.fccType = mmioStringToFOURCC("WAVE", 0)
        If mmioDescend(hIn, inf, ByVal 0, MMIO_FINDRIFF) Then
            mmioClose hIn, 0
            MsgBox "Is not valid file"
            Exit Function
        End If
        ' // Seek fmt chunk defined format of data
        sInf.ckid = mmioStringToFOURCC("fmt", 0)
        If mmioDescend(hIn, sInf, inf, MMIO_FINDCHUNK) Then
            mmioClose hIn, 0
            MsgBox "Format chunk not found"
            Exit Function
        End If
        ' // Check size
        If sInf.ckSize > Len(inpFmt) Then
            mmioClose hIn, 0
            MsgBox "Not supported format"
            Exit Function
        End If
        ' // Read format
        If mmioRead(hIn, inpFmt, sInf.ckSize) = -1 Then
            mmioClose hIn, 0
            MsgBox "Can't read format"
            Exit Function
        End If
        ' // Query to ACM can it convert this format to specified output format
        ret = acmStreamOpen(ByVal 0&, 0, inpFmt, mOutFmt, ByVal 0&, ByVal 0&, ByVal 0&, ACM_STREAMOPENF_QUERY)
        If ret Then
            mmioClose hIn, 0
            MsgBox "Can't convert wav file"
            Exit Function
        End If
        ' // Leave fmt chunk
        mmioAscend hIn, sInf, 0
        ' // Seek data chunk
        sInf.ckid = mmioStringToFOURCC("data", 0)
        If mmioDescend(hIn, sInf, inf, MMIO_FINDCHUNK) Then
            mmioClose hIn, 0
            MsgBox "Wave data not found"
            Exit Function
        End If
        ' // Check size
        If sInf.ckSize <= 0 Then
            mmioClose hIn, 0
            MsgBox "Invalid data size"
            Exit Function
        End If
        ' // Alloc buffer and read data
        ReDim buffer(sInf.ckSize - 1)
        If mmioRead(hIn, buffer(0), sInf.ckSize) = -1 Then
            mmioClose hIn, 0
            MsgBox "Can't read data"
            Exit Function
        End If
        ' // Close file
        mmioClose hIn, 0
        ' // Initialization of variables
        mDataSize = sInf.ckSize
        bufIdx = 0
        mInpFmt = inpFmt
        ReadWaveFile = True
        
    End Function
    
    ' // Get converted data
    Public Function Convert(ByVal lpOutData As Long, ByVal dwCountBytes As Long, dwCountRead As Long) As Boolean
        Dim ret             As Long
        Dim inpCountBytes   As Long
        Dim acmHdr          As ACMSTREAMHEADER
        ' // Check initialization
        If Not mInit Then
            If Not Init() Then Exit Function
        End If
        ' // Get sufficient size of input data for current query
        ret = acmStreamSize(hStream, dwCountBytes, inpCountBytes, ACM_STREAMSIZEF_DESTINATION)
        If ret Then Exit Function
        ' // Check out of range
        If inpCountBytes + bufIdx >= mDataSize Then
            inpCountBytes = mDataSize - bufIdx
            
            If inpCountBytes <= 0 Then
                Convert = True
                dwCountRead = 0
                Exit Function
            End If
            
        End If
        ' // Fill ACM header
        With acmHdr
            .cbStruct = Len(acmHdr)
            .lppbDst = lpOutData
            .lppbSrc = VarPtr(buffer(bufIdx))
            .cbDstLength = dwCountBytes
            .cbSrcLength = inpCountBytes
        End With
        ' // Preparing...
        ret = acmStreamPrepareHeader(hStream, acmHdr, 0)
        If ret Then Exit Function
        ' // Conversion...
        ret = acmStreamConvert(hStream, acmHdr, ACM_STREAMCONVERTF_BLOCKALIGN)
        ' // Release
        acmStreamUnprepareHeader hStream, acmHdr, 0
        If ret Then Exit Function
        ' // Return number of read bytes
        dwCountRead = acmHdr.cbDstLengthUsed
        bufIdx = bufIdx + acmHdr.cbSrcLengthUsed
        ' // Success
        Convert = True
        
    End Function
    
    ' // ACM stream initialization
    Private Function Init() As Boolean
        Dim ret As Long
        ' // Open conversion stream
        ret = acmStreamOpen(hStream, 0, mInpFmt, mOutFmt, ByVal 0&, ByVal 0&, ByVal 0&, 0)
        If ret Then Exit Function
        
        Init = True
        mInit = True
    End Function
    
    Private Sub Class_Initialize()
        ' // Default output format
        With mOutFmt
            .wFormatTag = 1
            .nChannels = 1
            .nSamplesPerSec = SampleRate
            .wBitsPerSample = 16
            .nBlockAlign = .wBitsPerSample \ 8 * .nChannels
            .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
        End With
    End Sub
    
    Private Sub Class_Terminate()
        If hStream Then acmStreamClose hStream, 0
    End Sub

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    We examine in detail the code. To open a file is the method ReadWaveFile, as an argument it takes the name of the wav-file. Wav-file extension is a file format RIFF, which in turn is composed of blocks called chunks. So we open a file using the mmioOpen, which returns a file handle that can be used with functions with RIFF files. On success, then we begin to search for the type of chunk WAVE, for this we call mmioDescend, which fills the structure MMCKINFO information chunk, if it is found. The identifier is used chunk structure FOURCC, which is a 4 ASCII characters, which are packed into a 32-bit number (in this case, Long). As a parent chunk use NULL, as we do not have a child chunk, and as the flag pass MMIO_FINDRIFF, which sets the RIFF chunk search with a given type (in this case WAVE). So, if the function mmioDescend worked successfully, our file is a WAVE-file, and you can proceed to obtain the data format. The format of the data is stored in a chunk fmt, inside chunk WAVE (embedded chunk). For this chunk, we call again mmioDescend, just as the parent chunk pass just found WAVE-chunk, and as a flag - MMIO_FINDCHUNK, which makes the search for the specified chunk. If successful, check the size of the chunk, it must match the size of the structure WAVEFORMATEX, and if all goes well read data chunk (which are the structure WAVEFORMATEX) by calling mmioRead. So now we need to make sure whether the ACM convert data from this format you want us to. To do this, we call acmStreamOpen with flag ACM_STREAMOPENF_QUERY, which allows you to query whether the ACM to convert data between the two formats. If successful start further analysis. So we are now inside the fmt chunk, we need to go back to WAVE chunk to chunk the data request. To do this, we call mmioAscend. Further, as we did with the fmt chunk the same sequence of steps is repeated for the data chunk that contains the data directly in the format fmt chunk. Data is read into the buffer, zero out the pointer in the array at the beginning of the data (bufIdx) and fill the structure with its original format. To set the output format is the method SetFormat, which tests the ability to convert to a format file when it was opened. The main function of class clsTrickWavConverter - Convert, which converts the data from the buffer at offset bufIdx in the required format. Let's examine how it works. When you first convert the stream conversion is not already open (mInit variable defines the initialisation stream conversion), so we call the Init method that opens stream conversion through acmStreamOpen. The first parameter is a pointer to a handle stream (hStream) - it function returns a handle on success and we will use for the conversion. In case of successful initialization stream, we define the size of the data needed something to convert. Because the caller passes a pointer to the buffer and its length in bytes, we need to correctly fill the buffer, without going outside. To do this, we call acmStreamSize, which returns the required size of the data to be converted. As we pass flag ACM_STREAMSIZEF_DESTINATION, which indicates getting the size in bytes of the original data based on the buffer size of the output buffer. Next we correct size based on the initial output buffer beyond since possible that the source file for example too short or we read the data near the end of the buffer. Next we fill ACMSTREAMHEADER header describes the data conversion and prepare (fix) it to the conversion using the acmStreamPrepareHeader. After that we call acmStreamConvert, which performs the conversion. ACM_STREAMCONVERTF_BLOCKALIGN flag indicates that we convert integer blocks, in this case the block size - mInpFmt.nBlockAlign. After conversion, we have to cancel the fixation through acmStreamUnprepareHeader and returns the number of bytes returned, and move the pointer to the source buffer to the number of bytes processed.
    As a capture/playback of audio use clsTrickSound class to work with sound by winmm.

  4. #4

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    clsTrickSound.cls:
    Code:
    ' // clsTrickSound.cls - class for sound capture and playback
    ' //  Krivous Anatoly Anatolevich (The trick), 2014
    
    Option Explicit
    
    Private Enum MMRESULT
        MMSYSERR_NOERROR = 0
        MMSYSERR_ERROR = 1
        MMSYSERR_BADDEVICEID = 2
        MMSYSERR_NOTENABLED = 3
        MMSYSERR_ALLOCATED = 4
        MMSYSERR_INVALHANDLE = 5
        MMSYSERR_NODRIVER = 6
        MMSYSERR_NOMEM = 7
        MMSYSERR_NOTSUPPORTED = 8
        MMSYSERR_BADERRNUM = 9
        MMSYSERR_INVALFLAG = 10
        MMSYSERR_INVALPARAM = 11
        MMSYSERR_HANDLEBUSY = 12
        MMSYSERR_INVALIDALIAS = 13
        MMSYSERR_BADDB = 14
        MMSYSERR_KEYNOTFOUND = 15
        MMSYSERR_READERROR = 16
        MMSYSERR_WRITEERROR = 17
        MMSYSERR_DELETEERROR = 18
        MMSYSERR_VALNOTFOUND = 19
        MMSYSERR_NODRIVERCB = 20
        WAVERR_BADFORMAT = 32
        WAVERR_STILLPLAYING = 33
        WAVERR_UNPREPARED = 34
        MMRESULT_END
    End Enum
    
    Public Enum Errors
        CAPTURE_IS_ALREADY_RUNNING = vbObjectError Or (MMRESULT_END)
        INVALID_BUFFERS_COUNT
        NOT_INITIALIZE
        ERROR_UNAVAILABLE
        ERROR_OBJECT_FAILED
        ERROR_OPEN_DEVICE = vbObjectError Or (2 * &H100)
        ERROR_PREPARE_BUFFERS = vbObjectError Or (3 * &H100)
        ERROR_ADD_BUFFERS = vbObjectError Or (4 * &H100)
        ERROR_STARTUP = vbObjectError Or (5 * &H100)
        ERROR_STOP = vbObjectError Or (6 * &H100)
    End Enum
    
    Private Type WNDCLASSEX
        cbSize              As Long
        style               As Long
        lpfnwndproc         As Long
        cbClsextra          As Long
        cbWndExtra2         As Long
        hInstance           As Long
        hIcon               As Long
        hCursor             As Long
        hbrBackground       As Long
        lpszMenuName        As Long
        lpszClassName       As Long
        hIconSm             As Long
    End Type
    
    Private Type WAVEFORMATEX
        wFormatTag          As Integer
        nChannels           As Integer
        nSamplesPerSec      As Long
        nAvgBytesPerSec     As Long
        nBlockAlign         As Integer
        wBitsPerSample      As Integer
        cbSize              As Integer
    End Type
    
    Private Type WAVEINCAPS
        wMid                As Integer
        wPid                As Integer
        vDriverVersion      As Long
        szPname(31)         As Integer
        dwFormats           As Long
        wChannels           As Integer
        wReserved1          As Integer
    End Type
    Private Type WAVEOUTCAPS
        wMid                As Integer
        wPid                As Integer
        vDriverVersion      As Long
        szPname(31)         As Integer
        dwFormats           As Long
        wChannels           As Integer
        wReserved           As Integer
        dwSupport           As Long
    End Type
    
    Private Type WAVEHDR
        lpData              As Long
        dwBufferLength      As Long
        dwBytesRecorded     As Long
        dwUser              As Long
        dwFlags             As Long
        dwLoops             As Long
        lpNext              As Long
        Reserved            As Long
    End Type
     
    Private Type buffer
        data()              As Byte
        Header              As WAVEHDR
        Status              As Boolean
    End Type
    
    Private Type PROCESS_HEAP_ENTRY
        lpData              As Long
        cbData              As Long
        cbOverhead          As Byte
        iRegionIndex        As Byte
        wFlags              As Integer
        dwCommittedSize     As Long
        dwUnCommittedSize   As Long
        lpFirstBlock        As Long
        lpLastBlock         As Long
    End Type
    
    Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
    Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
    Private Declare Function HeapWalk Lib "kernel32" (ByVal hHeap As Long, ByRef lpEntry As PROCESS_HEAP_ENTRY) As Long
    Private Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
    Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
    Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
    Private Declare Function GetClassInfoEx Lib "user32" Alias "GetClassInfoExW" (ByVal hInstance As Long, ByVal lpClassName As Long, lpWndClassEx As WNDCLASSEX) As Long
    Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassW" (ByVal lpClassName As Long, ByVal hInstance As Long) As Long
    Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExW" (pcWndClassEx As WNDCLASSEX) As Integer
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (lpString As Any) As Long
    Private Declare Function lstrcpyn Lib "kernel32" Alias "lstrcpynW" (lpString1 As Any, lpString2 As Any, ByVal iMaxLength As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
    
    Private Declare Function waveInGetNumDevs Lib "winmm.dll" () As Long
    Private Declare Function waveInGetID Lib "winmm.dll" (ByVal hWaveIn As Long, lpuDeviceID As Long) As Long
    Private Declare Function waveInGetDevCaps Lib "winmm.dll" Alias "waveInGetDevCapsW" (ByVal uDeviceID As Long, lpCaps As WAVEINCAPS, ByVal uSize As Long) As Long
    Private Declare Function waveInOpen Lib "winmm.dll" (lphWaveIn As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As MMRESULT
    Private Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
    Private Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
    Private Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
    Private Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
    Private Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
    Private Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
    Private Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextW" (ByVal err As Long, ByVal lpText As Long, ByVal uSize As Long) As MMRESULT
    Private Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
    Private Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsW" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long
    Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
    Private Declare Function waveOutGetID Lib "winmm.dll" (ByVal hWaveOut As Long, lpuDeviceID As Long) As Long
    Private Declare Function waveOutOpen Lib "winmm.dll" (lphWaveOut As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As MMRESULT
    Private Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
    Private Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
    Private Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
    Private Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT
    Private Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT
    Private Declare Function waveOutPause Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT
    Private Declare Function waveOutRestart Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT
    
    Private Const SndClass                      As String = "TrickSoundClass"
    Private Const HWND_MESSAGE                  As Long = -3
    Private Const WAVE_MAPPER                   As Long = -1&
    Private Const CALLBACK_WINDOW               As Long = &H10000
    Private Const WAVE_FORMAT_PCM               As Long = 1
    Private Const MM_WIM_DATA                   As Long = &H3C0
    Private Const MM_WOM_DONE                   As Long = &H3BD
    Private Const WNDPROCINDEX                  As Long = 18
    Private Const HEAP_CREATE_ENABLE_EXECUTE    As Long = &H40000
    Private Const HEAP_NO_SERIALIZE             As Long = &H1
    Private Const HEAP_ZERO_MEMORY              As Long = &H8
    Private Const PROCESS_HEAP_ENTRY_BUSY       As Long = &H4
    Private Const GWL_WNDPROC                   As Long = (-4)
    
    Private Init        As Boolean              ' // Whether class is initialized
    Private hwnd        As Long                 ' // Handle of receiver window
    Private mActive     As Boolean              ' // Whether process of capture/playback is active or not
    Private mSmpCount   As Long                 ' // Size of buffer in samples
    Private mFormat     As WAVEFORMATEX         ' // Format of wave
    Private hWaveIn     As Long                 ' // Handle of capture device
    Private hWaveOut    As Long                 ' // Handle of playback device
    Private Buffers()   As buffer               ' // Buffers array
    Private bufCount    As Long                 ' // Count of buffers
    Private unavailable As Boolean              ' // Determine if class is unavailable
    Private paused      As Boolean              ' // If pause is active
    Private devCap      As Collection           ' // List of capture devices
    Private devPlay     As Collection           ' // List of playback devices
    
    Dim hHeap   As Long
    Dim lpAsm   As Long
    
    ' // The event that get raised when new buffer is needed
    Public Event NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)
    
    ' // If capture/playback is active then true
    Public Property Get IsActive() As Boolean
        IsActive = mActive
    End Property
    
    ' // If capture/playback is initialized then true
    Public Property Get IsUnavailable() As Boolean
        IsUnavailable = unavailable
    End Property
    
    ' // If object initialization failed then ture
    Public Property Get IsFailed() As Boolean
        IsFailed = Not Init
    End Property
    
    ' // Size of buffer in second
    Public Property Get BufferLengthSec() As Single
        BufferLengthSec = mSmpCount / mFormat.nSamplesPerSec
    End Property
    
    ' // Size of buffer in samples
    Public Property Get BufferLengthSamples() As Long
        BufferLengthSamples = mSmpCount
    End Property
    
    ' // Sample rate
    Public Property Get SampleRate() As Long
        SampleRate = mFormat.nSamplesPerSec
    End Property
    
    ' // Bit per sample
    Public Property Get BitsPerSample() As Integer
        BitsPerSample = mFormat.wBitsPerSample
    End Property
    
    ' // Count of channels
    Public Property Get Channels() As Integer
        Channels = mFormat.nChannels
    End Property
    
    ' // Number of buffers
    Public Property Get BuffersCount() As Byte
        BuffersCount = bufCount
    End Property
    
    ' // Current capture device id
    Public Property Get CurrentCaptureDeviceID() As Long
        If hWaveIn Then
            waveInGetID hWaveIn, CurrentCaptureDeviceID
        Else
            err.Raise 5
        End If
    End Property
    
    ' // Current playback device id
    Public Property Get CurrentPlaybackDeviceID() As Long
        If hWaveOut Then
            waveOutGetID hWaveOut, CurrentPlaybackDeviceID
        Else
            err.Raise 5
        End If
    End Property
    
    ' // List of available capture devices
    Public Property Get CaptureDevices() As Collection
        Dim devCount    As Long
        Dim caps        As WAVEINCAPS
        Dim idx         As Long
        Dim strLen      As Long
        Dim tmpStr      As String
        
        If devCap Is Nothing Then
        
            devCount = waveInGetNumDevs()
            Set devCap = New Collection
            
            For idx = 0 To devCount - 1
                waveInGetDevCaps idx, caps, Len(caps)
                strLen = lstrlen(caps.szPname(0))
                tmpStr = Space(strLen)
                lstrcpyn ByVal StrPtr(tmpStr), caps.szPname(0), strLen + 1
                devCap.Add tmpStr
            Next
        End If
        
        Set CaptureDevices = devCap
        
    End Property
    
    ' // List of available playback devices
    Public Property Get PlaybackDevices() As Collection
        Dim devCount    As Long
        Dim caps        As WAVEOUTCAPS
        Dim idx         As Long
        Dim strLen      As Long
        Dim tmpStr      As String
        
        If devPlay Is Nothing Then
            
            devCount = waveOutGetNumDevs()
            Set devPlay = New Collection
            
            For idx = 0 To devCount - 1
                waveOutGetDevCaps idx, caps, Len(caps)
                strLen = lstrlen(caps.szPname(0))
                tmpStr = Space(strLen)
                lstrcpyn ByVal StrPtr(tmpStr), caps.szPname(0), strLen + 1
                devPlay.Add tmpStr
            Next
            
        End If
        
        Set PlaybackDevices = devPlay
        
    End Property

  5. #5

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    clsTrickSound.cls (continued):
    Code:
     ' // Start the capture/playback
    Public Function StartProcess() As Boolean
        Dim ret As MMRESULT
        
        If mActive And Not paused Then Exit Function
        
        If Not Init Then
            err.Raise Errors.ERROR_OBJECT_FAILED
            Exit Function
        End If
        
        If Not unavailable Then
            err.Raise Errors.NOT_INITIALIZE
            Exit Function
        End If
        
        If hWaveIn Then
        
            ret = waveInStart(hWaveIn)
            If ret Then
                err.Raise ERROR_STARTUP Or ret
                Exit Function
            End If
            
        Else
        
            Dim idx As Long
            
            If paused Then
            
                ret = waveOutRestart(hWaveOut)
                
                If ret Then
                    err.Raise ERROR_STARTUP Or ret
                    Exit Function
                End If
                
                paused = False
                
            Else
            
                For idx = 0 To bufCount - 1
                    
                    RaiseEvent NewData(Buffers(idx).Header.lpData, UBound(Buffers(idx).data) + 1)
                    
                    ret = waveOutWrite(hWaveOut, Buffers(idx).Header, Len(Buffers(idx).Header))
                    
                    If ret Then
                        err.Raise ERROR_STARTUP Or ret
                        Exit Function
                    End If
                    
                Next
            End If
    
        End If
        
        StartProcess = True
        mActive = True
    
    End Function
    
    ' // Pause playback
    Public Function PauseProcess() As Boolean
        Dim ret As MMRESULT
        
        If Not Init Then
            err.Raise Errors.ERROR_OBJECT_FAILED
            Exit Function
        End If
        
        If Not unavailable Then
            err.Raise Errors.NOT_INITIALIZE
            Exit Function
        End If
        
        If Not mActive Then Exit Function
        
        If hWaveOut Then
        
            paused = True
            waveOutPause hWaveOut
            mActive = False
                
            PauseProcess = True
            
        End If
        
    End Function
    
    ' // Stop playback/capture
    Public Function StopProcess() As Boolean
        Dim ret As Long
        
        If Not Init Then
            err.Raise Errors.ERROR_OBJECT_FAILED
            Exit Function
        End If
        
        If Not unavailable Then
            err.Raise Errors.NOT_INITIALIZE
            Exit Function
        End If
        
        If Not mActive Then Exit Function
        
        If hWaveIn Then
            ret = waveInStop(hWaveIn)
            
            If ret Then
                err.Raise ERROR_STOP Or ret
                Exit Function
            End If
    
        Else
        
            ret = waveOutReset(hWaveOut)
            
            If ret Then
                err.Raise ERROR_STOP Or ret
                Exit Function
            End If
            
        End If
        
        mActive = False
        paused = False
        StopProcess = True
        
    End Function
    
    ' // Playback initialization
    Public Function InitPlayback(ByVal NumOfChannels As Integer, _
                                 ByVal SamplesPerSec As Long, _
                                 ByVal BitsPerSample As Integer, _
                                 ByVal BufferSampleCount As Long, _
                                 Optional ByVal DeviceID As Long = WAVE_MAPPER, _
                                 Optional ByVal BuffersCount As Byte = 4) As Boolean
        Dim ret As MMRESULT
        Dim idx As Long
        
        If Not Init Then
            err.Raise Errors.ERROR_OBJECT_FAILED
            Exit Function
        End If
        
        If unavailable Then
            err.Raise Errors.ERROR_UNAVAILABLE
            Exit Function
        End If
        
        If BuffersCount < 1 Then
            err.Raise Errors.INVALID_BUFFERS_COUNT
            Exit Function
        End If
        
        unavailable = True
    
        With mFormat
            .cbSize = 0
            .wFormatTag = WAVE_FORMAT_PCM
            .wBitsPerSample = BitsPerSample
            .nSamplesPerSec = SamplesPerSec
            .nChannels = NumOfChannels
            .nBlockAlign = .nChannels * .wBitsPerSample \ 8
            .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
        End With
    
        mSmpCount = BufferSampleCount - (BufferSampleCount Mod mFormat.nBlockAlign)
        
        ret = waveOutOpen(hWaveOut, DeviceID, mFormat, hwnd, 0, CALLBACK_WINDOW)
        
        If ret Then
            err.Raise ERROR_OPEN_DEVICE Or ret
            Exit Function
        End If
        
        bufCount = BuffersCount
        ReDim Buffers(BuffersCount - 1)
    
        For idx = 0 To BuffersCount - 1
        
            With Buffers(idx)
                ReDim .data(mSmpCount * mFormat.nBlockAlign - 1)
                .Header.lpData = VarPtr(.data(0))
                .Header.dwBufferLength = UBound(.data) + 1
                .Header.dwFlags = 0
                .Header.dwLoops = 0
                
                ret = waveOutPrepareHeader(hWaveOut, .Header, Len(.Header))
                
                .Status = ret = MMSYSERR_NOERROR
            End With
             
            If ret Then
                Clear
                err.Raise ERROR_PREPARE_BUFFERS Or ret
                Exit Function
            End If
                 
        Next
            
        InitPlayback = True
                 
    End Function
    
    ' // Capture initialization
    Public Function InitCapture(ByVal NumOfChannels As Integer, _
                                ByVal SamplesPerSec As Long, _
                                ByVal BitsPerSample As Integer, _
                                ByVal BufferSampleCount As Long, _
                                Optional ByVal DeviceID As Long = WAVE_MAPPER, _
                                Optional ByVal BuffersCount As Byte = 4) As Boolean
        Dim ret As MMRESULT
        Dim idx As Long
        
        If Not Init Then
            err.Raise Errors.ERROR_OBJECT_FAILED
            Exit Function
        End If
        
        If unavailable Then
            err.Raise Errors.ERROR_UNAVAILABLE
            Exit Function
        End If
        
        If BuffersCount < 1 Then
            err.Raise Errors.INVALID_BUFFERS_COUNT
            Exit Function
        End If
        
        unavailable = True
    
        With mFormat
            .cbSize = 0
            .wFormatTag = WAVE_FORMAT_PCM
            .wBitsPerSample = BitsPerSample
            .nSamplesPerSec = SamplesPerSec
            .nChannels = NumOfChannels
            .nBlockAlign = .nChannels * .wBitsPerSample \ 8
            .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
        End With
    
        mSmpCount = BufferSampleCount - (BufferSampleCount Mod mFormat.nBlockAlign)
        
        ret = waveInOpen(hWaveIn, DeviceID, mFormat, hwnd, 0, CALLBACK_WINDOW)
        
        If ret Then
            err.Raise ERROR_OPEN_DEVICE Or ret
            Exit Function
        End If
        
        bufCount = BuffersCount
        ReDim Buffers(BuffersCount - 1)
    
        For idx = 0 To BuffersCount - 1
        
            With Buffers(idx)
                ReDim .data(mSmpCount * mFormat.nBlockAlign - 1)
                .Header.lpData = VarPtr(.data(0))
                .Header.dwBufferLength = UBound(.data) + 1
                .Header.dwFlags = 0
                .Header.dwLoops = 0
                
                ret = waveInPrepareHeader(hWaveIn, .Header, Len(.Header))
                
                .Status = ret = MMSYSERR_NOERROR
            End With
             
            If ret Then
                Clear
                err.Raise ERROR_PREPARE_BUFFERS Or ret
                Exit Function
            End If
                 
        Next
        
        For idx = 0 To BuffersCount - 1
        
            ret = waveInAddBuffer(hWaveIn, Buffers(idx).Header, Len(Buffers(idx).Header))
            If ret Then
                Clear
                err.Raise ERROR_PREPARE_BUFFERS Or ret
                Exit Function
            End If
            
        Next
        
        InitCapture = True
        
    End Function
    
    ' // ------------------------------------------------------------------------------------------------------------
    
    Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim idx As Long
        Dim hdr As WAVEHDR
        
        If unavailable Then
        
            Select Case Msg
            Case MM_WIM_DATA
                
                memcpy hdr, ByVal lParam, Len(hdr)
                idx = GetBufferIndex(hdr.lpData)
                
                If idx = -1 Then Exit Function
                
                RaiseEvent NewData(hdr.lpData, mSmpCount * mFormat.nBlockAlign)
                
                waveInAddBuffer hWaveIn, Buffers(idx).Header, Len(Buffers(idx).Header)
                
                Exit Function
                
            Case MM_WOM_DONE
                
                memcpy hdr, ByVal lParam, Len(hdr)
                idx = GetBufferIndex(hdr.lpData)
                
                If idx = -1 Then Exit Function
                
                RaiseEvent NewData(hdr.lpData, mSmpCount * mFormat.nBlockAlign)
                
                waveOutWrite hWaveOut, Buffers(idx).Header, Len(Buffers(idx).Header)
                
                Exit Function
                
            End Select
            
        End If
        
        WndProc = DefWindowProc(hwnd, Msg, wParam, lParam)
        
    End Function
    
    Private Function CreateAsm() As Boolean
        Dim inIDE   As Boolean
        Dim AsmSize As Long
        Dim ptr     As Long
        Dim isFirst As Boolean
    
        Debug.Assert MakeTrue(inIDE)
        
        If lpAsm = 0 Then
            If inIDE Then AsmSize = &H2C Else AsmSize = &H20
            hHeap = GetPrevHeap()
            
            If hHeap = 0 Then
                hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
                If hHeap = 0 Then err.Raise 7: Exit Function
                If Not SaveCurHeap() Then HeapDestroy hHeap: hHeap = 0: err.Raise 7: Exit Function
                isFirst = True
            End If
            
            lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, AsmSize)
            
            If lpAsm = 0 Then
                If isFirst Then HeapDestroy hHeap
                hHeap = 0
                err.Raise 7
                Exit Function
            End If
            
        End If
        
        ptr = lpAsm
        
        If inIDE Then
            CreateIDEStub (ptr): ptr = ptr + &HD
        End If
        
        CreateStackConv ptr
        CreateAsm = True
        
    End Function
    
    Private Function SaveCurHeap() As Boolean
        Dim i   As Long
        Dim out As String
        
        out = Hex(hHeap)
        For i = Len(out) + 1 To 8: out = "0" & out: Next
        SaveCurHeap = SetEnvironmentVariable(StrPtr(SndClass), StrPtr(out))
        
    End Function
    
    Private Function GetPrevHeap() As Long
        Dim out  As String
        
        out = Space(&H8)
        If GetEnvironmentVariable(StrPtr(SndClass), StrPtr(out), LenB(out)) Then GetPrevHeap = Val("&H" & out)
        
    End Function
    
    Private Function CreateStackConv(ByVal ptr As Long) As Boolean
        Dim lpMeth      As Long
        Dim vTable      As Long
        
        GetMem4 ByVal ObjPtr(Me), vTable
        GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
        
        GetMem4 &H5450C031, ByVal ptr + &H0:    GetMem4 &H488DE409, ByVal ptr + &H4:    GetMem4 &H2474FF04, ByVal ptr + &H8
        GetMem4 &H68FAE018, ByVal ptr + &HC:    GetMem4 &H12345678, ByVal ptr + &H10:   GetMem4 &HFFFFDAE8, ByVal ptr + &H14
        GetMem4 &H10C258FF, ByVal ptr + &H18:   GetMem4 &H0, ByVal ptr + &H1C
        
        GetMem4 ObjPtr(Me), ByVal ptr + &H10                    ' Push Me
        GetMem4 lpMeth - (ptr + &H14) - 5, ByVal ptr + &H14 + 1 ' Call WndProc
        
    End Function
     
    Private Function CreateIDEStub(ByVal ptr As Long) As Boolean
        Dim hInstVB6    As Long
        Dim lpEbMode    As Long
        Dim hInstUser32 As Long
        Dim lpDefProc   As Long
        
        hInstVB6 = GetModuleHandle(StrPtr("vba6"))
        If hInstVB6 = 0 Then Exit Function
        hInstUser32 = GetModuleHandle(StrPtr("user32"))
        If hInstUser32 = 0 Then Exit Function
        
        lpEbMode = GetProcAddress(hInstVB6, "EbMode")
        If lpEbMode = 0 Then Exit Function
        lpDefProc = GetProcAddress(hInstUser32, "DefWindowProcW")
        If lpDefProc = 0 Then Exit Function
    
    
        GetMem4 &HFFFFFBE8, ByVal ptr + &H0:    GetMem4 &HFC8FEFF, ByVal ptr + &H4
        GetMem4 &H34566B85, ByVal ptr + &H8:    GetMem4 &H12, ByVal ptr + &HC
    
        GetMem4 lpEbMode - ptr - 5, ByVal ptr + 1 + 0               ' Call EbMode
        GetMem4 lpDefProc - (ptr + &HD), ByVal ptr + &H9            ' JNE  DefWindowProcW
        
        CreateIDEStub = True
        
    End Function
    
    Private Function MakeTrue(Value As Boolean) As Boolean
    
        Value = True
        MakeTrue = True
        
    End Function
    
    Private Sub Clear()
        Dim idx As Long
        
        unavailable = False
        
        If hWaveIn Then
            
            waveInReset hWaveIn
            
            For idx = 0 To bufCount - 1
            
                If Buffers(idx).Status Then
                    waveInUnprepareHeader hWaveIn, Buffers(idx).Header, Len(Buffers(idx).Header)
                End If
                
            Next
        
            waveInClose hWaveIn
            
        Else
                
            waveOutReset hWaveOut
            
            For idx = 0 To bufCount - 1
            
                If Buffers(idx).Status Then
                    waveOutUnprepareHeader hWaveOut, Buffers(idx).Header, Len(Buffers(idx).Header)
                End If
                
            Next
            
            waveOutClose hWaveOut
            
        End If
        
        hWaveIn = 0
        hWaveOut = 0
        paused = False
        mActive = False
        bufCount = 0
        Erase Buffers()
        ZeroMemory mFormat, Len(mFormat)
        
    End Sub
    
    Private Function GetBufferIndex(ByVal ptr As Long) As Long
        Dim idx As Long
        
        For idx = 0 To UBound(Buffers)
        
            If Buffers(idx).Header.lpData = ptr Then
                GetBufferIndex = idx
                Exit Function
            End If
            
        Next
        
        GetBufferIndex = -1
    End Function
    
    Private Sub Class_Initialize()
        Dim cls     As WNDCLASSEX
        Dim hUser   As Long
        
        cls.cbSize = Len(cls)
        
        If GetClassInfoEx(App.hInstance, StrPtr(SndClass), cls) = 0 Then
            
            hUser = GetModuleHandle(StrPtr("user32"))
            If hUser = 0 Then Exit Sub
            
            cls.hInstance = App.hInstance
            cls.lpfnwndproc = GetProcAddress(hUser, "DefWindowProcW")
            cls.lpszClassName = StrPtr(SndClass)
            
            If RegisterClassEx(cls) = 0 Then Exit Sub
    
        End If
        
        If Not CreateAsm() Then Exit Sub
       
        hwnd = CreateWindowEx(0, StrPtr(SndClass), 0, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0&)
        If hwnd = 0 Then Exit Sub
     
        SetWindowLong hwnd, GWL_WNDPROC, lpAsm
        
        Init = True
    
    End Sub
    
    Private Sub Class_Terminate()
        
        If Not Init Then Exit Sub
        
        Clear
        
        DestroyWindow hwnd
        UnregisterClass StrPtr(SndClass), App.hInstance
        
        If hHeap = 0 Then Exit Sub
    
        HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
        
    End Sub

  6. #6

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    Working with the winmm I will not, I can only say that as a notification window messages are used. We create for each instance of your window and wave-functions transmit it in the form of a notification message, and we are using inline assembly, treat them in a special class method after setting it as the window procedure. I also added a check there EbMode, that would not be such as in DirectSound, when you can not put a normal breakpoint using the circular buffer. The class generates an event NewData when he needed next portion of audio data during playback and when once the buffer is full when capturing. To initialize the playback method is used InitPlayback, which initializes the playback device (DeviceID) on the basis of a predetermined size and number of buffers in the queue. List of devices obtained property PlaybackDevices, which represents a collection of playback devices. Device index (starting with 0) corresponds to the desired DeviceID. To provide functions to select the device by default for a given format, then transferred to constant WAVE_MAPPER. Initialization capture produced by a method similar InitCapture; list of capture devices obtained by the method CaptureDevices. Methods StartProcess, StopProcess respectively launch process playback / recording and stop; method PauseProcess pauses playback. Appointment of the remaining properties is clear from the comments in the code.

  7. #7

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    So, the source and the modulating signals we have. Now the next step is to filter. You can go several ways: use a bank of filters (IIR, FIR), or use the FFT (FFT, fast Fourier transform) or wavelet transform. For our implementation, we take the Fourier transform of the window, because IIR filter calculation is quite a complex task, and FIR filters on the computational complexity is not very effective. (Frankly, I originally did for the implementation of IIR Butterworth filter 2nd order, but I was not satisfied with the quality and the load on the processor). With the FFT turns pretty simple. Decompose speech signal into harmonic where each element of the vector represents the information about a particular frequency (it turns out that something like a large number of band-pass filters).Also decompose the carrier signal and performs modulation. After all do the inverse Fourier transform and obtain the desired signal. It turns out that the FFT makes two tasks at once - it decomposes the signal into frequency bands (see. Diagram) and performs the mixing signal after IFFT. For our task to make the adjustment amount of the frequency bands, this allows you to configure the desired color tone. For FFT and its binding write a class clsTrickFFT:
    Code:
    ' // clsTrickFFT.cls  - class for FFT transformation
    ' //  Krivous Anatoly Anatolevich (The trick), 2014
    
    Option Explicit
    
    Public Enum WindowType
        WT_RECTANGLE
        WT_TRIGANULAR
        WT_HAMMING
        WT_HANN
    End Enum
    
    Private Coef(1, 13) As Single
    Private mFFTSize    As Long
    Private mLog        As Long
    Private mWindow()   As Single
    Private mType       As WindowType
    
    ' // Window type
    Public Property Get WindowType() As WindowType
        WindowType = mType
    End Property
    Public Property Let WindowType(ByVal Value As WindowType)
    
        If InitWindow(Value) Then
        
            mType = Value
            
        End If
        
    End Property
    
    ' // Set size of FFT
    Public Property Let FFTSize(ByVal Value As Long)
        Dim log2    As Double
        
        log2 = Log(Value) / Log(2)
        ' // Value should be power of 2
        If log2 <> Fix(log2) Then
            err.Raise 5
            Exit Property
        End If
        ' // Check out of range
        If log2 < 2 Or log2 > 16384 Then
            err.Raise 9
            Exit Property
        End If
        
        InitWindow mType
        
        mLog = log2
        mFFTSize = Value
        
    End Property
    
    ' // Apply window function
    Public Function ApplyWindow(data() As Single) As Boolean
        Dim index   As Long
        Dim count   As Long
        
        count = UBound(data, 2) + 1
    
        For index = 0 To count - 1
            data(0, index) = data(0, index) * mWindow(index)
        Next
        
        ApplyWindow = True
        
    End Function
    
    ' // Convert 16-bit signed integer samples to normalize (-1...1) complex values
    Public Function Convert16BitToComplex(inData() As Integer, outData() As Single) As Boolean
        Dim index   As Long
    
        For index = 0 To UBound(inData)
            outData(0, index) = inData(index) / 32768
            outData(1, index) = 0
        Next
        
        Convert16BitToComplex = True
        
    End Function
    
    ' // Convert complex values to 16-bit real signed integer samples
    Public Function ConvertComplexTo16Bit(inData() As Single, outData() As Integer) As Boolean
        Dim index   As Long
        Dim Value   As Long
        
        For index = 0 To UBound(inData, 2)
            Value = inData(0, index) * 32767
            If Value > 32767 Then Value = 32767 Else If Value < -32768 Then Value = -32768
            outData(index) = Value
        Next
        
        ConvertComplexTo16Bit = True
            
    End Function
    
    ' // Apply mirroring
    Public Function MakeMirror(data() As Single) As Boolean
        Dim index   As Long
        Dim pointer As Long
        
        pointer = mFFTSize - 1
        
        For index = 1 To mFFTSize \ 2 - 1
            data(0, pointer) = data(0, index)
            data(1, pointer) = -data(1, index)
            pointer = pointer - 1
        Next
        
        MakeMirror = True
        
    End Function
    
    ' // Process
    Public Function FFT(data() As Single, ByVal IsInverse As Boolean) As Boolean
        Dim i As Long, j As Long, n As Long, K As Long, io As Long, ie As Long, in_ As Long, nn As Long
        Dim ur As Single, ui As Single, tpr As Single, tpi As Single, tqr As Single, tqi As Single, _
            wr As Single, wi As Single, sr As Single, ti As Long, tr As Long
        
        nn = mFFTSize \ 2: ie = mFFTSize
        For n = 1 To mLog
            wr = Coef(0, mLog - n): wi = Coef(1, mLog - n)
            If IsInverse Then wi = -wi
            in_ = ie \ 2: ur = 1: ui = 0
            For j = 0 To in_ - 1
                For i = j To mFFTSize - 1 Step ie
                    io = i + in_
                    tpr = data(0, i) + data(0, io): tpi = data(1, i) + data(1, io)
                    tqr = data(0, i) - data(0, io): tqi = data(1, i) - data(1, io)
                    data(0, io) = tqr * ur - tqi * ui: data(1, io) = tqi * ur + tqr * ui
                    data(0, i) = tpr: data(1, i) = tpi
                Next
                sr = ur: ur = ur * wr - ui * wi: ui = ui * wr + sr * wi
            Next
            ie = ie \ 2
        Next
        ' Перестановка
        j = 1
        For i = 1 To mFFTSize - 1
            If i < j Then
                io = i - 1: in_ = j - 1: tpr = data(0, in_): tpi = data(1, in_)
                data(0, in_) = data(0, io): data(1, in_) = data(1, io)
                data(0, io) = tpr: data(1, io) = tpi
            End If
            K = nn
            Do While K < j
                j = j - K: K = K \ 2
            Loop
            j = j + K
        Next
        If IsInverse Then FFT = True: Exit Function
        ' Нормализация
        wr = 1 / mFFTSize
        For i = 0 To mFFTSize - 1
            data(0, i) = data(0, i) * wr: data(1, i) = data(1, i) * wr
        Next
        FFT = True
        
    End Function
    
    ' // Init window
    Public Function InitWindow(ByVal Window As WindowType) As Boolean
        Dim index   As Long
        
        Select Case Window
        Case WT_RECTANGLE
            ReDim mWindow(mFFTSize - 1)
            For index = 0 To mFFTSize - 1
                mWindow(index) = 1
            Next
        Case WT_TRIGANULAR
            ReDim mWindow(mFFTSize - 1)
            For index = 0 To mFFTSize - 1
                mWindow(index) = IIf(index < mFFTSize \ 2, index / mFFTSize * 2, 1 - index / (mFFTSize - 1))
            Next
        Case WT_HAMMING
            ReDim mWindow(mFFTSize - 1)
            For index = 0 To mFFTSize - 1
                mWindow(index) = 0.53836 - 0.46164 * Cos(6.28318530717959 * index / (mFFTSize - 1))
            Next
        Case WT_HANN
            ReDim mWindow(mFFTSize - 1)
            For index = 0 To mFFTSize - 1
                mWindow(index) = 0.5 * (1 - Cos(6.28318530717959 * index / (mFFTSize - 1)))
            Next
        Case Else
            err.Raise 5
            Exit Function
        End Select
    
        InitWindow = True
        
    End Function
    
    ' // Initialize turning multipliers for FFT and default size
    Private Sub Class_Initialize()
        Dim n As Long, vRcoef As Variant, vIcoef As Variant
        vRcoef = Array(-1#, 0#, 0.707106781186547 _
              , 0.923879532511287, 0.98078528040323, 0.995184726672197 _
              , 0.998795456205172, 0.999698818696204, 0.999924701839145 _
              , 0.999981175282601, 0.999995293809576, 0.999998823451702 _
              , 0.999999705862882, 0.999999926465718)
        vIcoef = Array(0#, -1#, -0.707106781186547 _
             , -0.38268343236509, -0.195090322016128, -9.80171403295606E-02 _
             , -0.049067674327418, -2.45412285229122E-02, -1.22715382857199E-02 _
             , -6.1358846491544E-03, -3.0679567629659E-03, -1.5339801862847E-03 _
             , -7.669903187427E-04, -3.834951875714E-04)
        For n = 0 To 13
            Coef(0, n) = vRcoef(n): Coef(1, n) = vIcoef(n)
        Next
        
        mFFTSize = 512
        mLog = 9
        mType = WT_HAMMING
        InitWindow mType
        
    End Sub

  8. #8

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    Convert performs "FFT" method; for the reverse transformation of the second parameter passed to True. As the use of complex numbers will form an array arr (1, x), where x - complex number, the numbers arr (0, x) - the real part, arr (1, x) - the imaginary part. Dwell on the FFT I will not, because this is a very big topic, and who are interested in the network where there are many articles accessible language explained its meaning and properties; consider only the highlights. You need to convert the original real signal put into an array of complex numbers, resetting the imaginary part (the truth is based on the properties of the FFT can still accelerate if written in the real part of the one part and the imaginary other, but I did not so complicate). After conversion, we get a set of complex coefficients which correspond to the real part of the coefficients of the cosine and imaginary - before sinus. If you imagine this in the complex plane, each coefficient is a vector whose length characterizes the amplitude of the signal at that frequency and angle - phase:
    Also, there is a mirror effect (moire) - mirroring coefficients relative half the sampling frequency which is equal in amplitude and opposite in phase. This occurs because the sampled signal as frequency may be correctly presented only to half the sampling frequency when the frequency aliasing occurs:
    As can be seen initially red sinusoid has a frequency equal to two sampling periods, and gradually increases the sampling period, the frequency of the sampled signal is reduced and eventually at a sampling frequency equal to the frequency sine wave signal frequency becomes equal to 0 Hz. Because of this, the Fourier coefficients mirrored relative to half the sampling frequency. Therefore, when working with the spectrum can only handle half of the spectrum, before IFFT simply copy the second half of the mirror array make complex conjugate only (additional imaginary coefficients multiplied by -1). For this purpose the method MakeMirror. When the modulation signal, we will phase distortions occur because making the transformation to which any portion of the signal, we take this site for one period, which is repeated on both sides of the window indefinitely. And if we make any changes in the spectrum, our signals may not be the same at the edges of the window and breaks will occur (in our case, clicks). To prevent this, we multiply the signal by the weight window, which gradually decreases to the edges of the signal amplitude, and take the blocks overlapping. Because we do not need high quality sound, we will not use the weight of the window before the conversion (although should do so, because there is a blur of frequencies), and compute a "head-on" with the raw signal, transform, and perform IFFT only The results are applied window function. Also it will take the blocks with a 50% overlap at the hearing that is acceptable and fast enough. To make it clear here is clearly an example:
    As you can see, we take the original signal 2 times with a shift by grabbing the second half in the second pass. After manipulation, we mixed the two signals at the overlap and outputs the first part of the second half will later be mixed with the following parts. As the window we will use the Hann window. The method ApplyWindow do it.

  9. #9

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    As mentioned above for the FFT operation, we need to take the data with overlapping and send data to the output from the ceiling. To do this, we will write a special class (clsTrickOverlappedBuffer), which will give us the data, taking the overlap:
    Code:
    ' // clsTrickOverlappedBuffer.cls  - class of overlapped buffer
    ' //  Krivous Anatoly Anatolevich (The trick), 2014
    
    Option Explicit
    
    Private iBuffer()   As Single       ' // Input buffer
    Private oBuffer()   As Single       ' // Output buffer
    Private mInit       As Boolean      ' // Determine whether object is initialized or not
    Private miWritePtr  As Long         ' // Current writing index in input buffer
    Private moWritePtr  As Long         ' // Current writing index in output buffer
    Private mWndSize    As Long         ' // Size of part of data for I/O
    Private mOverlap    As Long         ' // Size of overlapping in samples
    Private iPtr        As Long         ' // Current reading index in input buffer
    Private oPtr        As Long         ' // Current reading index in output buffer
    Private sampleSize  As Long         ' // Size of sample in bytes
    
    ' // Initialization
    Public Function Init(ByVal windowSize As Long, ByVal overlapSizeSamples As Long) As Boolean
    
        If overlapSizeSamples > windowSize Or overlapSizeSamples <= 0 Then Exit Function
        If windowSize <= 0 Then Exit Function
        
        ' // Allocate buffers 2 times larger for overlapping of windowSize
        ReDim iBuffer(1, windowSize * 2 - 1)
        ReDim oBuffer(1, windowSize * 2 - 1)
        
        mInit = True
        mWndSize = windowSize
        mOverlap = overlapSizeSamples
        miWritePtr = mWndSize
        
        Init = True
    
    End Function
    
    ' // Write frame to input buffer
    Public Function WriteInputData(data() As Single) As Boolean
    
        memcpy iBuffer(0, miWritePtr), data(0, 0), (UBound(data, 2) + 1) * sampleSize
        miWritePtr = IIf(miWritePtr, 0, mWndSize)
        WriteInputData = True
        
    End Function
    
    ' // Write frame to output buffer
    Public Function WriteOutputData(data() As Single) As Boolean
        Dim sampleCount As Long
        Dim inSample    As Long
        Dim pointer     As Long
        Dim rest        As Long
        
        pointer = moWritePtr
        ' // Mix overlapped data. Check number of samples before end the buffer
        sampleCount = mWndSize * 2 - pointer
        ' // If number of samples is not enough then copy until end
        If sampleCount > mOverlap Then sampleCount = mOverlap
        ' // Mix
        For inSample = 0 To sampleCount - 1
        
            oBuffer(0, pointer) = oBuffer(0, pointer) + data(0, inSample)
            pointer = pointer + 1
            
        Next
        ' // If entire data has not copied continue from beginning
        If sampleCount < mOverlap Then
        
            pointer = 0
            
            Do While pointer < mOverlap - sampleCount
            
                oBuffer(0, pointer) = oBuffer(0, pointer) + data(0, inSample)
                pointer = pointer + 1
                inSample = inSample + 1
                
            Loop
            
        End If
        
        moWritePtr = pointer
        
        ' // Copy non-overlapped part
        sampleCount = mWndSize * 2 - pointer
        rest = mWndSize - mOverlap
        ' // Check out of range
        If sampleCount > rest Then sampleCount = rest
        ' // Direct copy
        If sampleCount Then memcpy oBuffer(0, pointer), data(0, inSample), sampleCount * sampleSize
        ' // If out of range has happened then copy to beginning
        If sampleCount < rest Then
        
            pointer = 0
            memcpy oBuffer(0, pointer), data(0, inSample), (rest - sampleCount) * sampleSize
            
        End If
        
        WriteOutputData = True
        
    End Function
    
    ' // Get input buffer data
    Public Function GetInputBuffer(data() As Single) As Boolean
        Dim sampleCount As Long
        ' // Get available samples until end of buffer
        sampleCount = mWndSize * 2 - iPtr
        ' // Check out of range
        If sampleCount > mWndSize Then sampleCount = mWndSize
        ' // Copy
        If sampleCount > 0 Then
            memcpy data(0, 0), iBuffer(0, iPtr), sampleCount * sampleSize
        End If
        ' // Copy to beginning if need
        If sampleCount < mWndSize Then
            memcpy data(0, sampleCount), iBuffer(0, 0), (mWndSize - sampleCount) * sampleSize
        End If
        ' // Update position
        iPtr = (iPtr + mOverlap) Mod mWndSize * 2
    
        GetInputBuffer = True
    
    End Function
    
    ' // Get output buffer data
    Public Function GetOutputBuffer(data() As Single) As Boolean
        Dim sampleCount As Long
        ' // Get available samples until end of buffer
        sampleCount = mWndSize * 2 - oPtr
        ' // Check out of range
        If sampleCount > mWndSize Then sampleCount = mWndSize
        ' // Copy
        If sampleCount > 0 Then
            memcpy data(0, 0), oBuffer(0, oPtr), sampleCount * sampleSize
            oPtr = oPtr + sampleCount
        End If
        ' // Copy to beginning if need
        If sampleCount < mWndSize Then
            memcpy data(0, sampleCount), oBuffer(0, 0), (mWndSize - sampleCount) * sampleSize
            oPtr = mWndSize - sampleCount
        End If
    
        GetOutputBuffer = True
    
    End Function
    
    Private Sub Class_Initialize()
        sampleSize = 8
    End Sub
    Init method initializes internal buffers storage. WriteInputData method writes data to the internal buffer of the input signal. Using this method, we write the captured signal and the carrier signal. WriteOutputData method mixes the transmitted data in an internal buffer with past data added to the previous call to this method. This method we will use to write processed data signal already modulated by using this method. GetInputBuffer and GetOutputBuffer fill the input buffer of data, taking the overlap. GetInputBuffer receives data recorded by WriteInputData, respectively GetOutputBuffer method gets the data recorded by WriteOutputData. Now consider the representation of the class itself modulator clsTrickModulator, which deals specifically with the transformation of the spectrum:
    Code:
    ' // clsTrickModulator.cls  - Modulator class
    ' //  Krivous Anatoly Anatolevich (The trick), 2014
    
    Option Explicit
    
    Private mBands      As Long     ' // Number of frequency bands
    Private mDryWet     As Single   ' // Balance between dry and wet signals
    Private mVolume     As Single   ' // Volume
    Private mLevels()   As Single   ' // Frequency response
    
    ' // Volume
    Public Property Let Volume(ByVal Value As Single)
        mVolume = Value
    End Property
    Public Property Get Volume() As Single
        Volume = mVolume
    End Property
    
    ' //  Frequency response
    Public Function SetLevels(Value() As Single) As Boolean
        mLevels = Value
    End Function
    Public Property Get Levels(ByVal index As Long) As Single
        Levels = mLevels(index)
    End Property
    
    ' // Balance
    Public Property Let DryWet(ByVal Value As Single)
        If Abs(Value) > 1 Then
            err.Raise 9
            Exit Property
        End If
        mDryWet = Value
    End Property
    Public Property Get DryWet() As Single
        DryWet = mDryWet
    End Property
    
    ' // Number of frequency bands
    Public Property Let Bands(ByVal Value As Long)
        If Value > 128 Or Value <= 0 Then
            err.Raise 9
            Exit Property
        End If
        mBands = Value
    End Property
    Public Property Get Bands() As Long
        Bands = mBands
    End Property
    
    ' // Process signal
    Public Function Process(carrier() As Single, modulation() As Single) As Boolean
        Dim nCount          As Long
        Dim band            As Long
        Dim endBand         As Long
        Dim sample          As Long
        Dim samplePerBand   As Long
        Dim offsetSample    As Long
        Dim modValue        As Single
        Dim ampValue        As Single
        Dim invDryWet       As Single
        Dim FFTSize         As Long
        
        invDryWet = 1 - mDryWet
        FFTSize = (UBound(carrier, 2) + 1)
        ' // Mirror part is not processed
        nCount = FFTSize \ 2
        ' // Get number of samples per band
        samplePerBand = nCount \ mBands
        ' // Calculate amplifier coefficient
        ampValue = (Sqr(mBands) * invDryWet) / 2.5 + mDryWet
        ' // Process each band
        For band = 0 To mBands - 1
            ' // Check out of range
            endBand = band * samplePerBand + samplePerBand
            If endBand >= nCount Then endBand = nCount - 1
            ' // Clear value of spectrum for current band
            modValue = 0
            ' // Process each sample
            For sample = band * samplePerBand To endBand
                ' // Calculate value of specturum for all samples of current band
                modValue = modValue + Sqr(modulation(0, sample) * modulation(0, sample) + _
                                          modulation(1, sample) * modulation(1, sample))
            Next
            ' // Modulate current band
            For sample = band * samplePerBand To endBand
                carrier(0, sample) = ((carrier(0, sample) * modValue * invDryWet) + _
                                     (modulation(0, sample) * mDryWet)) * ampValue * mLevels(sample) * mVolume
                carrier(1, sample) = ((carrier(1, sample) * modValue * invDryWet) + _
                                     (modulation(1, sample) * mDryWet)) * ampValue * mLevels(sample) * mVolume
            Next
        Next
        
    End Function
    
    Private Sub Class_Initialize()
        mDryWet = 0
        mVolume = 1
    End Sub

  10. #10

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    The class has a property Volume, which determines the level of output volume. Bands property specifies the number of bands which will be divided in modulation spectrum. For example, at a sampling rate of 44100 Hz. and the size of the FFT to 2048, we obtain the frequency resolution equal 44100/2048 ≈ 21.53 Hz. When the number of frequency bands equal to 64 will take 2048/2/64 = 16 samples (344.48 Hz) frequency for each modulation. DryWet property determines the balance between the original signal and convert the output of the modulator. SetLevels method sets an array of coefficients of the amplitude-frequency characteristic (AFC) which multiplies the signal. This will produce the equalization signal and improve the sound quality after processing. The main method - Process, which actually makes processing; analyze it in detail. First, we calculate the number of samples per band based on the properties of the Bands, and then calculate the gain of the output signal depending on the number of frequency bands - this formula was obtained experimentally. Then we go through the speech frequency bands (modulation) signal and the coefficients corresponding to each band to calculate the energy data frequencies. Earlier I wrote that the amplitude spectral component - is the length of the vector, so we'll just summarize the lengths of the vectors corresponding frequencies, it will be the energy in this frequency range. Next we are going to have carrier signal in the same spectral counts change the signal according to the calculated energy also directly calculate the output level, apply equalization. When multiplying two components of (complex number) by the amount of energy is its scalability. All these manipulations we modulate a carrier signal, a speech that we required.
    Thus, all components are ready. Now all you need to build and test the function. For the user interface I developed several controls specifically for the vocoder. Describe the operation and development of each, I will not, because it will take a lot of time and tell us briefly about each of them. ctlTrickKnob - control knob that something as simple as a potentiometer. He'll understand it is a regular controller, the similarity of the same Slider, only with a circular control. ctlTrickCommand - is a normal button with support for icons and added only for appearance. ctlTrickEqualizer - most interesting control. It allows you to adjust the frequency response of the signal. His panel has a logarithmic scale, both in frequency and level, which allows for more natural hearing to change the parameters. To add a point on the response you have to press the left mouse button in an empty place, to remove the - right. If you change the frequency response of a control generates an event Change. All the controls are designed only for the vocoder so their functionality is minimal.
    Now all the "throws" to the form and write the code:
    Code:
    ' // frmTrickVocoder.frm  - main form of TrickVocoder
    ' //  Krivous Anatoly Anatolevich (The trick), 2014
    
    Option Explicit
    
    Dim WithEvents AudioCapture     As clsTrickSound    ' // Capture device object
    Dim WithEvents AudioPlayback    As clsTrickSound    ' // Playback device object
    
    Private inpBuffer() As Integer                      ' // Capture buffer
    Private outBuffer() As Integer                      ' // Playback buffer
    Private rawBuffer() As Integer                      ' // Buffer of raw data of wave file
    Private plyBuffer   As clsTrickOverlappedBuffer     ' // Buffer of overlapped data of carrier
    Private capBuffer   As clsTrickOverlappedBuffer     ' // BUffer of overlapped data of modulator
    Private FFT         As clsTrickFFT                  ' // FFT object
    Private Modulator   As clsTrickModulator            ' // Modulator
    Private mFFTSize    As Long                         ' // Size of FFT
    Private mOverlap    As Long                         ' // Number of overlaps
    Private mRawSize    As Long                         ' // Size of raw data of buffer in samples
    Private mInpFile    As String                       ' // File name, if capture from file
    Private tmpCapBuf() As Single                       ' // Temporary capture buffer
    Private tmpPlyBuf() As Single                       ' // Temporary playback buffer
    Private wavConv     As clsTrickWavConverter         ' // Converter object of carrier signal
    Private inpConv     As clsTrickWavConverter         ' // Converter object of modulation signal
    
    ' // Get capture device
    Public Property Get AudioCaptureDevice() As clsTrickSound
        Set AudioCaptureDevice = AudioCapture
    End Property
    
    ' // Get file name of capture, if presents
    Public Property Get InputFileName() As String
        InputFileName = mInpFile
    End Property
    
    ' // Close window
    Private Sub btnClose_Click()
        Unload Me
    End Sub
    
    ' // Open carrier signal
    Private Sub btnOpenCarrier_Click()
        Dim FileName    As String
        Dim conv        As clsTrickWavConverter
        ' // Get file name
        FileName = GetFile(Me.hwnd)
        
        If Len(FileName) Then
    
            Set conv = New clsTrickWavConverter
            ' // If success set it as current signal
            If conv.ReadWaveFile(FileName) Then
                Set wavConv = conv
            End If
            
        End If
        
    End Sub
    
    ' // Settings
    Private Sub btnSettings_Click()
        Dim frm As frmSettings
        Dim cur As Long
        
        Set frm = New frmSettings
        
        frm.Show vbModal
        ' // When OK has been pressed
        If frm.Result = vbOK Then
            ' // Get current capture device
            cur = AudioCapture.CurrentCaptureDeviceID()
            ' // Clear buffer because we will hear current signal looped if failure happens
            memset inpBuffer(0), mFFTSize * 2, 0
            
            If frm.SelectedDevice >= AudioCapture.CaptureDevices.count Then
                ' // Capture from file
                Set inpConv = Nothing
                Set inpConv = New clsTrickWavConverter
                ' // Read file
                If Not inpConv.ReadWaveFile(frm.FileName) Then
                    ' // Restore back
                    InitCapture cur
                    
                Else
                
                    mInpFile = frm.FileName
                    AudioCapture.StopProcess
                    
                End If
                
            Else
                ' // Capture from device
                AudioPlayback.StopProcess
                
                If Not InitCapture(frm.SelectedDevice) Then
                    InitCapture cur
                Else
                    mInpFile = vbNullString
                End If
                
                On Error Resume Next
                AudioCapture.StartProcess
                AudioPlayback.StartProcess
                On Error GoTo 0
                
                If err.Number Then
                    MsgBox "Error"
                End If
                
            End If
            
        End If
        
    End Sub
    
    ' // Change frequency response
    Private Sub equResponse_Change()
        Dim data() As Single
        
        ReDim data(mFFTSize \ 2 - 1)
        ' // Get from control
        equResponse.GetCurve data()
        ' // Set to modulator
        Modulator.SetLevels data()
        
    End Sub
    
    ' // Loading of form
    Private Sub Form_Load()
        ' // Set FFT size
        mFFTSize = 2048
        ' // Set overlap
        mOverlap = 2
        ' // Playback initialization
        If Not InitPlayback() Then Unload Me
        ' // Capture initialization
        If Not InitCapture() Then
            Call btnSettings_Click
        Else
            AudioCapture.StartProcess
        End If
        
        Set plyBuffer = New clsTrickOverlappedBuffer
        Set capBuffer = New clsTrickOverlappedBuffer
        ' // Set up overlapped buffers
        plyBuffer.Init mFFTSize, mFFTSize \ mOverlap
        capBuffer.Init mFFTSize, mFFTSize \ mOverlap
        
        Set FFT = New clsTrickFFT
        ' // Set size of FFT and size of window
        FFT.FFTSize = mFFTSize
        FFT.WindowType = WT_HANN
        
        Set Modulator = New clsTrickModulator
        ' // Create buffers
        ReDim tmpCapBuf(1, mFFTSize - 1)
        ReDim tmpPlyBuf(1, mFFTSize - 1)
        ReDim inpBuffer(mFFTSize - 1)
        ReDim outBuffer(mFFTSize - 1)
        ' // Refresh information
        Call equResponse_Change
        Call knbBands_Change
        Call knbMix_Change
        Call knbVolume_Change
        Call knbPitch_Change
        ' // Run playback
        AudioPlayback.StartProcess
        
        Dim hRgn    As Long
        ' // Set window region
        hRgn = CreateRoundRectRgn(0, 0, Me.ScaleWidth, Me.ScaleHeight, 2, 2)
        SetWindowRgn Me.hwnd, hRgn, False
        ' // Set icon
        SetIcon Me.hwnd
    End Sub
    
    ' // New data has been obtained from capture device
    Private Sub AudioCapture_NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)
        ' // Copy to temporary buffer
        memcpy inpBuffer(0), ByVal DataPtr, CountBytes
    End Sub
    
    ' // Playback device requires new data
    Private Sub AudioPlayback_NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)
        ' // Process last captured data
        Call Process
        ' // Copy
        memcpy ByVal DataPtr, outBuffer(0), CountBytes
    End Sub
    
    ' // Process of last captured data
    Private Sub Process()
        Dim ovrLap      As Long
        Dim ret         As Long
        Dim idx         As Long
        Dim delta       As Single
        Dim datSize     As Long
        
        If Len(mInpFile) Then
            ' // Capture from file
            inpConv.Convert VarPtr(inpBuffer(0)), mFFTSize * 2, ret
            ' // If data have ended start at beginning
            If ret < mFFTSize * 2 Then
                inpConv.InputCurrentPosition = 0
                inpConv.Convert VarPtr(inpBuffer(ret \ 2)), mFFTSize * 2 - ret, ret
            End If
            
        End If
        ' // If carrier signal is not present
        If wavConv Is Nothing Then
            ' // Copy captured data to output buffer and exit
            outBuffer = inpBuffer
            Exit Sub
            
        End If
        ' // Transform data to complex form
        FFT.Convert16BitToComplex inpBuffer(), tmpCapBuf()
        ' // Write data to overlapped buffer
        capBuffer.WriteInputData tmpCapBuf()
        ' // Get size (in samples) of carrier signal
        datSize = wavConv.Rate * wavConv.InputDataSize \ 2
        
        If datSize < mRawSize Then
            ' // Data is too small
            wavConv.Convert VarPtr(rawBuffer(0)), mRawSize * 2, ret
            ' // If data doesn't fit entirely start at beginning
            If ret * 2 <> datSize Then
            
                wavConv.InputCurrentPosition = 0
                wavConv.Convert VarPtr(rawBuffer(ret \ 2)), datSize * 2 - ret, ret
                
            End If
            ' // Loop it within data
            ret = datSize
            idx = 0
            
            Do While ret < mRawSize
            
                rawBuffer(ret) = rawBuffer(idx)
                ret = ret + 1
                idx = idx + 1
                
            Loop
            ' // Refresh position
            wavConv.InputCurrentPosition = ((wavConv.InputCurrentPosition + idx) Mod datSize)
            
        Else
            ' // Data is enough to place
            wavConv.Convert VarPtr(rawBuffer(0)), mRawSize * 2, ret
            ' // If data has ended start at beginning
            If ret < mRawSize * 2 Then
            
                wavConv.InputCurrentPosition = 0
                wavConv.Convert VarPtr(rawBuffer(ret \ 2)), mRawSize * 2 - ret, ret
            End If
            
        End If
        
        ' // Stretch array considering pitch
        delta = 2 ^ (knbPitch.Value / 12)
        For idx = 0 To mFFTSize - 1
            outBuffer(idx) = rawBuffer(Fix(idx * delta))
        Next
        ' // Convert data of carrier signal to complex form
        FFT.Convert16BitToComplex outBuffer(), tmpPlyBuf()
        ' // Write data to overlapped buffer
        plyBuffer.WriteInputData tmpPlyBuf()
    
        ' // For each overlap
        For ovrLap = 0 To mOverlap - 1
    
            ' // Get current data from overlapped buffers
            capBuffer.GetInputBuffer tmpCapBuf()
            plyBuffer.GetInputBuffer tmpPlyBuf()
            ' // Direct FFT
            FFT.FFT tmpCapBuf(), False
            FFT.FFT tmpPlyBuf(), False
            ' // Modulation
            Modulator.Process tmpPlyBuf(), tmpCapBuf()
            ' // Mirroring
            FFT.MakeMirror tmpPlyBuf()
            ' // Reverse FFT
            FFT.FFT tmpPlyBuf(), True
            ' // Apply window
            FFT.ApplyWindow tmpPlyBuf()
            ' // Write to output buffer
            plyBuffer.WriteOutputData tmpPlyBuf()
    
        Next
        
        ' // Get all the processed data
        plyBuffer.GetOutputBuffer tmpPlyBuf()
        ' // Convert ot 16 bit real audio data
        FFT.ConvertComplexTo16Bit tmpPlyBuf(), outBuffer()
        
    End Sub
    
    ' // Capture initialization
    Private Function InitCapture(Optional DeviceID As Long = -1) As Boolean
        On Error GoTo ERROR_LABEL
        Set AudioCapture = Nothing
        
        Set AudioCapture = New clsTrickSound
        AudioCapture.InitCapture 1, SampleRate, 16, mFFTSize, DeviceID
        
        InitCapture = True
        
        Exit Function
    ERROR_LABEL:
        
        MsgBox "Error initialize capture", vbCritical
        
    End Function
    
    ' // Playback initialization
    Private Function InitPlayback(Optional DeviceID As Long = -1) As Boolean
        On Error GoTo ERROR_LABEL
        Set AudioPlayback = Nothing
        
        Set AudioPlayback = New clsTrickSound
        AudioPlayback.InitPlayback 1, SampleRate, 16, mFFTSize, DeviceID
        
        InitPlayback = True
        
        Exit Function
    ERROR_LABEL:
        
        MsgBox "Error initialize playback", vbCritical
        
    End Function
    
    ' // Press mouse button within window
    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
        Dim pos As Currency
        
        If y <= 26 Then
            ' // If mouse was being pressed within caption of window then movement is enabled
            ReleaseCapture
            GetCursorPos pos
            SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, pos
            
        End If
        
    End Sub
    
    ' // Change number of frequency bands
    Private Sub knbBands_Change()
        
        Modulator.Bands = knbBands.Value
        knbBands.Caption = knbBands.Value
        
    End Sub
    
    ' // Mix change
    Private Sub knbMix_Change()
        Dim lg As Single
        ' // Logarithmic size
        lg = ((10 ^ (knbMix.Value / 50)) - 1) / 99
        Modulator.DryWet = lg
        knbMix.Caption = Format(lg, "#0.00%")
            
    End Sub
    
    ' // Pitch change
    Private Sub knbPitch_Change()
        
        mRawSize = -Int(-mFFTSize * (2 ^ (knbPitch.Value / 12)))
        ReDim rawBuffer(mRawSize - 1)
        
        knbPitch.Caption = Format(knbPitch.Value, "0 sem;-0 sem;non\e")
        
    End Sub
    
    ' // Volume change
    Private Sub knbVolume_Change()
        Dim lg As Single
        ' // Logarithmic size
        lg = ((10 ^ (knbVolume.Value / 50)) - 1) / 99
        Modulator.Volume = lg
        knbVolume.Caption = Format(lg, "#0.00%")
                
    End Sub

  11. #11

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    When loading of form we perform initialization of all components. Capture, playing back the audio size FFT, the amount of overlap, overlapping buffers, creating buffers for integer and complex data. Next, I made a box shape with rounded corners, as use a window without frame (draw in the nonclient area had no desire). Now the whole problem is reduced to handling events - AudioPlayback_NewData and AudioCapture_NewData. First event occurs when the playback device needs another portion of the audio data, the second when the buffer capture, in which we simply copy the data into a temporary buffer from where it will take them at processing AudioPlayback_NewData. The main method - Process, in it we just do the conversion. First we check whether we capture from a file or device. To do this, we check the variable mInpFile, which specifies the name of the input file to capture. If capture is made from a file, then we are using object inpConv, which is an instance of clsTrickWavConverter, convert the data into the format you want us to. If the data is finished (the number of bytes read does not match the passed), it means that we are on the edge of the file and continue to have to start over again. Also check the carrier signal and if it is not set then just copy the input data on output and, in this case, we will hear the raw sound. Otherwise, we translate the data into a complex form (count a real part of the signal and the imaginary zero out) and puts the resulting array in an overlapping buffer. Next, start processing the carrier signal. Because carrier signal we can have a very small length (you can use one wave period), in order to optimize I will do the repetition of the signal if required. Let me explain. For example, if we have a carrier signal 10 ms and 100 ms buffer (for example), then you could just call the conversion each time using ACM overwriting the pointer to the array destination, but it is not optimal. For optimization can be converted only once, and then simply duplicate the data to the end of the array, which we did. Only then do not forget to change the position in the source file, otherwise the next phase of the reading will not be the same and will flicks. We will write to another buffer (rawBuffer). This buffer length is based on the pitch shift. For example, if we want to shift the tone for the amount of semitones (halftones), the buffer size must be rawBuffer 2semitones / 12 times more. Then we simply compress / stretch buffer to a value mFFTSize, which will give us the acceleration / deceleration, and as a result increase / decrease tone. After all the manipulations we write data in an overlapping buffer and start processing. To do this, we pass by the number of overlapping data and handle them. Class objects clsTrickOverlappedBuffer return us the correct data. Processing is clear from the code, as We consider in detail the performance of each class. After processing all of overlap we get the output and convert them to integer suitable for playback. As the setting uses a form frmSettings. As the list of devices using a standard listbox, just going through my drawing class. The list of devices will be added in the following order:
    • A default device predetermined format
    • Device 1
    • Device 2
    • ...
    • Device n
    • Capturing from a file

    For testing click on the last point message is used LB_GETITEMRECT, which receives the coordinates and size of the item in the list. If this is not done then click the sheet of paper, if there is an empty space at the bottom will be equivalent to clicking on the last point. In the handler settings button in the main form frmTrickVocoder we check capture device and either open the file for conversion or initialize capture. To adjust the volume and mixing using a logarithmic scale, as the sensitivity of the human ear is not linear.
    That's basically all. Thank you for your attention.
    Good luck!
    Attached Files Attached Files

  12. #12
    Fanatic Member
    Join Date
    Aug 2013
    Posts
    805

    Re: [VB6] - Vocoder.

    Hi Trick, I just wanted to say that this is a really beautiful code example. Thank you for sharing this (and other projects) on vbForums. I've learned a lot from your code.

    Your clsTrickFFT example is particularly nice. Out of curiosity, have you developed a version of the class that operates on Byte arrays? I might be interested in repurposing the class to work on image data (32-bit 2D RGBA data, ideally packing two channels into each real/imaginary pair, for performance reasons, and performing horizontal/vertical FFTs in separate passes).

    I've looked at porting something like FFTReal over to VB, and would be interested in seeing how it compares performance-wise to your existing implementation. Since you have a lot of experience in this area, I wanted to ask in case you have already worked on something similar.

    If not, no problem. Thanks again for your great work.
    Check out PhotoDemon, a pro-grade photo editor written completely in VB6. (Full source available at GitHub.)

  13. #13

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,319

    Re: [VB6] - Vocoder.

    Hello Tanner_H. My class clsTrickFFT work with float-numbers (complex). You can translate byte-array to float-array (Single on VB6) and use this class for image processing. Also you can use a trick that allows speed up the process: put to real-part - first part, put to imaginary-part - second part, make FFT. Because spectrum has a mirror effect, you can select the amplitude sine and cosine combine mirrors parts.

  14. #14

  15. #15
    Fanatic Member namrekka's Avatar
    Join Date
    Feb 2005
    Location
    Netherlands
    Posts
    639

    Re: [VB6] - Vocoder.

    Great project!!!

  16. #16
    Hyperactive Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    430

    Re: [VB6] - Vocoder.

    maybe out of topic

    On Win XP

    In IDE it works, but when Compiling-linking:

    Code:
    Microsoft (R) Incremental Linker Version 9.00.30729.01
    Copyright (C) Microsoft Corporation.  All rights reserved.
    LINK : warning LNK4010: invalid subsystem version number 4.0; default subsystem version assumed
    LINK : fatal error LNK1101: incorrect MSPDB80.DLL version; recheck installation of this product
    Strange... because all other VB6 project works!

    yes LINK.EXE and MSPDB80.DLL are not original VB6 but taken from VisualStudio9

    Maybe did I miss some other DLL ?

  17. #17
    Hyperactive Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    430

    Re: [VB6] - Vocoder.

    (Files I added are take from Visual Basic 2008 Express Edition [Microsoft Visual Studio 9.0])
    I added in VB98 folder even
    Link.exe.config
    and
    mspdbsrv.exe

    and the error changed to this
    Code:
    Microsoft (R) Incremental Linker Version 9.00.30729.01
    Copyright (C) Microsoft Corporation.  All rights reserved.
    LINK : warning LNK4010: invalid subsystem version number 4.0; default subsystem version assumed
    LINK : fatal error LNK1318: Unexpected PDB error; NOT_FOUND (4) ''msobj80.dll''
    So I added even
    msobj80.dll
    And Now works

    this way it is created one "extra" file: "TrickVocoder.pdb"

  18. #18

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width