frmmain.frm

FFT Demo Program. Written in VB

Private Sub DriveSetup_Change()
    DirSetup.Path = DriveSetup.Drive    ' Set directory path.

End Sub

Private Sub FileSetup_DblClick()
    DirSetup.Visible = False
    DriveSetup.Visible = False
    strFile = FileSetup.List(FileSetup.ListIndex)
    FileSetup.Visible = False
    LabFile.Caption = strFile
    LabFile.Visible = True
    DoEvents
    On Error GoTo ErrorHandler  ' Enable error-handling routine.
    Open strPath & strFile For Binary Access Read As #1    ' Open file for input.
    gblnErrFlg = False
    Call WavToArray
    If gblnErrFlg Then Exit Sub
    mnuDigFlt.Enabled = True
    mnuFFT.Enabled = True
    mnuGetWav.Enabled = False
    
Exit Sub
ErrorHandler:   ' Error-handling routine.
    If Err.Number <> 0 Then Call ErrorMsg
    Resume ENDERROR
ENDERROR:
    Close 1

End Sub

Public Sub WavToArray()
Dim Index As Long, Inner As Integer
    gblnErrFlg = False
    gstrRoutine = "WavToArray"
    On Error GoTo ErrorHandler  ' Enable error-handling routine.
    Get #1, 1, strHeader
    If Left(strHeader, 4) <> "RIFF" Or Right(strHeader, 4) <> "WAVE" _
        Then GoTo NOTWAVE
    Get #1, , strFormat
    If Left(strFormat, 3) <> "fmt" Then GoTo NOTWAVE
    Get #1, , ghdrWave
    Get #1, , strByte
    For Index = 0 To 100
        If strByte = "d" Then Get #1, , strByte
        If strByte = "a" Then Get #1, , strByte
        If strByte = "t" Then Get #1, , strByte
        If strByte = "a" Then GoTo FOUND
        If strByte <> "d" Then Get #1, , strByte
    Next Index
    GoTo NOTWAVE
    
FOUND:
    Get #1, , lngNumDataBytes
    gbytFchn = ghdrWave.NumChans
    gintResolution = ghdrWave.SampleRate
    LabRate.Caption = "Sample rate is " & gintResolution
    LabChans.Caption = "Number of channels is " & gbytFchn
    LabBits.Caption = "Bits per sample is " & ghdrWave.BitsPerSample
    lngTemp = lngNumDataBytes / ghdrWave.BytsPerBlock
    If gbytFchn = 2 Then
        glngMaxCount = lngTemp / 2
    Else
        glngMaxCount = lngTemp
    End If
    glngDispCount = glngMaxCount / 2
    LabSamps.Caption = "Total samples are " & lngTemp
    LabSamps.Visible = True
    LabRate.Visible = True
    LabChans.Visible = True
    LabBits.Visible = True
    sngTemp = lngNumDataBytes / ghdrWave.BytsPerSec
    LabSec.Caption = "Total seconds " & sngTemp
    LabSec.Visible = True
    
    ReDim gintPlot(glngMaxCount - 1)
    If gbytFchn = 2 Then
        ReDim gintDummy(glngMaxCount - 1)
        If ghdrWave.BitsPerSample = 8 Then
            ReDim gbytSource(1, lngTemp - 1)
            ReDim gintSource(1, lngTemp - 1)
            Get #1, , gbytSource
            Close #1
            For Index = 0 To lngTemp - 1
                For Inner = 0 To 1
                    gintSource(Inner, Index) = gbytSource(Inner, Index)
                Next Inner
            Next Index
            Call INTLVE(glngMaxCount, gintSource(0), gintPlot(0), _
                gintDummy(0))
        Else
            ReDim gintSource(lngTemp - 1)
            Get #1, , gintSource
            Close #1
            Call INTLVE(glngMaxCount, gintSource(0), gintPlot(0), _
                gintDummy(0))
        End If
    Else
        If ghdrWave.BitsPerSample = 8 Then
            ReDim gbytSource(lngTemp - 1)
            Get #1, , gbytSource
            Close #1
            For Index = 0 To lngTemp - 1
                gintPlot(Index) = gbytSource(Index)
            Next Index
        Else
            Get #1, , gintPlot
            Close #1
        End If
    End If
    
Exit Sub
NOTWAVE:
    Msg = "File does not appear to be a WAVE file"
    MsgBox Msg
    GoTo ENDERROR
    
Exit Sub
ErrorHandler:   ' Error-handling routine.
    If Err.Number <> 0 Then Call ErrorMsg
    Resume ENDERROR
ENDERROR:
    Close 1
    gblnErrFlg = True
    
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, ArgX As Single, ArgY As Single)
gblnMseFlg = True
gintMseX = ArgX
gintMseY = ArgY

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Unload frmMain
    Set frmMain = Nothing
    
End Sub

Private Sub mnuDigFlt_Click()
    Call DigitalFilter
    
End Sub

Private Sub mnuFFT_Click()
Dim Index As Long
    mnuDigFlt.Enabled = False
    mnuFFT.Enabled = False
    glngFFTItems = 8192
    For Index = 1 To 5
        If glngFFTItems > glngMaxCount Then GoTo OKAY
        glngFFTItems = glngFFTItems * 2
    Next Index
