Tipp-Upload: VB 5/6 0183: Resampling von Audiodaten 2
von OlimilO
Über den Tipp
Dieser Tippvorschlag ist noch unbewertet.
Der Vorschlag ist in den folgenden Kategorien zu finden:
- Mathematik
- Multimedia
Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Resampling, Samplerate konvertieren, Downsampling, Upsampling
Der Vorschlag wurde erstellt am: 27.01.2008 23:56.
Die letzte Aktualisierung erfolgte am 23.02.2008 15:07.
Beschreibung
In 
Tippvorschlag 174 wurde gezeigt wie man mit linearer Interpolation ein Resampling von Audiodaten durchführen kann. Das Ergebnis wird als Grafik ausgegeben. Hier wird das Ergebnis auch akustisch ausgegeben. Der Algorithmus wurde zusammen mit Klaus Langbein entwickelt. Das Beispielprojekt enthält eine Wave-Datei (tiefes E) einer Gitarre (ca 1.4Mb).
|
Schwierigkeitsgrad
|
Verwendete API-Aufrufe: PlaySoundA |
Download: |
' Dieser Source stammt von http://www.activevb.de ' und kann frei verwendet werden. Für eventuelle Schäden ' wird nicht gehaftet. ' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum. ' Ansonsten viel Spaß und Erfolg mit diesem Source! ' ------------- Anfang Projektdatei Projekt1.vbp ------------- ' ---- Anfang Formular "FrmResampleWave" alias Form1.frm ---- ' Steuerelement: Beschriftungsfeld "Label1" auf FraDestination ' Steuerelement: Kontrollkästchen-Steuerelement "ChkWriteSrcSPS" auf FraDestination ' Steuerelement: Vertikale Scrollbar "VScroll1" auf FraDestination ' Steuerelement: Beschriftungsfeld "LblSrcPFN" auf FraSource ' Steuerelement: Beschriftungsfeld "Label2" auf FraDestination ' Steuerelement: Schaltfläche "BtnPlayDst" auf FraDestination ' Steuerelement: Textfeld "TxtPFNSrc" auf FraSource ' Steuerelement: Schaltfläche "BtnExplorerGotoDstDir" auf FraDestination ' Steuerelement: Textfeld "TxtWaveFmtSrc" auf FraSource ' Steuerelement: Schaltfläche "BtnExplorerGotoSrcDir" auf FraSource ' Steuerelement: Rahmensteuerelement "FraSource" ' Steuerelement: Rahmensteuerelement "FraDestination" ' Steuerelement: Beschriftungsfeld "LblDstPFN" auf FraDestination ' Steuerelement: Textfeld "TxtSPSDst" auf FraDestination ' Steuerelement: Textfeld "TxtPFNDst" auf FraDestination ' Steuerelement: Schaltfläche "BtnReadSrc" auf FraSource ' Steuerelement: Schaltfläche "BtnPlaySrc" auf FraSource ' Steuerelement: Schaltfläche "BtnConvert" auf FraDestination Option Explicit Private mWavExt As String Private mSrcFNam As String Private mSrcWavePFN As String Private mSrcHead As TWaveFormat Private mSrcWav() As Integer ' ja müßte Long sein, für Private mDstWavePFN As String Private mDstHead As TWaveFormat Private mDstWav() As Integer Private Declare Function PlaySoundA Lib "winmm.dll" ( _ ByVal lpszName As String, _ ByVal hModule As Long, _ ByVal dwFlags As Long) As Long Private Sub Form_Load() Const InitSPSDst As Long = 44100 ReDim mSrcWav(0) ReDim mDstWav(0) mSrcFNam = "GuitarE" mWavExt = ".wav" TxtPFNSrc.Text = App.Path & "\" & mSrcFNam & mWavExt mSrcWavePFN = TxtPFNSrc.Text TxtSPSDst.Text = CStr(InitSPSDst) TxtPFNDst.Text = GetDstPFN(InitSPSDst) mDstWavePFN = TxtPFNDst.Text End Sub Private Function GetDstPFN(sps As Long) As String ' wo soll hingespeichert werden? ' vielleicht in Temp, in EigeneDateien, in Allusers oder in AppData Dim p As String p = Environ$("APPDATA") GetDstPFN = p & "\" & mSrcFNam & "_" & CStr(sps) & mWavExt End Function Private Sub ExplorerOpenDirectory(aPFN As String) Dim rv As Double ' der Windows-Dateiexplorer soll den Pfad öffnen rv = Shell("explorer.exe """ & ExtractPath(aPFN) & """", vbNormalFocus) End Sub Private Function ExtractPath(aPFN As String) ' Dir gibt nur den Dateinamen zurück ExtractPath = Left$(aPFN, Len(aPFN) - Len(Dir$(aPFN))) End Function Private Sub BtnReadSrc_Click() mSrcWavePFN = TxtPFNSrc.Text If WaveReaderWriter.ReadWave(mSrcHead, mSrcWav, mSrcWavePFN) Then TxtWaveFmtSrc.Text = WaveFormatToString(mSrcHead) Else MsgBox "Could not load Waveformat" End If End Sub Private Sub BtnConvert_Click() Dim sps As Long ' Alle anderen Daten bleiben gleich nur SPS ändert sich mDstHead = mSrcHead If Len(TxtSPSDst.Text) > 0 Then If IsNumeric(TxtSPSDst.Text) Then sps = CLng(TxtSPSDst.Text) If sps = 0 Then MsgBox "Value SamplesPerSecond is Null; press 'Read' first" Else WaveReaderWriter.SamplesPerSecond(mDstHead) = sps Call WaveResampler.ReSample(mDstWav, mDstHead, mSrcWav, mSrcHead) If ChkWriteSrcSPS.Value = vbChecked Then mDstHead = mSrcHead End If End If End If End If End Sub Private Sub BtnPlaySrc_Click() If Len(mSrcWavePFN) = 0 Then mSrcWavePFN = TxtPFNSrc.Text Call PlaySoundA(mSrcWavePFN, 0&, 1&) End Sub Private Sub BtnPlayDst_Click() If Len(mDstWavePFN) = 0 Then mDstWavePFN = TxtPFNDst.Text If ChkWriteSrcSPS.Value = vbChecked Then mDstHead = mSrcHead End If If mSrcHead.SamplesPerSecond = 0 Then MsgBox "Value SamplesPerSecond is Null; press 'Read' first" Else If WaveReaderWriter.WriteWave(mDstHead, mDstWav, mDstWavePFN) Then Call PlaySoundA(mDstWavePFN, 0&, 1&) Else MsgBox "Fehler beim Schreiben der Datei" End If End If End Sub Private Sub BtnExplorerGotoDstDir_Click() Call ExplorerOpenDirectory(mDstWavePFN) End Sub Private Sub BtnExplorerGotoSrcDir_Click() Call ExplorerOpenDirectory(mSrcWavePFN) End Sub Private Sub TxtPFNSrc_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyReturn Then If Len(TxtPFNSrc.Text) > 0 Then mSrcWavePFN = TxtPFNSrc.Text End If End If End Sub Private Sub TxtPFNDst_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyReturn Then If Len(TxtPFNDst.Text) > 0 Then mDstWavePFN = TxtPFNDst.Text End If End If End Sub Private Sub VScroll1_Change() Dim v As Long v = VScroll1.Value Label1.Caption = CStr(-v) Dim dstsps As Long Dim srcsps As Long srcsps = mSrcHead.SamplesPerSecond If v > 0 Then dstsps = srcsps * (2 ^ (Abs(v) / 12)) Else dstsps = srcsps / (2 ^ (Abs(v) / 12)) End If TxtSPSDst.Text = CStr(dstsps) ' einen neuen Dateinamen wählen: TxtPFNDst.Text = GetDstPFN(dstsps) mDstWavePFN = TxtPFNDst.Text BtnConvert_Click BtnPlayDst_Click End Sub ' ----- Ende Formular "FrmResampleWave" alias Form1.frm ----- ' --- Anfang Modul "WaveResampler" alias WaveResampler.bas --- Option Explicit Public Sub ReSample(DstWav() As Integer, DstWaveFmt As TWaveFormat, _ SrcWav() As Integer, SrcWaveFmt As TWaveFormat) On Error Resume Next Dim i As Long ' Laufvariable über alle Samples Dim c As Long ' Laufvariable über Channels Dim o As Long ' Kanal-Offset eines einzelnen Samples Dim nSamplesSrc As Long ' Anzahl an Samples Dim nSamplesDst As Long Dim nChannels As Long Dim tStepSrc As Double Dim tStepDst As Double Dim j1 As Double Dim j2 As Double Dim j3 As Double Dim y1 As Double Dim y3 As Double Dim t As Double nChannels = SrcWaveFmt.Channels tStepSrc = 1 / SrcWaveFmt.SamplesPerSecond tStepDst = 1 / DstWaveFmt.SamplesPerSecond nSamplesSrc = UBound(SrcWav) nSamplesDst = ((nSamplesSrc) * tStepSrc / tStepDst) ' Das Zielarray dimensionieren ReDim DstWav(0 To nSamplesDst) For c = 1 To nChannels ' den ersten Wert so zuweisen o = c - 1 DstWav(o) = SrcWav(o) For i = c To nSamplesDst - nChannels Step nChannels t = (i / nChannels) * tStepDst ' Zeit in der Zieldatei j2 = (t / tStepSrc) j1 = (Int(j2)) ' die Stelle des niedrigeren Wertes j3 = j1 + 1 ' die Stelle des höheren Wertes ' den unteren Wert aus SrcWav rauslesen y1 = CDbl(SrcWav(CLng(j1) * nChannels + o)) ' den oberen Wert aus SrcWav rauslesen y3 = CDbl(SrcWav(CLng(j3) * nChannels + o)) ' den Zielwert interpolieren und ins Zielarray schreiben DstWav(i) = CInt(LinIPol(y1, y3, j1, j2, j3)) Next ' den letzten Wert so zuweisen DstWav(nSamplesDst - (nChannels - c)) = SrcWav(nSamplesSrc - (nChannels - c)) Next End Sub Private Function LinIPol(ByVal y1 As Double, _ ByVal y3 As Double, _ ByVal x1 As Double, _ ByVal x2 As Double, _ ByVal x3 As Double) As Double ' errechnet einen Wert y2 zu dem Wert x2 durch lineare Interpolation If (x3 - x1) = 0 Then LinIPol = y1 Else LinIPol = y1 + (y3 - y1) / (x3 - x1) * (x2 - x1) End If End Function ' ---- Ende Modul "WaveResampler" alias WaveResampler.bas ---- ' --- Anfang Modul "WaveReaderWriter" alias WaveGenerator.bas --- Option Explicit Public Type TWaveFormat WAVEfmt As String * 8 ' Muss "WAVEfmt " enthalten = 1163280727, 544501094 WAVEfmtLen As Long ' Chunksize in Bytes FormatTag As Integer ' 2 meistens PCM = 1 Channels As Integer ' 2 Anzahl der Kanäle SamplesPerSecond As Long ' 4 Samples pro Sekunde AvgBytesPerSecond As Long ' 4 Bytes pro Sekunde BlockAlign As Integer ' 2 Blockalign (Byte pro Sample) BitsPerSample As Integer ' 2 bits pro Sample, 8 oder 16 End Type ' 16 Private Const C_RIFF As String = "RIFF" Private Const C_WAVEfmt_ As String = "WAVEfmt " Private Const C_data As String = "data" ' Public Function ReadWave(ByRef WAVEfmt As TWaveFormat, _ ByRef WaveData() As Integer, _ ByVal FNam As String) As Boolean TryE: On Error GoTo FinallyE Dim FNr As Integer Dim WavefmtPos As Long Dim DataLenPos As Long Dim DataLength As Long Dim RiffLength As Long FNr = FreeFile Open FNam For Binary As FNr Get FNr, 5, RiffLength WavefmtPos = InStrFile(FNr, C_WAVEfmt_) If WavefmtPos = 0 Then Exit Function DataLenPos = InStrFile(FNr, "data", WavefmtPos + Len(WAVEfmt)) If DataLenPos = 0 Then Exit Function Get FNr, WavefmtPos, WAVEfmt Get FNr, DataLenPos + 4, DataLength ReDim WaveData(0 To (DataLength / 2) - 1) Get FNr, , WaveData ReadWave = True FinallyE: Close FNr Exit Function CatchE: MsgBox Err.Number & " " & Err.Description GoTo FinallyE End Function Private Function InStrFile(ByVal FNr As Integer, StrSearch As String, Optional ByVal start As _ Long = 1) As Long ' liefert die Position eines Strings in einer Datei zurück Const C_LookupBuffLen As Long = 100 Dim LookUpBuffer As String * C_LookupBuffLen Dim SearchLen As Long Dim FileLength As Long Dim i As Long SearchLen = Len(StrSearch) FileLength = LOF(FNr) If (SearchLen / 2 > C_LookupBuffLen) Or (SearchLen > FileLength) Then Exit Function For i = start To ((FileLength / (C_LookupBuffLen / 2)) - start + 1) Step (C_LookupBuffLen / 2) Get FNr, i, LookUpBuffer InStrFile = InStr(1, LookUpBuffer, StrSearch, vbTextCompare) If InStrFile > 0 Then InStrFile = InStrFile + i - 1 Exit For End If Next End Function Public Function WriteWave(ByRef WAVEfmt As TWaveFormat, _ ByRef WaveData() As Integer, _ ByVal FNam As String) As Boolean ' schreibt eine Standardwavedatei raus Dim DataLength As Long Dim RiffLength As Long Dim FNr As Integer FNr = FreeFile DataLength = (UBound(WaveData) - LBound(WaveData) + 1) * Len(WaveData(0)) RiffLength = 8 + Len(WAVEfmt) + 8 + DataLength TryE: On Error GoTo FinallyE Call DeleteFile(FNam) Open FNam For Binary As FNr ' "RIFF" schreiben Put FNr, , C_RIFF ' die Rifflänge schreiben Put FNr, , RiffLength ' den Waveformat schreiben Put FNr, , WAVEfmt ' "data" schreiben Put FNr, , C_data ' die Datenlänge schreiben Put FNr, , DataLength ' Das Array mit allen Sounddaten schreiben Put FNr, , WaveData ' wenn bis hierher fehlerfrei dann ist alles OK WriteWave = True FinallyE: Close FNr Exit Function CatchE: MsgBox Err.Number & " " & Err.Description GoTo FinallyE End Function Private Sub DeleteFile(aPFN As String) On Error Resume Next Kill aPFN On Error GoTo 0 End Sub Public Property Let SamplesPerSecond(this As TWaveFormat, RHS As Long) If 0 < RHS And RHS < 200000 Then With this .SamplesPerSecond = RHS .AvgBytesPerSecond = .SamplesPerSecond * .BlockAlign End With Else MsgBox "What about a serious SPS-value?" End If End Property Public Function WaveFormatToString(this As TWaveFormat) As String Dim s As String With this s = s & "WAVEfmt : " & CStr(.WAVEfmt) & vbCrLf s = s & "WAVEfmtLen : " & CStr(.WAVEfmtLen) & vbCrLf s = s & "FormatTag : " & CStr(.FormatTag) & vbCrLf s = s & "Channels : " & CStr(.Channels) & vbCrLf s = s & "SamplesPerSecond: " & CStr(.SamplesPerSecond) & vbCrLf s = s & "BlockAlign : " & CStr(.BlockAlign) & vbCrLf s = s & "BytesPerSecond : " & CStr(.AvgBytesPerSecond) & vbCrLf s = s & "BitsPerSample : " & CStr(.BitsPerSample) & vbCrLf End With WaveFormatToString = s End Function ' --- Ende Modul "WaveReaderWriter" alias WaveGenerator.bas --- ' -------------- Ende Projektdatei Projekt1.vbp --------------
Diskussion
Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.
Folgende Diskussionen existieren bereits
Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.