freq.frm

我自己编写的VB的FFT程序

VERSION 5.00
Begin VB.Form PlotFreq 
   AutoRedraw      =   -1  'True
   Caption         =   "Frequency Analyser"
   ClientHeight    =   6105
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   11880
   ForeColor       =   &H8000000D&
   LinkTopic       =   "Form1"
   ScaleHeight     =   6105
   ScaleWidth      =   11880
   Begin VB.PictureBox Picture1 
      Height          =   5415
      Left            =   0
      ScaleHeight     =   5355
      ScaleWidth      =   11835
      TabIndex        =   0
      Top             =   600
      Width           =   11895
      Begin VB.HScrollBar HScroll1 
         Height          =   240
         LargeChange     =   600
         Left            =   0
         Max             =   17700
         Min             =   -60
         SmallChange     =   90
         TabIndex        =   2
         Top             =   4920
         Width           =   11775
      End
      Begin VB.PictureBox Picture2 
         AutoRedraw      =   -1  'True
         BackColor       =   &H00400040&
         ForeColor       =   &H8000000E&
         Height          =   4960
         Left            =   0
         MousePointer    =   2  'Cross
         ScaleHeight     =   4905
         ScaleWidth      =   29445
         TabIndex        =   1
         Top             =   0
         Width           =   29500
         Begin VB.Line Line1 
            BorderColor     =   &H0000FFFF&
            X1              =   3720
            X2              =   3720
            Y1              =   0
            Y2              =   4920
         End
         Begin VB.Label Label1 
            AutoSize        =   -1  'True
            BackColor       =   &H00400040&
            BackStyle       =   0  'Transparent
            Caption         =   "Frequency Analysis"
            BeginProperty Font 
               Name            =   "Times New Roman"
               Size            =   12
               Charset         =   0
               Weight          =   700
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            ForeColor       =   &H000000FF&
            Height          =   285
            Left            =   9960
            TabIndex        =   3
            Top             =   0
            Width           =   2205
         End
      End
   End
   Begin VB.Label Label12 
      Caption         =   "57"
      Height          =   255
      Left            =   6360
      TabIndex        =   11
      Top             =   0
      Visible         =   0   'False
      Width           =   615
   End
   Begin VB.Label Label11 
      Caption         =   "52"
      Height          =   255
      Left            =   5520
      TabIndex        =   10
      Top             =   0
      Visible         =   0   'False
      Width           =   495
   End
   Begin VB.Label Label10 
      BackStyle       =   0  'Transparent
      Height          =   255
      Left            =   4440
      TabIndex        =   9
      Top             =   0
      Visible         =   0   'False
      Width           =   615
   End
   Begin VB.Label Label9 
      AutoSize        =   -1  'True
      Caption         =   "Label9"
      Height          =   195
      Left            =   3120
      TabIndex        =   8
      Top             =   360
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Label Label5 
      AutoSize        =   -1  'True
      Caption         =   "Hz"
      Height          =   195
      Left            =   5040
      TabIndex        =   7
      Top             =   360
      Width           =   195
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      Caption         =   "Octave:"
      Height          =   195
      Left            =   8760
      TabIndex        =   6
      Top             =   360
      Width           =   570
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Height          =   195
      Left            =   5760
      TabIndex        =   5
      Top             =   360
      Width           =   45
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      Height          =   195
      Left            =   4920
      TabIndex        =   4
      Top             =   360
      Width           =   45
   End
End
Attribute VB_Name = "PlotFreq"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'TrueWavAnalyzer
'by: Paul Bryan in 2002
'Allows for graphical isolation of sample ranges
'will analyze by frequency and decibal for up
'to 32768 samples (VB Single Precision Demension Max)
'Uses the FFT alogorythm
' I hope this helps, feel free to re-use this code.
Dim Ad$
Dim NotFilePos1 As Integer, NotFilePos2 As Integer
Dim Original(32768) As Double 'original data (before FFT)
Dim AfterFFT(32768) As Double 'data after FFT calculation
Dim yi(16384) As Double, yimax As Double 'imaginary
Dim yr(16384) As Double, yrmax As Double 'real
Dim ymod(16384) As Double, ymodmax As Double 'vector
Dim SampFreq As Long 'File Sampling Frequency

