gray.frm

GDI 图形处理

    If Enc = 0 Then
        MsgBox "SelectObject Error"
        Exit Sub
    End If
    Enc = BitBlt(iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, PicFrm.hdc, 0, 0, vbSrcCopy)
    If Enc = 0 Then
        MsgBox "BitBlt Error"
        Exit Sub
    End If
    Enc = GetDIBits(iDC, iBitmap, 1, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS)
    If Enc = 0 Then
        MsgBox "GetDibits Error"
        Exit Sub
    End If
    Enc = DeleteDC(iDC)
    If Enc = 0 Then
        MsgBox "DeleteDC Error"
        Exit Sub
    End If
    Enc = DeleteObject(iBitmap)
    If Enc = 0 Then
        MsgBox "DeleteObject Error"
        Exit Sub
    End If
    
'\\\\\\\\\\\\\\\
Grayinx = 0
  For Cnt = LBound(bBytes) To bBytesAryMax Step 3
        
        bRed = bBytes(Cnt)
        bGreen = bBytes(Cnt + 1)
        bBlue = bBytes(Cnt + 2)
        Tmp = (9798 * bRed + 19235 * bGreen + 3735 * bBlue) \ 32768
        Tmp = Tmp * ZoomV
        If Tmp > 255 Then Tmp = 255
        Tmp = Tmp And Graykval
        Grayval(Grayinx) = Tmp
        Grayinx = Grayinx + 1
    Next Cnt


'\\\\\\\\\\\\\\\\\\\\\\\\\\



'\\\\\\\\\\\\\\\\\\\\\\\\\\\
' Sobe算子  GM＝|G+2*H+I-A-2*B-C|+|A+2*D+G-C-2*F-I|
ReDim Tmpbytes(bBytesAryMax) As Byte
Tmp = GrayAryMax
If Tmp <> BmpWidth * BmpHeight Then Exit Sub
For Hinx = 1 To BmpHeight - 3
    For Winx = 1 To BmpWidth
        Tmp1 = (Hinx - 1) * BmpWidth + Winx
        A = Grayval(Tmp1 - 1)
        B = Grayval(Tmp1)
        C = Grayval(Tmp1 + 1)
        
        Tmp2 = Hinx * BmpWidth + Winx
        D = Grayval(Tmp2 - 1)
        E = Grayval(Tmp2)
        F = Grayval(Tmp2 + 1)
        
        Tmp3 = (Hinx + 1) * BmpWidth + Winx
        G = Grayval(Tmp3 - 1)
        H = Grayval(Tmp3)
        I = Grayval(Tmp3 + 1)
        
        Tmp2 = Abs(G + H * 2 + I - A - B * 2 - C)
        Tmp3 = Abs(A + D * 2 + G - C - F * 2 - I)
        Tmp = Abs(Tmp2 + Tmp3)
        
        If Tmp > Kval Then
            Tmp = 255
        'Else
           ' Tmp = 0
        End If
        Tmp2 = Tmp1 * 3
        Tmpbytes(Tmp2 - 2) = Tmp
        Tmpbytes(Tmp2 - 1) = Tmp
        Tmpbytes(Tmp2) = Tmp
    Next Winx
Next Hinx
    Enc = SetDIBitsToDevice(PicFrm.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, _
            0, 0, 0, bi24BitInfo.bmiHeader.biHeight, Tmpbytes(1), bi24BitInfo, DIB_RGB_COLORS)
    If Enc = 0 Then
        MsgBox "SetDiBitsToDevice Error"
        Exit Sub
    End If
    PicFrm.Refresh

'\\\\\\\\\\\\\\\\\\\\\\\\\\\
Tmp = GetTickCount
Tmp = Tmp - T
Text2.Text = Tmp & " ms"
Working = False
Exit Sub
err:
MsgBox "error" & Error
End Sub

Private Sub CapBMP_Click()
If Working = True Then Exit Sub Else Working = True
Dim iBitmap As Long, iDC As Long
Dim Enc As Long
Dim CS As CREATESTRUCT
Dim Rec As RECT, WinWidth As Long, WinHeight As Long
Dim WinRgn As Long
Dim Tmp As Long, Tmp1 As Long, T As Long

