Advertisement
ledlight

FarbWahl

Jun 25th, 2022
852
316 days
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Imports System.Drawing.Imaging
  2. Imports System.Runtime.InteropServices
  3.  
  4. Public Class Form1
  5.  
  6.     Private m_Bitmap As Bitmap
  7. #Region "Form1_Load"
  8.     ' Draw some random circles.
  9.     Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Load
  10.         Me.WindowState = FormWindowState.Maximized
  11.         MakeBitmap()
  12.     End Sub
  13. #End Region ' Form1_Load"
  14.  
  15.  
  16. #Region "MakeBitmap"
  17.     Private Sub MakeBitmap()
  18.         If Me.ClientRectangle.Width < 10 OrElse Me.ClientRectangle.Height < 10 Then Exit Sub
  19.  
  20.         m_Bitmap = New Bitmap(Me.ClientRectangle.Width, Me.ClientRectangle.Height)
  21.         Dim gr As Graphics = Graphics.FromImage(m_Bitmap)
  22.         gr.Clear(Color.Silver)
  23.  
  24.         Dim rnd As New Random
  25.         Dim max_r As Integer = Math.Min(Me.ClientRectangle.Width, Me.ClientRectangle.Height) \ 3
  26.         Dim min_r As Integer = max_r \ 4
  27.         For i As Integer = 1 To 15
  28.             Dim r As Integer = rnd.Next(min_r, max_r)
  29.             Dim x As Integer = rnd.Next(min_r, Me.ClientRectangle.Width - min_r)
  30.             Dim y As Integer = rnd.Next(min_r, Me.ClientRectangle.Height - min_r)
  31.             gr.DrawEllipse(Pens.Black, x - r, y - r, 2 * r, 2 * r)
  32.         Next i
  33.         gr.Dispose()
  34.     End Sub
  35. #End Region ' MakeBitmap
  36.  
  37.     ' Display the picture.
  38. #Region "Form1_Paint"
  39.     Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles MyBase.Paint
  40.         e.Graphics.DrawImage(m_Bitmap, 0, 0)
  41.     End Sub
  42. #End Region ' Form1_Paint
  43.  
  44. #Region "MouseDown"
  45.     ' Flood fill the clicked area.
  46.     Private Sub Form1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseDown
  47.         ' Pick a random new color.
  48.         Dim rnd As New Random
  49.         Dim old_color As Color = m_Bitmap.GetPixel(e.X, e.Y)
  50.         Dim new_color As Color
  51.         Do
  52.             new_color = Color.FromArgb(255, rnd.Next(1, 256), rnd.Next(1, 255), rnd.Next(1, 255))
  53.         Loop Until Not (new_color.Equals(old_color))
  54.  
  55.         ' Flood.
  56.         Dim start_time As Date = Now
  57.         If e.Button = MouseButtons.Left Then
  58.             UnsafeFloodFill(m_Bitmap, e.X, e.Y, new_color)
  59.         ElseIf e.Button = Windows.Forms.MouseButtons.Right Then
  60.             SafeFloodFill(m_Bitmap, e.X, e.Y, new_color)
  61.         End If
  62.         Dim elapsed_time As TimeSpan = Now.Subtract(start_time)
  63.         Debug.WriteLine(elapsed_time.TotalSeconds.ToString("0.00"))
  64.  
  65.         ' Redraw.
  66.         Me.Invalidate()
  67.     End Sub
  68. #End Region 'MouseDown
  69.  
  70. #Region "SafeFloodFill"
  71.     ' Flood fill the point.
  72.     Public Sub SafeFloodFill(ByVal bm As Bitmap, ByVal x As Integer, ByVal y As Integer, ByVal new_color As Color)
  73.         ' Get the old and new colors.
  74.         Dim old_color As Color = bm.GetPixel(x, y)
  75.  
  76.         ' The following "If Then" test was added by Reuben Jollif
  77.         ' to protect the code in case the start pixel
  78.         ' has the same color as the fill color.
  79.         If old_color.ToArgb <> new_color.ToArgb Then
  80.             ' Start with the original point in the stack.
  81.             Dim pts As New Stack(1000)
  82.             pts.Push(New Point(x, y))
  83.             bm.SetPixel(x, y, new_color)
  84.  
  85.             ' While the stack is not empty, process a point.
  86.             Do While pts.Count > 0
  87.                 Dim pt As Point = DirectCast(pts.Pop(), Point)
  88.                 If pt.X > 0 Then SafeCheckPoint(bm, pts, pt.X - 1, pt.Y, old_color, new_color)
  89.                 If pt.Y > 0 Then SafeCheckPoint(bm, pts, pt.X, pt.Y - 1, old_color, new_color)
  90.                 If pt.X < bm.Width - 1 Then SafeCheckPoint(bm, pts, pt.X + 1, pt.Y, old_color, new_color)
  91.                 If pt.Y < bm.Height - 1 Then SafeCheckPoint(bm, pts, pt.X, pt.Y + 1, old_color, new_color)
  92.             Loop
  93.         End If
  94.     End Sub
  95.  
  96.     ' See if this point should be added to the stack.
  97.     Private Sub SafeCheckPoint(ByVal bm As Bitmap, ByVal pts As Stack, ByVal x As Integer, ByVal y As Integer, ByVal old_color As Color, ByVal new_color As Color)
  98.         Dim clr As Color = bm.GetPixel(x, y)
  99.         If clr.Equals(old_color) Then
  100.             pts.Push(New Point(x, y))
  101.             bm.SetPixel(x, y, new_color)
  102.         End If
  103.     End Sub
  104. #End Region ' SafeFloodFill
  105.  
  106. #Region "UnsafeFloodFill"
  107.     ' Flood the area at this point.
  108.     Public Sub UnsafeFloodFill(ByVal bm As Bitmap, ByVal x As Integer, ByVal y As Integer, ByVal new_color As Color)
  109.         ' Get the old and new colors' components.
  110.         Dim old_r As Byte = bm.GetPixel(x, y).R
  111.         Dim old_g As Byte = bm.GetPixel(x, y).G
  112.         Dim old_b As Byte = bm.GetPixel(x, y).B
  113.  
  114.         Dim new_r As Byte = new_color.R
  115.         Dim new_g As Byte = new_color.G
  116.         Dim new_b As Byte = new_color.B
  117.  
  118.         ' Start with the original point in the stack.
  119.         Dim pts As New Stack(1000)
  120.         pts.Push(New Point(x, y))
  121.         bm.SetPixel(x, y, new_color)
  122.  
  123.         ' Make a BitmapBytesARGB32 object.
  124.         Dim bm_bytes As New BitmapBytesARGB32(bm)
  125.  
  126.         ' Lock the bitmap.
  127.         bm_bytes.LockBitmap()
  128.  
  129.         ' While the stack is not empty, process a point.
  130.         Dim pix As Integer = 0
  131.         Do While pts.Count > 0
  132.             Dim pt As Point = DirectCast(pts.Pop(), Point)
  133.             If pt.X > 0 Then UnsafeCheckPoint(bm_bytes, pts, pt.X - 1, pt.Y, old_r, old_g, old_b, new_r, new_g, new_b)
  134.             If pt.Y > 0 Then UnsafeCheckPoint(bm_bytes, pts, pt.X, pt.Y - 1, old_r, old_g, old_b, new_r, new_g, new_b)
  135.             If pt.X < bm.Width - 1 Then UnsafeCheckPoint(bm_bytes, pts, pt.X + 1, pt.Y, old_r, old_g, old_b, new_r, new_g, new_b)
  136.             If pt.Y < bm.Height - 1 Then UnsafeCheckPoint(bm_bytes, pts, pt.X, pt.Y + 1, old_r, old_g, old_b, new_r, new_g, new_b)
  137.         Loop
  138.  
  139.         ' Unlock the bitmap.
  140.         bm_bytes.UnlockBitmap()
  141.     End Sub
  142.  
  143.     ' See if this point should be added to the stack.
  144.     Private Sub UnsafeCheckPoint(ByVal bm_bytes As BitmapBytesARGB32, ByVal pts As Stack, ByVal x As Integer, ByVal y As Integer, ByVal old_r As Byte, ByVal old_g As Byte, ByVal old_b As Byte, ByVal new_r As Byte, ByVal new_g As Byte, ByVal new_b As Byte)
  145.         Dim pix As Integer = y * bm_bytes.RowSizeBytes + x * BitmapBytesARGB32.PixelSizeBytes
  146.         Dim b As Byte = bm_bytes.ImageBytes(pix)
  147.         Dim g As Byte = bm_bytes.ImageBytes(pix + 1)
  148.         Dim r As Byte = bm_bytes.ImageBytes(pix + 2)
  149.  
  150.         If (r = old_r) AndAlso (g = old_g) AndAlso (b = old_b) Then
  151.             pts.Push(New Point(x, y))
  152.             bm_bytes.ImageBytes(pix) = new_b
  153.             bm_bytes.ImageBytes(pix + 1) = new_g
  154.             bm_bytes.ImageBytes(pix + 2) = new_r
  155.         End If
  156.     End Sub
  157. #End Region ' UnsafeFloodFill
  158.  
  159. End Class
  160.  
  161. #Region "BitmapBytesARGB32"
  162. Public Class BitmapBytesARGB32
  163.     ' Provide public access to the picture's byte data.
  164.     Public ImageBytes() As Byte
  165.     Public RowSizeBytes As Integer
  166.     Public Const PixelSizeBytes As Integer = 4                  ' 4 bytes/pixel.
  167.     Public Const PixelSizeBits As Integer = PixelSizeBytes * 8  ' 32 bits per pixel.
  168.  
  169.     ' A reference to the Bitmap.
  170.     Private m_Bitmap As Bitmap
  171.  
  172.     ' Save a reference to the bitmap.
  173.     Public Sub New(ByVal bm As Bitmap)
  174.         m_Bitmap = bm
  175.     End Sub
  176.  
  177.     ' Bitmap data.
  178.     Private m_BitmapData As BitmapData
  179.  
  180.     ' Lock the bitmap's data.
  181.     Public Sub LockBitmap()
  182.         ' Lock the bitmap data.
  183.         Dim bounds As Rectangle = New Rectangle( _
  184.             0, 0, m_Bitmap.Width, m_Bitmap.Height)
  185.         m_BitmapData = m_Bitmap.LockBits(bounds, _
  186.             Imaging.ImageLockMode.ReadWrite, _
  187.             Imaging.PixelFormat.Format32bppArgb)
  188.         RowSizeBytes = m_BitmapData.Stride
  189.  
  190.         ' Allocate room for the data.
  191.         Dim total_size As Integer = m_BitmapData.Stride * m_BitmapData.Height
  192.         ReDim ImageBytes(total_size)
  193.  
  194.         ' Copy the data into the ImageBytes array.
  195.         Marshal.Copy(m_BitmapData.Scan0, ImageBytes, 0, total_size)
  196.     End Sub
  197.  
  198.     ' Copy the data back into the Bitmap
  199.     ' and release resources.
  200.     Public Sub UnlockBitmap()
  201.         ' Copy the data back into the bitmap.
  202.         Dim total_size As Integer = m_BitmapData.Stride * m_BitmapData.Height
  203.         Marshal.Copy(ImageBytes, 0, _
  204.             m_BitmapData.Scan0, total_size)
  205.  
  206.         ' Unlock the bitmap.
  207.         m_Bitmap.UnlockBits(m_BitmapData)
  208.  
  209.         ' Release resources.
  210.         ImageBytes = Nothing
  211.         m_BitmapData = Nothing
  212.     End Sub
  213.  
  214. End Class
  215. #End Region
Advertisement
RAW Paste Data Copied
Advertisement