Sub FFTWave(Y() As Double, Npont As Long, Freq As Long, Sectime As String)
   ' Me.Caption = "Frequency Analysis for first 32768 Samples of " & Sectime & " Selected."
    
    Dim N As Long, g As Long
    N = Npont / 2
    'Store original data
    SampFreq = Freq
    For g = 1 To Npont
        Original(g) = Y(g)
    Next g
    RealFFT Y(), N, 1
    'Store FFT data
    For g = 1 To Npont
        AfterFFT(g) = Y(g)
    Next g
    GraphFFT Y(), N
    'PlotFreq.SetFocus
    PlotFreq.Show
End Sub
Sub RealFFT(Y() As Double, N As Long, Isign As Integer)
    Dim wr As Double, wi As Double, wpr As Double
    Dim PIsin As Double, TmpW As Double, CalcA As Double
    Dim c1 As Double, c2 As Double
    Dim PB As Long, Paul As Long, i As Long
    Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
    Dim wrs As Single, wis As Single
    Dim h1r As Double, h1i As Double
    Dim h2r As Double, h2i As Double
    PB = 2 * N
    CalcA = 3.14159265358979 / CDbl(N)
    c1 = 0.5
    If Isign = 1 Then
        c2 = -0.5
        PlotIt Y(), N, 1
      Else
        c2 = 0.5
        CalcA = -CalcA
    End If
    wpr = -2# * Sin(0.5 * CalcA) ^ 2
    PIsin = Sin(CalcA)
    wr = 1# + wpr
    wi = PIsin
    Paul = 2 * N + 3
    For i = 2 To N / 2 + 1
       i1 = 2 * i - 1
       i2 = i1 + 1
       i3 = Paul - i2
       i4 = i3 + 1
       wrs = CSng(wr)
       wis = CSng(wi)
       h1r = c1 * (Y(i1) + Y(i3))
       h1i = c1 * (Y(i2) - Y(i4))
       h2r = -c2 * (Y(i2) + Y(i4))
       h2i = c2 * (Y(i1) - Y(i3))
       Y(i1) = h1r + wrs * h2r - wis * h2i
       Y(i2) = h1i + wrs * h2i + wis * h2r
       Y(i3) = h1r - wrs * h2r + wis * h2i
       Y(i4) = -h1i + wrs * h2i + wis * h2r
       TmpW = wr
       wr = wr * wpr - wi * PIsin + wr
       wi = wi * wpr + TmpW * PIsin + wi
    Next i
    If Isign = 1 Then
        h1r = Y(1)
        Y(1) = h1r + Y(2)
        Y(2) = h1r - Y(2)
      Else
        h1r = Y(1)
        Y(1) = c1 * (h1r + Y(2))
        Y(2) = c1 * (h1r - Y(2))
        PlotIt Y(), N, -1
    End If
End Sub

Sub PlotIt(Y() As Double, PB As Long, Isign As Integer)
    Dim N As Long, i As Long, j As Long
    Dim m As Long, mmax As Long, istep As Long
    Dim TmpR As Double, TmpI As Double
    Dim wr As Double, wi As Double, wpr As Double
    Dim PIsin As Double, TmpW As Double, CalcA As Double
    N = 2 * PB
    j = 1
    For i = 1 To N Step 2
       If j > i Then
          TmpR = Y(j)
          TmpI = Y(j + 1)
          Y(j) = Y(i)
          Y(j + 1) = Y(i + 1)
          Y(i) = TmpR
          Y(i + 1) = TmpI
       End If
       m = N / 2
1:     If (m >= 2 And j > m) Then
          j = j - m
          m = m / 2
          GoTo 1
       End If