VB.NET中使用种子填充算法实现给图片着色的例子

某人最近在使用C#写一个类似Windows的画图工具,在填色的部分卡住了。劳资要他使用种子填充算法着色(不要调用Windows提供的API,否则还锻炼个毛线),现在我把这个功能实现了,程序的效率很高。现在在这里大概写一下实现方法。

程序是用VB.NET写的,C#写法类似(而且还不需要使用Marshal类访问非托管资源,更加方便)。程序的运行结果如下:

 种子填充算法说白了就是宽度优先搜索算法(BFS),如果你不知道这是什么东西,那说明你数据结构根本就没有学,请自行补充相应的知识。

  第一步:实现“铅笔”工具

我们定义如下的全局变量(窗体类的私有成员),作用是啥一看名字就知道:

复制代码 代码如下:

Private Enum DrawStyle
    Drawing = 0
    Fill = 1
    DrawDragging = 2
End Enum
                                                                    
Private _fillColor() As Color = {Color.Blue,Color.Green,Color.Red,Color.LightGray,Color.LightPink,Color.LightSkyBlue,_
                                 Color.GreenYellow,Color.Gold,Color.LightSeaGreen}
                                                                    
Private _drawStyle As DrawStyle = DrawStyle.Drawing
Private _imgMain As Bitmap
Private _g As Graphics
Private _lastPosition As Point
Private _drawingPen As Pen

 这个程序中填充的颜色是随机决定的(都懒得做一个选颜色的功能了),可以填充的颜色在_fillColor数组中。_drawStyle定义当前的绘图模式(Drawing表示使用铅笔工具,但未按下,Fill表示准备填充,DrawDragging表示鼠标正按下并拖拽)。

  _imgMain是绘制的图片,_g是创建在这个Bitmap上的Graphics对象。

  需要注意的是,Drawing和Drawing2D类不提供画点的方法,我们需要通过画直线或画矩形来模拟。至于_lastPosition的作用,由于鼠标拖拽过程中,如果速度过快,那么MouseMove事件中的坐标点(每次MouseMove事件被触发)并不是连续的,所以我们需要在当前点和上一次的鼠标位置之间画一条直线,否则画出来的线是间断的。

  MouseDown、MouseMove和MouseUp实现铅笔工具的基本功能,代码如下:

复制代码 代码如下:

Private Sub PictureBox1_MouseDown(sender As Object,e As MouseEventArgs) Handles PictureBox1.MouseDown
    If CheckBox1.Checked Then _drawStyle = DrawStyle.Fill Else _drawStyle = DrawStyle.Drawing
                             
    If _drawStyle = DrawStyle.Fill Then
        Call FillRegion(e.Location,_fillColor(New Random().Next(_fillColor.Count)))
    Else
        _drawStyle = DrawStyle.DrawDragging
        _lastPosition = e.Location
    End If
End Sub
                             
Private Sub PictureBox1_MouseMove(sender As Object,e As MouseEventArgs) Handles PictureBox1.MouseMove
    If _drawStyle = DrawStyle.DrawDragging Then
        _g.DrawLine(_drawingPen,_lastPosition,e.Location)
        _lastPosition = e.Location
        PictureBox1.Image = _imgMain
    End If
End Sub
                             
Private Sub PictureBox1_MouseUp(sender As Object,e As MouseEventArgs) Handles PictureBox1.MouseUp
    _drawStyle = DrawStyle.Drawing
End Sub

  二、正题――种子填充算法的实现

  上面说了一堆废话,现在终于可以开始实现填充的算法了。

  当用户点击图片中某一个点后,需要填充与这个点相邻的、颜色相同的其他点。为什么要叫“种子填充”呢?大概是这样:你在点中的那个点中播下一颗种子,它开花结果(颜色变成目标颜色),然后它又播种出新的种子(与它上下左右相邻且颜色等于原来颜色的点);新种子再开花结果(变颜色),播种新种子…… 如此往复,直到没有地方播种了为止,算法结束。

  按照BFS通常的实现方式,可以使用循环队列作为数据结构。对于BFS算法来说,需要的存储空间较大,具体需要多少还真不好估算。这里给大家一个参考,我的这个程序图片框大小是832*450,大概是37万像素,循环队列的容量设置为1600可以满足需求(全部着色)。如果你的图片框比较大,可以先取一个较大的数值(比如8000),再逐渐缩小,反复尝试。

  实现这个循环队列直接定义成一个一维数组就可以了,没有必要使用ConcurrentQueue类,否则性能会下降,也没有这个必要。

  首先,由于要向四个方向填充,为了避免类似的代码反复写导致程序丑陋无比,我们可以定义一个fill_direction数组:

复制代码 代码如下:

Dim fill_direction() As Point = {New Point(-1,0),New Point(1,New Point(0,-1),1)}

 这样,使用一个For循环就可以完成四个方向的操作了。

  按照首先说的思路,程序的实现就很简单了:首先将点击的那个点入队,记录这个点的颜色。然后使用一个循环,取出队首元素,并向四个方向撒种子(颜色相同,且没有越出图片框边界),将每一个种子的颜色改变成目标颜色并入队。如此往复直到队列为空为止。代码如下:

复制代码 代码如下:

Private Sub FillRegion2(sourcePoint As Point,destinationColor As Color)
    Dim new_bitmap As Bitmap = DirectCast(PictureBox1.Image,Bitmap)
    Dim source_color As Color = new_bitmap.GetPixel(sourcePoint.X,sourcePoint.Y)
                   
    Dim MIN_X As Integer = 0,MIN_Y As Integer = 0
    Dim MAX_X As Integer = PictureBox1.Width - 1,MAX_Y As Integer = PictureBox1.Height - 1
                   
    Dim fill_queue(MAX_FILL_QUEUE) As Point
                   
    Dim fill_direction() As Point = {New Point(-1,1)}
                   
    Dim queue_head As Integer = 0
    Dim queue_tail As Integer = 1
                   
    fill_queue(queue_tail) = sourcePoint
                   
    Do While queue_head <> queue_tail
        queue_head = (queue_head + 1) Mod MAX_FILL_QUEUE
        Dim current_point As Point = fill_queue(queue_head)
                   
        For i As Integer = 0 To 3
            Dim new_point_x As Integer = current_point.X + fill_direction(i).X
            Dim new_point_y As Integer = current_point.Y + fill_direction(i).Y
                   
            If new_point_x < MIN_X OrElse new_point_y < MIN_Y OrElse new_point_x > MAX_X OrElse new_point_y > MAX_Y Then Continue For
                   
            If new_bitmap.GetPixel(new_point_x,new_point_y) = source_color Then
                new_bitmap.SetPixel(new_point_x,new_point_y,destinationColor)
                   
                queue_tail = (queue_tail + 1) Mod MAX_FILL_QUEUE
                fill_queue(queue_tail) = New Point(new_point_x,new_point_y)
            End If
        Next
                   
    Loop
                   
    PictureBox1.Image = new_bitmap
End Sub

 可能会有一个问题,就是第一个点在入队前应该要先改成目标颜色,但我这里没有改。效果其实是一样的,因为它旁边的点在撒种子的时候发现这个点颜色没变,还是会将它入队(注意:如果只有一个点需要填充,即起始点没有相邻的点,那么会导致这个点不被填充成目标颜色,请自行改进算法)。我们在这里忽略这个小问题。

  运行程序,可以发现已经可以实现填充的功能了。


备注:如果目标颜色和起始点的颜色相同,且起始点有相邻的、相同颜色的点,那么会导致相同的点反复入队,最终导致队列溢出。此时队首指针等于队尾指针,程序会认为队列为空而终止填充,因此最终结果没有变化(如果不是采用循环队列,会导致程序死循环)。为了避免这种情况,应该在进行填充前判断目标颜色是否和原点颜色相同,相同时直接结束。在这里我没有进行这样的判断。
  

三、提升效率

 在运行程序时发现了一个问题,就是如果填色区域过大(比如直接填充整个图片框),程序会很慢,大概需要2秒左右才能填充完。产生这个问题的主要原因是GetPixel和SetPixel的性能不高,每次调用这两个方法时都会做很多额外的操作,在我以前使用汇编语言调用DOS中断画点时就有这个问题。

  为此,M$提供了LockBits和UnlockBits方法。LockBits方法可以将图片锁定到内存中,以便通过访问内存直接对这些数据进行修改。在C#中我们可以直接使用指针访问这片数据,但对于VB是不行的,因为VB不允许使用指针,我们可以借助System.Runtime.InteropServices.Marshal类达到直接访问内存的功能。

  关于LockBits的详细介绍可以参考这篇日志:http://www.bobpowell.net/lockingbits.htm

  其中很重要的一点就是要搞清楚如何计算图片上某一点的内存地址。