OKAY:

    ReDim gsngRLEDAT(glngFFTItems - 1)
    ReDim gsngRLEIMG(glngFFTItems - 1)
    ReDim gsngFFTSIN(glngFFTItems - 1)
    ReDim gsngFFTCOS(glngFFTItems - 1)
    Screen.MousePointer = vbHourglass
    For Index = 0 To glngMaxCount - 1
        gsngRLEDAT(Index) = gintPlot(Index)
    Next Index
    For Index = glngMaxCount To glngFFTItems - 1
        gsngRLEDAT(Index) = 0#
    Next Index
    sngTemp = gintResolution
    gsngFreqPerPoint = sngTemp / (CSng(glngFFTItems) / 2)
    gbytRepeat = 0
    gblnInverse = False
    Call FastFourierTransform
    gsngRLEDAT(0) = 0#
    Call DoSmoothing(glngDispCount)
    Call FixAmplitude(glngDispCount)
    For Index = 0 To glngDispCount - 1
        gintPlot(Index) = Abs(gsngRLEDAT(Index))
    Next Index
    gintPlot(0) = gintPlot(1)
    ReDim gsngRLEDAT(0)
    ReDim gsngRLEIMG(0)
    ReDim gsngFFTSIN(0)
    ReDim gsngFFTCOS(0)
    Call FixPlot
    Call DispPlot
    Screen.MousePointer = vbArrow
    Call DisplayFreq
    
End Sub

Private Sub mnuGetWav_Click()
    DriveSetup.Drive = Left(App.Path, 3)
    DirSetup.Path = App.Path
    FileSetup.Pattern = "*.wav"
    DriveSetup.Visible = True
    DirSetup.Visible = True
    FileSetup.Visible = True
    gblnRetFlg = False
RETRY:
    DoEvents
    If Not gblnRetFlg Then GoTo RETRY

End Sub

Private Sub TxtHighFreq_KeyPress(KeyAscii As Integer)
    If KeyAscii <> vbKeyReturn Then Exit Sub
    gblnRetFlg = True
    KeyAscii = 0
    
End Sub

Private Sub TxtLowFreq_KeyPress(KeyAscii As Integer)
    If KeyAscii <> vbKeyReturn Then Exit Sub
    gblnRetFlg = True
    KeyAscii = 0

End Sub

Private Sub FixPlot()
Dim Index As Long, Nhigh As Single, Nlow As Single
Dim sngTemp As Single, Count As Single, Nstop As Long, Inner As Integer
Dim sngCrtFactor As Single
    ReDim gintDispPlot(800 - 1)
    ReDim gsngPlot(800 - 1)
    sngTemp = 800#
    gsngPosFactor = CSng(glngDispCount) / sngTemp
    gsngPlot(0) = 0#
    Inner = 1
    Nstop = Inner * gsngPosFactor
    Count = 0#
    sngTemp = 0#
    For Index = 1 To glngDispCount - 1
        sngTemp = sngTemp + CSng(gintPlot(Index))
        Count = Count + 1
        If Index = Nstop Then
            gsngPlot(Inner) = sngTemp / Count
            Count = 0#
            sngTemp = 0#
            Inner = Inner + 1
            Nstop = Inner * gsngPosFactor
        End If
        If Inner = 800 Then GoTo PLOTDONE
    Next Index
PLOTDONE:

    Nlow = 32767#
    Nhigh = 0#
    For Index = 0 To 800 - 1
        If gsngPlot(Index) > Nhigh Then Nhigh = gsngPlot(Index)
        If gsngPlot(Index) < Nlow Then Nlow = gsngPlot(Index)
    Next Index
    If Abs(Nlow) > Nhigh Then Nhigh = Abs(Nlow)
    If Nhigh = 0 Then Nhigh = 170#
    sngCrtFactor = 170# / Nhigh
    For Index = 0 To 800 - 1
        gintDispPlot(Index) = gsngPlot(Index) * sngCrtFactor
    Next Index

End Sub

Private Sub DispPlot()
Dim ArgX1 As Integer, ArgX2 As Integer, ArgY1 As Integer, ArgY2 As Integer
Dim Index As Integer, OfstY1 As Integer, OfstY3 As Integer
Dim ArgY3 As Integer, ArgY4 As Integer
    gstrRoutine = "DrawPlot"
    AutoRedraw = True
    Line (0, 300)-(799, 479), vbBlack, BF
    ArgX1 = 0
    ArgX2 = 1
    ArgY1 = gintDispPlot(0) + 475
    For Index = 1 To 800 - 1
        ArgY2 = 475 - gintDispPlot(Index)
        Line (ArgX1, ArgY1)-(ArgX2, ArgY2), vbYellow
        ArgY1 = ArgY2
        ArgX1 = ArgX1 + 1
        ArgX2 = ArgX2 + 1
    Next Index
    
    AutoRedraw = False

End Sub

Private Sub DisplayFreq()
    Dim Freq As String, Temp As Long
    LabMsg.Caption = "Place cursor on trace and click. Repeat as desired."
    LabMsg.Visible = True
    CmdDone.Visible = True
    gblnRetFlg = False
MORE:
    gblnMseFlg = False
OVER:
    DoEvents
    If gblnRetFlg Then GoTo DONE
    If gblnMseFlg = False Then GoTo OVER
    Temp = gintMseX * gsngPosFactor
    
    Freq = Str(Temp * gsngFreqPerPoint)
    LabMsg.Caption = "Frequency: " & Freq
    GoTo MORE
    
DONE:
    LabMsg.Visible = False
    CmdDone.Visible = False
    LabSamps.Visible = False
    LabRate.Visible = False
    LabChans.Visible = False
    LabBits.Visible = False
    LabSec.Visible = False
    LabFile.Visible = False
    mnuGetWav.Enabled = True
    AutoRedraw = True
    Line (0, 300)-(799, 479), vbButtonFace, BF
    AutoRedraw = False
    
End Sub