fft.frm

这是本人的本科毕业论文《二维FFT变换程序实现及其应用》中的程序

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "二维FFT的图像应用"
   ClientHeight    =   8130
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   15210
   LinkTopic       =   "Form1"
   ScaleHeight     =   8130
   ScaleWidth      =   15210
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox Picture2 
      AutoRedraw      =   -1  'True
      BackColor       =   &H8000000E&
      Height          =   8055
      Left            =   2160
      ScaleHeight     =   7995
      ScaleWidth      =   12915
      TabIndex        =   1
      Top             =   0
      Width           =   12975
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   1740
      Left            =   0
      ScaleHeight     =   116
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   132
      TabIndex        =   0
      Top             =   0
      Width           =   1980
   End
   Begin VB.Menu load 
      Caption         =   "装入特定尺寸的位图"
   End
   Begin VB.Menu gxpp1 
      Caption         =   "光学FFT频谱图像"
   End
   Begin VB.Menu lvpptx1 
      Caption         =   "滤波后频谱图像1"
   End
   Begin VB.Menu lbpptx2 
      Caption         =   "滤波后频谱图像2(不经灰度变换)"
   End
   Begin VB.Menu qqytg 
      Caption         =   "全区域通过"
   End
   Begin VB.Menu yxsjz 
      Caption         =   "原像素矩阵"
   End
   Begin VB.Menu xsxjz 
      Caption         =   "新像素矩阵"
      Begin VB.Menu gxhxsjz 
         Caption         =   "光学FFT后像素矩阵"
      End
      Begin VB.Menu pptxxsjz 
         Caption         =   "频谱图像像素矩阵"
      End
      Begin VB.Menu lbhppxsjz 
         Caption         =   "滤波后频谱图像像素矩阵"
      End
      Begin VB.Menu lbhxsjz 
         Caption         =   "滤波后像素矩阵"
      End
   End
   Begin VB.Menu save 
      Caption         =   "保存像素矩阵"
   End
   Begin VB.Menu txcl 
      Caption         =   "空域和频域图像处理"
      Begin VB.Menu fx 
         Caption         =   "反相"
      End
      Begin VB.Menu dbdjb 
         Caption         =   "对比度减半"
      End
      Begin VB.Menu dtlb 
         Caption         =   "理想带通滤波处理（调用FFTFilterImage，有问题）"
      End
      Begin VB.Menu dtlb2 
         Caption         =   "理想带通滤波处理2（用vb改写FFTFilterImage直接调用FFT2）"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type BITMAP
          bmType   As Long
          bmWidth   As Long
          bmHeight   As Long
          bmWidthBytes   As Long
          bmPlanes   As Integer
          bmBitsPixel   As Integer
          bmBits   As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function FFTImage Lib "dft.dll" Alias "_FFTImage@16" (image_in As Byte, image_out As Byte, ByVal xsize As Long, ByVal ysize As Long) As Long
Private Declare Function FFTFilterImage Lib "dft.dll" Alias "_FFTFilterImage@24" (image_in As Byte, image_out As Byte, ByVal xsize As Long, ByVal ysize As Long, ByVal a As Long, ByVal b As Long) As Long
Private Declare Function FFTFilter Lib "dft.dll" Alias "_FFTFilter@24" (image_in As Byte, image_out As Byte, ByVal xsize As Long, ByVal ysize As Long, ByVal a As Long, ByVal b As Long) As Long
Private Declare Function FFT2 Lib "dft.dll" Alias "_FFT2@20" (SB As Single, XB As Single, ByVal INV As Long, ByVal xsize As Long, ByVal ysize As Long) As Long
Dim PicBits1() As Byte, PicBits2() As Byte, PicInfo As BITMAP
Dim a&, i&, cnt&, j&
Sub pretreat()
GetObject Picture1.Image, Len(PicInfo), PicInfo
a = PicInfo.bmWidth * PicInfo.bmHeight
ReDim PicBits1(1 To a) As Byte
ReDim PicBits2(1 To a) As Byte
GetBitmapBits Picture1.Picture.Handle, a, PicBits1(1)
Picture1.Picture = LoadPicture("")
End Sub
Sub showbmp()
For cnt = 1 To a
j = cnt Mod PicInfo.bmWidth
i = (cnt - j) / PicInfo.bmWidth
SetPixel Picture1.hdc, j, i, RGB(PicBits2(cnt), PicBits2(cnt), PicBits2(cnt))
Next cnt
Picture1.Refresh
End Sub





