gray.frm

GDI 图形处理

         Width           =   1150
      End
      Begin VB.OptionButton Option1 
         Caption         =   "低通滤波2"
         Height          =   255
         Index           =   1
         Left            =   120
         TabIndex        =   11
         Top             =   480
         Width           =   1150
      End
      Begin VB.OptionButton Option1 
         Caption         =   "低通滤波1"
         Height          =   255
         Index           =   0
         Left            =   120
         TabIndex        =   10
         Top             =   240
         Value           =   -1  'True
         Width           =   1150
      End
   End
   Begin VB.Frame Frame1 
      Height          =   1665
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   1935
      Begin VB.CommandButton Command4 
         Caption         =   "Command4"
         Height          =   375
         Left            =   1560
         TabIndex        =   96
         Top             =   1200
         Width           =   255
      End
      Begin VB.CommandButton AutoCmd 
         Caption         =   "&Auto"
         Height          =   300
         Left            =   1000
         TabIndex        =   8
         Top             =   240
         Width           =   820
      End
      Begin VB.TextBox Text3 
         Enabled         =   0   'False
         Height          =   270
         Left            =   720
         Locked          =   -1  'True
         TabIndex        =   6
         TabStop         =   0   'False
         Text            =   "100 * 100"
         Top             =   1245
         Width           =   1095
      End
      Begin VB.TextBox Text2 
         Enabled         =   0   'False
         Height          =   270
         Left            =   720
         Locked          =   -1  'True
         TabIndex        =   4
         TabStop         =   0   'False
         Text            =   "00"
         Top             =   960
         Width           =   1095
      End
      Begin VB.CommandButton Undo 
         Caption         =   "Undo"
         Height          =   300
         Left            =   120
         TabIndex        =   3
         Top             =   600
         Width           =   820
      End
      Begin VB.CommandButton CapBMP 
         Caption         =   "扑捉"
         Height          =   300
         Left            =   120
         TabIndex        =   2
         Top             =   240
         Width           =   820
      End
      Begin VB.CommandButton Gray 
         Caption         =   "Gray"
         Height          =   300
         Left            =   1000
         TabIndex        =   1
         Top             =   600
         Width           =   820
      End
      Begin VB.Label Label3 
         Caption         =   "大小："
         Height          =   255
         Left            =   120
         TabIndex        =   7
         Top             =   1275
         Width           =   735
      End
      Begin VB.Label Label2 
         Caption         =   "耗时："
         Height          =   255
         Left            =   120
         TabIndex        =   5
         Top             =   960
         Width           =   735
      End
   End
End
Attribute VB_Name = "Gray"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const ENUM_CURRENT_SETTINGS As Long = -1&
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const ABS_AUTOHIDE = &H1
Const ABS_ONTOP = &H2
Const ABM_GETSTATE = &H4
Const ABM_GETTASKBARPOS = &H5

Private Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
Private 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
Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type

Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
Const SWP_DRAWFRAME = &H20
Const SWP_FRAMECHANGED = &H20        '  The frame changed: send WM_NCCALCSIZE

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Const WS_EX_STATICEDGE = &H20000
Const WS_EX_TRANSPARENT = &H20&
Const WS_CHILD = &H40000000
Const CW_USEDEFAULT = &H80000000
Const SW_NORMAL = 1
Private Type CREATESTRUCT
    lpCreateParams As Long
    hInstance As Long
    hMenu As Long
    hWndParent As Long
    cy As Long
    cx As Long
    Y As Long
    X As Long
    style As Long
    lpszName As String
    lpszClass As String
    ExStyle As Long
End Type
Private Type BlotWidth
    X1 As Long
    X2 As Long
End Type
Private Type BlotHeight
    Y1 As Long
    Y2 As Long
End Type
Private Type APPBARDATA
        cbSize As Long
        hwnd As Long
        uCallbackMessage As Long
        uEdge As Long
        rc As RECT
        lParam As Long '  message specific
