modfft.bas

FFT Demo Program. Written in VB

Attribute VB_Name = "ModFFT"
Option Explicit
Dim blnArcFlg As Boolean
Dim lngColor As Long
Dim Plot1() As Integer
Dim CurX As Integer
Dim CurY As Integer
Dim BpixX() As Integer
Dim BpixY() As Integer
Dim Key() As Integer
Dim BpixPtr As Integer
Dim PrevDir As Byte
Dim CurrDir As Byte
Dim TryX As Integer
Dim TryY As Integer
Dim NumBP As Integer
Dim intSectInFile As Integer        'NSC100
Dim intTotalSect As Integer         'NSC25
Dim intSampsPerSect As Integer  'SCTSMP
Dim intSectOffset As Integer            'SCTOFS
Dim sngFFTFct As Single         'FFTFCT
Public glngFFTItems As Long         'NPNTS
Public gbytRepeat As Byte           'RPTFFT
Public gsngRLEDAT() As Single
Public gsngRLEIMG() As Single
Public gsngFFTSIN() As Single
Public gsngFFTCOS() As Single
Public gblnInverse As Boolean
Public gintDispItems As Integer         'NITM
Dim sngScaleFct As Single           'SCLFCT
Public gsngAmplitudeFct As Single     'AMPFCT
Public gintPasses As Integer            'SMTH

Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, _
   ByVal y As Long) As Long

Public Sub FastFourierTransform()
Dim Index As Long, NI As Long, NJ As Long, NA As Long, NB As Long, NK As Long
Dim Temp As Single, Tmp As Long, Pnt0 As Long, Pnt1 As Long
Dim MaxPwr As Long, PI As Single, Harm As Single, HX As Single
Dim Inner As Long, Arg As Long, Points As Single
Dim ProductRle As Single, ProductImg As Single
    PI = 3.14159265
    If gblnInverse = False Then
        For Index = 0 To glngFFTItems - 1 Step 1
            gsngRLEIMG(Index) = 0#
        Next Index
    End If
    NI = 0
    NJ = 0
    Points = glngFFTItems
    For Index = 1 To glngFFTItems - 1 Step 1
        If NI < NJ Then
            Temp = gsngRLEDAT(NI)
            gsngRLEDAT(NI) = gsngRLEDAT(NJ)
            gsngRLEDAT(NJ) = Temp
            Temp = gsngRLEIMG(NI)
            gsngRLEIMG(NI) = gsngRLEIMG(NJ)
            gsngRLEIMG(NJ) = Temp
        End If
        Tmp = glngFFTItems / 2
FN12:
        If Tmp > NJ Then GoTo FN13
        NJ = NJ - Tmp
        Tmp = Tmp / 2
        GoTo FN12

FN13:
        NJ = NJ + Tmp
        NI = NI + 1
    Next Index
    
    MaxPwr = 0
    Tmp = glngFFTItems
FN14:
    If Tmp = 1 Then GoTo FN15
    MaxPwr = MaxPwr + 1
    Tmp = Tmp / 2
    GoTo FN14
    
FN15:
    If gblnInverse Then GoTo FN22
    If gbytRepeat = 1 Then GoTo FN22
    If gbytRepeat = 2 Then GoTo FN24
    Harm = (2 * PI) / Points
    HX = 0#
    NI = 0
    For Index = 1 To glngFFTItems Step 1
        Temp = Harm * HX
        gsngFFTSIN(NI) = Sin(Temp) * (-1)
        gsngFFTCOS(NI) = Cos(Temp)
        NI = NI + 1
        HX = HX + 1#
    Next Index
    GoTo FN24
    
FN22:
    For Index = 0 To glngFFTItems - 1 Step 1
        gsngFFTSIN(Index) = gsngFFTSIN(Index) * (-1)
    Next Index
    
FN24:
    NA = 2
    NB = 1
    For Index = 1 To MaxPwr Step 1
        Pnt0 = glngFFTItems / NA
        Pnt1 = 0
        NK = 0
        For Inner = 1 To NB Step 1
            NI = NK
FN35:
            If NI >= glngFFTItems Then GoTo FN100
            Arg = NI + NB
            ProductRle = gsngRLEDAT(Arg)
            ProductImg = gsngRLEIMG(Arg)
            If NK = 0 Then GoTo FN40
            On Error GoTo ERROR1
            ProductRle = (ProductRle * gsngFFTCOS(Pnt1)) - _
                (gsngRLEIMG(Arg) * gsngFFTSIN(Pnt1))
            On Error GoTo ERROR2
            ProductImg = (ProductImg * gsngFFTCOS(Pnt1)) + _
                (gsngRLEDAT(Arg) * gsngFFTSIN(Pnt1))
            On Error GoTo 0

FN40:
            gsngRLEDAT(Arg) = gsngRLEDAT(NI) - ProductRle
            gsngRLEIMG(Arg) = gsngRLEIMG(NI) - ProductImg
            gsngRLEDAT(NI) = gsngRLEDAT(NI) + ProductRle
            gsngRLEIMG(NI) = gsngRLEIMG(NI) + ProductImg
            NI = NI + NA
            GoTo FN35

FN100:
            Pnt1 = Pnt1 + Pnt0
            NK = NK + 1
        Next Inner
        NA = NA + NA
        NB = NB + NB
    Next Index
    
    If gblnInverse Then Exit Sub
    For Index = 0 To glngFFTItems - 1 Step 1
        gsngRLEDAT(Index) = gsngRLEDAT(Index) / Points
        gsngRLEIMG(Index) = gsngRLEIMG(Index) / Points
    Next Index
    
Exit Sub
ERROR1:
    ProductRle = 0#
    Resume Next

ERROR2:
    ProductImg = 0#
    Resume Next
    
End Sub

Public Sub FixAmplitude(Nsize As Long)
Dim Index As Long, Nlow As Long, Nhigh As Long
Dim sngScaleFct As Single
    Nlow = 65535
    Nhigh = -65535
    For Index = 0 To Nsize - 1
        If gsngRLEDAT(Index) > Nhigh Then Nhigh = gsngRLEDAT(Index)
        If gsngRLEDAT(Index) < Nlow Then Nlow = gsngRLEDAT(Index)
    Next Index
    If Abs(Nlow) > Nhigh Then Nhigh = Abs(Nlow)
    If Nhigh > 32767 Then
        sngScaleFct = 32000# / CSng(Nhigh)
        For Index = 0 To Nsize - 1
            gsngRLEDAT(Index) = gsngRLEDAT(Index) * sngScaleFct
        Next Index
    End If

End Sub

Public Sub DoSmoothing(Nsize As Long)
Dim Index As Integer, Inner As Long
    For Index = 1 To 4 Step 1
        For Inner = 1 To Nsize - 2 Step 1
            gsngRLEIMG(Inner) = ((gsngRLEDAT(Inner) * 2) + gsngRLEDAT(Inner - 1) + _
                gsngRLEDAT(Inner + 1)) / 4
        Next Inner
        For Inner = 1 To Nsize - 2 Step 1
            gsngRLEDAT(Inner) = gsngRLEIMG(Inner)
        Next Inner
    Next Index
    
End Sub

Public Sub ZeroArrays(Quan As Long, Samp As Long)
Dim Index As Long
    If Quan = 0 Then Exit Sub
    Index = (Quan + Samp) - 1
    If Index > glngFFTItems Then
        Quan = glngFFTItems - Samp
    End If
    For Index = 1 To Quan
        gsngRLEDAT(Samp) = 0#
        gsngRLEIMG(Samp) = 0#
        Samp = Samp + 1
    Next Index
    
End Sub