signal.bas

用VB实现正弦波的采集和傅里叶变换。将时域信号变化为频域信号

Attribute VB_Name = "SA"
Option Explicit

Public Sub SampleRnd(n As Integer, xr() As Single)
Dim j As Integer, temp As Single
'-----------------------
For j = 0 To n - 1
  xr(j) = Rnd
Next j
'---------零均值化--------------
temp = 0#
For j = 0 To n - 1
  temp = temp + xr(j)
Next j
temp = temp / CSng(n)
For j = 0 To n - 1
  xr(j) = xr(j) - 0.5
  xr(j) = 2# * xr(j)
Next j
'-----------------------
End Sub

Public Sub SampleSine(n As Integer, xr() As Single, f0 As Single)
Dim j As Integer, fs As Single
Dim w As Single, q As Single
'--------------------------------------------
fs = f0 * 32#
w = 2# * PI / fs
For j = 0 To n - 1
  q = CSng(j) * w * f0
  xr(j) = 1# * Cos(q)
Next j
'---------------------------------------------
End Sub

Sub SampleSquare(n As Integer, xr() As Single, f0 As Single)
Dim j As Integer, i As Integer
Dim a As Single, fs As Single
Dim m1 As Integer, m2 As Integer, k As Integer
'--------------------------------------------
fs = f0 * 32#: a = 1#
m1 = 0.7 * fs / f0: m2 = 0.3 * fs / f0
i = 0
For k = 0 To 1 Step 0
  For j = 0 To m1 - 1
    xr(i) = a: i = i + 1
  Next j
  For j = m1 To m1 + m2 - 1
    xr(i) = -a: i = i + 1
  Next j
  If i >= n Then Exit For
Next k

End Sub

Sub SampleTriangle(n As Integer, xr() As Single, f0 As Single)
Dim j As Integer, i As Integer
Dim a As Single, w As Single, q As Single
Dim m As Integer, k As Integer, fs As Single
'--------------------------------------------
fs = f0 * 32#: a = 1#: w = 4# * a / fs
m = 0.5 * fs / f0
i = 0
For k = 0 To 1 Step 0
  For j = 0 To m - 1
    q = CSng(j) * w * f0
    xr(i) = a - q: i = i + 1
  Next j
  For j = m To 2 * m - 1
    q = CSng(j) * w * f0
    xr(i) = q - 3# * a: i = i + 1
  Next j
If i >= n Then Exit For
Next k

End Sub

Public Sub SampleDC(n As Integer, xr() As Single)
Dim j As Integer
'--------------------------------------------
For j = 0 To n - 1
  xr(j) = -1#
Next j
'---------------------------------------------
End Sub

Sub SampleScan(n As Integer, xr() As Single, fs As Single)
Dim j As Integer, k As Single
Dim f0 As Single, w As Single, q As Single
'--------------------------------------------
f0 = 50#: k = 20000#: w = 2# * PI / fs
For j = 0 To n - 1
  q = CSng(j) * w * f0 + k * CSng(j) * CSng(j) / (fs * fs)
  xr(j) = 1# * Sin(q)
Next j

End Sub

Sub SampleTransient(n As Integer, xr0() As Single, fs As Single)
Dim i As Integer
Dim f0 As Single, w As Single, q As Single
Dim ci As Single
'--------------------------------------------
f0 = 100: w = 2 * PI / fs: ci = 40
For i = 0 To n - 1
 q = i * w * f0
 xr0(i) = 40# * Exp(-ci * i / fs) '* Sin(q)
Next i
'---------------------------------------------
End Sub

Public Sub SampleSineNoise(n As Integer, xr() As Single, f0 As Single)
Dim j As Integer, fs As Single
Dim w As Single, q As Single
Dim xi(4096) As Single
'---------------- ----------------------------
fs = f0 * 32#
w = 2# * PI / fs
For j = 0 To n - 1
  q = CSng(j) * w * f0
  xr(j) = 1# * Cos(q)
Next j
Call SampleRnd(n, xi)
For j = 0 To n - 1
   xr(j) = xr(j) + xi(j)