On Error GoTo err
SetWindowPos m_Picfrmhwnd, HWND_TOPMOST, -m_PicfrmW, 0, m_PicfrmW, m_PicfrmH, SWP_NOACTIVATE Or SWP_SHOWWINDOW ' Or SWP_DRAWFRAME  'Or SWP_NOMOVE 'Or SWP_NOSIZE
Enc = GetWindowRect(Capfrm.hwnd, Rec)
m_PicfrmW = Rec.Right - Rec.Left
m_PicfrmH = Rec.Bottom - Rec.Top
BmpWidth = Abs(m_PicfrmW - m_WinfraW * 2)
BmpHeight = Abs(m_PicfrmH - m_WinfraH - 4)
BlotXmax = BmpWidth: BlotYmax = BmpHeight
T = GetTickCount
If BmpWidth = 0 Or BmpHeight = 0 Then GoTo err
If BmpWidth < 30 Then GoTo err
PixelTotal = BmpWidth * BmpHeight
Text3.Text = BmpWidth & "×" & BmpHeight
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = BmpWidth
        .biHeight = BmpHeight
    End With
    Tmp = BmpWidth * BmpHeight
    bBytesAryMax = Tmp * 3
    GrayAryMax = Tmp
    iDC = 0
    iDC = CreateCompatibleDC(0)
    If iDC = 0 Then GoTo err
    iBitmap = 0
    iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    If iBitmap = 0 Then GoTo err
    Enc = SelectObject(iDC, iBitmap)
    If Enc = 0 Then GoTo err
    Enc = BitBlt(iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, Capfrm.hdc, 0, 0, vbSrcCopy)
    If Enc = 0 Then GoTo err
    Enc = GetDIBits(iDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS)
    If Enc = 0 Then GoTo err
    Enc = DeleteDC(iDC)
    If Enc = 0 Then GoTo err
    Enc = DeleteObject(iBitmap)
    If Enc = 0 Then GoTo err
    
    Enc = StretchBlt(PicFrm.hdc, 0, 0, BmpWidth, BmpHeight, Capfrm.hdc, 0, 0, BmpWidth, BmpHeight, vbSrcCopy)
    'If Enc = 0 Then GoTo err
    DoEvents
    If Enc = 0 Then GoTo err
    PicFrm.Refresh
SetWindowPos m_Picfrmhwnd, HWND_TOPMOST, m_DisplayW - m_PicfrmW, 0, m_PicfrmW, m_PicfrmH, SWP_NOACTIVATE Or SWP_SHOWWINDOW ' Or SWP_DRAWFRAME 'Or SWP_NOMOVE 'Or SWP_NOSIZE
Working = False
Tmp = GetTickCount
Tmp = Tmp - T
Text2.Text = Tmp & " ms"
Exit Sub
err:
Working = False
MsgBox "Error" & Error
End Sub











Private Sub capture_Click()
CapBMP_Click
End Sub

Private Sub Command1_Click()
If Working = True Then Exit Sub Else Working = True
Dim iBitmap As Long, iDC As Long
Dim bBlue As Long, bRed As Long, bGreen As Long
Dim Tmp As Single, T As Long
Dim Tmpbytes() As Byte
On Error GoTo err
Dim Enc As Long
Dim CS As CREATESTRUCT
T = GetTickCount

'\\\\\\\\\\\\\\
If BmpWidth = 0 Or BmpHeight = 0 Then Exit Sub
If BmpWidth < 30 Then GoTo err
PixelTotal = BmpWidth * BmpHeight
Text3.Text = BmpWidth & "×" & BmpHeight
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = BmpWidth
        .biHeight = BmpHeight
    End With
'    ReDim bBytes(1 To BmpWidth * BmpHeight * 3) As Byte
    iDC = CreateCompatibleDC(0)
    If iDC = 0 Then GoTo err
    iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    If iBitmap = 0 Then GoTo err
    Enc = SelectObject(iDC, iBitmap)
    If Enc = 0 Then GoTo err
    Enc = BitBlt(iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, PicFrm.hdc, 0, 0, vbSrcCopy)
    If Enc = 0 Then GoTo err
    Enc = GetDIBits(iDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS)
    If Enc = 0 Then GoTo err
    
    Enc = DeleteDC(iDC)
    If Enc = 0 Then GoTo err
    Enc = DeleteObject(iBitmap)
    If Enc = 0 Then GoTo err
        
'\\\\\\\\\\\\\\\
ReDim Tmpbytes(bBytesAryMax) As Byte
'灰度指数非线性变换 G(x,y)=(B^C)^(f(x,y)-A)-1
Dim A As Single, B As Single, C As Single
Dim Tmp1 As Single, Tmp2 As Single, G As Single
ReDim Tmpbytes(bBytesAryMax)
A = PowS(0) '50
B = PowS(1) / 100 '0.15
C = PowS(2) / 100 '1.16 'C值小可将变化不大的部分模糊

For Grayinx = 1 To (GrayAryMax) - 1
    Tmp = Grayval(Grayinx)
    Tmp1 = B ^ C
    Tmp2 = Tmp - A
    G = Tmp1 ^ Tmp2 - 1
    If G < 0 Then G = 0
    If G > 255 Then G = 255
    Grayval(Grayinx) = G
    Tmp = Grayinx * 3
    Tmpbytes(Tmp) = G
    Tmpbytes(Tmp - 1) = G
    Tmpbytes(Tmp - 2) = G
Next Grayinx
    Enc = SetDIBitsToDevice(PicFrm.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, 0, 0, 0, bi24BitInfo.bmiHeader.biHeight, Tmpbytes(1), bi24BitInfo, DIB_RGB_COLORS)
    If Enc = 0 Then GoTo err
PicFrm.Refresh
Tmp = GetTickCount
Tmp = Tmp - T
Text2.Text = Tmp & " ms"
Working = False
Exit Sub
err:
Working = False
MsgBox "error" & Error


End Sub

