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

Public Event DTMF(Number As Integer)

Private IsBusy As Boolean

Private Const Green = &HFF00&
Private Const Yellow = &HFFFF&
Private Const Red = &HFF&

Private FloorOffset As Integer

Public Type EQDef
    Freq As Long
    Gain As Long
    Width As Integer
End Type

Public Enum GraphModeConstants
    gmcBars = 0
    gmcLeds = 1
    gmcLine = 2
End Enum

Public Enum WindowConstants
    wcNone = 0
    wcTriangle = 1
    wcHanning = 2
    wcHamming = 3
    wcWelch = 4
    wcGaussian = 5
    wcBlackman = 6
    wcParzen = 7
End Enum

Public Type PrefDef
    picFFT As Object
    IsStereo As Boolean
    Is16bits As Boolean
    GraphColor As OLE_COLOR
    PreAmp As Single
    PeaksColor As OLE_COLOR
    Min As Long
    Max As Long
    ShowEnergy As Boolean
    HoldPeaks As Boolean
    LogScale As Boolean
    DetectDTMF As Boolean
    GraphMode As GraphModeConstants
    MaxFreq As Long
    ZoomToScale As Boolean
    UseRightChannel As Boolean
    FFTSize As Integer
    FFTWindow As WindowConstants
    SmoothDisplay As Boolean
    EQ() As EQDef
    ShowGrid As Boolean
End Type

Private mPref As PrefDef

Private oFFT() As Double
Private fAvg(0 To 3) As Long

Private fMin As Long
Private fMax As Long
Private fTotal As Long
Private picHeight As Long
Private BarsHeight As Single

Private LastAvg() As Double
Private lpDelay() As Long
Private LastPoint() As Double
Private s As Integer
Private minStep As Integer
Private eqWAV() As Double
Private fScale As Double

Private k1 As Long
Private k2 As Long

'Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
'Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
'Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
'Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'Private Type RECT
'    Left As Long
'    Top As Long
'    Right As Long
'    Bottom As Long
'End Type
'Private Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
'Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
'Private Const SRCERASE = &H440328        ' (DWORD) dest = source AND (NOT dest )
'Private Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR dest
'Private Const SRCPAINT = &HEE0086        ' (DWORD) dest = source OR dest
'Private Const MERGECOPY = &HC000CA       ' (DWORD) dest = (source AND pattern)
'Private Const MERGEPAINT = &HBB0226      ' (DWORD) dest = (NOT source) OR dest
'Private Const WHITENESS = &HFF0062       ' (DWORD) dest = WHITE
'Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK

Public Property Get Preferences() As PrefDef

    Preferences = mPref

End Property

Public Property Let Preferences(NewPref As PrefDef)

    Dim DoFullRefresh As Boolean
    Dim i As Integer
    Dim n As Integer
    Dim tmpEQ() As Double
    Dim f As Integer
    
    ' Do we need to rebuild all the arrays?
    DoFullRefresh = (mPref.Is16bits <> NewPref.Is16bits) Or _
                    (mPref.IsStereo <> NewPref.IsStereo)

    ' Assign the new preferences
    mPref = NewPref
    
    ' Setup the variables that control the display range
    fTotal = mPref.FFTSize \ 2
    fMin = (mPref.Min / mPref.MaxFreq) * fTotal
    fMax = (mPref.Max / mPref.MaxFreq) * fTotal
    
    ' Setup the picture scaling system based on the display control varaibles
    With mPref.picFFT
        .ScaleMode = 0
        If fMax > 0 Then
            If mPref.ZoomToScale Then
                .ScaleLeft = fMin
                .ScaleWidth = (fMax - fMin)
            Else
                .ScaleLeft = 0
                .ScaleWidth = fTotal
            End If
        End If
        If mPref.LogScale Then
            .ScaleLeft = Log10(.ScaleLeft)
            .ScaleWidth = Log10(.ScaleWidth)
        End If
        .ScaleHeight = 125 * IIf(mPref.Is16bits, 15, 1)
        .ScaleHeight = -Abs(.ScaleHeight)
        .ScaleTop = Abs(.ScaleHeight)
        picHeight = Abs(.ScaleHeight)
        FloorOffset = picHeight / 100
        BarsHeight = picHeight / 100
        minStep = picHeight / 200
        
        Select Case mPref.FFTSize
            Case 128
                fScale = 0.2
            Case 256
                fScale = 0.7
            Case 512
                fScale = 0.8
            Case 1024
                fScale = 1.1
            Case 2048
                fScale = 1.6
            Case 4096
                fScale = 1.8
        End Select
    End With
    
    ' Resize the arrays used to draw the main graphic and
    ' the peaks points
    If DoFullRefresh Then
        ReDim LastAvg(0 To mPref.FFTSize - 1)
        ReDim LastPoint(0 To mPref.FFTSize - 1)
        ReDim lpDelay(0 To mPref.FFTSize - 1)
    Else
        ReDim Preserve LastAvg(0 To mPref.FFTSize - 1)
        ReDim Preserve LastPoint(0 To mPref.FFTSize - 1)
        ReDim Preserve lpDelay(0 To mPref.FFTSize - 1)
    End If
    
    ' Undocumented...
    If mPref.SmoothDisplay Then
        s = IIf(mPref.FFTSize > 512, Int(mPref.FFTSize / 512), 1)
    Else
        s = 1
    End If
    
    ' Build the EQ signal if any
    On Error Resume Next
    Err.Clear
    n = UBound(mPref.EQ)
    ReDim eqWAV(0 To mPref.FFTSize - 1)
    If Err.Number = 0 Then
        For i = 0 To n
            tmpEQ = ApplyEQ(mPref.EQ(i))
            For f = 0 To mPref.FFTSize - 1
                eqWAV(f) = eqWAV(f) + tmpEQ(f)
            Next f
        Next i
    End If
    
    ' Set the step constants
    k1 = IIf(mPref.Is16bits, IIf(mPref.IsStereo, 4, 2), IIf(mPref.IsStereo, 2, 1))
    If mPref.UseRightChannel Then
        k2 = 0
    Else
        k2 = IIf(mPref.Is16bits, 2, 1)
    End If
    
