Planet Source Code Jumbo …e CD Visual Basic 1 to 7/4_2005-2006.ISO/data/Zips/WaveIn_Rec2001136152006.psc/EncoderWAV.cls

Text File | 2006-06-14 | 13KB | 439 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "EncoderWAV"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' WAV Encoder with ACM support for compressed formats
' (from my project "Monoton")

' this class implemented "IEncoder".
' to hold the size of the project down, I removed it.
' now the members of IEncoder have the prefix "encoder".


Private Const Extension         As String = "wav"
Private Const Description       As String = "Wave ACM Encoder"


Private Declare Sub CpyMem Lib "kernel32" _
Alias "RtlMoveMemory" ( _
    pDst As Any, _
    pSrc As Any, _
    ByVal dwLen As Long _
)

Private Declare Sub ZeroMem Lib "kernel32" _
Alias "RtlZeroMemory" ( _
    pDst As Any, _
    ByVal dwLen As Long _
)

Private Declare Function IsBadReadPtr Lib "kernel32" ( _
    ptr As Any, _
    ByVal ucb As Long _
) As Long

Private Declare Function IsBadWritePtr Lib "kernel32" ( _
    ptr As Any, _
    ByVal ucb As Long _
) As Long

Private Declare Function CreateFile Lib "kernel32.dll" _
Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    lpSecurityAttributes As Any, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long

Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal HFILE As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any _
) As Long

Private Declare Function WriteFile Lib "kernel32" ( _
    ByVal HFILE As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, _
    ByVal lpOverlapped As Any _
) As Long

Private Declare Function SetFilePointer Lib "kernel32" ( _
    ByVal HFILE As Long, _
    ByVal lDistanceToMove As Long, _
    ByVal lpDistanceToMoveHigh As Long, _
    ByVal dwMoveMethod As Long _
) As Long

Private Declare Function GetFileSize Lib "kernel32" ( _
    ByVal HFILE As Long, _
    ByVal lpFileSizeHigh As Long _
) As Long

Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long

Private Declare Function acmStreamPrepareHeader Lib "msacm32" ( _
    ByVal has As Long, _
    pash As ACMSTREAMHEADER, _
    ByVal fdwPrepare As Long _
) As Long

Private Declare Function acmStreamUnprepareHeader Lib "msacm32" ( _
    ByVal has As Long, _
    pash As ACMSTREAMHEADER, _
    ByVal fdwUnprepare As Long _
) As Long

Private Declare Function acmStreamOpen Lib "msacm32" ( _
    phas As Long, _
    ByVal had As Long, _
    pwfxSrc As Any, _
    pwfxDst As Any, _
    ByVal pwfltr As Long, _
    ByVal dwCallback As Long, _
    ByVal dwInstance As Long, _
    ByVal fdwOpen As Long _
) As Long

Private Declare Function acmStreamSize Lib "msacm32" ( _
    ByVal has As Long, _
    ByVal cbInput As Long, _
    pdwOutputBytes As Long, _
    ByVal fdwSize As Long _
) As Long

Private Declare Function acmStreamConvert Lib "msacm32" ( _
    ByVal has As Long, _
    pash As ACMSTREAMHEADER, _
    ByVal fdwConvert As Long _
) As Long

Private Declare Function acmStreamReset Lib "msacm32" ( _
    ByVal has As Long, _
    ByVal fdwReset As Long _
) As Long

Private Declare Function acmStreamClose Lib "msacm32" ( _
    ByVal has As Long, _
    ByVal fdwClose As Long _
) As Long

Private Declare Function acmFormatChoose Lib "msacm32" _
Alias "acmFormatChooseA" ( _
    pfmtc As ACMFORMATCHOOSEA _
) As Long

Public Enum SND_RESULT
    SND_ERR_SUCCESS = 0
    SND_ERR_INVALID_SOURCE
    SND_ERR_INVALID_OUTPUT
    SND_ERR_INTERNAL
    SND_ERR_OUT_OF_RANGE
    SND_ERR_END_OF_STREAM
    SND_ERR_INVALID_TAG
    SND_ERR_INVALID_PARAM
    SND_ERR_TOO_BIG
    SND_ERR_NEED_MORE
    SND_ERR_WRITE_ERROR
    SND_ERR_UNKNOWN