如这张图所示(图片来自那篇博文),坐标为(X,Y)的点在内存中的地址就是Scan0 + (Y * Stride) + X * k。k与图片中每个点占用的字节有关,我们这里使用的是32位ARPG,每个像素占4个字节,因此k就是4。另外注意Stride并不一定是n*k(n表示每行存n个像素),因为末尾可能有多余的位使数组对齐(与处理机的字长匹配)。无论如何,我们可以通过BitmapData对象的Stride属性得到。

  由于一个ARGB值是4个字节,所以我们需要调用Marshal类的ReadInt32和WriteInt32方法对每个像素点的颜色进行读取和写入。我们要操作的是颜色的ARGB值而不是Color对象。

  那么把上面的代码稍加改造,就可以写出如下程序:

复制代码 代码如下:

Private Sub FillRegion(sourcePoint As Point,destinationColor As Color)
   
    Dim new_bitmap As Bitmap = DirectCast(PictureBox1.Image,Bitmap)
    Dim source_color_int As Integer = new_bitmap.GetPixel(sourcePoint.X,sourcePoint.Y).ToArgb
   
    Dim bitmap_data As BitmapData = new_bitmap.LockBits(New Rectangle(0,PictureBox1.Width,PictureBox1.Height),_
                                                        Imaging.ImageLockMode.ReadWrite,new_bitmap.PixelFormat)
   
    Dim stride As Integer = Math.Abs(bitmap_data.Stride)
   
    Dim scan0 As IntPtr = bitmap_data.Scan0
   
    Dim bytes As Integer = stride * new_bitmap.Height
   
    Dim MIN_X As Integer = 1,MIN_Y As Integer = 1
    Dim MAX_X As Integer = PictureBox1.Width - 1,MAX_Y As Integer = PictureBox1.Height - 1
   
    Dim fill_queue(MAX_FILL_QUEUE) As Point
   
    Dim fill_direction() As Point = {New Point(-1,1)}
   
    Dim destination_color_int As Integer = destinationColor.ToArgb
   
    Dim queue_head As Integer = 0
    Dim queue_tail As Integer = 1
   
    fill_queue(queue_tail) = sourcePoint
   
    Do While queue_head <> queue_tail
        queue_head = (queue_head + 1) Mod MAX_FILL_QUEUE
        Dim current_point As Point = fill_queue(queue_head)
   
        For i As Integer = 0 To 3
            Dim new_point_x As Integer = current_point.X + fill_direction(i).X
            Dim new_point_y As Integer = current_point.Y + fill_direction(i).Y
   
            If new_point_x < MIN_X OrElse new_point_y < MIN_Y OrElse new_point_x > MAX_X OrElse new_point_y > MAX_Y Then Continue For
   
            Dim offset As Integer = (new_point_y * stride) + new_point_x * 4
   
            Dim current_color_int As Integer = System.Runtime.InteropServices.Marshal.ReadInt32(scan0,offset)
   
            If current_color_int = source_color_int Then
                System.Runtime.InteropServices.Marshal.WriteInt32(scan0,offset,destination_color_int)
   
                queue_tail = (queue_tail + 1) Mod MAX_FILL_QUEUE
                fill_queue(queue_tail) = New Point(new_point_x,new_point_y)
            End If
        Next
   
    Loop
   
    new_bitmap.UnlockBits(bitmap_data)
   
    PictureBox1.Image = new_bitmap
   
End Sub

 当然,如果你还有其他更好的实现方法,还请多多指教。(啊,不要告诉我使用Windows的API。。。)  现在运行一下程序,发现效率急剧上升。我测试了一下,在我的电脑上,填充37万个像素大概只需要50~60毫秒左右,效率还是令人满意的。

版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。

相关推荐


