Die Community zu .NET und Classic VB.
Menü

Tipp-Upload: VB 5/6 0183: Resampling von Audiodaten 2

 von 

Ü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.

Zurück zur Übersicht

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

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

PlaySoundA

Download:

Download des Beispielprojektes [1,01 MB]

' 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.