getgray.bas

在VB里调入显示图像

Attribute VB_Name = "Getgray"
Option Explicit
Option Base 1
'Public gausswidth As Integer      '二维高斯窗口宽度
'Public sigma As Double          '高斯函数的方差
'Public size As Integer         '非极大值抑制的领域宽度
'Public thresh As Integer       '最终确定角点所需的阈值

'DefLng A-W
'DefSng X-Z
Public PicGray1() As Double, PicGray2() As Double
Public PICW As Long, PICH As Long, m As Integer, n As Integer             ' Display picbox Width & Height (pixels)
Public palbgr() As Byte
' To hold 3 full palettes (12 x PICW x PICH)
Public PalBGR2() As Byte
Public PalBGR3() As Byte
Public PalBGR4() As Byte
Public PalBGR5() As Byte
Public PalBGRPtr As Long

'*********************************************************
    Public OriAimR  As Integer  '一级匹配目标窗口半径
    Public OriSearchR As Integer  '一级匹配搜索窗口半径
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

Public Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal HDC As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long
Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpbi As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal HDC As Long) As Long
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal Lenbmp As Long, dimbmp As Any) As Long

Public Declare Function StretchDIBits Lib "gdi32" (ByVal HDC As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal DesW As Long, ByVal DesH As Long, _
ByVal SrcX As Long, ByVal SrcY As Long, _
ByVal PICWW As Long, ByVal PICHH As Long, _
lpBits As Any, lpBitsInfo As BITMAPINFO, _
ByVal wUsage As Long, ByVal dwRop As Long) As Long


Public Type BITMAPFILEHEADER
        bfType As Integer
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
End Type

Public Type BITMAP
   bmType As Long              ' Type of bitmap
   bmWidth As Long             ' Pixel width
   bmHeight As Long            ' Pixel height
   bmWidthBytes As Long        ' Byte width = 3 x Pixel width
   bmPlanes As Integer         ' Color depth of bitmap
   bmBitsPixel As Integer      ' Bits per pixel, must be 16 or 24
   bmBits As Long              ' This is the pointer to the bitmap data  !!!
End Type

'NB PICTURE STORED IN MEMORY UPSIDE DOWN
'WITH INCREASING MEMORY GOING UP THE PICTURE
'bmp.bmBits points to the bottom left of the picture

Public bmp As BITMAP
'------------------------------------------------------------------------------

' Structures for StretchDIBits
Public Type BITMAPINFOHEADER ' 40 bytes
   biSize As Long
   biwidth As Long
   biheight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Public Type BITMAPINFO
   bmiH As BITMAPINFOHEADER
   'bmiH As RGBTRIPLE            'NB Palette NOT NEEDED for 16,24 & 32-bit
End Type
Public bm As BITMAPINFO

Dim ObjWin As Integer

Public Sub GETDIBS(ByVal PICIM As Long)                           '获取像素？
    Dim NewDC, OldH, BytesPerScanLine, PadBytesPerScanLine, ret
    GetObjectAPI PICIM, Len(bmp), bmp
    NewDC = CreateCompatibleDC(0&)
    OldH = SelectObject(NewDC, PICIM)
    With bm.bmiH
       .biSize = 40
       .biwidth = bmp.bmWidth
       .biheight = bmp.bmHeight
       .biPlanes = 1
       .biBitCount = 32
       .biCompression = 0
       BytesPerScanLine = ((((.biwidth * .biBitCount) + 31) \ 32) * 4)
       PadBytesPerScanLine = _
           BytesPerScanLine - (((.biwidth * .biBitCount) + 7) \ 8)
       .biSizeImage = BytesPerScanLine * Abs(.biheight)
    End With
    ReDim palbgr(4, PICW, PICH)
    ReDim PalBGR2(4, PICW, PICH)
    ret = GetDIBits(NewDC, PICIM, 1, PICH, PalBGR2(1, 1, 1), bm, 1)
    ret = GetDIBits(NewDC, PICIM, 1, PICH, palbgr(1, 1, 1), bm, 1)
    SelectObject NewDC, OldH
    DeleteDC NewDC
    Exit Sub
    '==========
DIBError:
      MsgBox "Error", vbInformation
      On Error GoTo 0
End Sub

