关于ps 中的魔术棒的算法

阿浊 2008-03-11 10:30:39

我已经做出来，就是速度太慢
1 不要遍历那种的，我用过了慢
2 我用的是边界跟踪，可是还是慢
3 提出优化代码，或者优化的算法，100分，或者无论什么办法，能接近ps 的魔术棒的选取速度

...全文

757 26 打赏收藏举报

写回复

26 条回复

切换为时间正序

请发表友善的回复…

发表回复

qiu5208 2008-03-19

打赏
举报

[Quote=引用 24 楼 anywn1314 的回复:]
（r－r0）^2+(g-g0)^2+(c-c0)^2 越小，颜色越接近
兄弟，谢谢你了
你能总结一下这个算法，用文字表达一下吗？
我看你的那个算法，感觉就是我没有发现某个函数可以在自己里面调用自己，呵呵大大节约了速度

还有个问题就是我想计算里面的面积有没有办法？把标记为1的都加起来就是周长，是吗？
[/Quote]
算法就是找到一个边界点，以此点为种子。判断是否是边界，再以此点的四周的点为种子，判断是否为边界，
不断重复，递归此过程即可。

周长确实是标记为1的点。
面积，以标记为1的点，做相应的计算，也不是什么难事。

qiu5208 2008-03-19

打赏
举报

[Quote=引用 23 楼 anywn1314 的回复:]
ok 可以了，现在就差颜色了，我一般用的就是getpix中的值的范围，没有分r b g三个值
[/Quote]
我对颜色不是很了解，用R，B，G ，比较直观。
如果6位的十六进制能直接判断的话，速度更快。

qiu5208 2008-03-18

打赏
举报

为了不误导其他人，上面代码作废，
代码重发。







'获得图象的像素高和宽

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

'创建兼容DC的函数

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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



'为DC选择图象的函数

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long



'清除DC的函数

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long



'获得图象像素值的函数

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



'给GetObject函数使用的结构

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

Dim i As Long, j As Long

Dim A() As Byte

Dim R0 As Long  '当前色

Dim G0 As Long

Dim B0 As Long

Dim r As Long, g As Long, b As Long

Dim gap As Long

Dim Mybmp As BITMAP

Dim pic1 As IPictureDisp

'把图片放如DC设备

Dim myDc As Long



'//////////把颜色整数值变为R,G,B///////////

Private Sub Hex2RGB(ByVal HexColor As String, Red As Long, Green As Long, Blue As Long)

   HexColor = Space(6 - Len(HexColor)) + HexColor

    Red = Val("&H" & Left(HexColor, 2))

    Green = Val("&H" & Mid(HexColor, 3, 2))

    Blue = Val("&H" & Right(HexColor, 2))

End Sub

'////////////颜色比对//////////////////

Private Function colorDiffer(x As Long, y As Long) As Boolean

   Hex2RGB Hex(GetPixel(myDc, x, y)), r, g, b

    If Abs(r - R0) < gap And Abs(g - G0) < gap And Abs(b - B0) < gap Then

     colorDiffer = False

     Else

     colorDiffer = True

     End If

End Function

'////////////////////////////////////

'//////寻找边界的过程/////////

Sub FindVerge(x As Long, y As Long)

 On Error Resume Next

 

 Do

  If colorDiffer(x - 1, y) Or x = 0 Then

    

    Exit Sub

    Else

    x = x - 1

    End If

 Loop

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++



Public Sub FindFigure(ByVal x As Long, ByVal y As Long)

On Error Resume Next

If colorDiffer(x + 1, y) Or _

   colorDiffer(x + 1, y + 1) Or _

   colorDiffer(x + 1, y - 1) Or _

   colorDiffer(x, y + 1) Or _

   colorDiffer(x, y - 1) Or _

   colorDiffer(x - 1, y) Or _

   colorDiffer(x - 1, y + 1) Or _

   colorDiffer(x - 1, y - 1) Then

       

       A(x, y) = 1

       PSet (x, y), vbWhite

       

         

        If colorDiffer(x, y + 1) Or A(x, y + 1) = 1 Then

        Else

        FindFigure x, y + 1

        End If

        If colorDiffer(x - 1, y) Or A(x - 1, y) = 1 Then

        Else

        FindFigure x - 1, y

        End If

        If colorDiffer(x, y - 1) Or A(x, y - 1) = 1 Then

        Else

        FindFigure x, y - 1

        End If

        If colorDiffer(x + 1, y) Or A(x + 1, y) = 1 Then

        Else

        FindFigure x + 1, y

        End If

 End If

           

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++



Private Sub Form_Load()

Me.ScaleMode = 3

MsgBox "鼠标左键是魔术棒,鼠标右键设置容差"

Dim str1 As String