End Enum

Public Enum ENCODER_METRICS
    ENC_M_PCM_PER_DELIVERY_MIN = 0
    ENC_M_PCM_PER_DELIVERY_MAX
    ENC_M_SUPPORT_TAGS
End Enum

Private Enum FILE_OPEN_METHOD
    CREATE_NEW = 1
    CREATE_ALWAYS = 2
    OPEN_EXISTING = 3
    OPEN_ALWAYS = 4
End Enum

Private Enum FILE_SHARE_RIGHTS
    FILE_SHARE_READ = &H1
    FILE_SHARE_WRITE = &H2
End Enum

Private Enum FILE_ACCESS_RIGHTS
    GENERIC_READ = &H80000000
    GENERIC_WRITE = &H40000000
End Enum

Private Enum SEEK_METHOD
    FILE_BEGIN = 0
    FILE_CURRENT = 1
    FILE_END = 2
End Enum

Private Enum HACMSTREAM
    INVALID_STREAM_HANDLE = 0
End Enum

Private Enum ACM_STREAMSIZEF
    ACM_STREAMSIZEF_DESTINATION = &H1
    ACM_STREAMSIZEF_SOURCE = &H0
    ACM_STREAMSIZEF_QUERYMASK = &HF
End Enum

Private Enum ACM_STREAMCONVERTF
    ACM_STREAMCONVERTF_BLOCKALIGN = &H4
    ACM_STREAMCONVERTF_START = &H10
    ACM_STREAMCONVERTF_END = &H20
End Enum

Private Const INVALID_HANDLE                As Long = -1

Private Const ACMFMTDET_FORMAT_CHARS        As Long = 128
Private Const ACMFMTTAGDET_FORMATTAG_CHARS  As Long = 48

Private Const ACM_FORMATENUMF_CONVERT       As Long = &H100000

Private Const WAVE_FORMAT_PCM               As Long = 1

' some codecs (e.g. Vorbis ACM) have very big
' WFX structs. so make the WFX buffer extra large.
Private Const WFXSize                       As Long = 128& * 1024&

Private Const WAV_RIFF                      As Long = 1179011410
Private Const WAV_WAVE                      As Long = 1163280727
Private Const WAV_DATA                      As Long = 1635017060
Private Const WAV_FMT                       As Long = 544501094

Private Type HFILE
    handle                                  As Long
    path                                    As String
End Type

Private Type ACMSTREAMHEADER
    cbStruct                                As Long
    fdwStatus                               As Long
    dwUser                                  As Long
    pbSrc                                   As Long
    cbSrcLength                             As Long
    cbSrcLengthUsed                         As Long
    dwSrcUser                               As Long
    pbDst                                   As Long
    cbDstLength                             As Long
    cbDstLengthUsed                         As Long
    dwDstUser                               As Long
    dwReservedDriver(9)                     As Long
End Type

Private Type ACMFORMATCHOOSEA
    cbStruct                                As Long
    fdwStyle                                As Long
    hwndOwner                               As Long
    pwfx                                    As Long
    cbwfx                                   As Long
    pszTitle                                As Long
    szFormatTag                             As String * ACMFMTTAGDET_FORMATTAG_CHARS
    szFormat                                As String * ACMFMTDET_FORMAT_CHARS
    pszName                                 As Long
    cchName                                 As Long
    fdwEnum                                 As Long
    pwfxEnum                                As Long
    hInstance                               As Long
    pszTemplateName                         As Long
    lCustData                               As Long
    pfnHook                                 As Long
    btSpace(1023)                           As Byte ' had some strange crashes...
End Type

Private Type MMWAVEFORMATEX
    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 WAVRIFF
    RIFF                                    As Long         ' "RIFF"
    hdrlen                                  As Long
    WAVE                                    As Long         ' "WAVE"
    fmt                                     As Long         ' "fmt "
    chnksize                                As Long
End Type

Private udtWFXIn                            As MMWAVEFORMATEX
Private btWfxOut()                          As Byte
Private lngWFXOutLen                        As Long
Private strFormatID                         As String
Private strFormatTag                        As String

Private btInp()                             As Byte
Private btOut()                             As Byte
Private lngInpLen                           As Long
Private lngOutLen                           As Long

