fftmodule.bas

脑波FFT分析程序,是分析周波数并画图的程序,用在脑波分析软件中

Attribute VB_Name = "fftModule"
Option Explicit
'(x0,y0): 尨揰偺埵抲
'xw : x幉偺挿偝  yh : y幉偺挿偝
Const x0 As Single = 0
Const y0 As Single = 0
Const xw As Single = 1024
Const yh As Single = 100
Dim sp() As Double '=sqrt(x()^2+y()^2) spectrum梡

Public Sub fftMain(pic1 As PictureBox, pic2 As PictureBox, _
     x() As Double, y() As Double, N As Integer, wind As Integer)
'win = 0 window 側偟
'win = 1 Hamming window
'win = 2 Hanning window
'
 ReDim sp(N / 2) As Double
 
  fftInitPic pic1, 1
  fftInitPic pic2, 2
  fftWindow x(), y(), N, wind
  fftDrawData pic1, 1, x(), N
  fftCalc x(), y(), N, 1#
  fftAbs x(), y(), sp(), N / 2
  fftDrawData pic2, 2, sp(), N / 2
  
End Sub

Public Sub fftCalc(x() As Double, y() As Double, N As Integer, id As Double)
' N    僨乕僞悢丄2偺傋偒忔偱偁傞偙偲丂128,256,512,1024,...
' id= 1.0 FFT偺寁嶼
' id=-1.0 媡FFT(RFT)偺寁嶼
' 擖椡丂x() 幚悢抣僨乕僞丂y() 嫊悢抣僨乕僞
' 弌椡丂x()偲y()偵寢壥偑擖傞丂(x(),y()偺撪梕偼幐傢傟傞)
Dim i As Integer, i0 As Integer, i1 As Integer, j As Integer, _
   ns As Integer, k As Integer, arg As Integer
Dim s As Double, c As Double, sc As Double, x1 As Double, y1 As Double
    ns = N / 2: sc = 2 * 4 * Atn(1#) / N
    
    Do While ns >= 1
        arg = 0
        For j = 1 To N Step 2 * ns
            k = N / 4
            c = Cos(sc * arg): s = Sin(id * sc * arg)
            For i0 = j To j + ns - 1
                i1 = i0 + ns
                x1 = x(i1) * c - y(i1) * s: y1 = y(i1) * c + x(i1) * s
                x(i1) = x(i0) - x1: y(i1) = y(i0) - y1
                x(i0) = x(i0) + x1: y(i0) = y(i0) + y1
            Next i0
            Do While k <= arg
                arg = arg - k: k = k / 2
                If k = 0 Then Exit Do
            Loop
            arg = arg + k
        Next j
        ns = ns / 2
    Loop
    If id < 0 Then
        For i = 1 To N
            x(i) = x(i) / N: y(i) = y(i) / N
        Next i
    End If
    j = 1
    For i = 1 To N - 1
        If i <= j Then
            x1 = x(i): x(i) = x(j): x(j) = x1
            y1 = y(i): y(i) = y(j): y(j) = y1
        End If
        k = N / 2
        Do While k < j
            j = j - k: k = k / 2
        Loop
        j = j + k
    Next i
End Sub

Public Sub fftWindow(x() As Double, y() As Double, N As Integer, win As Integer)
 Select Case win
   Case 1
      fftHamming x(), y(), N
   Case 2
      fftHanning x(), y(), N
   Case Else
   
 End Select
End Sub

Public Sub fftHanning(x() As Double, y() As Double, N As Integer)
Dim i As Integer, sc As Double
    sc = 2 * 4 * Atn(1#) / N
    For i = 1 To N
      x(i) = 0.5 * x(i) * (1# - Cos(sc * (i - 1)))
    Next i
End Sub

Public Sub fftHamming(x() As Double, y() As Double, N As Integer)
Dim i As Integer, sc As Double
    sc = 2 * 4 * Atn(1#) / N
    For i = 1 To N
      x(i) = x(i) * (0.54 - 0.46 * Cos(sc * (i - 1)))
    Next i

End Sub

Public Sub fftAbs(x() As Double, y() As Double, z() As Double, N As Integer)
' z()=sqrt(x()^2+y()^2)
 Dim i As Integer
  For i = 1 To N
    z(i) = Sqr(x(i) ^ 2 + y(i) ^ 2)
  Next i
End Sub
Public Sub fftInitPic(pic As PictureBox, index As Integer)
  'index=1 : 墶T帤宆嵗昗幉
  'index=2 : L帤宆嵗昗幉
  
  pic.AutoRedraw = True
  Dim clBlue As Long
  
  clBlue = QBColor(1)
  pic.DrawStyle = 0
  
  If index = 1 Then
    pic.Scale (x0 - 50, yh + 10)-(xw + 50, y0 - yh - 10)
    pic.Line (x0, y0)-(x0 + xw, y0), clBlue 'X-幉
    pic.Line (x0, -yh)-(x0, yh), clBlue  'Y-幉
  Else
    pic.Scale (x0 - 50, yh + 10)-(xw + 50, y0 - 10)
    pic.Line (x0, y0)-(x0 + xw, y0), clBlue 'X-幉
    pic.Line (x0, y0)-(x0, yh), clBlue  'Y-幉
  End If
End Sub

Public Sub fftDrawData(pic As PictureBox, index As Integer, x() As Double, N As Integer)
Dim i As Integer, ColorId As Integer
Dim xs As Double, ys As Double, max As Double, min As Double
    fftMaxMin x(), N, max, min
    xs = xw / N: ys = yh / max
    ColorId = 12
    If index = 1 Then
        pic.PSet (0, x(1) * ys)
        For i = 2 To N
            pic.Line -((i - 1) * xs, x(i) * ys), QBColor(ColorId)
        Next i
    Else
        For i = 1 To N
            pic.Line ((i - 1) * xs, 0)-((i - 1) * xs, x(i) * ys), QBColor(ColorId)
        Next i
    End If
  
End Sub

Public Sub fftMaxMin(x() As Double, N As Integer, max As Double, min As Double)
  Dim i As Integer
  max = x(1): min = x(1)
  For i = 2 To N
     If x(i) > max Then max = x(i)
     If x(i) < min Then min = x(i)
  Next i
  
End Sub