str1 = "C:\WINDOWS\Web\Wallpaper\tulips.jpg"

gap = 70 '设置容差值

'初始化

ChDir App.Path

On Error GoTo Z:

Set pic1 = LoadPicture(str1)

GetObject pic1, Len(Mybmp), Mybmp

myDc = CreateCompatibleDC(0)

SelectObject myDc, pic1

ReDim A(Mybmp.bmWidth - 1, Mybmp.bmHeight - 1)



Exit Sub

Z:

  str1 = InputBox("请输入一张图片的路径及文件名. 比如:c:\mypicture\photo1.bmp")

  

 Resume Next

 

  



End Sub



Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

 If Button = 1 Then

 

 

 Cls

 BitBlt Form1.hdc, 0, 0, Form1.Height, Form1.Width, myDc, 0, 0, vbSrcCopy

 Dim x1 As Long, y1 As Long

 Dim tep



 x1 = CLng(x): y1 = CLng(y)

 



 

 Hex2RGB Hex(GetPixel(myDc, x1, y1)), R0, G0, B0

 Debug.Print "kai" & R0

 Debug.Print G0

 Debug.Print B0

 Dim t As Single

 

 FindVerge x1, y1

 FindFigure x1, y1

 

 ReDim A(Mybmp.bmWidth - 1, Mybmp.bmHeight - 1)

 Else

 gap = Val(InputBox("请输入容差值(0~100)"))

 End If

 

End Sub



Private Sub Form_Paint()

BitBlt Form1.hdc, 0, 0, Form1.Height, Form1.Width, myDc, 0, 0, vbSrcCopy

End Sub

qiu5208 2008-03-18

打赏
举报

找到原因了。！！！！！！！！！！！！！！！！！！！！！
你要把窗口的坐标模式设为象素。
Me.ScaleMode = 3

阿浊 2008-03-18

打赏
举报

我就是那样做的，可是就是
HexColor = Space(6 - Len(HexColor)) + HexColor
这个有错
而且 HexColor的值一直都是FFFFFFFF
这个地方出问题，不能运行下去，然后我把6改成8 也就是一个点变了颜色，不知道怎么搞的

qiu5208 2008-03-18

打赏
举报

上面的代码在vb6中测试过，没问题的。
你直接新建窗体，把所有的代码复制运行看一看。

我不知道你的程序其他的模块如何/
上面代码最核心是FindFigure追踪边界子过程，
至于颜色比对你根据你自己的实际情况做修改。

阿浊 2008-03-18

打赏
举报

（r－r0）^2+(g-g0)^2+(c-c0)^2 越小，颜色越接近
兄弟，谢谢你了
你能总结一下这个算法，用文字表达一下吗？
我看你的那个算法，感觉就是我没有发现某个函数可以在自己里面调用自己，呵呵大大节约了速度

还有个问题就是我想计算里面的面积有没有办法？把标记为1的都加起来就是周长，是吗？

阿浊 2008-03-18

打赏
举报

ok 可以了，现在就差颜色了，我一般用的就是getpix中的值的范围，没有分r b g三个值

tingting1123 2008-03-17

打赏
举报

/*记号*/

阿浊 2008-03-17

打赏
举报

HexColor = Space(6 - Len(HexColor)) + HexColor
这个有错
而且 HexColor的值一直都是FFFFFFFF

阿浊 2008-03-17

打赏
举报

还是有点不对，该怎么改呢？

阿浊 2008-03-17

打赏
举报

哦，那我是不是弄成Space(8 - Len(HexColor)) + HexColor 是吗？

qiu5208 2008-03-17

打赏
举报

[Quote=引用 13 楼 anywn1314 的回复:]
HexColor = Space(6 - Len(HexColor)) + HexColor
这个有错
而且 HexColor的值一直都是FFFFFFFF
[/Quote]
颜色值由GetPixel函数返回的，是256色的位图颜色。
白色是FFFFFF就6位十六进制

可能你的系统是32位色，所以不一样。

东方之珠 2008-03-17

打赏
举报

顶一个

qiu5208 2008-03-16

打赏
举报

复制代码到窗口,看一看能不能符合你的速度要求.



'获得图象的像素高和宽

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

'创建兼容DC的函数

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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



'为DC选择图象的函数

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long



'清除DC的函数

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long



'获得图象像素值的函数

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



'给GetObject函数使用的结构

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

Dim i As Long, j As Long

Dim A() As Byte

Dim R0 As Long  '当前色

Dim G0 As Long

Dim B0 As Long

Dim r As Long, g As Long, b As Long

Dim gap As Long

Dim Mybmp As BITMAP

Dim pic1 As IPictureDisp

'把图片放如DC设备

Dim myDc As Long



'//////////把颜色整数值变为R,G,B///////////