Private udtStreamHdr                        As ACMSTREAMHEADER
Private hStream                             As HACMSTREAM

Private hFOut                               As HFILE

Private blnWriteHeader                      As Boolean

'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''

Private Sub Class_Initialize()
    Dim wfx As MMWAVEFORMATEX

    ReDim btWfxOut(WFXSize - 1) As Byte
    blnWriteHeader = True

    wfx = CreateWFX(44100, 2, 16)

    SetFormat VarPtr(wfx), _
              Len(wfx), _
              "44.1 kHz 16 Bit Stereo", "PCM"

    hFOut.handle = INVALID_HANDLE
End Sub

Private Sub Class_Terminate()
    Encoder_EncoderClose
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''

' write RIFF/WAVE/FMT /DATA chunks
Public Property Get WriteHeader( _
) As Boolean

    WriteHeader = blnWriteHeader
End Property

Public Property Let WriteHeader( _
ByVal bln As Boolean _
)

    If hFOut.handle = INVALID_HANDLE Then
        blnWriteHeader = bln
    Else
        Err.Raise 90, , "Encoder already running!"
    End If
End Property

Public Property Get FormatTag( _
) As String

    FormatTag = strFormatTag
End Property

Public Property Get FormatID( _
) As String

    FormatID = strFormatID
End Property

Public Sub SetPCMFormat( _
    ByVal samplerate As Long, _
    ByVal Channels As Integer, _
    Optional ByVal FormatID As String, _
    Optional ByVal FormatTag As String _
)

    Dim wfx As MMWAVEFORMATEX

    wfx = CreateWFX(samplerate, Channels, 16)

    If FormatID = "" Then
        With wfx
            strFormatID = Round(.nSamplesPerSec / 1000, 1) & " " & _
                          .wBitsPerSample & " Bit " & _
                          IIf(.nChannels = 2, "stereo", "mono")
        End With
    End If

    If FormatTag = "" Then
        FormatTag = "PCM"
    End If

    SetFormat VarPtr(wfx), Len(wfx), _
              FormatID, FormatTag
End Sub

Public Sub SetFormat( _
    ByVal wfx_ptr As Long, _
    ByVal wfx_len As Long, _
    Optional FormatID As String, _
    Optional FormatTag As String _
)

    If 0 = IsBadReadPtr(ByVal wfx_ptr, wfx_len) Then
        If wfx_len > UBound(btWfxOut) + 1 Then
            ReDim btWfxOut(wfx_len - 1) As Byte
        End If
        CpyMem btWfxOut(0), ByVal wfx_ptr, wfx_len

        lngWFXOutLen = wfx_len

        strFormatID = FormatID
        strFormatTag = FormatTag
    End If
End Sub

Public Function SelectFormat( _
    ByVal samplerate As Long, _
    ByVal Channels As Integer, _
    Optional ByVal hwndOwner As Long, _
    Optional ByVal Title As String = "WAV Format" _
) As SND_RESULT

    Dim btTitle()   As Byte
    Dim btWFX()     As Byte
    Dim wfx         As MMWAVEFORMATEX
    Dim wfxinp      As MMWAVEFORMATEX
    Dim udtFmtCh    As ACMFORMATCHOOSEA

    ReDim btWFX(WFXSize - 1) As Byte

    btTitle = StrConv(Title & Chr$(0), vbFromUnicode)

    With wfxinp
        .nSamplesPerSec = samplerate
        .nChannels = Channels
        .wBitsPerSample = 16
        .wFormatTag = WAVE_FORMAT_PCM
        .nBlockAlign = .nChannels * (.wBitsPerSample / 8)
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With

    CpyMem btWFX(0), wfxinp, Len(wfxinp)

    With udtFmtCh
        .cbStruct = LenB(udtFmtCh)
        .hwndOwner = hwndOwner
        .pwfx = VarPtr(btWFX(0))
        .cbwfx = WFXSize
        .pwfxEnum = VarPtr(wfxinp)
        .fdwEnum C .hwndOwner ibutes As Any, _
    ByVal le            x As MMWAVEFORMATE((((((((((((mOSub SetFormat( _
    ByVal wfx_pPtr(wfxi4vate Const DescripEenBi