End Type
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRECT As RECT) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private 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
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function SetColorAdjustment Lib "gdi32" (ByVal hdc As Long, lpca As COLORADJUSTMENT) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SHAppBarMessage Lib "Shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
'''''''''''''
Private bCancel As Boolean
'hotkey
Dim bi24BitInfo As BITMAPINFO, Cnt As Long
Dim bBytes() As Byte, Grayval() As Byte, bBytesAryMax As Long, GrayAryMax As Long
Dim Grayinx As Long, Redval() As Byte, Greenval() As Byte, Blueval() As Byte
Dim GrayMax As Byte, GrayMin As Byte
Dim Working As Boolean, WorkTim As Long
Dim Kval As Byte, Graykval As Byte, ZoomV As Single
'Dim Blot(1600, 1200) As Byte, BlotXmax As Long, BlotYmax As Long
Dim Blot(1024, 768) As Byte, BlotXmax As Long, BlotYmax As Long, BlotCnt As Long
Dim BlotCode(1024, 768) As RECT
Dim Tmpbytes() As Byte
Dim LFilterSel As Byte, HFilterSel As Byte
Dim BlotSize(2) As Byte, LogS(2) As Byte, LimitV(1) As Byte, FigureS As Byte
Dim PowS(2) As Byte




Private Sub AdjGray_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 Long, T As Long
Dim Tmpbytes() As Byte
'Dim Grayval() As Byte
'Dim bBytes() As Byte
On Error GoTo err
'ReDim GrayCnt(255) As Long, RedCnt(255) As Long, GreenCnt(255) As Long, BlueCnt(255) As Long
Dim Enc As Long
Dim CS As CREATESTRUCT
T = GetTickCount

'\\\\\\\\\\\\\\
If BmpWidth = 0 Or BmpHeight = 0 Then Exit Sub
If BmpWidth < 30 Then
        MsgBox "error"
        Exit Sub
    End If
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)=((d-c) *( f(x,y)-a))/(b-a)+c
Dim A As Long, B As Long, C As Long, D As Long, G As Long
ReDim Tmpbytes(bBytesAryMax)
A = GrayMin
B = GrayMax
C = LimitV(1) '10
D = LimitV(0) '240
Tmp2 = B - A
For Grayinx = 1 To (GrayAryMax) - 1
    Tmp = Grayval(Grayinx)
    G = (230 * (Tmp - A)) / Tmp2 + 10
    If G > 255 Then G = 255
    'G = G And Graykval
    If G < 0 Then G = 0
    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 Adjcmd_Click()
Adj.Show
End Sub

Private Sub AutoCmd_Click()
On Error GoTo err
Dim iBitmap As Long, iDC As Long
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 Single, Tmp1 As Long, Tmp2 As Long, Tmp3 As Long, Gm As Byte, T As Long
Dim bBlue As Long, bRed As Long, bGreen As Long
Dim Enc As Long
Dim CS As CREATESTRUCT
'\\\\\\\\\\\\\\
m_PicfrmW = m_CapfrmW
m_PicfrmH = m_CapfrmH
Enc = SetWindowPos(m_Picfrmhwnd, HWND_TOPMOST, 10, 300, m_PicfrmW, m_PicfrmH, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_DRAWFRAME Or SWP_NOMOVE) 'Or SWP_NOSIZE
If Enc = 0 Then MsgBox "SetWindowPos Picfrm Error"
'\\\\\\\\\\\\\\\\
T = GetTickCount
CapBMP_Click
Tmp = bBytesAryMax
If Tmp = 0 Then GoTo err
'ReDim Grayval(Tmp / 3) As Byte
ReDim Tmpbytes(Tmp) As Byte


'\\\\\\\\\\\\\\
If BmpWidth = 0 Or BmpHeight = 0 Then Exit Sub
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = BmpWidth
        .biHeight = BmpHeight
    End With
'    ReDim bBytes(1 To bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3) As Byte
    iDC = CreateCompatibleDC(0)
    If iDC = 0 Then
        MsgBox "CreateCompatibleDC Error"
        Exit Sub
    End If
    iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    If iBitmap = 0 Then
        MsgBox "CreateDIBSection Error"
        Exit Sub
    End If
    Enc = SelectObject(iDC, iBitmap)