Format[$] ( expr [ , fmt ] ) format 返回变体型 format$ 强制返回为文本 -------------------------------- 数字类型的格式化 --------------------------------     固定格式参数:     General Number 普通数字,如可以用来去掉千位分隔号     format$("100,1
VB6或者ASP 格式化时间为 MM/dd/yyyy 格式,竟然没有好的办法, Format 或者FormatDateTime 竟然结果和系统设置的区域语言的日期和时间格式相关。意思是尽管你用诸如 Format(Now, "MM/dd/yyyy"),如果系统的设置格式区域语言的日期和时间格式分隔符是"-",那他还会显示为 MM-dd-yyyy     只有拼凑: <%response.write
在项目中添加如下代码:新建窗口来显示异常信息。 Namespace My ‘全局错误处理,新的解决方案直接添加本ApplicationEvents.vb 到工程即可 ‘添加后还需要一个From用来显示错误。如果到这步还不会则需要先打好基础啦 ‘======================================================== ‘以下事件
转了这一篇文章,原来一直想用C#做k3的插件开发,vb没有C#用的爽呀,这篇文章写与2011年,看来我以前没有认真去找这个方法呀。 https://blog.csdn.net/chzjxgd/article/details/6176325 金蝶K3 BOS的插件官方是用VB6编写的,如果  能用.Net下的语言工具开发BOS插件是一件很愉快的事情,其中缘由不言而喻,而本文则是个人首创,实现在了用V
Sub 分列() ‘以空格为分隔符,连续空格只算1个。对所选中的单元格进行处理 Dim m As Range, tmpStr As String, s As String Dim x As Integer, y As Integer, subStr As String If MsgBox("确定要分列处理吗?请确定分列的数据会覆盖它后面的单元格!", _
  窗体代码 1 Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) 2 Dim path As String, hash As String 3 For Each fil
  Imports MySql.Data.MySqlClient Public Class Form1 ‘ GLOBAL DECLARATIONS Dim conString As String = "Server=localhost;Database=net2;Uid=root;Pwd=123456;" Dim con As New MySqlConnection
‘導入命名空間 Imports ADODB Imports Microsoft.Office.Interop   Private Sub A1() Dim Sql As String Dim Cnn As New ADODB.Connection Dim Rs As New ADODB.Recordset Dim S As String   S = "Provider=OraOLEDB.Oracl
Imports System.IO Imports System.Threading Imports System.Diagnostics Public Class Form1 Dim A(254) As String    Function ping(ByVal IP As Integer) As String Dim IPAddress As String IPAddress = "10.0.
VB运行EXE程序,并等待其运行结束 参考:https://blog.csdn.net/useway/article/details/5494084 Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Pr
今天碰到一个问题,登陆的时候,如果不需要验证手机号为空,则不去验证手机号 因为登陆的时候所有的验证信息都存放在一个数组里 Dim CheckUserInfo() As String ={UserBirthday, SecEmail, UserMob, UserSex, RealNameFirst, RealName, CheckCardID, CheckCardType, Contactemail
在VB6.0中,数据访问接口有三种: 1、ActiveX数据对象(ADO) 2、远程数据对象(RDO) 3、数据访问对象(DAO) 1.使用ADO(ActiveX Data Objec,ActiveX数据对象)连接SQL Server 1)使用ADO控件连接 使用ADO控件的ConnectionString属性就可以连接SQL Server,该属性包含一个由分号分隔的argument=value语
注:大家如果没有VB6.0的安装文件,可自行百度一下下载,一般文件大小在200M左右的均为完整版的软件,可以使用。   特别提示:安装此软件的时候最好退出360杀毒软件(包括360安全卫士,电脑管家等,如果电脑上有这些软件的话),因为现如今的360杀毒软件直接会对VB6.0软件误报,这样的话就可能会在安装过程中被误报阻止而导致安装失败,或者是安装后缺乏很多必须的组件(其它的杀毒软件或安全卫士之类的
Private Sub Form_Load() Call conndb End Sub Private Function conndb() Dim cn As New ADODB.Connection Dim rs As New ADODB.Recordset Dim strCn, sql As String Dim db_host As String Dim db_user As String
  PPSM06S70:  Add  moddate  EDITSPRINTJOB:  MAX(TO_CHAR(ETRN.MODDATE, ‘yyyy/mm/dd/HH24:MI AM‘)) ACTUAL_SHIPDATE   4.Test Scenario (1) :Query SQL Test DN:8016578337 SELECT CTRN.TKCTID TRUCK_ID,        
  沒有出現CrystalReportViewer時,須安裝CRforVS_13_0. 新增1個數據集,新增1個數據表,添加二列,列名要和資料庫名一樣. 修改目標Framework 修改app.config, <startup >改成<startup useLegacyV2RuntimeActivationPolicy ="true">  CrystalReport1.rpt增加數據庫專家 在表單
Imports System.Threading Imports System Public Class Form1 Dim th1, th2 As Thread Public Sub Method1() Dim i As Integer For i = 1 To 100 If Me.Label1.BackColor =
Friend Const PROCESS_ALL_ACCESS = &H1F0FFF = 2035711 Friend Const PROCESS_VM_READ = &H10 Friend Const PROCESS_VM_WRITE = &H20 Friend Const PAGE_READONLY = &H2 Friend Const PAGE_READWRITE = &H4 Friend
以下代码随手写的 并没有大量测试 效率也有待提升 如果需要C#的请自行转换 Function SplitBytes(Data As Byte(), Delimiter As Byte()) As List(Of Byte()) Dim i = 0 Dim List As New List(Of Byte()) Dim bytes As New
Imports System.Data.SqlClient Public Class Form1 REM Public conn1 As SqlConnection = New SqlConnection("server=.; Integrated Security=False;Initial Catalog= mydatabase1; User ID= sa;password")