如何用vb将图片二值化？

Question

本帖最后由 wtime101 于 2010-09-17 14:04:41 编辑

Answer 1

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private tmpPic As Picture
Private Sub Form_Load()
    Picture1.ScaleMode = 3
    Picture1.AutoRedraw = True
    Set tmpPic = Picture1.Picture
End SubPrivate Sub Command1_click()
'灰度
    Dim width5  As Long, heigh5 As Long, rgb5 As Long
    Dim hdc5 As Long, i As Long, j As Long
    Dim bBlue As Long, bRed As Long, bGreen As Long
    Dim y As Long
    
    width5 = Picture1.ScaleWidth
    heigh5 = Picture1.ScaleHeight
    hdc5 = Picture1.hdc
    For i = 1 To width5
        For j = 1 To heigh5
            rgb5 = GetPixel(hdc5, i, j)
            bBlue = Blue(rgb5)      '获得兰色值
            bRed = Red(rgb5)        '获得红色值
            bGreen = Green(rgb5)    '获得绿色值
            '将三原色转换为灰度
            y = (9798 * bRed + 19235 * bGreen + 3735 * bBlue) \ 32768
            '将灰度转换为RGB
            rgb5 = RGB(y, y, y)
            SetPixelV hdc5, i, j, rgb5
        Next j
    Next i
    Set Picture1.Picture = Picture1.Image
End SubPrivate Function Red(ByVal mlColor As Long) As Long
    '从RGB值中获得红色值
    Red = mlColor And &HFF
End Function
Private Function Green(ByVal mlColor As Long) As Long
    '从RGB值中获得绿色值
    Green = (mlColor \ &H100) And &HFF
End Function
Private Function Blue(ByVal mlColor As Long) As Long
    ''从RGB值中获得蓝色值
    Blue = (mlColor \ &H10000) And &HFF
End Function

Answer 2

TO  Kill2010
你那不是二值化，只是把图片转为灰色了

Answer 3

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private tmpPic As Picture
Private Sub Form_Load()
    Picture1.ScaleMode = 3
    Picture1.AutoRedraw = True
    Set tmpPic = Picture1.Picture
End SubPrivate Sub Command1_click()
'灰度
    Dim width5  As Long, heigh5 As Long, rgb5 As Long
    Dim hdc5 As Long, i As Long, j As Long
    Dim bBlue As Long, bRed As Long, bGreen As Long
    Dim y As Long
    
    width5 = Picture1.ScaleWidth
    heigh5 = Picture1.ScaleHeight
    hdc5 = Picture1.hdc
    For i = 1 To width5
        For j = 1 To heigh5
            rgb5 = GetPixel(hdc5, i, j)
            bBlue = Blue(rgb5)      '获得兰色值
            bRed = Red(rgb5)        '获得红色值
            bGreen = Green(rgb5)    '获得绿色值
            '将三原色转换为灰度
            y = (9798 * bRed + 19235 * bGreen + 3735 * bBlue) \ 32768
            '将灰度转换为RGB
            If y > 72 Then '这个数字可以修改一下看看效果
                rgb5 = RGB(255, 255, 255)
            Else
                rgb5 = RGB(0, 0, 0)
            End If
            SetPixelV hdc5, i, j, rgb5
        Next j
    Next i
    Set Picture1.Picture = Picture1.Image
End SubPrivate Function Red(ByVal mlColor As Long) As Long
    '从RGB值中获得红色值
    Red = mlColor And &HFF
End Function
Private Function Green(ByVal mlColor As Long) As Long
    '从RGB值中获得绿色值
    Green = (mlColor \ &H100) And &HFF
End Function
Private Function Blue(ByVal mlColor As Long) As Long
    ''从RGB值中获得蓝色值
    Blue = (mlColor \ &H10000) And &HFF
End Function

Answer 4

呵呵，是0和1，但不是 byte类型的0和1，是bit级别的。显然楼主对这个问题本身的了解也不清除，而KillAllCoder如果你用过PS，你可以去了解下PS的位图模式的图像，楼主想得到的是这种。
    

Answer 5

TO  KillAllCoder
我写的代码跟你们的差不多，实现的结果也一样，但是当我用一个小的画图软件打开转化后的图片文件时会报出这样的提示“Bitmaps containing more than 256 colors are not currently supported.”
我的意思是针对这个提示应该怎么修改程序。
由于小弟对这一块不怎么熟悉，可能提问题时，表述的不怎么清晰，望大家谅解。
谢谢！！！

Answer 6

            If y > 120 Then '这个数字可以修改一下看看效果
                rgb5 = vbWhite
            Else
                rgb5 = vbBlack
            End If
试试

Answer 7

是不是中间这个图的效果？
http://www.vbaccelerator.com/home/VB/Code/vbMedia/Transparent_GDI_Sprite_Library/article.asp

Answer 8

http://www.vbaccelerator.com/home/VB/Code/vbMedia/Transparent_GDI_Sprite_Library/article.asp

Answer 9