Private Sub Hex2RGB(ByVal HexColor As String, Red As Long, Green As Long, Blue As Long)

   HexColor = Space(6 - Len(HexColor)) + HexColor

    Red = Val("&H" & Left(HexColor, 2))

    Green = Val("&H" & Mid(HexColor, 3, 2))

    Blue = Val("&H" & Right(HexColor, 2))

End Sub

'////////////颜色比对//////////////////

Private Function colorDiffer(x As Long, y As Long) As Boolean

   Hex2RGB Hex(GetPixel(myDc, x, y)), r, g, b

    If Abs(r - R0) < gap And Abs(g - G0) < gap And Abs(b - B0) < gap Then

     colorDiffer = False

     Else

     colorDiffer = True

     End If

End Function

'////////////////////////////////////

'//////寻找边界的过程/////////

Sub FindVerge(x As Long, y As Long)

 On Error Resume Next

 

 Do

  If colorDiffer(x - 1, y) Or x = 0 Then

    

    Exit Sub

    Else

    x = x - 1

    End If

 Loop

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++



Public Sub FindFigure(ByVal x As Long, ByVal y As Long)

On Error Resume Next

If colorDiffer(x + 1, y) Or _

   colorDiffer(x + 1, y + 1) Or _

   colorDiffer(x + 1, y - 1) Or _

   colorDiffer(x, y + 1) Or _

   colorDiffer(x, y - 1) Or _

   colorDiffer(x - 1, y) Or _

   colorDiffer(x - 1, y + 1) Or _

   colorDiffer(x - 1, y - 1) Then

       

       A(x, y) = 1

       PSet (x, y), vbWhite

       

         

        If colorDiffer(x, y + 1) Or A(x, y + 1) = 1 Then

        Else

        FindFigure x, y + 1

        End If

        If colorDiffer(x - 1, y) Or A(x - 1, y) = 1 Then

        Else

        FindFigure x - 1, y

        End If

        If colorDiffer(x, y - 1) Or A(x, y - 1) = 1 Then

        Else

        FindFigure x, y - 1

        End If

        If colorDiffer(x + 1, y) Or A(x + 1, y) = 1 Then

        Else

        FindFigure x + 1, y

        End If

 End If

           

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++



Private Sub Form_Load()



MsgBox "鼠标左键是魔术棒,鼠标右键设置容差"

Dim str1 As String

str1 = "C:\WINDOWS\Web\Wallpaper\tulips.jpg"

gap = 70 '设置容差值

'初始化

ChDir App.Path

On Error GoTo Z:

Set pic1 = LoadPicture(str1)

GetObject pic1, Len(Mybmp), Mybmp

myDc = CreateCompatibleDC(0)

SelectObject myDc, pic1

ReDim A(Mybmp.bmWidth - 1, Mybmp.bmHeight - 1)



Exit Sub

Z:

  str1 = InputBox("请输入一张图片的路径及文件名. 比如:c:\mypicture\photo1.bmp")

  

 Resume Next

 

  



End Sub



Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

 If Button = 1 Then

 

 

 Cls

 BitBlt Form1.hdc, 0, 0, Form1.Height, Form1.Width, myDc, 0, 0, vbSrcCopy

 Dim x1 As Long, y1 As Long



 x1 = CLng(x): y1 = CLng(y)

 Hex2RGB Hex(GetPixel(myDc, x1, y1)), R0, G0, B0

 Debug.Print "kai" & R0

 Debug.Print G0

 Debug.Print B0

 Dim t As Single

 

 FindVerge x1, y1

 FindFigure x1, y1

 

 ReDim A(Mybmp.bmWidth - 1, Mybmp.bmHeight - 1)

 Else

 gap = Val(InputBox("请输入容差值(0~100)"))

 End If

 

End Sub



Private Sub Form_Paint()

BitBlt Form1.hdc, 0, 0, Form1.Height, Form1.Width, myDc, 0, 0, vbSrcCopy

End Sub

阿浊 2008-03-15

打赏
举报

就是四个及八个方向找点，我始终要扫描一小块区域，这样算法就比较浪费时间了，对于一般的图像还好，要是对于复杂的图像就比较麻烦

qiu5208 2008-03-12

打赏
举报

此中算法是公司机密,不得外传.

阿浊 2008-03-12

打赏
举报

哪位大侠知道呀？？

laviewpbt 2008-03-12

打赏
举报

你能把你的算法给我们参考下嘛，对于代码优化我还是有所研究的。

阿浊 2008-03-11

打赏
举报

就是跟ps里面的魔术棒一样，我就是搞不清adobe公司到底采用的哪种算法，我用的算法虽然能实现，对付一般的还行，要是图像大的，太慢了

加载更多回复（6）