Keskustelu: Koodit: VB6: WAV tiedoston käsittely

'===================================================
' WaveFileModule: Procedures for handling wave files
' Created by Tapio Nordbo, 2001, Freeware
'===================================================
Option Explicit
Private Type bufferi
   bu(0 To 9999) As Integer        ' buffer type 9000 * 16 bit
End Type
Private fil As Integer             ' #file number
Private i As Integer
Private b As Byte                  ' to read one byte
Private SamplesPerSec As Long      ' these are the wave file header data
Private FormatTag As Integer
Private Channels As Integer
Private AvgBytesPerSec As Long
Private BlockAlign As Integer
Private BitsPerSample As Integer
Private Datasize As Long
Private RIFF As String ' for chunk name
Private buff As bufferi              ' read buffer
Private buff2 As bufferi             ' write buffer
Function EqualizeWave(sFil As String, sFil2 As String, g50 As Single, g200 As Single, g800 As Single, g3200 As Single, g12800 As Single, txtObj As Object, Modify_original As Boolean) As Boolean
' Enchance bass & treble, normalize volume to 16 bit max
' sFil: path to the file to be modified
' sFil2: path to the modified file
' g50 ... g12800 : gain of bandpass filters 50 Hz ... 12800 Hz
' txtObj: textfield for progress text (set txtOBJ = Form1.text2)
' Modify_original: True = original file will be modified, FALSE = a new result file
Dim fil As Integer, fil2 As Integer '#filenumbers
Dim Dataa As Long                   ' for datasize
Dim k As Long
Dim L As Single, R As Single        ' left and right sample data
Dim maxvolume As Single             ' max sample volume found
'Static buff As bufferi              ' read buffer
'Static buff2 As bufferi             ' write buffer
Dim i As Integer
Dim datacount As Long               ' counter for data
Dim k2 As Long
Dim fs, F                           ' filesystem, file
Dim pit As Integer                  ' position in string
Dim sfilname As String              ' string for filename
Dim a1 As Single, b1 As Single, LB As Single, RB As Single
Dim a2 As Single, b2 As Single, LT As Single
Dim a3 As Single, b3 As Single
Dim a4 As Single, b4 As Single
Dim a5 As Single, b5 As Single

Dim LTT As Single, RT As Single, RTT As Single
Dim sR() As String ' for split return array
Dim L50 As Single, L200 As Single, L800 As Single, L3200 As Single, L12800 As Single
Dim R50 As Single, R200 As Single, R800 As Single, R3200 As Single, R12800 As Single
Dim L200H As Single, L800H As Single, L3200H As Single, L12800H As Single
Dim R200H As Single, R800H As Single, R3200H As Single, R12800H As Single

' count filter coeff
a1 = Exp(-2 * 3.14 * 50 / 44100)    ' 50 Hz cut frequency
b1 = 1 - a1
a2 = Exp(-2 * 3.14 * 200 / 44100)  ' 200 Hz cut frequency
b2 = 1 - a2
a3 = Exp(-2 * 3.14 * 800 / 44100)  ' 800 Hz cut frequency
b3 = 1 - a3
a4 = Exp(-2 * 3.14 * 3200 / 44100)  ' 3200 Hz cut frequency
b4 = 1 - a4
a5 = Exp(-2 * 3.14 * 12800 / 44100)  ' 12800 Hz cut frequency
b5 = 1 - a5

On Local Error Resume Next          ' in case there is no sFil2 file
Kill (sFil2)
On Error GoTo ErrHand               ' start error handler
'Err.Raise 6                        ' for testing error