End Property

Public Sub DoFFT(FromPos As Long, ToPos As Long, Values() As Byte)

    Static iWAV() As Double
    Dim i As Long
    Dim j As Long
    Dim EOB As Long
    Dim Avg As Double
    Dim z1 As Double
    Dim z2 As Double
    Dim lz As Double
    Dim c As Long
    Static xi As Integer
    Dim nSamples As Integer
    Dim y, ly, lyp As Double
    Dim tVal As Long
    
    Static sAvg As Double
        
    If IsBusy Then Exit Sub
    IsBusy = True
    
    On Error Resume Next
    
    EOB = UBound(Values)
    If ToPos < FromPos Then
        nSamples = EOB - FromPos + ToPos
    Else
        nSamples = ToPos - FromPos
    End If
    
    If mPref.IsStereo Then nSamples = nSamples / 2
    If mPref.Is16bits Then nSamples = nSamples / 2
    nSamples = 2 ^ Int(Log(nSamples) / Log(2))

    If xi = 0 Then
        ReDim iWAV(0 To mPref.FFTSize - 1)
        ReDim oFFT(0 To mPref.FFTSize - 1)
    End If
    
    For i = 0 To nSamples - 1
        If i + xi >= mPref.FFTSize Then Exit For
        j = i * k1 + FromPos + k2
        If j > EOB Then
            j = j - EOB + 1
            If j > EOB Then Exit For
        End If
        If mPref.Is16bits Then
            tVal = Values(j + 1) * 256& + Values(j)
            If tVal > 32767 Then tVal = tVal - 65536
        Else
            tVal = Values(j)
            tVal = 128 - tVal
        End If
        iWAV(i + xi) = tVal * ApplyWindow(i + xi, nSamples) + eqWAV(i + xi)
        'iWAV(i + xi) = tVal * ApplyWindow(i + xi, nSamples)
    Next i
    
    xi = xi + i
    If xi < (mPref.FFTSize) Then GoTo ExitFFTSub
    xi = 0
    
    FourierTransform mPref.FFTSize, iWAV, oFFT, False
    
    DoEvents
    
    If mPref.DetectDTMF Then MonitorDTMF
    
    mPref.picFFT.Cls
    
    With mPref
    Select Case .GraphMode
    Case gmcBars, gmcLine
        fAvg(0) = 0
        If .GraphMode = gmcLine Then
            If fMin = 0 Then fMin = 1
            lz = IIf(.LogScale, Log10(fMin - 1), fMin - 1)
            ly = Sqr(Abs(oFFT(fMin - 1))) * .PreAmp
            lyp = ly
        End If
        For i = fMin + IIf(.LogScale And fMin = 0, 1, 0) To fMax Step s
            
            ' Calculate RMS
            Avg = Sqr((Abs(oFFT(i)))) * .PreAmp / fScale
            
            If Avg > LastAvg(i) Then
                sAvg = Avg
            Else
                sAvg = LastAvg(i) - (LastAvg(i) - Avg) / 3
            End If
            LastAvg(i) = sAvg

            ' Calculate next point in the freq. scale (x)
            If .LogScale Then
                z1 = Log10(i)
                z2 = Log10(i + s)
            Else
                z1 = i
                z2 = z1 + s
            End If

            y = sAvg + FloorOffset
            If .GraphMode = gmcBars Then
                .picFFT.Line (z1, 0)-(z2, y), .GraphColor, BF
            Else
                .picFFT.Line (lz, ly)-(z1, y), .GraphColor
                ly = y
            End If
            fAvg(0) = fAvg(0) + Avg

            If .HoldPeaks Then
                If LastPoint(i) < sAvg Then
                    lpDelay(i) = 40
                    LastPoint(i) = sAvg
                ElseIf LastPoint(i) > 0 And lpDelay(i) = 0 Then
                    LastPoint(i) = LastPoint(i) - minStep
                Else
                    If lpDelay(i) > 0 Then lpDelay(i) = lpDelay(i) - 1
                End If
                y = LastPoint(i) + FloorOffset
                If .GraphMode = gmcBars Then
                    .picFFT.Line (z1, y - picHeight / 200)-(z2, y), .PeaksColor, BF
                Else
                    .picFFT.Line (lz, lyp)-(z1, y), .PeaksColor
                    lyp = y
                End If
            End If
            lz = z1
        Next i
        If .ShowEnergy Then RenderEnergy fMin, fMax
    Case gmcLeds
        fAvg(0) = 0
        For i = fMin + IIf(.LogScale And fMin = 0, 1, 0) To fMax Step s * 4
            Avg = Sqr(Abs(oFFT(i))) * .PreAmp / fScale - BarsHeight * 2
            
            If Avg > LastAvg(i) Then
                sAvg = Avg
            Else
                sAvg = LastAvg(i) - (LastAvg(i) - Avg) / 5
            End If
            LastAvg(i) = sAvg
            For y = 0 To sAvg Step BarsHeight * 2
                If y < picHeight / 2 Then
                    c = Green
                Else
                    If y < picHeight / 1.25 Then
                        c = Yellow
                    Else
                        c = Red
                    End If
                End If
                
                If mPref.LogScale Then
                    z1 = Log10(i + 1)
                    z2 = Log10(i + 1 + s)
                Else
                    z1 = i
                    z2 = z1 + s * 3
                End If
                
                .picFFT.Line (z1, y)-(z2, y + BarsHeight), c, BF
            Next y
            fAvg(0) = fAvg(0) + Avg
            
            If .HoldPeaks Then
                If LastPoint(i) < sAvg Then
                    lpDelay(i) = 40
                    LastPoint(i) = sAvg
                ElseIf LastPoint(i) > 0 And lpDelay(i) = 0 Then
                    LastPoint(i) = LastPoint(i) - minStep
                Else
                    If lpDelay(i) > 0 Then lpDelay(i) = lpDelay(i) - 1
                End If
                y = LastPoint(i) + FloorOffset
                If y < picHeight / 2 Then
                    c = Green
                Else
                    If y < picHeight / 1.25 Then
                        c = Yellow
                    Else
                        c = Red
                    End If
                End If
                .picFFT.Line (z1, y)-(z2, y + BarsHeight \ 2), c, BF
            End If
        Next i
        If .ShowEnergy Then RenderEnergy fMin, fMax
    End Select
    End With
    