Private Sub dbdjb_Click()
pretreat
For cnt = 1 To a
PicBits2(cnt) = PicBits1(cnt) / 2
Next cnt
showbmp
End Sub

Private Sub dtlb_Click()
pretreat
i = CLng(InputBox("请输入a值："))
j = CLng(InputBox("请输入b值："))
FFTFilterImage PicBits1(1), PicBits2(1), PicInfo.bmWidth, PicInfo.bmHeight, i, j
showbmp
End Sub

Private Sub dtlb2_Click()
Dim r!, re() As Single, im() As Single, ii&, jj&
ii = CLng(InputBox("请输入a值："))
jj = CLng(InputBox("请输入b值："))
pretreat
ReDim re(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single
ReDim im(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single
For i = 1 To a
re(i) = PicBits1(i)
im(i) = 0
Next i
FFT2 re(1), im(1), 1, PicInfo.bmWidth, PicInfo.bmHeight
'不要灰度变换
For cnt = 1 To a
j = cnt Mod PicInfo.bmWidth
i = (cnt - j) / PicInfo.bmWidth + 1
If j = 0 Then j = PicInfo.bmWidth
r = Sqr((i - PicInfo.bmWidth / 2 - 0.5) ^ 2 + (j - PicInfo.bmHeight / 2 - 0.5) ^ 2)
If r >= ii And r <= jj Then
re(cnt) = re(cnt)
im(cnt) = im(cnt)
Else
re(cnt) = 0
im(cnt) = 0
End If
Next cnt
FFT2 re(1), im(1), -1, PicInfo.bmWidth, PicInfo.bmHeight
For i = 1 To a
If re(i) > 255 Then re(i) = 255
If re(i) < 0 Then re(i) = 0
PicBits2(i) = re(i)
Next i
showbmp
End Sub

Private Sub fx_Click()
pretreat
For i = 1 To a
PicBits2(i) = 255 - PicBits1(i)
Next i
showbmp
End Sub

Private Sub gxhxsjz_Click()
Dim re() As Single, im() As Single
pretreat
ReDim re(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single, im(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single
For i = 1 To PicInfo.bmWidth * PicInfo.bmHeight
re(i) = PicBits1(i)
im(i) = 0
Next i
pretreat
FFT2 re(1), im(1), 1, PicInfo.bmWidth, PicInfo.bmHeight
Picture2.Cls
Picture2.Print "光学FFT后像素矩阵"
For i = CInt(InputBox("请输入上标值：")) To CInt(InputBox("请输入下标值："))
Picture2.Print re(i) & "+" & im(i) & "i,";
If (i Mod 6) = 0 Then Picture2.Print
Next i
End Sub

Private Sub gxpp1_Click()
pretreat
FFTImage PicBits1(1), PicBits2(1), PicInfo.bmWidth, PicInfo.bmHeight
showbmp
End Sub


Private Sub lbhppxsjz_Click()
pretreat
i = CLng(InputBox("请输入a值："))
j = CLng(InputBox("请输入b值："))
FFTFilter PicBits1(1), PicBits2(1), PicInfo.bmWidth, PicInfo.bmHeight, i, j
Picture2.Cls
Picture2.Print "滤波后频谱像素矩阵"
For i = CInt(InputBox("请输入上标值：")) To CInt(InputBox("请输入下标值："))
Picture2.Print "b" & i & "=" & PicBits2(i);
If (i Mod 10) = 0 Then Picture2.Print
Next i
End Sub

Private Sub lbhxsjz_Click()
pretreat
i = CLng(InputBox("请输入a值："))
j = CLng(InputBox("请输入b值："))
FFTFilterImage PicBits1(1), PicBits2(1), PicInfo.bmWidth, PicInfo.bmHeight, i, j
Picture2.Cls
Picture2.Print "滤波后像素矩阵"
For i = CInt(InputBox("请输入上标值：")) To CInt(InputBox("请输入下标值："))
Picture2.Print "b" & i & "=" & PicBits2(i);
If (i Mod 10) = 0 Then Picture2.Print
Next i
End Sub

Private Sub lbpptx2_Click()
Dim re() As Single, im() As Single, ii&, jj&
Dim r!
ii = CLng(InputBox("请输入a值："))
jj = CLng(InputBox("请输入b值："))
pretreat
ReDim re(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single
ReDim im(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single
For i = 1 To a
re(i) = PicBits1(i)
im(i) = 0
Next i
FFT2 re(1), im(1), 1, PicInfo.bmWidth, PicInfo.bmHeight
For i = 1 To a
re(i) = Sqr(re(i) ^ 2 + im(i) ^ 2)
Next i
'不要灰度变换
For cnt = 1 To a
j = cnt Mod PicInfo.bmWidth
If j = 0 Then j = PicInfo.bmWidth
i = (cnt - j) / PicInfo.bmWidth + 1
r = Sqr((i - 64.5) ^ 2 + (j - 64.5) ^ 2)
If r >= ii And r <= jj Then
re(cnt) = re(cnt)
Else
re(cnt) = 0
End If
If re(cnt) > 255 Then PicBits2(cnt) = 255
If re(cnt) < 0 Then PicBits2(cnt) = 0
If re(cnt) <= 255 And re(cnt) >= 0 Then PicBits2(cnt) = re(cnt)
Next cnt
showbmp
End Sub

Private Sub load_Click()
Picture1.Picture = LoadPicture(App.Path & "\test.bmp")
Picture2.Left = Picture1.Width
End Sub

Private Sub lvpptx1_Click()
pretreat
i = CLng(InputBox("请输入a值："))
j = CLng(InputBox("请输入b值："))
FFTFilter PicBits1(1), PicBits2(1), PicInfo.bmWidth, PicInfo.bmHeight, i, j
showbmp
End Sub

Private Sub pptxxsjz_Click()
pretreat
FFTImage PicBits1(1), PicBits2(1), PicInfo.bmWidth, PicInfo.bmHeight
Picture2.Cls
Picture2.Print "频谱图像像素矩阵"
For i = CInt(InputBox("请输入上标值：")) To CInt(InputBox("请输入下标值："))
Picture2.Print "b" & i & "=" & PicBits2(i);
If (i Mod 10) = 0 Then Picture2.Print
Next i
End Sub

Private Sub qqytg_Click()
Dim re() As Single, im() As Single
pretreat
ReDim re(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single
ReDim im(1 To PicInfo.bmWidth * PicInfo.bmHeight) As Single
For i = 1 To a
re(i) = PicBits1(i)
im(i) = 0
Next i
FFT2 re(1), im(1), 1, PicInfo.bmWidth, PicInfo.bmHeight
FFT2 re(1), im(1), -1, PicInfo.bmWidth, PicInfo.bmHeight
For i = 1 To a
If re(i) < 0 Then re(i) = 0
If re(i) > 255 Then re(i) = 255
PicBits2(i) = re(i)
Next i
showbmp
End Sub

Private Sub save_Click()
SavePicture Picture2.Image, "xsjz.bmp"
End Sub

Private Sub yxsjz_Click()
pretreat
Picture2.Cls
Picture2.Print "原像素矩阵"
For i = CInt(InputBox("请输入上标值：")) To CInt(InputBox("请输入下标值："))
Picture2.Print "a" & i & "=" & PicBits1(i);
If (i Mod 10) = 0 Then Picture2.Print
Next i
End Sub