Public Sub ShowPalBGR(pic As PictureBox)
    pic.Picture = LoadPicture()
    pic.AutoRedraw = True
    pic.Width = PICW
    pic.Height = PICH
    PalBGRPtr = VarPtr(PalBGR4(1, 1, 1)) '- 500
    bm.bmiH.biwidth = PICW
    bm.bmiH.biheight = PICH
    If StretchDIBits(pic.HDC, _
       0, 0, _
       PICW, PICH, _
       0, 0, _
       PICW, PICH, _
       ByVal PalBGRPtr, bm, _
       1, vbSrcCopy) = 0 Then
          
          Erase PalBGR4
          MsgBox "Blit Error", vbInformation
          Exit Sub
    End If
    Erase PalBGR4
End Sub
Public Sub ShowPalBGR_RE(pic As PictureBox)
    pic.Picture = LoadPicture()
    pic.AutoRedraw = True
    pic.Width = 70
    pic.Height = 70
    PalBGRPtr = VarPtr(PalBGR3(1, 1, 1)) '- 500
    bm.bmiH.biwidth = 70
    bm.bmiH.biheight = 70
    If StretchDIBits(pic.HDC, _
       0, 0, _
       70, 70, _
       0, 0, _
       70, 70, _
       ByVal PalBGRPtr, bm, _
       1, vbSrcCopy) = 0 Then
          
          Erase PalBGR3
          MsgBox "Blit Error", vbInformation
          Exit Sub
    End If
    Erase PalBGR3
End Sub
Public Sub ShowPalBGR_hd(pic As PictureBox)
    pic.Picture = LoadPicture()
    pic.AutoRedraw = True
    pic.Width = 70
    pic.Height = 70
    PalBGRPtr = VarPtr(PalBGR4(1, 1, 1)) '- 500
    bm.bmiH.biwidth = 70
    bm.bmiH.biheight = 70
    If StretchDIBits(pic.HDC, _
       0, 0, _
       70, 70, _
       0, 0, _
       70, 70, _
       ByVal PalBGRPtr, bm, _
       1, vbSrcCopy) = 0 Then
          
          Erase PalBGR4
          MsgBox "Blit Error", vbInformation
          Exit Sub
    End If
    Erase PalBGR4
End Sub

Public Function ChangeImage(palbgr() As Byte) As Byte
Dim i As Integer
Dim j As Integer
Dim x As Double, a As Double, b As Double, P As Integer, q As Integer
Dim y As Double, c As Double, x0 As Integer, y0 As Integer, d As Integer, e As Integer, x01 As Integer, y01 As Integer, x00 As Integer, y00 As Integer
 ReDim PalBGR3(1 To 4, 1 To 70, 1 To 70)
    For i = 1 To PICW
        For j = 1 To PICH

        a = palbgr(3, i, j)
        b = palbgr(2, i, j)
        c = palbgr(1, i, j)
        If a = 255 And b = 0 And c = 0 Then
            x0 = i
            y0 = j
            i = PICW
            j = PICH
        End If
        Next j
    Next i
    
    
    
    For P = x0 To x0 + 69
        For q = y0 - 34 To y0 + 34
        
        
        PalBGR3(1, P - x0 + 1, q - y0 + 35) = palbgr(1, P, q)
        PalBGR3(2, P - x0 + 1, q - y0 + 35) = palbgr(2, P, q)
        PalBGR3(3, P - x0 + 1, q - y0 + 35) = palbgr(3, P, q)
        palbgr(1, P, q) = 0
        palbgr(2, P, q) = 0
        palbgr(3, P, q) = 0
        Next q
    Next P
    
        
        
