Advertisement
ledlight

FarbWechsel

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