'    i = GetDC(0)
'    StretchBlt i, 0, 0, Screen.Width / 15, Screen.Height / 15, _
'                        mPref.picFFT.hdc, 0, 0, mPref.picFFT.Width / 15, mPref.picFFT.Height / 15, vbSrcCopy
'
'
'    'BitBlt i, 0, (Screen.Height - mPref.picFFT.Height) / 15 - 50, mPref.picFFT.Width / 15, mPref.picFFT.Height / 15, _
'                        mPref.picFFT.hdc, 0, 0, BLACKNESS
'    ReleaseDC 0, i

ExitFFTSub:
    IsBusy = False
          
End Sub

Private Sub MonitorDTMF()

    Dim v As Long
    Dim NewDTMF As Integer
    
    NewDTMF = 1
    If DTMFLevel(1209, 697) Then GoTo SkipOthers
    
    NewDTMF = 4
    If DTMFLevel(1209, 770) Then GoTo SkipOthers
    
    NewDTMF = 7
    If DTMFLevel(1209, 852) Then GoTo SkipOthers
    
    
    
    NewDTMF = 2
    If DTMFLevel(1336, 697) Then GoTo SkipOthers
    
    NewDTMF = 5
    If DTMFLevel(1336, 770) Then GoTo SkipOthers
    
    NewDTMF = 8
    If DTMFLevel(1336, 852) Then GoTo SkipOthers
    
    NewDTMF = 0
    If DTMFLevel(1336, 941) Then GoTo SkipOthers
    
    
    
    NewDTMF = 3
    If DTMFLevel(1477, 697) Then GoTo SkipOthers
    
    NewDTMF = 6
    If DTMFLevel(1477, 770) Then GoTo SkipOthers
    
    NewDTMF = 9
    If DTMFLevel(1477, 852) Then GoTo SkipOthers
    
    RaiseEvent DTMF(-1)
    Exit Sub
    
