please see this images
Green Background
Red Background
This person's picture has a green background. When I replace the green color to another color, it also replaces the color of the card
I drew a rectangle on the card, how do I exclude the rectangle from the replacement
replace color code:
Public Function ReplaceColor(ByVal _image As Image, ByVal _colorOld As Color, ByVal _colorNew As Color, ByVal _tolerance As Integer) As Image
Dim bmap As Bitmap = CType(_image.Clone(), Bitmap)
Dim c As Color
Dim iR_Min, iR_Max As Integer
Dim iG_Min, iG_Max As Integer
Dim iB_Min, iB_Max As Integer
iR_Min = Math.Max(CInt(_colorOld.R) - _tolerance, 0)
iR_Max = Math.Min(CInt(_colorOld.R) + _tolerance, 255)
iG_Min = Math.Max(CInt(_colorOld.G) - _tolerance, 0)
iG_Max = Math.Min(CInt(_colorOld.G) + _tolerance, 255)
iB_Min = Math.Max(CInt(_colorOld.B) - _tolerance, 0)
iB_Max = Math.Min(CInt(_colorOld.B) + _tolerance, 255)
For x As Integer = 0 To bmap.Width - 1
For y As Integer = 0 To bmap.Height - 1
c = bmap.GetPixel(x, y)
If (c.R >= iR_Min AndAlso c.R <= iR_Max) AndAlso (c.G >= iG_Min AndAlso c.G <= iG_Max) AndAlso (c.B >= iB_Min AndAlso c.B <= iB_Max) Then
If _colorNew = Color.Transparent Then
bmap.SetPixel(x, y, Color.FromArgb(0, _colorNew.R, _colorNew.G, _colorNew.B))
Else
bmap.SetPixel(x, y, Color.FromArgb(c.A, _colorNew.R, _colorNew.G, _colorNew.B))
End If
End If
Next
Next
Return CType(bmap.Clone(), Image)
End Function
my rectangle mastk info:
Private Rct2 As New Rectangle(247, 378, 100, 70)
how do I exclude the rectangle from the replacement
Just use Rectangle.Contains(), but put a Not in front like this:
Public Function ReplaceColor(ByVal _image As Image, ByVal _colorOld As Color, ByVal _colorNew As Color, ByVal _tolerance As Integer) As Image
' ... other code ...
For x As Integer = 0 To bmap.Width - 1
For y As Integer = 0 To bmap.Height - 1
If Not Rct2.Contains(New Point(x, y)) Then
' ... other code ...
End If
Next
Next
Return CType(bmap.Clone(), Image)
End Function
Related
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Compare(PictureBox1.Image, PictureBox2.Image)
End Sub
Public Function Compare(ByVal img1_ As Image, ByVal img2_ As Image) As Double
Dim pixelNb As Integer = img1_.Width * img1_.Height
Dim percent As Double = 100
Dim resized_img2_ As Bitmap = ResizeBitmap(CType(img2_, Bitmap), img1_.Width, img1_.Height)
For i As Integer = 0 To img1_.Width - 1
For j As Integer = 0 To img1_.Height - 1
percent -= ColorCompare((CType(img1_, Bitmap)).GetPixel(i, j), (CType(resized_img2_, Bitmap)).GetPixel(i, j)) / pixelNb
Next
Next
Return percent
End Function
Public Function ResizeBitmap(ByVal b As Bitmap, ByVal nWidth As Integer, ByVal nHeight As Integer) As Bitmap
Dim result As Bitmap = New Bitmap(nWidth, nHeight)
Using g As Graphics = Graphics.FromImage(CType(result, Image))
g.DrawImage(b, 0, 0, nWidth, nHeight)
End Using
Return result
End Function
Public Function ColorCompare(ByVal c1 As Color, ByVal c2 As Color) As Double
Return Double.Parse((Math.Abs(c1.B - c2.B) + Math.Abs(c1.R - c2.R) + Math.Abs(c1.G - c2.G)).ToString()) * 100 / (3 * 255)
End Function
Error Give in this line
Return Double.Parse((Math.Abs(c1.B - c2.B) + Math.Abs(c1.R - c2.R) +
Math.Abs(c1.G - c2.G)).ToString()) * 100 / (3 * 255)
c1.B returns a byte. A Byte has a value of 0-255 and is unsigned so it cannot hold a negative value.
Dim a As Byte = 200
Dim b As Byte = 201
Dim x = a - b
causes the same overflow error.
Changing to an integer avoids the error. A cast doesn't seem to be necessary as it is widening (no data loss).
Dim a As Byte = 200
Dim b As Byte = 201
Dim c As Integer = a
Dim d As Integer = b
Dim x = c - d
Change your color bytes to Integers and try again.
Dim g, h, i, j, k, l As Integer
g = c1.B
h = c2.B
i = c1.R
j = c1.R
k = c1.G
l = c1.G
Dim result As Double = CDbl(Math.Abs(g - h) + Math.Abs(i - j) + Math.Abs(k - l)) * 100 / (3 * 255)
Return result
Im looking for a way to detect the center of grid squares when VB.net is feed an image
I want to start with an image of a grid with blue squares like this:
Grid
and i want the program to make an array of points in the center of each square like this (points aren't centered in picture)
Grid with Red points
i dont want to modify the image, i just want to get the points. I've tried getpixel for x and y but that just returns the same point
Dim search_color As Color = Color.FromArgb(255, 64, 128, 192)
Dim background_color As Color = Color.FromArgb(255, 240, 240, 240)
Dim grid_color As Color = Color.FromArgb(255, 144, 144, 144)
Dim pix As Color
Dim liney = 0, linex = 0
Dim loc, sloc, gloc As Point
For ch As Integer = 1 To 64
For y As Integer = liney To Bmp.Height - 1
For x As Integer = linex To Bmp.Width - 1
If Bmp.GetPixel(x, y) = search_color Then
sloc = New Point(x, y)
linex = x
liney = y
x = Bmp.Width - 1
y = Bmp.Height - 1
End If
Next
Next
Dim xloc = 0
For x As Integer = sloc.X To Bmp.Width - 1
If Bmp.GetPixel(x, sloc.Y) = grid_color Then
xloc = x - 1
End If
If Bmp.GetPixel(x, sloc.Y) = background_color Then
xloc = x - 1
End If
Next
For y As Integer = sloc.Y To Bmp.Height - 1
If Bmp.GetPixel(xloc, y) = grid_color Or Bmp.GetPixel(xloc, y) = background_color Then
gloc = New Point(xloc, y - 1)
End If
Next
loc = New Point((gloc.X + sloc.X) / 2, (gloc.Y + sloc.Y) / 2)
liney = gloc.Y
linex = gloc.X + 20
ListBox1.Items.Add(loc.ToString)
Next
Try this:
I added the following controls to a form to test the code:
pbImageToScan (PictureBox) - btnAnalyzeIMG (Button) - lbResult (ListBox)
Public Class Form1
Dim arrCenters() As Point
Dim bmpToAnalyze As Bitmap
Dim search_color As Color = Color.FromArgb(255, 64, 128, 192)
Dim background_color As Color = Color.FromArgb(255, 240, 240, 240)
Dim grid_color As Color = Color.FromArgb(255, 144, 144, 144)
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
bmpToAnalyze = New Bitmap(Application.StartupPath & "\Image.bmp")
pbImageToScan.Image = Image.FromFile(Application.StartupPath & "\Image.bmp")
End Sub
Private Sub btnAnalyzeIMG_Click(sender As Object, e As EventArgs) Handles btnAnalyzeIMG.Click
FindCenters()
End Sub
Private Sub FindCenters()
bmpToAnalyze = New Bitmap(Application.StartupPath & "\Image.bmp")
pbImageToScan.Image = Image.FromFile(Application.StartupPath & "\Image.bmp")
'arrCenters is the array who will contains all centers data
ReDim arrCenters(0)
'arrCenters already starts with an element; this boolean is used to handle the first point insertion
Dim bFirstElementAddedToArray As Boolean
lbResult.Items.Clear()
Dim iIMGWidth As Integer = bmpToAnalyze.Width
Dim iIMGHeight As Integer = bmpToAnalyze.Height
'X, Y coordinates used for iterations
Dim iX As Integer = 0
Dim iY As Integer = 0
'Bitmap limits reached
Dim bExit As Boolean
'Used to skip a great part of Ys, if a match has been found along the current examinated line
Dim iDeltaYMax As Integer = 0
'Main cycle
Do While Not bExit
Dim colCurrentColor As Color = bmpToAnalyze.GetPixel(iX, iY)
If colCurrentColor = search_color Then
Dim iXStart As Integer = iX
Dim iYStart As Integer = iY
Dim iXEnd As Integer
Dim iYEnd As Integer
'Width of the Blue square
For iXEnd = iX + 1 To iIMGWidth - 1
Dim colColorSearchX As Color = bmpToAnalyze.GetPixel(iXEnd, iY)
If (colColorSearchX = background_color) Or (colColorSearchX = grid_color) Then
iXEnd -= 1
Exit For
End If
Next
'Height of the Blue square
For iYEnd = iY + 1 To iIMGHeight - 1
Dim colColorSearchY As Color = bmpToAnalyze.GetPixel(iXEnd, iYEnd)
If (colColorSearchY = background_color) Or (colColorSearchY = grid_color) Then
iYEnd -= 1
Exit For
End If
Next
iDeltaYMax = iYEnd - iYStart
'Blue square center coordinates
Dim pCenter As New Point((iXStart + iXEnd) / 2, (iYStart + iYEnd) / 2)
Dim iArrLenght As Integer = 0
If Not bFirstElementAddedToArray Then
bFirstElementAddedToArray = True
Else
iArrLenght = arrCenters.GetLength(0)
ReDim Preserve arrCenters(iArrLenght)
End If
arrCenters(iArrLenght) = pCenter
lbResult.Items.Add(pCenter.ToString)
iX = iXEnd
'Checks if the Width limit of the bitmap has been reached
If iX = (iIMGWidth - 1) Then
iX = 0
iY += iDeltaYMax + 1
iDeltaYMax = 0
Else
iX += 1
End If
Else
'Checks if the Width limit of the bitmap has been reached
If iX = (iIMGWidth - 1) Then
iX = 0
iY += iDeltaYMax + 1
iDeltaYMax = 0
Else
iX += 1
End If
End If
'Width and Height limit of the bitmap have been reached
If (iX = iIMGWidth - 1) And (iY = iIMGHeight - 1) Then
bExit = True
End If
Loop
'Draws a Red point on every center found
For Each P As Point In arrCenters
bmpToAnalyze.SetPixel(P.X, P.Y, Color.Red)
Next
pbImageToScan.Image = bmpToAnalyze
End Sub
End Class
How would I go about reducing the latency of grabbing an image from Picturebox then emboss that image and return you picturebox as this is a camera handle and will need to capture/emboss at least 16 fps but i'm getting like 1 every 2.5 seconds
SwitchImageSave = 1
Button1.Enabled = False
StCam.StopTransfer(m_hCamera)
Dim nReval As Integer
Dim nLastErrorNo As Integer
Dim nBufferSize As Integer
Dim dwWidth As Integer
Dim dwHeight As Integer
Dim dwLinePitch As Integer
nReval = StCam.GetPreviewDataSize(m_hCamera, nBufferSize, dwWidth, dwHeight, dwLinePitch)
Dim dwPreviewPixelFormat As Integer
nReval = StCam.GetPreviewPixelFormat(m_hCamera, dwPreviewPixelFormat)
Dim pixelFormat As Imaging.PixelFormat = Imaging.PixelFormat.Format8bppIndexed
Select Case dwPreviewPixelFormat
Case StCam.STCAM_PIXEL_FORMAT_24_BGR
pixelFormat = Imaging.PixelFormat.Format24bppRgb
Case StCam.STCAM_PIXEL_FORMAT_32_BGR
pixelFormat = Imaging.PixelFormat.Format32bppRgb
End Select
Dim pbyteImageBuffer(nBufferSize) As Byte
Dim dwNumberOfByteTrans As Integer = 0
Dim pdwFrameNo(1) As Integer
Dim dwMilliseconds As Integer = 100
Dim gch As System.Runtime.InteropServices.GCHandle = System.Runtime.InteropServices.GCHandle.Alloc(pbyteImageBuffer, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim ptr As IntPtr = gch.AddrOfPinnedObject()
nReval = StCam.TakePreviewSnapShot(m_hCamera, ptr, nBufferSize, dwNumberOfByteTrans, pdwFrameNo, dwMilliseconds)
gch.Free()
Dim bitmap As Bitmap = New Bitmap(dwWidth, dwHeight, pixelFormat)
Select Case pixelFormat
Case Imaging.PixelFormat.Format8bppIndexed
Dim colorPalette As System.Drawing.Imaging.ColorPalette = bitmap.Palette
For pixelValue As Integer = 0 To 255
colorPalette.Entries(pixelValue) = Color.FromArgb(pixelValue, pixelValue, pixelValue)
Next
bitmap.Palette = colorPalette
End Select
Dim bitmapData As Imaging.BitmapData = bitmap.LockBits(New Rectangle(0, 0, dwWidth, dwHeight), Imaging.ImageLockMode.WriteOnly, pixelFormat)
Runtime.InteropServices.Marshal.Copy(pbyteImageBuffer, 0, bitmapData.Scan0(), nBufferSize)
bitmap.UnlockBits(bitmapData)
Dim bmap As Bitmap
bmap = New Bitmap(bitmap)
PictureBox2.Image = bmap
' PictureBox2.Image = bmap
Dim tempbmp As New Bitmap(bmap)
Dim i, j As Integer
Dim DispX As Integer = 1, DispY As Integer = 1
Dim red, green, blue As Integer
With tempbmp
For i = 0 To .Height - 2
For j = 0 To .Width - 2
Dim pixel1, pixel2 As System.Drawing.Color
pixel1 = .GetPixel(j, i)
pixel2 = .GetPixel(j + DispX, i + DispY)
red = Math.Min(Math.Abs(CInt(pixel1.R) - CInt(pixel2.R)) + 128, 255)
green = Math.Min(Math.Abs(CInt(pixel1.G) - CInt(pixel2.G)) + 128, 255)
blue = Math.Min(Math.Abs(CInt(pixel1.B) - CInt(pixel2.B)) + 128, 255)
bmap.SetPixel(j, i, Color.FromArgb(red, green, blue))
Next
Next
End With
PictureBox2.Image = bmap
PictureBox2.Refresh()
PictureBox2.BringToFront()
Dim bitmapData As Imaging.BitmapData = bitmap.LockBits(New Rectangle(0, 0, dwWidth, dwHeight), Imaging.ImageLockMode.WriteOnly, pixelFormat)
Runtime.InteropServices.Marshal.Copy(pbyteImageBuffer, 0, bitmapData.Scan0(), nBufferSize)
bitmap.UnlockBits(bitmapData)
PictureBox2.Image = bitmap
Dim temp As Bitmap = PictureBox2.Image
Dim raz As Integer = temp.Height / 4
Dim height As Integer = temp.Height
Dim width As Integer = temp.Width
Dim rect As New Rectangle(Point.Empty, temp.Size)
Dim bmpData As BitmapData = temp.LockBits(rect, ImageLockMode.[ReadOnly], temp.PixelFormat)
Dim bpp As Integer = If((temp.PixelFormat = PixelFormat.Format32bppArgb), 4, 3)
Dim size As Integer = bmpData.Stride * bmpData.Height
Dim data As Byte() = New Byte(size - 1) {}
'byte[] newdata = new byte[size];
System.Runtime.InteropServices.Marshal.Copy(bmpData.Scan0, data, 0, size)
'System.Runtime.InteropServices.Marshal.Copy(bmpData.Scan0, newdata, 0, size);
Dim options = New ParallelOptions()
Dim maxCore As Integer = Environment.ProcessorCount - 1
options.MaxDegreeOfParallelism = If(maxCore > 0, maxCore, 1)
For y As Integer = 0 To height - 4
For x As Integer = 0 To width - 4
If True Then
Dim index As Integer = y * bmpData.Stride + x * bpp
'Blue
data(index) = CByte(Math.Min(Math.Abs(CInt(data(index)) - CInt(data(index + bpp + bmpData.Stride))) + 128, 255))
'Green
data(index + 1) = CByte(Math.Min(Math.Abs(CInt(data(index + 1)) - CInt(data(index + bpp + 1 + bmpData.Stride))) + 128, 255))
'Red
data(index + 2) = CByte(Math.Min(Math.Abs(CInt(data(index + 2)) - CInt(data(index + bpp + 2 + bmpData.Stride))) + 128, 255))
End If
Next
Next
I am fairly new to coding (started early this year) and I'm making a program in VB 2010 express that makes a line chart for values that have been given by the user.
In other words, I ask for values and make the program create rectangles on a canvas, one rectangle for every item added to my ArrayList.
This part of the code works, now I want a gradient color scheme, so another color for every rectangle. To achieve this I tried this:
Dim red As Integer = 254
Dim green As Integer = 141
Dim blue As Integer = 150
calcColor(red, green, blue)
Dim MyBrushColor As Color = Color.FromRgb(red, green, blue)
Private Sub calcColor(ByVal red As Integer, ByVal green As Integer, ByVal blue As Integer)
If (red <= 0 Or green <= 0 Or blue <= 0) Then
red = 254
green = 141
blue = 150
red = red + 8
green = green + 8
blue = blue + 8
End If
If (red >= 254 Or green >= 141 Or blue >= 150) Then
red = 254
green = 141
blue = 150
red = red - 8
green = green - 8
blue = blue - 8
End If
End Sub
Just doing -8 and +8 every time is not going to cut it and once they reach either zero or their inital value they'll have another ratio..
As a very inexperienced coder I have no idea how to calculate this ratio. I just know that it's this kind of code I want.
Don't reinvent the wheel. The GDI+ library provides linear gradient brushes. You define starting point and an end point and colors in between and just use this brush for painting.
Example (will comment below):
Dim bmp As New Bitmap(400, 400)
Using brush As Drawing2D.LinearGradientBrush = New Drawing2D.LinearGradientBrush(New Point(0, 0), _
New Point(400, 400), _
Color.Blue, _
Color.Red)
Using p As New Pen(brush)
Using g As Graphics = Graphics.FromImage(bmp)
For i = 1 To 400 Step 10
g.DrawRectangle(p, i - 5, i - 5, 10, 10)
Next
End Using
End Using
End Using
If PictureBox1.Image IsNot Nothing Then PictureBox1.Image.Dispose()
PictureBox1.Image = bmp
First I create a bitmap as a canvas (bmp).
I then create a new object of the paint class. In the constructor I provide an object of the LinearGradientBrush class, with a start point in the top left corner, and an end point in the lower right with colors blue at the start and red at the end.
I then just paint a row of rectangles along the diagonal with this pen for reference.
This brush can do much more, as well. It can use several points on planes and so on and does the color interpolation for you. You just draw with it. Refer to the MSDN for further details: http://msdn.microsoft.com/de-de/library/system.drawing.drawing2d.lineargradientbrush.aspx
Please only look at this if you get stuck. You will learn more by trying it yourself first. Your teacher has probably seen this.
If you use the HSL colour representation, you should be able to get a nice effect by keeping S (saturation) and L (lightness) constant while varying H (hue). You will need to write functions to convert between RGB and HSL - there are many instances of that on the Internet, so here's another one:
Public Class ColourRepresentation
' Adapted from http://www.geekymonkey.com/Programming/CSharp/RGB2HSL_HSL2RGB.htm
' with conversion from C# to VB.NET by http://www.developerfusion.com/tools/convert/csharp-to-vb/
Public Class HSLcolour
Property H As Double
Property S As Double
Property L As Double
Public Overrides Function ToString() As String
Return String.Format("H={0}, S={1}, L={2}", H, S, L)
End Function
End Class
''' <summary>
''' Convert from HSL to RGB.
''' </summary>
''' <param name="c">An HSLcolour</param>
''' <returns>A System.Drawing.Color with A set to 255.</returns>
''' <remarks>H, S, L in the range [0.0, 1.0].</remarks>
Public Shared Function HSLtoRGB(c As HSLcolour) As Color
Dim r As Double = c.L
Dim g As Double = c.L
Dim b As Double = c.L
Dim v As Double = If((c.L <= 0.5), (c.L * (1.0 + c.S)), (c.L + c.S - c.L * c.S))
If v > 0 Then
Dim m As Double = c.L + c.L - v
Dim sv As Double = (v - m) / v
c.H *= 6.0
Dim sextant As Integer = CInt(Math.Truncate(c.H))
Dim fract As Double = c.H - sextant
Dim vsf As Double = v * sv * fract
Dim mid1 As Double = m + vsf
Dim mid2 As Double = v - vsf
Select Case sextant
Case 0, 6
r = v
g = mid1
b = m
Case 1
r = mid2
g = v
b = m
Case 2
r = m
g = v
b = mid1
Case 3
r = m
g = mid2
b = v
Case 4
r = mid1
g = m
b = v
Case 5
r = v
g = m
b = mid2
End Select
End If
Return Color.FromArgb(255, CByte(r * 255), CByte(g * 255), CByte(b * 255))
End Function
' Given a Color (RGB Struct) in range of 0-255
' Return H,S,L in range of 0-1
''' <summary>
''' Convert from a Color to an HSLcolour.
''' </summary>
''' <param name="rgb">A System.Drawing.Color.</param>
''' <returns>An HSLcolour.</returns>
''' <remarks>Ignores Alpha value in the parameter.</remarks>
Public Shared Function RGBtoHSL(rgb As Color) As HSLcolour
Dim r As Double = rgb.R / 255.0
Dim g As Double = rgb.G / 255.0
Dim b As Double = rgb.B / 255.0
Dim v As Double = Math.Max(r, g)
v = Math.Max(v, b)
Dim m As Double = Math.Min(r, g)
m = Math.Min(m, b)
Dim l As Double = (m + v) / 2.0
If l <= 0.0 Then
Return New HSLcolour With {.H = 0, .L = 0, .S = 0}
End If
Dim vm As Double = v - m
Dim s As Double = vm
If s > 0.0 Then
s /= If((l <= 0.5), (v + m), (2.0 - v - m))
Else
Return New HSLcolour With {.H = 0, .L = 0, .S = 0}
End If
Dim r2 As Double = (v - r) / vm
Dim g2 As Double = (v - g) / vm
Dim b2 As Double = (v - b) / vm
Dim h As Double = 0
If r = v Then
h = (If(g = m, 5.0 + b2, 1.0 - g2))
ElseIf g = v Then
h = (If(b = m, 1.0 + r2, 3.0 - b2))
Else
h = (If(r = m, 3.0 + g2, 5.0 - r2))
End If
h /= 6.0
Return New HSLcolour With {.H = h, .L = l, .S = s}
End Function
End Class
Then you will need a way of varying the hue, which I have used in this crude example of drawing a bar chart (I put one PictureBox on a Form):
Option Strict On
Option Infer On
Public Class Form1
Dim rand As New Random
Dim data As List(Of Double)
Private Function DoubleModOne(value As Double) As Double
While value > 1.0
value -= 1.0
End While
While value < 0.0
value += 1.0
End While
Return value
End Function
Sub DrawBars(sender As Object, e As PaintEventArgs)
Dim target = DirectCast(sender, PictureBox)
e.Graphics.Clear(Color.DarkGray)
' an approximation of the bar width
'TODO: Improve the approximation.
Dim barWidth As Integer = CInt(CDbl(target.Width) / data.Count)
Dim maxBarHeight = target.Height
Using br As New SolidBrush(Color.Black)
Dim r As Rectangle
'TODO: make it work for Color.Gainsboro
Dim startColour = ColourRepresentation.RGBtoHSL(Color.Fuchsia)
' these components are broken out in case something needs to be done to them.
Dim startColourH = startColour.H
Dim startColourS = startColour.S
Dim startColourL = startColour.L
' Using 1.0 as the quotient makes the colours go through the whole spectrum.
Dim colourInc As Double = 1.0 / data.Count
' Only expects data to be in the range (0, 1).
For i = 0 To data.Count - 1
Dim thisHSLcolour As New ColourRepresentation.HSLcolour With {.H = DoubleModOne(startColourH + i * colourInc), .S = startColourS, .L = startColourL}
br.Color = ColourRepresentation.HSLtoRGB(thisHSLcolour)
r = New Rectangle(CInt(i * barWidth), CInt(data(i) * maxBarHeight), barWidth, maxBarHeight)
e.Graphics.FillRectangle(br, r)
Next
End Using
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim nBars = 100
data = New List(Of Double)(nBars)
For i = 0 To nBars - 1
data.Add(rand.NextDouble())
Next
AddHandler PictureBox1.Paint, AddressOf DrawBars
End Sub
End Class
Resulting in:
No-one ever accused me of choosing subtle colours, lol.
I have found some code using google for listview printing. I modified the code base on my needs. I have some problem if the list view more than one pages. It will not stop counting "Generating Previews" of my document. If I press the cancel it was display the data in multiple pages but the same content.
Any suggestion would greatly appreciated.
Thanks in advance
Here is the code
Public Sub pd_PrintPage(ByVal sender As Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs)
Dim pd As New PrintDocument
Dim CurrRow As Integer = 0
Dim Ratio As Single = 0
Dim c As ColumnHeader
Dim g As Graphics = e.Graphics
Dim l As Integer = 0 'stores current left
Dim iCount As Integer
Dim f As Font = lsvToPrint.Font
Dim FontBold As New System.Drawing.Font("Microsoft Sans Serif", 10, FontStyle.Bold)
Dim b As Brush = Brushes.Black
Dim currentY As Integer = 0
Dim maxY As Integer = 0
Dim gap As Integer = 5
Dim lvsi As ListViewItem.ListViewSubItem
Dim colLefts(lsvToPrint.Columns.Count) As Integer
Dim colWidths(lsvToPrint.Columns.Count) As Integer
Dim idx As Integer = 0
Dim ii As Integer
Dim lr As RectangleF
e.HasMorePages = False
'Page Settings
Dim PSize As Integer = lsvToPrint.Items.Count
Dim PHi As Double
With pd.DefaultPageSettings
Dim Ps As PaperSize
PHi = PSize * 20 + 350
Ps = New PaperSize("Cust", 800, PHi)
.Margins.Top = 15
.Margins.Bottom = 20
.PaperSize = Ps
End With
Dim sfc As New StringFormat
sfc.LineAlignment = StringAlignment.Center
sfc.Alignment = StringAlignment.Center
'Title
Dim headfont As Font
Dim X1 As Integer
Dim Y As Integer
headfont = New Font("Courier New", 16, FontStyle.Bold)
X1 = pd.DefaultPageSettings.Margins.Left
Y = pd.DefaultPageSettings.Margins.Top + 5
With pd.DefaultPageSettings
e.Graphics.DrawLine(Pens.Black, 0, Y + 70, e.PageBounds.Width, Y + 70)
End With
'Headings
currentY = 100
For Each c In lsvToPrint.Columns
maxY = Math.Max(maxY, g.MeasureString(c.Text, f, c.Width).Height)
colLefts(idx) = l
colWidths(idx) = c.Width
lr = New RectangleF(colLefts(idx), currentY, colWidths(idx), maxY)
If lr.Width > 0 Then g.DrawString(c.Text, FontBold, b, lr, sfc)
l += c.Width
idx += 1
Next
currentY += maxY + gap
g.DrawLine(Pens.Black, 0, currentY, e.PageBounds.Width, currentY)
currentY += gap
'Rows
iCount = lsvToPrint.Items.Count - 1
For ii = CurrRow To iCount
If (currentY + maxY + maxY) > e.PageBounds.Height Then 'jump down another line to see if this line will fit
CurrRow = ii - 1
e.HasMorePages = True
currentY += maxY + gap
Exit For 'does next page
End If
l = 0
maxY = 0
idx = 0
For Each lvsi In lsvToPrint.Items(ii).SubItems
maxY = Math.Max(maxY, g.MeasureString(lvsi.Text, f, colWidths(idx)).Height)
lr = New RectangleF(colLefts(idx), currentY, colWidths(idx), maxY)
If lsvToPrint.Columns(idx).Text <> "Name" Then
If lr.Width > 0 Then g.DrawString(lvsi.Text , f, b, lr, sfc)
Else
If lr.Width > 0 Then g.DrawString(lvsi.Text, f, b, lr)
End If
idx += 1
Next
currentY += maxY + gap
Next
End Sub
Make sure that you compensate the height of the MaxY for the new page. On the first page it's fine, but then when it gets to the next page, CurrentY + MaxY might already be bigger than the height of the page.