# 关于ps 中的魔术棒的算法

1 不要遍历那种的，我用过了慢
2 我用的是边界跟踪，可是还是慢
3 提出优化代码，或者优化的算法，100分，或者无论什么办法，能接近ps 的魔术棒的选取速度
...全文
757 26 打赏 收藏 举报

26 条回复

qiu5208 2008-03-19
• 打赏
• 举报

[Quote=引用 24 楼 anywn1314 的回复:]
（r－r0）^2+(g-g0)^2+(c-c0)^2 越小，颜色越接近

[/Quote]

qiu5208 2008-03-19
• 打赏
• 举报

[Quote=引用 23 楼 anywn1314 的回复:]
ok 可以了，现在就差颜色了，我一般用的就是getpix中的值的范围，没有分r b g三个值
[/Quote]

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
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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

• 打赏
• 举报

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

qiu5208 2008-03-18
• 打赏
• 举报

• 打赏
• 举报

（r－r0）^2+(g-g0)^2+(c-c0)^2 越小，颜色越接近

• 打赏
• 举报

ok 可以了，现在就差颜色了，我一般用的就是getpix中的值的范围，没有分r b g三个值
tingting1123 2008-03-17
• 打赏
• 举报

/*记号*/

• 打赏
• 举报

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

• 打赏
• 举报

• 打赏
• 举报

qiu5208 2008-03-17
• 打赏
• 举报

[Quote=引用 13 楼 anywn1314 的回复:]
HexColor = Space(6 - Len(HexColor)) + HexColor

[/Quote]

• 打赏
• 举报

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
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++

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
``````

• 打赏
• 举报

qiu5208 2008-03-12
• 打赏
• 举报

• 打赏
• 举报

laviewpbt 2008-03-12
• 打赏
• 举报

• 打赏
• 举报

1066

VB 资源

2008-03-11 10:30