' shorten the file name, for lack of space
 If Len(sFil) Then
 sR() = Split(sFil, "\")
 sfilname = sR(UBound(sR))
 End If


'initialize
maxvolume = 0
fil = FreeFile
Dataa = GetDataSize(sFil)          ' music byte size

' copy headers to the new file
Open sFil For Binary As #fil       ' open original file at binary mode
fil2 = FreeFile
Open sFil2 For Binary As #fil2
For k = 1 To 44 Step 2             ' 44 byte header
Get #fil, k, L
Put #fil2, k, L
Next k

k = 45 ' music starts at byte 45
datacount = 0
' pass one, find out the max volume after enchancements
Do While datacount < Dataa
    txtObj.Text = Str(Int(datacount / Dataa * 50)) + " % of " + sfilname 'progress indication
    DoEvents ' give time for the main form to show the progress
    Get #fil, k, buff ' read 10000 integers = 5000 samples * 2 channels * 16 bits
    For i = 0 To 9998 Step 2 ' go thru the buffer


            L = CSng(buff.bu(i))      ' left channel value
            R = CSng(buff.bu(i + 1))  ' next is the right channel value
            L50 = a1 * L50 + b1 * L
            R50 = a1 * R50 + b1 * R

            L200H = a2 * L200H + b2 * L
            R200H = a2 * R200H + b2 * R
            L200 = a2 * L200 + b2 * (L - L200H)
            R200 = a2 * R200 + b2 * (R - R200H)

            L800H = a3 * L800H + b3 * L
            R800H = a3 * R800H + b3 * R
            L800 = a3 * L800 + b3 * (L - L800H)
            R800 = a3 * R800 + b3 * (R - R800H)

            L3200H = a4 * L3200H + b4 * L
            R3200H = a4 * R3200H + b4 * R
            L3200 = a4 * L3200 + b4 * (L - L3200H)
            R3200 = a4 * R3200 + b4 * (R - R3200H)

            L12800H = a5 * L12800H + b5 * L
            R12800H = a5 * R12800H + b5 * R
            L12800 = L - L12800H
            R12800 = R - R12800H

            L = g50 * L50 + g200 * L200 + g800 * L800 + g3200 * L3200 + g12800 * L12800
            R = g50 * R50 + g200 * R200 + g800 * R800 + g3200 * R3200 + g12800 * R12800


        datacount = datacount + 4     ' for bytes handled at a loop
        k = k + 4
        If Abs(L) > maxvolume Then maxvolume = Abs(L) ' get the max of the samples after modifications
        If Abs(R) > maxvolume Then maxvolume = Abs(R)
    Next i

Loop

'pass two, like pass one but now the max volume is limited and results go to the buff2
k = 45
datacount = 0
Do While datacount < Dataa
    txtObj.Text = Str(Int(50 + datacount / Dataa * 50)) + " % of " + sfilname 'can be commented out
    DoEvents
    Get #fil, k, buff
    k2 = k
    For i = 0 To 9998 Step 2
        L = (CSng(buff.bu(i)) * 32000#) / (maxvolume + 1#)
        R = (CSng(buff.bu(i + 1)) * 32000#) / (maxvolume + 1#)
            L50 = a1 * L50 + b1 * L
            R50 = a1 * R50 + b1 * R

            L200H = a2 * L200H + b2 * L
            R200H = a2 * R200H + b2 * R
            L200 = a2 * L200 + b2 * (L - L200H)
            R200 = a2 * R200 + b2 * (R - R200H)

            L800H = a3 * L800H + b3 * L
            R800H = a3 * R800H + b3 * R
            L800 = a3 * L800 + b3 * (L - L800H)
            R800 = a3 * R800 + b3 * (R - R800H)

            L3200H = a4 * L3200H + b4 * L
            R3200H = a4 * R3200H + b4 * R
            L3200 = a4 * L3200 + b4 * (L - L3200H)
            R3200 = a4 * R3200 + b4 * (R - R3200H)

            L12800H = a5 * L12800H + b5 * L
            R12800H = a5 * R12800H + b5 * R
            L12800 = L - L12800H
            R12800 = R - R12800H

            L = (g50 * L50 + g200 * L200 + g800 * L800 + g3200 * L3200 + g12800 * L12800)
            R = (g50 * R50 + g200 * R200 + g800 * R800 + g3200 * R3200 + g12800 * R12800)


        If datacount < Dataa Then
            buff2.bu(i) = CInt(L)        ' from buff to buff2
            buff2.bu(i + 1) = CInt(R)
            Else
            buff2.bu(i) = 0              ' rest is zero silence
            buff2.bu(i + 1) = 0
            End If
        datacount = datacount + 4
        k = k + 4
    Next i
    Put #fil2, k2, buff2                 ' write buff2 to the file2
Loop

Close #fil
Close #fil2
CorrectAvgBytesPerSec (sFil2)            'Check and correct
' copy sfil2 to sfil and delete sfil2
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.GetFile(sFil2)
If Modify_original Then F.Copy sFil
Set F = Nothing
Set fs = Nothing
If Modify_original Then Kill (sFil2)
EqualizeWave = True  ' return value of the function
Exit Function
ErrHand:
ErrSub                      ' error handling sub rutine
Resume Next
End Function
Function NormaliseWaveVolume(sFil As String, sFil2 As String, Megabass As Single, Treble As Single, txtObj As Object, Modify_original As Boolean) As Boolean
' Enchance bass & treble, normalize volume to 16 bit max
' sFil: path to the file to be modified
' sFil2: path to the modified file
' Megabass : multiplier for bass, 10 = 20 dB
' Treble : multiplier for treble, 10 = 20 dB
' txtObj: textfield for progress text (set txtOBJ = Form1.text2)
' Modify_original: True = original file will be modified, FALSE = a new result file
Dim fil As Integer, fil2 As Integer '#filenumbers
Dim Dataa As Long                   ' for datasize
Dim k As Long
Dim L As Single, R As Single        ' left and right sample data
Dim maxvolume As Single             ' max sample volume found
'Static buff As bufferi              ' read buffer
'Static buff2 As bufferi             ' write buffer
Dim i As Integer
Dim datacount As Long               ' counter for data
Dim k2 As Long
Dim fs, F                           ' filesystem, file
Dim pit As Integer                  ' position in string
Dim sfilname As String              ' string for filename
Dim a1 As Single, b1 As Single, LB As Single, RB As Single  ' for bass filter
Dim a2 As Single, b2 As Single, LT As Single                ' for treble filter
Dim LTT As Single, RT As Single, RTT As Single
Dim sR() As String                   ' for split return array

' count filter coeff
a1 = Exp(-2 * 3.14 * 50 / 44100)    ' 50 Hz cut frequency
b1 = 1 - a1
a2 = Exp(-2 * 3.14 * 5000 / 44100)  ' 5000 Hz cut frequency
b2 = 1 - a2


On Local Error Resume Next          ' in case there is no sFil2 file
Kill (sFil2)
On Error GoTo ErrHand               ' start error handler
'Err.Raise 6                        ' for testing error

' shorten the file name, for lack of space
 If Len(sFil) Then
 sR() = Split(sFil, "\")
 sfilname = sR(UBound(sR))
 End If


'initialize
maxvolume = 0
fil = FreeFile
Dataa = GetDataSize(sFil)          ' music byte size

' copy headers to the new file
Open sFil For Binary As #fil       ' open original file at binary mode
fil2 = FreeFile
Open sFil2 For Binary As #fil2
For k = 1 To 44 Step 2             ' 44 byte header
Get #fil, k, L
Put #fil2, k, L
Next k

k = 45 ' music starts at byte 45
datacount = 0
' pass one, find out the max volume after enchancements
Do While datacount < Dataa
    txtObj.Text = Str(Int(datacount / Dataa * 50)) + " % of " + sfilname 'progress indication
    DoEvents ' give time for the main form to show the progress
    Get #fil, k, buff ' read 10000 integers = 5000 samples * 2 channels * 16 bits
    For i = 0 To 9998 Step 2 ' go thru the buffer

        If (Megabass > 0) Or (Treble > 0) Then
            L = CSng(buff.bu(i))      ' left channel value
            R = CSng(buff.bu(i + 1))  ' next is the right channel value
            LB = a1 * LB + b1 * L     ' this is the bass filter (1st order low pass filter at 50 Hz)
            RB = a1 * RB + b1 * R
            L = Megabass * LB + L
            R = Megabass * RB + R

            LT = a2 * LT + b2 * L     ' this is the treble filter (1st order high pass filter at 5000 Hz)
            RT = a2 * RT + b2 * R
            LTT = L - LT
            RTT = R - RT
            L = Treble * LTT + L
            R = Treble * RTT + R

        Else
            L = CSng(buff.bu(i))      ' case no filter
            R = CSng(buff.bu(i + 1))
        End If

        datacount = datacount + 4     ' for bytes handled at a loop
        k = k + 4
        If Abs(L) > maxvolume Then maxvolume = Abs(L) ' get the max of the samples after modifications
        If Abs(R) > maxvolume Then maxvolume = Abs(R)
    Next i

Loop

'pass two, like pass one but now the max volume is limited and results go to the buff2
k = 45
datacount = 0
Do While datacount < Dataa
    txtObj.Text = Str(Int(50 + datacount / Dataa * 50)) + " % of " + sfilname 'can be commented out
    DoEvents
    Get #fil, k, buff
    k2 = k
    For i = 0 To 9998 Step 2
    If (Megabass > 0) Or (Treble > 0) Then
        L = (CSng(buff.bu(i)) * 32000#) / (maxvolume + 1#)
        R = (CSng(buff.bu(i + 1)) * 32000#) / (maxvolume + 1#)
        LB = a1 * LB + b1 * L
        RB = a1 * RB + b1 * R
        L = Megabass * LB + L ' add megabass to left channel
        R = Megabass * RB + R ' add megabass to right channel

        LT = a2 * LT + b2 * L
        RT = a2 * RT + b2 * R
        LTT = L - LT
        RTT = R - RT
        L = Treble * LTT + L
        R = Treble * RTT + R
        Else
        L = (CSng(buff.bu(i)) * 32000#) / (maxvolume + 1#)
        R = (CSng(buff.bu(i + 1)) * 32000#) / (maxvolume + 1#)
        End If

        If datacount < Dataa Then
            buff2.bu(i) = CInt(L)        ' from buff to buff2
            buff2.bu(i + 1) = CInt(R)
            Else
            buff2.bu(i) = 0              ' rest is zero silence
            buff2.bu(i + 1) = 0
            End If
        datacount = datacount + 4
        k = k + 4
    Next i
    Put #fil2, k2, buff2                 ' write buff2 to the file2
Loop

Close #fil
Close #fil2
CorrectAvgBytesPerSec (sFil2)            'Check and correct
' copy sfil2 to sfil and delete sfil2
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.GetFile(sFil2)
If Modify_original Then F.Copy sFil
Set F = Nothing
Set fs = Nothing
If Modify_original Then Kill (sFil2)
NormaliseWaveVolume = True  ' return value of the function
Exit Function
ErrHand:
ErrSub                      ' error handling sub rutine
Resume Next
End Function

Function CorrectAvgBytesPerSec(sFil As String) As Long
' corrects the AverageBytesPerSec value at wav file
Dim X As Long
Dim Y As Long
Dim Z As Long
On Error GoTo ErrHand
If sFil = "" Then
    CorrectAvgBytesPerSec = 0
    Exit Function
    End If
If InStr(sFil, "*") Then
    CorrectAvgBytesPerSec = 0
    Exit Function
    End If
If Not CheckIfWaveFile(sFil) Then
    CorrectAvgBytesPerSec = 0
    Exit Function
    End If
X = GetNumberOfChannels(sFil)
Y = GetSamplesPerSec(sFil)
Z = GetBitsPerSample(sFil)
If Z > 8 Then
    AvgBytesPerSec = X * 2 * Y  ' 16 bit samples
    Else
    AvgBytesPerSec = X * Y      ' 8 bit samples
    End If
Open sFil For Binary As #fil
Put #fil, 29, AvgBytesPerSec    ' put to file, byte place 29
Get #fil, 29, AvgBytesPerSec
CorrectAvgBytesPerSec = AvgBytesPerSec
Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function
Function GetBitsPerSample(sFil As String) As Integer
' returns the Bits per sample value of the wav file
On Error GoTo ErrHand
If sFil = "" Then
    GetBitsPerSample = 0
    Exit Function
    End If
If InStr(sFil, "*") Then
    GetBitsPerSample = 0
    Exit Function
    End If
If Not CheckIfWaveFile(sFil) Then
    GetBitsPerSample = 0
    Exit Function
    End If
fil = FreeFile
Open sFil For Binary As #fil
Get #fil, 35, BitsPerSample
GetBitsPerSample = BitsPerSample
Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function
Function GetNumberOfChannels(sFil As String) As Integer
'returns the number of channels (mono=1 , stereo=2)
On Error GoTo ErrHand
If sFil = "" Then
    GetNumberOfChannels = 0
    Exit Function
    End If
If InStr(sFil, "*") Then
    GetNumberOfChannels = 0
    Exit Function
    End If
If Not CheckIfWaveFile(sFil) Then
    GetNumberOfChannels = 0
    Exit Function
    End If
fil = FreeFile
Open sFil For Binary As #fil
Get #fil, 23, Channels
GetNumberOfChannels = Channels
Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function

Function GetAvgBytesPerSec(sFil As String) As Long
' returns the Average bytes per sec
On Error GoTo ErrHand
If sFil = "" Then
    GetAvgBytesPerSec = 0
    Exit Function
    End If
If InStr(sFil, "*") Then
    GetAvgBytesPerSec = 0
    Exit Function
    End If
If Not CheckIfWaveFile(sFil) Then
    GetAvgBytesPerSec = 0
    Exit Function
    End If
fil = FreeFile
Open sFil For Binary As #fil
Get #fil, 29, AvgBytesPerSec
GetAvgBytesPerSec = AvgBytesPerSec
Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function

Function GetDataSize(sFil As String) As Long
' returns the data size, lenght of the sound data
On Error GoTo ErrHand
If sFil = "" Then
    GetDataSize = 0
    Exit Function
    End If
If InStr(sFil, "*") Then
    GetDataSize = 0
    Exit Function
    End If
If Not CheckIfWaveFile(sFil) Then
    GetDataSize = 0
    Exit Function
    End If
fil = FreeFile
Open sFil For Binary As #fil
Get #fil, 41, Datasize
GetDataSize = Datasize
Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function

Function GetBlockAlign(sFil As String) As Integer
On Error GoTo ErrHand

If sFil = "" Then
    GetBlockAlign = 0
    Exit Function
    End If
If InStr(sFil, "*") Then
    GetBlockAlign = 0
    Exit Function
    End If
If Not CheckIfWaveFile(sFil) Then
    GetBlockAlign = 0
    Exit Function
    End If
fil = FreeFile
Open sFil For Binary As #fil
Get #fil, 33, BlockAlign
GetBlockAlign = BlockAlign
Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function
Function GetSamplesPerSec(sFil As String) As Long
'returns the Samples per sec value
On Error GoTo ErrHand

If sFil = "" Then
    GetSamplesPerSec = 0
    Exit Function
    End If
If InStr(sFil, "*") Then
    GetSamplesPerSec = 0
    Exit Function
    End If
If Not CheckIfWaveFile(sFil) Then
    GetSamplesPerSec = 0
    Exit Function
    End If

fil = FreeFile
Open sFil For Binary As #fil
Get #fil, 25, SamplesPerSec
GetSamplesPerSec = SamplesPerSec

Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function


Function CheckIfWaveFile(sFil As String) As Boolean
On Error GoTo ErrHand

If sFil = "" Then
    CheckIfWaveFile = False
    Exit Function
    End If
If InStr(sFil, "*") Then
    CheckIfWaveFile = False
    Exit Function
    End If

fil = FreeFile
Open sFil For Binary As #fil


'Check if a RIFF file
RIFF = ""
For i = 1 To 4
    Get #fil, i, b
    RIFF = RIFF + Chr(CLng(b))
Next i
If RIFF <> "RIFF" Then
    CheckIfWaveFile = False
    Close #fil
    Exit Function
    End If

'Check if a Wave file
RIFF = ""
For i = 9 To 12
    Get #fil, i, b
    RIFF = RIFF + Chr(CLng(b))
Next i
If RIFF <> "WAVE" Then
    CheckIfWaveFile = False
    Close #fil
    Exit Function
    End If

'Check if a fmt chunk
RIFF = ""
For i = 13 To 16
    Get #fil, i, b
    RIFF = RIFF + Chr(CLng(b))
Next i
If RIFF <> "fmt " Then
    CheckIfWaveFile = False
    Close #fil
    Exit Function
    End If

'Check format tag
Get #fil, 21, FormatTag
If FormatTag <> 1 Then
    CheckIfWaveFile = False
    Close #fil
    Exit Function
    End If

'Check if a data chunk
RIFF = ""
For i = 37 To 40
    Get #fil, i, b
    RIFF = RIFF + Chr(CLng(b))
Next i
If RIFF <> "data" Then
    CheckIfWaveFile = False
    Close #fil
    Exit Function
    End If

' Is MS wave with data
CheckIfWaveFile = True

Close #fil
Exit Function
ErrHand:
ErrSub
Resume Next
End Function

Private Sub ErrSub()
Dim msg As String
' Check for error, then show message.
If Err.Number <> 0 Then
   msg = "Error # " & Str(Err.Number) & " was generated by " _
         & Err.Source & " / WaveFileModule " & Chr(13) & Err.Description
   MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext
End If
End Sub