Code:Option Explicit Private Const FOURCC_MEM As Long = &H204D454D Private Const MMIO_CREATERIFF As Long = &H20 Private Const MMIO_DIRTY As Long = &H10000000 Private Const MMIO_CREATE As Long = &H1000 Private Const MMIO_WRITE As Long = &H1 Private Const MMIO_READWRITE As Long = &H2 Private Const WAVE_FORMAT_PCM As Long = 1 Private Const SEEK_SET As Long = 0 Private Const MMIO_FINDCHUNK As Long = &H10 Private Const MMIO_FINDRIFF As Long = &H20 Private Type MMCKINFO ckid As Long ckSize As Long fccType As Long dwDataOffset As Long dwFlags As Long End Type Private Type MMIOINFO dwFlags As Long fccIOProc As Long pIOProc As Long wErrorRet As Long htask As Long cchBuffer As Long pchBuffer As Long pchNext As Long pchEndRead As Long pchEndWrite As Long lBufOffset As Long lDiskOffset As Long adwInfo(4) As Long dwReserved1 As Long dwReserved2 As Long hmmio 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 Declare Function mmioClose Lib "winmm.dll" ( _ ByVal hmmio As Long, _ Optional ByVal uFlags As Long) As Long Private Declare Function mmioOpen Lib "winmm.dll" _ Alias "mmioOpenW" ( _ ByVal szFileName As Long, _ ByRef lpmmioinfo As Any, _ ByVal dwOpenFlags 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, _ ByRef lpck As MMCKINFO, _ ByVal uFlags As Long) As Long Private Declare Function mmioCreateChunk Lib "winmm.dll" ( _ ByVal hmmio As Long, _ ByRef lpck As MMCKINFO, _ ByVal uFlags As Long) As Long Private Declare Function mmioWrite Lib "winmm.dll" ( _ ByVal hmmio As Long, _ ByRef pch As Any, _ ByVal cch As Long) As Long Private Declare Function mmioDescend Lib "winmm.dll" ( _ ByVal hmmio As Long, _ ByRef lpck As MMCKINFO, _ ByRef lpckParent As Any, _ ByVal uFlags As Long) As Long Private Declare Function mmioSeek Lib "winmm.dll" ( _ ByVal hmmio As Long, _ ByVal lOffset As Long, _ ByVal iOrigin As Long) As Long Private Declare Function memcpy Lib "kernel32" _ Alias "RtlMoveMemory" ( _ ByRef Destination As Any, _ ByRef Source As Any, _ ByVal Length As Long) As Long Private Declare Function mmioRead Lib "winmm.dll" ( _ ByVal hmmio As Long, _ ByRef pch As Any, _ ByVal cch As Long) As Long Private Declare Function mmioGetInfo Lib "winmm.dll" ( _ ByVal hmmio As Long, _ ByRef lpmmioinfo As Any, _ ByVal wFlags As Long) As Long Sub main() Dim bData() As Byte Dim bOutPart() As Byte ' // Open file to array Open "E:\Distance_to_Mars.wav" For Binary Access Read As #1 ReDim bData(LOF(1) - 1) Get 1, , bData Close 1 ' // Extract part of file to other file in-memory ' // Select from 1777777 sample to 1777777 + 55556 sample ExtractPartOfWaveFile bData(), 1777777, 55556, bOutPart() ' // Save part of file to file Open "E:\Distance_to_Mars_part.wav" For Binary Access Write As #1 Put 1, , bOutPart Close 1 End Sub ' // Extract part of a WAVE-file-in-memory to other WAVE-file-in-memory ' // !!! NO BOUNDS CHECKING (arrays etc.) !!! Private Function ExtractPartOfWaveFile( _ ByRef bData() As Byte, _ ByVal lStartSample As Long, _ ByVal lLength As Long, _ ByRef bOut() As Byte) As Boolean Dim tIoInfo As MMIOINFO Dim tckRIFF As MMCKINFO Dim tckWAVE As MMCKINFO Dim tckFMT As MMCKINFO Dim tckDATA As MMCKINFO Dim bInData() As Byte Dim bFMT() As Byte Dim hOutFile As Long If Not ExtractData(bData(), lStartSample, lLength, bInData(), bFMT()) Then Exit Function End If With tIoInfo .fccIOProc = FOURCC_MEM .cchBuffer = 2048 .adwInfo(0) = 2048& * 2048 End With hOutFile = mmioOpen(0, tIoInfo, MMIO_READWRITE Or MMIO_CREATE) If hOutFile = 0 Then MsgBox "Error opening wave file" Exit Function End If tckRIFF.fccType = mmioStringToFOURCC("WAVE", 0) If mmioCreateChunk(hOutFile, tckRIFF, MMIO_CREATERIFF) Then MsgBox "Error creating RIFF-WAVE chunk" GoTo CleanUp End If tckFMT.ckid = mmioStringToFOURCC("fmt", 0) If mmioCreateChunk(hOutFile, tckFMT, 0) Then MsgBox "Error creating fmt chunk" GoTo CleanUp End If If mmioWrite(hOutFile, bFMT(0), UBound(bFMT) + 1) = -1 Then MsgBox "Error writing format" GoTo CleanUp End If mmioAscend hOutFile, tckFMT, 0 tckDATA.ckid = mmioStringToFOURCC("data", 0) If mmioCreateChunk(hOutFile, tckDATA, 0) Then MsgBox "Error creating data chunk" GoTo CleanUp End If If mmioWrite(hOutFile, bInData(0), UBound(bInData) + 1) = -1 Then MsgBox "Error writing data" GoTo CleanUp End If mmioAscend hOutFile, tckDATA, 0 mmioAscend hOutFile, tckRIFF, 0 If mmioGetInfo(hOutFile, tIoInfo, 0) Then MsgBox "Unable to get stream info" GoTo CleanUp End If ReDim bOut(tIoInfo.pchNext - tIoInfo.pchBuffer - 1) memcpy bOut(0), ByVal tIoInfo.pchBuffer, UBound(bOut) + 1 ExtractPartOfWaveFile = True CleanUp: mmioClose hOutFile, 0 End Function ' // Extract format and part of data from in-memory-file Private Function ExtractData( _ ByRef bData() As Byte, _ ByVal lStartSample As Long, _ ByVal lLength As Long, _ ByRef bOut() As Byte, _ ByRef bFMT() As Byte) As Boolean Dim tIoInfo As MMIOINFO Dim tckRIFF As MMCKINFO Dim tckWAVE As MMCKINFO Dim tckFMT As MMCKINFO Dim tckDATA As MMCKINFO Dim tFMT As WAVEFORMATEX Dim hInFile As Long Dim lByteOffset As Long Dim lBytesCount As Long With tIoInfo .fccIOProc = FOURCC_MEM .cchBuffer = UBound(bData) + 1 .pchBuffer = VarPtr(bData(0)) End With hInFile = mmioOpen(0, tIoInfo, MMIO_READWRITE) If hInFile = 0 Then MsgBox "Error opening wave file" Exit Function End If tckWAVE.fccType = mmioStringToFOURCC("WAVE", 0) If mmioDescend(hInFile, tckWAVE, ByVal 0&, MMIO_FINDRIFF) Then MsgBox "Is not valid file" GoTo CleanUp End If tckFMT.ckid = mmioStringToFOURCC("fmt", 0) If mmioDescend(hInFile, tckFMT, tckWAVE, MMIO_FINDCHUNK) Then MsgBox "Format chunk not found" GoTo CleanUp End If If tckFMT.ckSize < 0 Then MsgBox "Invalid format" GoTo CleanUp End If ReDim bFMT(tckFMT.ckSize - 1) If mmioRead(hInFile, bFMT(0), tckFMT.ckSize) = -1 Then MsgBox "Can't read format" GoTo CleanUp End If mmioAscend hInFile, tckFMT, 0 tckDATA.ckid = mmioStringToFOURCC("data", 0) If mmioDescend(hInFile, tckDATA, tckWAVE, MMIO_FINDCHUNK) Then MsgBox "Wave data is not found" GoTo CleanUp End If If tckDATA.ckSize <= 0 Then MsgBox "Invalid data size" GoTo CleanUp End If If tckFMT.ckSize > Len(tFMT) Then tckFMT.ckSize = Len(tFMT) End If memcpy tFMT, bFMT(0), tckFMT.ckSize lByteOffset = lStartSample * tFMT.nBlockAlign lBytesCount = lLength * tFMT.nBlockAlign If mmioSeek(hInFile, tckDATA.dwDataOffset + lByteOffset, SEEK_SET) = -1 Then MsgBox "Unable to locate data" GoTo CleanUp End If ReDim bOut(lBytesCount - 1) If mmioRead(hInFile, bOut(0), lBytesCount) = -1 Then MsgBox "Can't read data" GoTo CleanUp End If ExtractData = True CleanUp: mmioClose hInFile, 0 End Function




Reply With Quote