End Function
Public Function HDBYJC(palbgr() As Byte) As Byte
    
    'On Error Resume Next
    Dim i As Long
    Dim j As Long
    Dim m As Integer, a As Integer, b As Integer, c As Integer, d As Integer, e As Integer, f As Integer, g As Integer, h As Integer
    Dim n As Integer
    Dim GX As Double, PX As Double, PY As Double
    Dim GY As Double
    
    Dim π As Single
    Dim ChangeGray As Integer
    Dim P(1 To 70, 1 To 70) As Double
    Dim θ(1 To 70, 1 To 70) As Double
    ReDim PalBGR4(1 To 4, 1 To 70, 1 To 70)
    π = 3.1415926
    'Call FillMemory(PalBGR4(1, 1, 1), PICW * PICH * 4, 255)
    For i = 1 To 70
        For j = 1 To 70
        ChangeGray = 0.299 * palbgr(1, i, j) + 0.587 * palbgr(2, i, j) + 0.114 * palbgr(3, i, j)
        PalBGR4(1, i, j) = ChangeGray
        PalBGR4(2, i, j) = ChangeGray
        PalBGR4(3, i, j) = ChangeGray
        Next j
    Next i
   '高斯卷积
    For i = 2 To 69
        For j = 2 To 69
            PalBGR4(1, i, j) = (PalBGR4(1, i - 1, j + 1) + PalBGR4(1, i, j + 1) * 2 + PalBGR4(1, i + 1, j + 1) + PalBGR4(1, i - 1, j) * 2 + PalBGR4(1, i, j) * 4 + PalBGR4(1, i + 1, j) * 2 + PalBGR4(1, i - 1, j - 1) + PalBGR4(1, i, j - 1) * 2 + PalBGR4(1, i + 1, j - 1)) / 16
            PalBGR4(2, i, j) = PalBGR4(1, i, j)
            PalBGR4(3, i, j) = PalBGR4(1, i, j)
        Next j
    Next i
    '求梯度大小和方向
    
    For i = 2 To 69
        For j = 2 To 69
        a = PalBGR4(1, i + 1, j - 1)
        b = PalBGR4(1, i - 1, j)
        e = PalBGR4(1, i - 1, j + 1)
        f = PalBGR4(1, i - 1, j - 1)
        c = PalBGR4(1, i + 1, j + 1)
        d = PalBGR4(1, i + 1, j)
        g = PalBGR4(1, i, j + 1)
        h = PalBGR4(1, i, j - 1)
        PX = (c - e + d - b + a - f) / 3
        PY = (e - f + g - h + c - a) / 3
        P(i, j) = Sqr(PX ^ 2 + PY ^ 2)
        If PX <> 0 Then
            θ(i, j) = Atn(PY / PX)
        ElseIf PX = 0 And PY <> 0 Then
            θ(i, j) = π / 2
        End If
        Next j
    Next i
    '对梯度幅值进行非极大值抑制
    
    For i = 2 To 69
        For j = 2 To 69
        If θ(i, j) >= -22.5 * π / 180 And θ(i, j) <= 22.5 * π / 180 Then
            If P(i, j) <= P(i - 1, j) Or P(i, j) <= P(i + 1, j) Then
                PalBGR4(1, i, j) = 0
                PalBGR4(2, i, j) = 0
                PalBGR4(3, i, j) = 0
            End If
        ElseIf θ(i, j) > 22.5 * π / 180 And θ(i, j) <= 67.5 * π / 180 Then
            If P(i, j) <= P(i + 1, j + 1) Or P(i, j) <= P(i - 1, j - 1) Then
                PalBGR4(1, i, j) = 0
                PalBGR4(2, i, j) = 0
                PalBGR4(3, i, j) = 0
            End If
        ElseIf θ(i, j) > 67.5 * π / 180 And θ(i, j) < π / 2 Or θ(i, j) > -π / 2 And θ(i, j) < -67.5 * π / 180 Then
            If P(i, j) <= P(i, j + 1) Or P(i, j) <= P(i, j - 1) Then
                PalBGR4(1, i, j) = 0
                PalBGR4(2, i, j) = 0
                PalBGR4(3, i, j) = 0
            End If
        ElseIf θ(i, j) >= -67.5 * π / 180 And θ(i, j) < -22.5 * π / 180 Then
            If P(i, j) <= P(i - 1, j + 1) Or P(i, j) <= P(i - 1, j + 1) Then
                PalBGR4(1, i, j) = 0
                PalBGR4(2, i, j) = 0
                PalBGR4(3, i, j) = 0
            End If
        End If
        Next j
    Next i
    For i = 1 To 70
        For j = 1 To 70
        If PalBGR4(1, i, j) < 100 Then
            PalBGR4(1, i, j) = 0
            PalBGR4(2, i, j) = 0
            PalBGR4(3, i, j) = 0
        End If
        Next j
    Next i
        
            
              
        
    
        
        
        
        
            
    
End Function