SkipOthers:
    RaiseEvent DTMF(NewDTMF)

End Sub

Private Function DTMFLevel(f1 As Integer, f2 As Integer) As Boolean

    Dim i As Integer
    Dim a As Long
    Dim b As Long
    
    a = Sqr(Abs(oFFT(f1 / mPref.MaxFreq * mPref.FFTSize))) * mPref.PreAmp
    b = Sqr(Abs(oFFT(f2 / mPref.MaxFreq * mPref.FFTSize))) * mPref.PreAmp
    
    'Debug.Print a > 600, b > 600
        
    DTMFLevel = (a > 800) And (b > 800)

End Function

Private Sub RenderEnergy(fMin As Long, fMax As Long)

    fAvg(0) = fAvg(0) / (fMax - fMin)

    fAvg(3) = fAvg(2)
    fAvg(2) = fAvg(1)
    fAvg(1) = fAvg(0)
    fAvg(0) = (fAvg(1) + fAvg(2) + fAvg(3)) / 3

    mPref.picFFT.Line (fMin, fAvg(0) - minStep + FloorOffset)-(fMax, fAvg(0)), mPref.PeaksColor, BF

End Sub

Public Function Log10(ByVal x As Long) As Double

    If x > 0 Then Log10 = Log(x) / Log(10)

End Function

Private Function ApplyWindow(i As Long, w As Integer) As Double

    With mPref
        Select Case .FFTWindow
            Case wcNone
                ApplyWindow = 1
            Case wcTriangle
                ApplyWindow = 1 - Abs(1 - ((2 * i) / (w - 1)))
            Case wcHanning
                ApplyWindow = (0.5 * (1 - Cos(PI2 * i / (w - 1))))
            Case wcHamming
                ApplyWindow = 0.54 - 0.46 * Cos(PI2 * i / (w - 1))
            Case wcWelch
                ApplyWindow = 1 - (i - 0.5 * (w - 1)) / (0.5 * (w + 1) ^ 2)
            Case wcGaussian
                ApplyWindow = 2.71828182845905 ^ (-6.25 * Pi * i ^ 2 / w ^ 2)
            Case wcBlackman
                ApplyWindow = 0.42 - 0.5 * Cos(Pi * i / (w - 1)) + 0.08 * Cos(2 * PI2 * i / (w - 1))
            Case wcParzen
                ApplyWindow = 1 - Abs((i - 0.5 * (w - 1)) / (0.5 * (w + 1)))
        End Select
    End With

End Function

Private Function ApplyEQ(EQ As EQDef) As Double()

    Dim i As Integer
    Dim eqFFT() As Double
    Dim eqSIG() As Double
    Dim idx As Long
    
    Dim s As Integer
    Dim e As Integer
    
    ReDim eqFFT(0 To mPref.FFTSize - 1)
    ReDim eqSIG(0 To mPref.FFTSize - 1)
    
    idx = Freq2Index(EQ.Freq)
    If EQ.Width > 1 Then
        s = idx - EQ.Width / 2
        e = idx + EQ.Width / 2
        For i = s To e
            eqFFT(i) = EQ.Gain * 1000 * Sin((i - s) / (e - s) * Pi - Pi)
        Next i
    Else
        eqFFT(i) = EQ.Gain * 1000
    End If
    
    FourierTransform mPref.FFTSize, eqFFT, eqSIG, True
    
    ApplyEQ = eqSIG

End Function

Public Function FreqLevel(Freq As Long) As Double

    FreqLevel = LastAvg(Freq)

End Function

Public Function Freq2Index(Freq As Long) As Long

    Freq2Index = Freq / (mPref.MaxFreq / 2) * (mPref.FFTSize / 2)

End Function

Public Function Index2Freq(Index As Long) As Long

    Index2Freq = Index / (mPref.FFTSize / 2) * (mPref.MaxFreq / 2)

End Function