Next j
'---------------------------------------
End Sub

Public Sub FFT3(n As Integer, xr() As Single, xi() As Single, inverse As Integer)
Dim i As Integer, j As Integer, l As Integer
Dim k As Integer, k1 As Integer, k2 As Integer
Dim m As Integer, m1 As Integer, m2 As Integer
Dim lk As Integer
Dim tr As Single, ti As Single
Dim wr As Single, wi As Single
Dim ur As Single, ui As Single
'---------------------------------------
m = Int(Log(n) / Log(2!) + 0.1)
For i = 0 To n - 1
   xr(i) = xr(i) / CSng(n)
   xi(i) = xi(i) / CSng(n)
   If inverse = 1 Then xi(i) = -xi(i)
Next i

For k = 0 To n - 1
   j = 0: k1 = k
   For l = 1 To m
      k2 = Int(k1 / 2)
      j = j * 2 + k1 - k2 * 2
      k1 = k2
   Next l
   If j > k Then
     tr = xr(k)
     ti = xi(k)
     xr(k) = xr(j)
     xi(k) = xi(j)
     xr(j) = tr
     xi(j) = ti
   End If
Next k
'-------------------
For m1 = 1 To m
  ur = 1
  ui = 0
  k = 2 ^ (m1 - 1)
  wr = Cos(PI / CSng(k))
  wi = Sin(PI / CSng(k))
  m2 = 2 ^ m1
  For j = 0 To k - 1
    For l = j To n - 1 Step m2
      lk = l + k
      tr = xr(lk) * ur - xi(lk) * ui
      ti = xi(lk) * ur + xr(lk) * ui
      xr(lk) = xr(l) - tr: xi(lk) = xi(l) - ti
      xr(l) = xr(l) + tr: xi(l) = xi(l) + ti
    Next l
    tr = ur: ti = ui
    ur = wr * tr - wi * ti
    ui = wi * tr + wr * ti
  Next j
Next m1
'----------------------------
If inverse = 0 Then
  For i = 0 To n - 1
    xr(i) = xr(i) * CSng(n)
    xi(i) = xi(i) * CSng(n)
  Next i
End If
'------------------------------------------
End Sub

Public Sub Windowing(n As Integer, xr() As Single)
Dim i As Integer, wst As Single
'-------------Hanning 窗-------------------
For i = 0 To n - 1
  wst = 1# - Cos(2 * PI * CSng(i) / CSng(n - 1))
  xr(i) = xr(i) * wst
Next i
'---------------------------
End Sub

Public Sub PreProcess(n As Integer, xr() As Single)
'------拟合直线  y = ax + b--------
Dim a As Single, b As Single
Dim i As Integer, temp As Single
Dim a1 As Single, A2 As Single
Dim b1 As Single, B2 As Single
Dim c1 As Single, C2 As Single
'---------------------------------
a1 = 0#: A2 = 0#: c1 = 0#: C2 = 0#
For i = 0 To n - 1
  temp = i
  a1 = a1 + temp * temp: A2 = A2 + i
  c1 = c1 + xr(i) * i: C2 = C2 + xr(i)
Next i
b1 = A2: B2 = n
'---------解方程组----------------
temp = a1 * B2 - A2 * b1
a = (c1 * B2 - C2 * b1) / temp
b = (C2 * a1 - c1 * A2) / temp
'------去除趋势项 y = at + b---------
For i = 0 To n - 1
  xr(i) = xr(i) - (a * i + b)
Next i
'------------------------------------
End Sub

Public Sub ExtractIndex(n As Integer, xr() As Single, rms As Single, kurt As Single)
Dim j As Integer
 
 rms = 0#
 For j = 0 To n - 1
   rms = rms + xr(j) * xr(j)
 Next j
 rms = Sqr(rms / CSng(n))
 If rms = 0 Then rms = 0.001
 
 kurt = 0#
 For j = 0 To n - 1
  kurt = kurt + xr(j) * xr(j) * xr(j) * xr(j)
 Next j
 kurt = (kurt / CSng(n)) / (rms * rms * rms * rms)

End Sub