Hello!
Today with the computerized embroidery sewing machines and with the built-in digitized patterns, not too many people do hand cross Stitch embroidery. It was popular when I was a child, back home. But still people buy and sew cross stitch patterns for blankets, table tops, children clothing, drapes, and some other crafts. And I know at of least one lady that does it regularly while listening to programs on television, peeking once on a while to the screen.
Anyway, the idea of making this program was just to make it. I do like these patterns, and as a child I did some small ones from educational magazines my mother had.
This program takes a picture and converts it to grid of squares and writting an 'X' on them using colors resembling the original image in a way that by observing it, it will recreate the original image in your mind.
There are few options or adjustments:
You can set the number of colors available to the pattern, you could lighten and darken the image, you could clear artifacts or undesired shadows or shades, clear certain colors, flip the original and enlarge the output or you can get an outline.
These resulting patterns are juts JPEG images that can be saved to disk. Another use that occurs to me is to create the screens for assigning colors to the leds on a pixel advertising board.
As allways, headings and the form load routine create the Tooltips and assign initial needed values and the drag and drop handlers, and we create the reload and work images:
Imports System.Drawing.Imaging
Imports System.Drawing.Drawing2D
Public Class Form1
Dim W, H, NewWidth, NewHeight As Integer
Dim Ratio As Single
Dim minus As Color = Color.Black
Dim Rx, Gx, Bx As Integer
Dim RL, RH, GL, GH, BL, BH As Integer
Dim WorkImg As Image
Dim ReloadImg As Image
Dim ToolTip1 As New ToolTip
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
ToolTip1.AutoPopDelay = 1000
' ToolTip1.AutomaticDelay = 1000
ToolTip1.InitialDelay = 1000
ToolTip1.ReshowDelay = 2000
ToolTip1.BackColor = Color.Aquamarine
ToolTip1.SetToolTip(TrackBar1, "Dark<<Intensity>>Bright")
ToolTip1.SetToolTip(sbEdge, "More<<Edge>>Less")
ToolTip1.SetToolTip(btnPermanent, "Makes Image1 Permanent")
ToolTip1.SetToolTip(btnSave1, "Saves Image1 To File")
ToolTip1.SetToolTip(btnEdge, "Outlines Image1 According To Scroll Settings")
ToolTip1.SetToolTip(btnSave2, "Saves Image2 To File")
ToolTip1.SetToolTip(btnTransfer21, "Copy Image2 To PictureBox1")
ToolTip1.SetToolTip(btnTransfer12, "Copy Image1 To PictureBox2")
ToolTip1.SetToolTip(lblPopOrig, "Popup Original Image1 Thumbnail" & vbNewLine & "And Reload It To
PictureBox1")
ToolTip1.SetToolTip(lblPopPic1, "Popup Modified Image1 Thumbnail" & vbNewLine & "And Save It When Clicked")
ToolTip1.SetToolTip(lblPopPic2, "Popup Image2 Thumbnail" & vbNewLine & "And Save It When Clicked")
ToolTip1.SetToolTip(btnGenerate, "Convert To CrossStitch")
ToolTip1.SetToolTip(rbTrueC, "Available Colors For Image")
ToolTip1.SetToolTip(rbCol64, "Available Colors For Image")
ToolTip1.SetToolTip(rbCol512, "Available Colors For Image")
ToolTip1.SetToolTip(rbCol4096, "Available Colors For Image")
ToolTip1.SetToolTip(Num1, "Magnification")
ToolTip1.SetToolTip(btnConvert, "Reduce Colors")
ToolTip1.SetToolTip(btnGenerate, "Create Pattern")
ToolTip1.SetToolTip(btnClear, "Clear Selected Color")
ToolTip1.SetToolTip(btnFlip, "Flip Image Horizontally")
WorkImg = Work.Image
ReloadImg = Work.Image.Clone
W = Work.Width
H = Work.Height
Ratio = CSng(W / H)
NewWidth = CInt(400 * Ratio)
NewHeight = 400
PopupPictures.Height = 400
PopupPictures.Width = NewWidth
'Drag And Drop
AddHandler Me.DragDrop, AddressOf Form_DragDrop
AddHandler Me.DragEnter, AddressOf Form_DragEnter
End Sub
Private Sub Form_DragDrop(ByVal sender As System.Object, ByVal e As System.Windows.Forms.DragEventArgs)
Dim strng As String = ""
If e.Data.GetDataPresent(DataFormats.FileDrop) Then
Dim Files() As String
Files = e.Data.GetData(DataFormats.FileDrop)
strng = Files(0).ToLower
' Type of data
If strng.Contains(".jpg") Or strng.Contains(".bmp") Or strng.Contains(".png") Or strng.Contains(".gif")
Or strng.Contains(".tif") Then
Dim img As Image
img = ConvertToRGB(Image.FromFile(Files(0)))
Work.Image = ConvertToRGB(Image.FromFile(Files(0)))
Cross.Image = ConvertToRGB(Image.FromFile(Files(0)))
WorkImg = ConvertToRGB(Image.FromFile(Files(0)))
ReloadImg = ConvertToRGB(Image.FromFile(Files(0)))
W = GetImageWidth(Files(0))
H = GetImageHeight(Files(0))
Ratio = CSng(W / H)
NewWidth = CInt(400 * Ratio)
NewHeight = 400
PopupPictures.Height = 400
PopupPictures.Width = NewWidth
Me.Text = "FilterColors -> " & Files(0).Substring(Files(0).LastIndexOf("\") + 1)
Else
MessageBox.Show("Please Try An Image")
End If
End If
End Sub
Private Sub Form_DragEnter(ByVal sender As System.Object, ByVal e As System.Windows.Forms.DragEventArgs)
If e.Data.GetDataPresent(DataFormats.FileDrop) Then
e.Effect = DragDropEffects.All
End If
End Sub
'Drag And Drop
OK! There, as I said, are few image manipulation routines: Horizontal Flip, Intensity Adjustment, Color Reduction, Convertion To RGB, Clearing Color, Getting Edges.
Horizontal Flip:
Private Sub btnFlip_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnFlip.Click
Dim Bitmap1 As Bitmap
Try
Bitmap1 = CType(Work.Image, Bitmap)
If Bitmap1 IsNot Nothing Then
Bitmap1.RotateFlip(RotateFlipType.Rotate180FlipY)
Work.Image = Bitmap1
End If
Catch ex As Exception
MessageBox.Show(ex.ToString)
End Try
End Sub
Intensity Adjustment:
Here we use a trackbar to assign values to a color matrix and graphic objects to change the work image.
Private Sub tbIntensity_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles
tbIntensity.MouseUp
Dark()
End Sub
Private Sub Dark()
Try
Work.Image = WorkImg.Clone
Dim image_attr As New ImageAttributes
Dim rect As Rectangle = Rectangle.Round(Work.Image.GetBounds(GraphicsUnit.Pixel))
Dim wid As Integer = Work.Image.Width
Dim hgt As Integer = Work.Image.Height
' Dim Wrk_img As New Bitmap(wid, hgt)
Dim gr As Graphics = Graphics.FromImage(Work.Image)
Dim cm As ColorMatrix = New ColorMatrix(New Single()() _
{ _
New Single() {Math.Abs(tbIntensity.Value / 127), 0, 0, 0.0, 0.0}, _
New Single() {0, Math.Abs(tbIntensity.Value / 127), 0, 0.0, 0.0}, _
New Single() {0, 0, Math.Abs(tbIntensity.Value / 127), 0.0, 0.0}, _
New Single() {0, 0, 0, 1.0, 0.0}, _
New Single() {0.01, 0.01, 0.01, 0.0, 1.0}})
image_attr.SetColorMatrix(cm)
gr.DrawImage(Work.Image, rect, 0, 0, wid, hgt, GraphicsUnit.Pixel, image_attr)
Work.Refresh()
Catch ex As Exception
MessageBox.Show(ex.ToString)
End Try
End Sub
We can then make these changes permanent by assigning the image to the work image by pressin "Glue 1".
Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles
btnPermanent.Click
WorkImg = Work.Image
End Sub
Color Reduction:
There are not millions of shades on commercial thread, so I tried to make some similar shades be grouped in an unique color, and at the same time getting the difference between areas a little more marked, so it would be easier to clear colors or getting outlines, so I divided the three color components on chunks of equal lenght and getting the individual values of each pixel transformed by susbtracting the values left afer a "MOD" operation and then multiplying them again by the original divider. This way I eliminate the small variation between chunks.
These values are selected by clicking on a radiobutton and by pressing the button "Set Colors". I have provided for truecolor, 4096, 512 and 64 colors. These colors are the maximum available to the embroidery pattern, but are not necessarily present:
Private Sub btnConvert_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles
btnConvert.Click
Work.Image = ReduceColors(Work.Image)
End Sub
Private Function ReduceColors(ByVal img As Bitmap) As Image
Dim R, G, B, Total, Reduction As Integer
R = 2
G = 1
B = 0
If rbCol64.Checked = True Then
Reduction = 64
ElseIf rbCol512.Checked = True Then
Reduction = 32
ElseIf rbCol4096.Checked = True Then
Reduction = 16
Else
Reduction = 1
End If
' Reduction = 32
Try
' Lock the bitmap's bits.
Dim rect As New Rectangle(0, 0, img.Width, img.Height)
Dim bmpData As System.Drawing.Imaging.BitmapData = img.LockBits(rect, _
Drawing.Imaging.ImageLockMode.ReadWrite, img.PixelFormat)
' Get the address of the first line.
Dim ptr As IntPtr = bmpData.Scan0
' Declare an array to hold the bytes of the bitmap.
' This code is specific to a bitmap with 24 bits per pixels.
Dim bytes As Integer = Math.Abs(bmpData.Stride) * img.Height
Dim rgbvaluesSr(bytes - 1) As Byte
' Copy the RGB values into the array.
System.Runtime.InteropServices.Marshal.Copy(ptr, rgbvaluesSr, 0, bytes)
For x As Integer = 0 To rgbvaluesSr.Length - 3 Step 3
Total = CInt(rgbvaluesSr(x + R)) + CInt(rgbvaluesSr(x + G)) + CInt(rgbvaluesSr(x + B)/>)
If Total < 765 Then
rgbvaluesSr(x + R) = rgbvaluesSr(x + R) - (rgbvaluesSr(x + R) Mod Reduction)
rgbvaluesSr(x + G) = rgbvaluesSr(x + G) - (rgbvaluesSr(x + G) Mod Reduction)
rgbvaluesSr(x + B)/> = rgbvaluesSr(x + B)/> - (rgbvaluesSr(x + B)/> Mod Reduction)
End If
Next
' Copy the RGB values back to the bitmap
System.Runtime.InteropServices.Marshal.Copy(rgbvaluesSr, 0, ptr, bytes)
' Unlock the bits.
img.UnlockBits(bmpData)
Return img
Catch ex As Exception
MessageBox.Show(ex.ToString)
Return img
End Try
End Function
Convert To RGB:
Some images, like the ones with indexed color tables can not generate graphics objects to work on, so I transform them beforehand to RGB images by creating a RGB bitmap and painting on them the indexed image. It is a way of cheating, but who cares?
Public Shared Function ConvertToRGB(ByVal original As Bitmap) As Bitmap
Dim newImage As New Bitmap(original.Width, original.Height,
System.Drawing.Imaging.PixelFormat.Format24bppRgb)
newImage.SetResolution(original.HorizontalResolution, original.VerticalResolution)
Dim g As Graphics = Graphics.FromImage(newImage)
g.DrawImageUnscaled(original, 0, 0)
g.Dispose()
Return newImage
End Function
Clearing a Color:
When you reduce the colors I have seen some problems, some shades became very dark, the clear background gets darkened, shadows are pronounced and some artifacts(spots) not seen on the original image appear. Also you may want to clear some colors to improve your pattern. So I have provide a function to clear a color by clicking and selecting it from the work image, comparing it with a range of colors selected from a scrollbar and processing the image to clear any similar enough color.
Clicking on the image picks a color and generates other values that are ranges of values for the color comparison.
Private Sub Work_MouseClick(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles
Work.MouseClick
Dim bmx As Bitmap
bmx = New Bitmap(Work.Image)
minus = bmx.GetPixel(e.X, e.Y)
Rx = minus.R
Gx = minus.G
Bx = minus.B
RL = Rx - 5
If RL < 0 Then RL = 0
GL = Gx - 5
If GL < 0 Then GL = 0
BL = Bx - 5
If BL < 0 Then BL = 0
RH = Rx + 5
If RH > 255 Then RH = 255
GH = Gx + 5
If GH > 255 Then GH = 255
BH = Bx + 5
If BH > 255 Then BH = 255
End Sub
Private Sub btnClear_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnClear.Click
Dim x, y As Integer
Dim Tol As Integer = sbTolerance.Value
Try
Dim rect As Rectangle = Rectangle.Round(Work.Image.GetBounds(GraphicsUnit.Pixel))
Dim wid As Integer = Work.Image.Width
Dim hgt As Integer = Work.Image.Height
Dim img As New Bitmap(wid, hgt)
img = Work.Image.Clone
Dim bmpSr As BitmapData = img.LockBits(New Rectangle(0, 0, img.Width, img.Height),
ImageLockMode.ReadWrite, img.PixelFormat)
Dim ptrSr As IntPtr = bmpSr.Scan0
Dim R, G, B, A As Integer
A = 3
R = 2
G = 1
B = 0
Dim bytesSr As Integer = bmpSr.Stride * img.Height
Dim rgbvaluesSr(bytesSr) As Byte
System.Runtime.InteropServices.Marshal.Copy(ptrSr, rgbvaluesSr, 0, bytesSr)
Dim RR, GG, BB As Integer
Dim MinusR, MinusG, MinusB As Integer
If img.PixelFormat = System.Drawing.Imaging.PixelFormat.Format24bppRgb Then
For y = 0 To img.Height - 1
For x = y * bmpSr.Stride To (y + 1) * bmpSr.Stride - 3 Step 3
RR = CInt(rgbvaluesSr(x + R))
GG = CInt(rgbvaluesSr(x + G))
BB = CInt(rgbvaluesSr(x + B)/>)
MinusR = CInt(minus.R)
MinusG = CInt(minus.G)
MinusB = CInt(minus.B)/>
If Math.Abs(RR - MinusR) < Tol And Math.Abs(GG - MinusG) < Tol And Math.Abs(BB - MinusB) <
Tol Then
rgbvaluesSr(x + R) = 255
rgbvaluesSr(x + G) = 255
rgbvaluesSr(x + B)/> = 255
Else
End If
Next x
Next y
ElseIf img.PixelFormat = System.Drawing.Imaging.PixelFormat.Format32bppArgb Then
For y = 0 To img.Height - 1
For x = y * bmpSr.Stride To (y + 1) * bmpSr.Stride - 4 Step 4
RR = CInt(rgbvaluesSr(x + R))
GG = CInt(rgbvaluesSr(x + G))
BB = CInt(rgbvaluesSr(x + B)/>)
MinusR = CInt(minus.R)
MinusG = CInt(minus.G)
MinusB = CInt(minus.B)/>
If Math.Abs(RR - MinusR) < Tol And Math.Abs(GG - MinusG) < Tol And Math.Abs(BB - MinusB) <
Tol Then
rgbvaluesSr(x + R) = 255
rgbvaluesSr(x + G) = 255
rgbvaluesSr(x + B)/> = 255
rgbvaluesSr(x + A) = 255
End If
Next x
Next y
Else
MessageBox.Show("No Provisions for this format")
img.UnlockBits(bmpSr)
Exit Sub
End If
System.Runtime.InteropServices.Marshal.Copy(rgbvaluesSr, 0, ptrSr, bytesSr)
img.UnlockBits(bmpSr)
Work.Image = img
Work.Invalidate()
Dim bmpFromImage As New Bitmap(Work.Width, Work.Height)
bmpFromImage = Work.Image
Dim g1 As Graphics = Graphics.FromImage(img)
g1.DrawImage(bmpFromImage, 0, 0, img.Width, img.Height)
g1.Dispose()
Catch ex As Exception
MessageBox.Show("NoImage To Process")
End Try
End Sub
Getting Edges:
If you want the outline of the image, you could press "Edge". It will process the image to detect sharp variations of color or intensity and eliminate all the other flat colors, the amount of variation on the value of the neighboring pixels is set by a scrollbar:
Private Sub btnEdge_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnEdge.Click
Dim x, y As Integer
Dim Tol As Integer = sbEdge.Value '10 'TrackBar5.Value
Try
Dim rect As Rectangle = Rectangle.Round(Work.Image.GetBounds(GraphicsUnit.Pixel))
Dim wid As Integer = Work.Image.Width
Dim hgt As Integer = Work.Image.Height
Dim img As New Bitmap(wid, hgt)
img = WorkImg.Clone
Dim bmpSr As BitmapData = img.LockBits(New Rectangle(0, 0, img.Width, img.Height),
ImageLockMode.ReadWrite, img.PixelFormat)
Dim ptrSr As IntPtr = bmpSr.Scan0
Dim R, G, B, A, A1, A2, A3, A4 As Integer
R = 2
G = 1
B = 0
A = 3
Dim bytesSr As Integer = bmpSr.Stride * img.Height
Dim rgbvaluesSr(bytesSr) As Byte
System.Runtime.InteropServices.Marshal.Copy(ptrSr, rgbvaluesSr, 0, bytesSr)
'For i As Integer = 0 To rgbvaluesSr.Length - 4 Step 4
For y = 0 To img.Height - 2
If img.PixelFormat = PixelFormat.Format24bppRgb Then
For x = y * bmpSr.Stride To (y + 1) * bmpSr.Stride - 6 Step 3
A1 = CInt(rgbvaluesSr(x + R)) + CInt(rgbvaluesSr(x + G)) + CInt(rgbvaluesSr(x + B)/>)
A2 = CInt(rgbvaluesSr(x + 4 + R)) + CInt(rgbvaluesSr(x + 4 + G)) + CInt(rgbvaluesSr(x + 4 +
B)/>)
A3 = CInt(rgbvaluesSr(x + R + bmpSr.Stride)) + CInt(rgbvaluesSr(x + G + bmpSr.Stride)) +
CInt(rgbvaluesSr(x + B + bmpSr.Stride))
A4 = CInt(rgbvaluesSr(x + 4 + R + bmpSr.Stride)) + CInt(rgbvaluesSr(x + 4 + G +
bmpSr.Stride)) + CInt(rgbvaluesSr(x + 4 + B + bmpSr.Stride))
'If (A2 - A1) > Tol Or (A3 - A1) > Tol Or (A4 - A1) > Tol Then
If Math.Abs(A2 - A1) > Tol Or Math.Abs(A3 - A1) > Tol Or Math.Abs(A4 - A1) > Tol Then
' rgbvaluesSr(x + R) = 0
' rgbvaluesSr(x + G) = 0
' rgbvaluesSr(x + B)/> = 0
Else
rgbvaluesSr(x + R) = 255
rgbvaluesSr(x + G) = 255
rgbvaluesSr(x + B)/> = 255
End If
If x = (y + 1) * bmpSr.Stride - 3 Then
'Dark Line To the Right
rgbvaluesSr(x + R + 4) = 255
rgbvaluesSr(x + G + 4) = 255
rgbvaluesSr(x + B + 4) = 255
rgbvaluesSr(x + R + 8) = 255
rgbvaluesSr(x + G + 8) = 255
rgbvaluesSr(x + B + 8) = 255
rgbvaluesSr(x + R + 12) = 255
rgbvaluesSr(x + G + 12) = 255
rgbvaluesSr(x + B + 12) = 255
End If
Next x
ElseIf img.PixelFormat = PixelFormat.Format32bppArgb Then
For x = y * bmpSr.Stride To (y + 1) * bmpSr.Stride - 8 Step 4
A1 = CInt(rgbvaluesSr(x + R)) + CInt(rgbvaluesSr(x + G)) + CInt(rgbvaluesSr(x + B)/>)
A2 = CInt(rgbvaluesSr(x + 4 + R)) + CInt(rgbvaluesSr(x + 4 + G)) + CInt(rgbvaluesSr(x + 4 +
B)/>)
A3 = CInt(rgbvaluesSr(x + R + bmpSr.Stride)) + CInt(rgbvaluesSr(x + G + bmpSr.Stride)) +
CInt(rgbvaluesSr(x + B + bmpSr.Stride))
A4 = CInt(rgbvaluesSr(x + 4 + R + bmpSr.Stride)) + CInt(rgbvaluesSr(x + 4 + G +
bmpSr.Stride)) + CInt(rgbvaluesSr(x + 4 + B + bmpSr.Stride))
'If (A2 - A1) > Tol Or (A3 - A1) > Tol Or (A4 - A1) > Tol Then
If Math.Abs(A2 - A1) > Tol Or Math.Abs(A3 - A1) > Tol Or Math.Abs(A4 - A1) > Tol Then
' rgbvaluesSr(x + A) = 255
' rgbvaluesSr(x + R) = 0
' rgbvaluesSr(x + G) = 0
' rgbvaluesSr(x + B)/> = 0
Else
rgbvaluesSr(x + A) = 255
rgbvaluesSr(x + R) = 255
rgbvaluesSr(x + G) = 255
rgbvaluesSr(x + B)/> = 255
End If
If x = (y + 1) * bmpSr.Stride - 8 Then
'Dark Line To the Right
rgbvaluesSr(x + A + 4) = 255
rgbvaluesSr(x + R + 4) = 255
rgbvaluesSr(x + G + 4) = 255
rgbvaluesSr(x + B + 4) = 255
rgbvaluesSr(x + A + 8) = 255
rgbvaluesSr(x + R + 8) = 255
rgbvaluesSr(x + G + 8) = 255
rgbvaluesSr(x + B + 8) = 255
rgbvaluesSr(x + A + 12) = 255
rgbvaluesSr(x + R + 12) = 255
rgbvaluesSr(x + G + 12) = 255
rgbvaluesSr(x + B + 12) = 255
End If
Next x
Else
MessageBox.Show("No Provisions Fot This Format")
Exit Sub
End If
Next y
System.Runtime.InteropServices.Marshal.Copy(rgbvaluesSr, 0, ptrSr, bytesSr)
img.UnlockBits(bmpSr)
Work.Image = img
Work.Invalidate()
Dim bmpFromImage As New Bitmap(Work.Width, Work.Height)
bmpFromImage = Work.Image
Dim g1 As Graphics = Graphics.FromImage(img)
g1.DrawImage(bmpFromImage, 0, 0, img.Width, img.Height)
g1.Dispose()
Catch
MessageBox.Show("NoImage To Process")
End Try
End Sub
The pattern creation routine runs on two nested loops using lockbits, so we move across and down on the values of "x" and "y". We divide the image in squares of 5 pixels, that is a small area of about one-sixteen of and inch. It is an odd number so we can have a simmetric "X". We check the values of the colors in that area and determine the color of the "X" and assign that value to the figure and blank all the other pixels.
When we are done and return the image, we enlarge it by a factor set on the numeric Up-Down. We are enlarging a picture that may already be large, so there is a warning when the value is set to 5:
Private Sub Num1_ValueChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles
Num1.ValueChanged
If Num1.Value = 5 Then MessageBox.Show("Please Be Cautious With Large Images")
End Sub
Private Sub btnGenerate_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles
btnGenerate.Click
Dim x, y As Integer
WorkImg = Work.Image
Try
Dim rect As Rectangle = Rectangle.Round(Work.Image.GetBounds(GraphicsUnit.Pixel))
Dim wid As Integer = Work.Image.Width
Dim hgt As Integer = Work.Image.Height
Dim img As New Bitmap(wid, hgt)
img = WorkImg.Clone 'ConvertToLess(WorkImg.Clone)
img = ConvertToRGB(img)
Dim bmpSr As BitmapData = img.LockBits(New Rectangle(0, 0, img.Width, img.Height),
ImageLockMode.ReadWrite, img.PixelFormat)
Dim ptrSr As IntPtr = bmpSr.Scan0
Dim R, G, B As Integer
R = 2
G = 1
B = 0
'A = 3
Dim bytesSr As Integer = bmpSr.Stride * img.Height
Dim rgbvaluesSr(bytesSr) As Byte
System.Runtime.InteropServices.Marshal.Copy(ptrSr, rgbvaluesSr, 0, bytesSr)
Dim stp As Integer = 5 'Size Of Pixelation
For y = 0 To img.Height - stp - 1 Step stp
If img.PixelFormat = PixelFormat.Format24bppRgb Then
For x = y * bmpSr.Stride To (y + 1) * bmpSr.Stride Step 3 * stp
' Dim PromR As Integer = rgbvaluesSr(x + R + 6 + 2 * bmpSr.Stride)
' Dim PromG As Integer = rgbvaluesSr(x + G + 6 + 2 * bmpSr.Stride)
' Dim PromB As Integer = rgbvaluesSr(x + B + 6 + 2 * bmpSr.Stride)
Dim PromR As Integer = 16 * (rgbvaluesSr(x + R + 6 + 2 * bmpSr.Stride) / 16)
Dim PromG As Integer = 16 * (rgbvaluesSr(x + G + 6 + 2 * bmpSr.Stride) / 16)
Dim PromB As Integer = 16 * (rgbvaluesSr(x + B + 6 + 2 * bmpSr.Stride) / 16)
rgbvaluesSr(x + R) = 255 'PromR
rgbvaluesSr(x + R + 12) = 255 'PromR
rgbvaluesSr(x + G) = 255 'PromG
rgbvaluesSr(x + G + 12) = 255 'PromG
rgbvaluesSr(x + B)/> = 255 'PromB
rgbvaluesSr(x + B + 12) = 255 'PromB
rgbvaluesSr(x + R + 3) = 255
rgbvaluesSr(x + R + 9) = 255
rgbvaluesSr(x + G + 3) = 255
rgbvaluesSr(x + G + 9) = 255
rgbvaluesSr(x + B + 3) = 255
rgbvaluesSr(x + B + 9) = 255
rgbvaluesSr(x + R + 6) = 255
rgbvaluesSr(x + G + 6) = 255
rgbvaluesSr(x + B + 6) = 255
'
rgbvaluesSr(x + R + bmpSr.Stride + 3) = PromR
rgbvaluesSr(x + R + bmpSr.Stride + 9) = PromR
rgbvaluesSr(x + G + bmpSr.Stride + 3) = PromG
rgbvaluesSr(x + G + bmpSr.Stride + 9) = PromG
rgbvaluesSr(x + B + bmpSr.Stride + 3) = PromB
rgbvaluesSr(x + B + bmpSr.Stride + 9) = PromB
rgbvaluesSr(x + R + bmpSr.Stride) = 255
rgbvaluesSr(x + R + bmpSr.Stride + 12) = 255
rgbvaluesSr(x + G + bmpSr.Stride) = 255
rgbvaluesSr(x + G + bmpSr.Stride + 12) = 255
rgbvaluesSr(x + B + bmpSr.Stride) = 255
rgbvaluesSr(x + B + bmpSr.Stride + 12) = 255
rgbvaluesSr(x + R + bmpSr.Stride + 6) = 255
rgbvaluesSr(x + G + bmpSr.Stride + 6) = 255
rgbvaluesSr(x + B + bmpSr.Stride + 6) = 255
'
rgbvaluesSr(x + R + 2 * bmpSr.Stride + 6) = PromR
rgbvaluesSr(x + G + 2 * bmpSr.Stride + 6) = PromG
rgbvaluesSr(x + B + 2 * bmpSr.Stride + 6) = PromB
rgbvaluesSr(x + R + 2 * bmpSr.Stride) = 255
rgbvaluesSr(x + R + 2 * bmpSr.Stride + 12) = 255
rgbvaluesSr(x + G + 2 * bmpSr.Stride) = 255
rgbvaluesSr(x + G + 2 * bmpSr.Stride + 12) = 255
rgbvaluesSr(x + B + 2 * bmpSr.Stride) = 255
rgbvaluesSr(x + B + 2 * bmpSr.Stride + 12) = 255
rgbvaluesSr(x + R + 2 * bmpSr.Stride + 3) = 255
rgbvaluesSr(x + R + 2 * bmpSr.Stride + 9) = 255
rgbvaluesSr(x + G + 2 * bmpSr.Stride + 3) = 255
rgbvaluesSr(x + G + 2 * bmpSr.Stride + 9) = 255
rgbvaluesSr(x + B + 2 * bmpSr.Stride + 3) = 255
rgbvaluesSr(x + B + 2 * bmpSr.Stride + 9) = 255
'
rgbvaluesSr(x + R + 3 * bmpSr.Stride + 3) = PromR
rgbvaluesSr(x + R + 3 * bmpSr.Stride + 9) = PromR
rgbvaluesSr(x + G + 3 * bmpSr.Stride + 3) = PromG
rgbvaluesSr(x + G + 3 * bmpSr.Stride + 9) = PromG
rgbvaluesSr(x + B + 3 * bmpSr.Stride + 3) = PromB
rgbvaluesSr(x + B + 3 * bmpSr.Stride + 9) = PromB
rgbvaluesSr(x + R + 3 * bmpSr.Stride) = 255
rgbvaluesSr(x + R + 3 * bmpSr.Stride + 12) = 255
rgbvaluesSr(x + G + 3 * bmpSr.Stride) = 255
rgbvaluesSr(x + G + 3 * bmpSr.Stride + 12) = 255
rgbvaluesSr(x + B + 3 * bmpSr.Stride) = 255
rgbvaluesSr(x + B + 3 * bmpSr.Stride + 12) = 255
rgbvaluesSr(x + R + 3 * bmpSr.Stride + 6) = 255
rgbvaluesSr(x + G + 3 * bmpSr.Stride + 6) = 255
rgbvaluesSr(x + B + 3 * bmpSr.Stride + 6) = 255
'
rgbvaluesSr(x + R + 4 * bmpSr.Stride) = 255 ' PromR
rgbvaluesSr(x + R + 4 * bmpSr.Stride + 12) = 255 'PromR
rgbvaluesSr(x + G + 4 * bmpSr.Stride) = 255 'PromG
rgbvaluesSr(x + G + 4 * bmpSr.Stride + 12) = 255 'PromG
rgbvaluesSr(x + B + 4 * bmpSr.Stride) = 255 'PromB
rgbvaluesSr(x + B + 4 * bmpSr.Stride + 12) = 255 'PromB
rgbvaluesSr(x + R + 4 * bmpSr.Stride + 3) = 255
rgbvaluesSr(x + R + 4 * bmpSr.Stride + 9) = 255
rgbvaluesSr(x + G + 4 * bmpSr.Stride + 3) = 255
rgbvaluesSr(x + G + 4 * bmpSr.Stride + 9) = 255
rgbvaluesSr(x + B + 4 * bmpSr.Stride + 3) = 255
rgbvaluesSr(x + B + 4 * bmpSr.Stride + 9) = 255
rgbvaluesSr(x + R + 4 * bmpSr.Stride + 6) = 255
rgbvaluesSr(x + G + 4 * bmpSr.Stride + 6) = 255
rgbvaluesSr(x + B + 4 * bmpSr.Stride + 6) = 255
'
If x = (y + 1) * bmpSr.Stride - 6 Then
'Dark Line To the Right
rgbvaluesSr(x + R + 4) = 255
rgbvaluesSr(x + G + 4) = 255
rgbvaluesSr(x + B + 4) = 255
rgbvaluesSr(x + R + 8) = 255
rgbvaluesSr(x + G + 8) = 255
rgbvaluesSr(x + B + 8) = 255
rgbvaluesSr(x + R + 12) = 255
rgbvaluesSr(x + G + 12) = 255
rgbvaluesSr(x + B + 12) = 255
End If
Next x
Else
MessageBox.Show("No Provisions Fot This Format")
Exit Sub
End If
Next y
System.Runtime.InteropServices.Marshal.Copy(rgbvaluesSr, 0, ptrSr, bytesSr)
img.UnlockBits(bmpSr)
' PictureBox1.Image = img
' PictureBox1.Invalidate()
Cross.Image = DoublSize(img, Num1.Value)
Work.Invalidate()
Dim bmpFromImage As New Bitmap(Work.Width, Work.Height)
bmpFromImage = Work.Image
Dim g1 As Graphics = Graphics.FromImage(img)
g1.DrawImage(bmpFromImage, 0, 0, img.Width, img.Height)
g1.Dispose()
Catch ex As Exception
MessageBox.Show(ex.ToString)
End Try
End Sub
Public Function DoublSize(ByVal OrigImg As Image, ByVal XSize As Integer) As Image
Dim imgFormat = OrigImg.RawFormat
'Create Bitmap from the image
Dim imgOutput As New Bitmap(OrigImg, XSize * Work.Width, XSize * Work.Height)
'Create a Graphics object
Dim GResize As Graphics
GResize = Graphics.FromImage(imgOutput)
'Set the image to high quality
GResize.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
GResize.DrawImage(OrigImg, 0, 0, XSize * Work.Width, XSize * Work.Height)
GResize.Dispose()
Return imgOutput
End Function
I play with graphics, but as you may already have noticed, I am not good for graphic design, I don't produce good user's interfaces, but I go more to functionality on my end. Anyway, you may have noticed an enclosed area with three black squares, two arrows and two diskette icons. These are convenience commands.
The arrows will tranfer the image on the left picturebox to the right one and vice-versa. The diskette icons, will save the image 1 or the image 2.
The 3 squares are black labels (like some whiskeys), the left one will pop a thumbail of the reload image when hovering on it. If you click on it you will reload the original image to picturebox1. The one in the center pops up a thumbnail of the inmediate work image, appearing on picturebox1. Some images are larger than the panel, so they won't show on its entirety. If you click on it, it will save the thumbnail on its actual size. The one on the right will do the same but with the cross stitch pattern image:
Private Sub lblPopPic1_MouseEnter(ByVal sender As Object, ByVal e As System.EventArgs) Handles
lblPopPic1.MouseEnter, lblPopPic2.MouseEnter, lblPopOrig.MouseEnter
If sender Is lblPopPic1 Then PopupPictures.Image = Work.Image
If sender Is lblPopPic2 Then PopupPictures.Image = Cross.Image
If sender Is lblPopOrig Then PopupPictures.Image = ReloadImg
PopupPictures.Visible = True
End Sub
Private Sub lblPopPic1_MouseLeave(ByVal sender As Object, ByVal e As System.EventArgs) Handles
lblPopPic1.MouseLeave, lblPopPic2.MouseLeave, lblPopOrig.MouseLeave
PopupPictures.Visible = False
End Sub
Private Sub btnTransfer21_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles
btnTransfer21.Click
Work.Image = Cross.Image.Clone
End Sub
Private Sub btnTransfer12_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles
btnTransfer12.Click
Cross.Image = Work.Image.Clone
End Sub
Private Sub lblPopPic1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles
lblPopPic1.Click, lblPopPic2.Click
Dim i As Integer
Dim str As String = ""
For i = 1 To 1000
If i < 10 Then str = "Picture_00" & i.ToString & ".jpg"
If i > 9 And i < 100 Then str = "Picture_0" & i.ToString & ".jpg"
If i > 99 Then str = "Picture_" & i.ToString & ".jpg"
If i > 900 Then MsgBox("You Have Over 900 Pictures, Please Check And Delete Unnecesary Ones")
If Not System.IO.File.Exists(str) Then
Try
If Not PopupPictures.Image Is Nothing Then
' Image Size Is Not The Same As PictureBox Size(SizeMode)
GetThumb(PopupPictures.Image, PopupPictures.Width, PopupPictures.Height).Save(str,
System.Drawing.Imaging.ImageFormat.Jpeg)
End If
Catch Ex As Exception
MsgBox("Could Not Write To Location")
End Try
Exit For
End If
Next
End Sub
Public Function GetThumb(ByVal OrigImg As Image, ByVal NewW As Integer, ByVal NewH As Integer) As Image
Dim imgFormat = OrigImg.RawFormat
'Create Bitmap from the image
Dim imgOutput As New Bitmap(OrigImg, NewW, NewH)
'Create a Graphics object
Dim GResize As Graphics
GResize = Graphics.FromImage(imgOutput)
'Set the image to high quality
GResize.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
GResize.DrawImage(OrigImg, 0, 0, PopupPictures.Width, PopupPictures.Height)
GResize.Dispose()
Return imgOutput
End Function
Using the arrows you can transfer back and forth images between picturebox1 and picturebox2. I have provided a routine for picturebox2 that will clear and area by clicking and dragging the mouse. At mouseup it will clear that area, then you could transfer it to picturebox1 in order to more processing. There we are creating a polygon and filling it with white:
Private Sub Cross_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles
Cross.MouseDown
selected_path.Reset()
' Erase any previous drawing.
' Save the starting point.
m_MaxPoint = 0
ReDim m_Points(m_MaxPoint)
m_Points(m_MaxPoint).X = e.X
m_Points(m_MaxPoint).Y = e.Y
End Sub
Private Sub Cross_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles
Cross.MouseMove
If (e.Button = MouseButtons.Left) Then
' Do nothing if we're not selecting a region.
If m_Points Is Nothing Then Exit Sub
' Save the new point.
m_MaxPoint += 1
ReDim Preserve m_Points(m_MaxPoint)
m_Points(m_MaxPoint).X = e.X
m_Points(m_MaxPoint).Y = e.Y
' Draw the latest line.
Dim gr As Graphics = Cross.CreateGraphics
'gr.DrawLine(Pens.Yellow, _
gr.DrawLine(Pens.White, _
m_Points(m_MaxPoint).X, _
m_Points(m_MaxPoint).Y, _
m_Points(m_MaxPoint - 1).X, _
m_Points(m_MaxPoint - 1).Y)
End If
End Sub
Private Sub Cross_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles
Cross.MouseUp
Dim MyGraphics As Graphics
Dim TransBrush As New SolidBrush(Color.White)
' Do nothing if we're not selecting a region.
If m_Points Is Nothing Then Exit Sub
' Close the region.
If (m_Points(0).X <> m_Points(m_MaxPoint).X) Or _
(m_Points(0).Y <> m_Points(m_MaxPoint).Y) _
Then
' Save the new point.
m_MaxPoint += 1
ReDim Preserve m_Points(m_MaxPoint)
m_Points(m_MaxPoint).X = m_Points(0).X
m_Points(m_MaxPoint).Y = m_Points(0).Y
End If
' Make the points into a Path.
selected_path.AddLines(m_Points)
Try
' px(UBound(pts)) = px(0)
Dim bm As New Bitmap(Cross.Image)
MyGraphics = Graphics.FromImage(bm)
MyGraphics.FillPolygon(TransBrush, m_Points)
Cross.Image = bm
m_Points = Nothing
GC.Collect()
Catch
MessageBox.Show("Error")
m_Points = Nothing
Exit Sub
End Try
End Sub
There is a little bit more of code that you could see in the project enclosed, that is just convenience routines, like view output folder ore check pixel format.
Take a look, please.
Thank you for checking me out.
ricardosms.
Attached File(s)
-
CrossStitch1.zip (158.17K)
Number of downloads: 224
MultiQuote
| 