TO KillAllCoder
还是一样的结果，用画图软件打不开，报出一样的提示。

Answer 10

本帖最后由 bcrun 于 2010-09-20 10:14:56 编辑

  

Answer 11

这些已有的代码，保存的文件格式应该都还是32位BMP吧。只是，里面的内容被转化为了，单色，灰度，等。

Answer 12

Option ExplicitPrivate Const DIB_RGB_COLORS As Long = 0
Private Const SRCCOPY As Long = &HCC0020
Private Const BI_RGB As Long = 0&Private Type BITMAPINFOHEADER
    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 TypePrivate Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End TypePrivate Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End TypePrivate Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End TypePrivate Declare Function CreateCompatibleDC Lib "gdi32.dll" ( _
     ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
     ByVal hdc As Long, _
     ByVal nWidth As Long, _
     ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" ( _
     ByVal hdc As Long, _
     ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" ( _
     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 GetDIBits Lib "gdi32.dll" ( _
     ByVal aHDC As Long, _
     ByVal hBitmap As Long, _
     ByVal nStartScan As Long, _
     ByVal nNumScans As Long, _
     ByRef lpBits As Any, _
     ByRef lpBI As BITMAPINFO, _
     ByVal wUsage As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" ( _
     ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" ( _
     ByVal hObject As Long) As Long
Private Declare Function GetBitmapObject Lib "gdi32" Alias "GetObjectA" ( _
    ByVal hBitmap As Long, _
    ByVal cbBuffer As Long, _
    ByRef destBmp As Any) As LongPrivate Sub SavePictureBW(ByVal ctrl As PictureBox, ByVal destfile As String)
    Dim hdcMono As Long, hbmpMono As Long, hbmpOld As Long, dxBlt As Long, dyBlt As Long, success As Long
    Dim numscans As Long, byteswide As Long, totalbytes As Long, lfilesize As Long
    Dim bmpsrc As BITMAP, bmpdst As BITMAP
    Dim bInfo As BITMAPINFO
    Dim bitmaparray() As Byte, fileheader() As Byte
    Dim ff As Integer, by8
    
    'Object's scalemode must be Pixel.
    dxBlt = ctrl.ScaleWidth
    dyBlt = ctrl.ScaleHeight
    
    'Create monochrome bitmap from control.
    hdcMono = CreateCompatibleDC(0)
    hbmpMono = CreateCompatibleBitmap(hdcMono, dxBlt, dyBlt)
    success = GetBitmapObject(hbmpMono, Len(bmpsrc), bmpsrc)
    hbmpOld = SelectObject(hdcMono, hbmpMono)
    success = BitBlt(hdcMono, 0, 0, dxBlt, dyBlt, ctrl.hdc, 0, 0, SRCCOPY)
    
    'Calculate array size needed for bitmap bits (dword aligned)
    numscans = dyBlt
    by8 = dxBlt / 8
    If (dxBlt Mod 8) = 0 And (by8 Mod 4) = 0 Then
       byteswide = by8
    Else
       byteswide = (Int(by8) + 4) - (Int(by8) Mod 4)
    End If
    totalbytes = numscans * byteswide
    ReDim bitmaparray(1 To totalbytes)
    
    'Set BITMAPINFO values to pass to GetDIBits function.
    With bInfo
       .bmiHeader.biSize = Len(.bmiHeader)
       .bmiHeader.biWidth = bmpsrc.bmWidth
       .bmiHeader.biHeight = bmpsrc.bmHeight
       .bmiHeader.biPlanes = bmpsrc.bmPlanes
       .bmiHeader.biBitCount = bmpsrc.bmBitsPixel
       .bmiHeader.biCompression = BI_RGB
    End With
    
    success = GetDIBits(hdcMono, ctrl.Image, 0, numscans, bitmaparray(1), bInfo, DIB_RGB_COLORS)
    
    'bitmaparray should now contain bitmap bit data. Now create bitmap file header.
    ReDim fileheader(1 To &H3E)
    fileheader(1) = &H42 'B
    fileheader(2) = &H4D 'M
    lfilesize = UBound(fileheader) + UBound(bitmaparray)
    fileheader(3) = lfilesize And 255
    fileheader(4) = (lfilesize \ 256) And 255
    fileheader(5) = (lfilesize \ 65536) And 255
    fileheader(6) = (lfilesize \ 16777216) And 255
    fileheader(11) = &H3E 'offset
    fileheader(15) = &H28 'size of bitmapinfoheader
    fileheader(19) = dxBlt And 255
    fileheader(20) = (dxBlt \ 256) And 255
    fileheader(21) = (dxBlt \ 65536) And 255
    fileheader(22) = (dxBlt \ 16777216) And 255
    fileheader(23) = dyBlt And 255
    fileheader(24) = (dyBlt \ 256) And 255
    fileheader(25) = (dyBlt \ 65536) And 255
    fileheader(26) = (dyBlt \ 16777216) And 255
    fileheader(27) = 1
    fileheader(29) = 1
    fileheader(35) = UBound(bitmaparray) And 255
    fileheader(36) = (UBound(bitmaparray) \ 256) And 255
    fileheader(37) = (UBound(bitmaparray) \ 65536) And 255
    fileheader(38) = (UBound(bitmaparray) \ 16777216) And 255
    fileheader(47) = 2
    fileheader(51) = 2
    fileheader(59) = &HFF
    fileheader(60) = &HFF
    fileheader(61) = &HFF
    
    ff = FreeFile
    Open destfile For Binary Access Write As #ff
       Put #ff, , fileheader
       Put #ff, , bitmaparray
    Close #ff
    
    ' Clean up
    Call SelectObject(hdcMono, hbmpOld)
    Call DeleteDC(hdcMono)
    Call DeleteObject(hbmpMono)
End SubPrivate Sub Command1_Click()
    Call SavePictureBW(Picture1, "d:\123.bmp")
End Sub窗体上加一个图片框，scalemode设置为pixel。再加一个按钮。图片框里弄个图片进去。点按钮。这个就是1BIT位图。这代码我要你800分都不过份

Answer 13

各位能否帮我解决webbrowser后台查色的问题？？就是最小化后找某一点的颜色

Answer 14

这段程序可以实现我的要求并且在运行时也是正常的，但是用Setup Factory 7.0做成安装程序后运行这段程序时就会报错！

Answer 15

http://user.qzone.qq.com/631603669?ADUIN=631603669&ADSESSION=1286532882&ADTAG=CLIENT.QQ.2881_MyTip.0&ptlang=2052

Answer 16

shell "alchemy -b -d src.bmp des.bmp",vbHide

Answer 17

TO  zhao4zhong1
这条语句是什么意思，是在原程序上的改动吗？

Answer 18

31楼的这段程序在编辑过程中运行时没问题，但是通过生成的.exe文件运行时就会报错
错误形式的链接为http://user.qzone.qq.com/631603669?ADUIN=631603669&ADSESSION=1286532882&ADTAG=CLIENT.QQ.2881_MyTip.0&ptlang=2052
（实在是上传不了图片）

Answer 19

http://user.qzone.qq.com/631603669?ADUIN=631603669&ADSESSION=1286532882&ADTAG=CLIENT.QQ.2881_MyTip.0&ptlang=2052
麻烦各位在链接的相册里面看看错误的形式
抱歉！！

Answer 20

把十进制R G B分量加起来 然后除以三   得到的商和0-255之间的数来比较   大的是0，小的是1  
通过调节阀值来达到你要求的效果       这样行不?

Answer 21

http://files.cnblogs.com/laviewpbt/%e7%9c%9f%e5%bd%a9%e8%bd%ac%e4%b8%ba%e4%bd%8d%e5%9b%be.rar

Answer 22

http://hi.csdn.net/space-5823404-do-album-picid-652448.html

Answer 23

跟踪了一下,发现是OPEN语句那里出的问题,很怪,不理解.有可能是API使用上的问题.但编译为P代码后无此问题.我看你还是找找laviewpbt吧,早就告诉你了的,他是这方面真正的专家.你看看你这帖子,第一个就看明白你的意图并解析出关键点的就是他.

Answer 24

意思就是利用图像处理命令行程序alchemy处理图像
参考http://www.handmade.com/

Answer 25

http://www.vbaccelerator.com/home/VB/Code/vbMedia/Image_Processing/Floyd-Stucci_Colour_Reduction_Methods_and_Gray_Scaling/article.asp

Answer 26

问题终于解决了，真是谢谢大家的热心帮助和指点。
对了，顺便说一下myjian给出的代码的问题所在：
将Private Sub SavePictureBW(ByVal ctrl As PictureBox, ByVal destfile As String)改成Private Sub SavePictureBW(ByVal ctrl As PictureBox, ByRef destfile As String)即可

Answer 27

使用API函数 GetBitmapBits()
  
Dim PicBits() As Byte
GetBitmapBits Picture1.Image, UBound(PicBits), PicBits(1)

Answer 28

呵呵
由于第一次碰到这样的问题，刚开始比较茫然，希望您能理解！
不过，还想请教您一个问题：
你是用什么方法做到“跟踪了一下,发现是OPEN语句那里出的问题”
由于小弟的水平还属于菜鸟级，对于好多方法还不甚了解。
还请您不厌其烦的解答一下小弟的这个疑问。
谢谢！！

Answer 29

嗯?ByRef?汗!居然是这样?我只跟了一次,没细细去品这个代码,粗心了.对于编译后的调试,我是日志法,在语句里插入日志语句:Option ExplicitPrivate Declare Sub OutputDebugString Lib "kernel32.dll" Alias "OutputDebugStringA" ( _
     ByVal lpOutputString As String)Public Sub DbgPrint(ByRef sMsg As Variant)
    OutputDebugString sMsg
    Debug.Print sMsg
End Sub
调用DbgPrint时,能用DbgView看到输出,也就能间接地确定运行位置了.另外,如果不嫌烦,也可以插入Msgbox....