Private Sub Command10_Click()
Select Case FigureS
    Case 0
        SobelFun
    Case 1
        RobertsFun
    Case 2
        LaplaclanFun
End Select
End Sub


Private Sub Command2_Click()
VScroll4(0).Value = 120
VScroll4(1).Value = 130
VScroll4(2).Value = 40
End Sub

Private Sub Command3_Click()
If Command3.Caption = ">" Then
    WinBig
Else
    WinSmall
End If
End Sub



Private Sub Command4_Click()
If Working = True Then Exit Sub Else Working = True
'中值滤波 找出3个像素中的中间值
Dim Winx As Long, Hinx As Long
Dim A As Long, B As Long, C As Long, D As Long, E As Long, F As Long, G As Long, H As Long, I As Long
Dim Tmp As Long, Tmp1 As Long, Tmp2 As Long, Tmp3 As Long, Gm As Byte, T As Long
On Error GoTo err
ReDim Tmpbytes(bBytesAryMax)
ReDim Graytmp(GrayAryMax) As Byte
Tmp = GrayAryMax
T = GetTickCount
If Tmp <> BmpWidth * BmpHeight Then GoTo err
BlotCnt = 0
For Hinx = 1 To BmpHeight - 3
    For Winx = 1 To BmpWidth
        
        Tmp1 = (Hinx - 1) * BmpWidth + Winx
        B = Grayval(Tmp1)
        
        Tmp2 = Hinx * BmpWidth + Winx
        D = Grayval(Tmp2 - 1)
        E = Grayval(Tmp2)
        F = Grayval(Tmp2 + 1)
        
        Tmp3 = (Hinx + 1) * BmpWidth + Winx
        H = Grayval(Tmp3)
        If D > E Then
            If D < F Then
                Tmp = D
            Else
                Tmp = F
            End If
        Else
            If E < F Then
                Tmp = E
            Else
                Tmp = F
            End If
        End If
        Tmp2 = Tmp1 * 3
        Tmpbytes(Tmp2 - 2) = Tmp
        Tmpbytes(Tmp2 - 1) = Tmp
        Tmpbytes(Tmp2) = Tmp
        If Winx = BmpWidth - 1 Then Winx = BmpWidth
    Next Winx
Next Hinx
 
 CopyMemory ByVal VarPtr(Grayval(0)), ByVal VarPtr(Graytmp(0)), GrayAryMax
 
     SetDIBitsToDevice PicFrm.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, _
            0, 0, 0, bi24BitInfo.bmiHeader.biHeight, Tmpbytes(1), bi24BitInfo, DIB_RGB_COLORS
    PicFrm.Refresh
Tmp = GetTickCount
Tmp = Tmp - T
Text2.Text = Tmp & " ms"
Working = False
Exit Sub
err:
Working = False
MsgBox "error" & Error

End Sub

Private Sub Command6_Click()
If Working = True Then Exit Sub Else Working = True
Dim iBitmap As Long, iDC As Long
Dim bBlue As Long, bRed As Long, bGreen As Long
Dim Tmp As Single, T As Long
Dim Tmpbytes() As Byte
On Error GoTo err
Dim Enc As Long
Dim CS As CREATESTRUCT
T = GetTickCount

'\\\\\\\\\\\\\\
If BmpWidth = 0 Or BmpHeight = 0 Then Exit Sub
If BmpWidth < 30 Then GoTo err
PixelTotal = BmpWidth * BmpHeight
Text3.Text = BmpWidth & "×" & BmpHeight
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = BmpWidth
        .biHeight = BmpHeight
    End With
'    ReDim bBytes(1 To BmpWidth * BmpHeight * 3) As Byte
    iDC = CreateCompatibleDC(0)
    If iDC = 0 Then GoTo err
    iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    If iBitmap = 0 Then GoTo err
    Enc = SelectObject(iDC, iBitmap)
    If Enc = 0 Then GoTo err
    Enc = BitBlt(iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, PicFrm.hdc, 0, 0, vbSrcCopy)
    If Enc = 0 Then GoTo err
    Enc = GetDIBits(iDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS)
    If Enc = 0 Then GoTo err
    
    Enc = DeleteDC(iDC)
    If Enc = 0 Then GoTo err
    Enc = DeleteObject(iBitmap)
    If Enc = 0 Then GoTo err
        
'\\\\\\\\\\\\\\\
ReDim Tmpbytes(bBytesAryMax) As Byte
'灰度对数非线性变换 G(x,y)=Log(f(x,y)+1)/(b×Log(c))+a
Dim A As Single, B As Single, C As Single
Dim Tmp1 As Single, Tmp2 As Single
ReDim Tmpbytes(bBytesAryMax)
A = LogS(0) '50
B = LogS(1) / 100 '0.15
C = LogS(2) / 100 '1.16 'C值小可将变化不大的部分模糊

For Grayinx = 1 To (GrayAryMax) - 1
    Tmp = Grayval(Grayinx)
    Tmp1 = Log(C)
    Tmp2 = 1 / (B * Tmp1)
    Tmp3 = Log(Tmp + 1)
    G = (Tmp3) * Tmp2 + A
    If G > 255 Then G = 255