car counting and classification using EmguCV and Vb.net - vb.net

i am new in Stackoverflow
i am doing a project for 4th stage college that is car counting and classification based on EmguCV and Vb.net now i've done coding car counting but i have a problem in classification that i don't know how to code a classification like how many heavy cars and light cars.
this is my code:
'MultipleObjectTrackingVB.sln
'frmMain.vb
'
'form components
'
'tableLayoutPanel
'btnOpenFile
'lblChosenFile
'imageBox
'txtInfo
'openFileDialog
'
'Emgu CV 3.1.0
Option Explicit On 'require explicit declaration of variables, this is NOT Python !!
Option Strict On 'restrict implicit data type conversions to only widening conversions
Imports Emgu.CV '
Imports Emgu.CV.CvEnum 'usual Emgu Cv imports
Imports Emgu.CV.Structure '
Imports Emgu.CV.UI '
Imports Emgu.CV.Util
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Class Form1
' member variables ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim SCALAR_BLACK As New MCvScalar(0.0, 0.0, 0.0)
Dim SCALAR_WHITE As New MCvScalar(255.0, 255.0, 255.0)
Dim SCALAR_BLUE As New MCvScalar(255.0, 0.0, 0.0)
Dim SCALAR_GREEN As New MCvScalar(0.0, 200.0, 0.0)
Dim SCALAR_RED As New MCvScalar(0.0, 0.0, 255.0)
Dim capVideo As Capture
Dim blnFormClosing As Boolean = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles MyBase.FormClosing
blnFormClosing = True
CvInvoke.DestroyAllWindows()
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub btnOpenFile_Click(sender As Object, e As EventArgs) Handles btnOpenFile.Click
Dim drChosenFile As DialogResult
drChosenFile = openFileDialog.ShowDialog() 'open file dialog
If (drChosenFile <> DialogResult.OK Or openFileDialog.FileName = "") Then 'if user chose Cancel or filename is blank . . .
lblChosenFile.Text = "file not chosen" 'show error message on label
Return 'and exit function
End If
Try
capVideo = New Capture(openFileDialog.FileName) 'attempt to open chosen video file
Catch ex As Exception 'catch error if unsuccessful
'show error via message box
MessageBox.Show("unable to read video file, error: " + ex.Message)
Return
End Try
lblChosenFile.Text = openFileDialog.FileName
If (capVideo Is Nothing) Then
txtInfo.AppendText("unable to read video file")
End If
If (capVideo.GetCaptureProperty(CapProp.FrameCount) < 2) Then 'check and make sure the video has at least 2 frames
txtInfo.AppendText("error: video file must have at least two frames")
End If
trackBlobsAndUpdateGUI()
End Sub
Sub trackBlobsAndUpdateGUI()
Dim imgFrame1 As Mat
Dim imgFrame2 As Mat
Dim blobs As New List(Of Blob)
Dim crossingLine(2) As Point
Dim carCount As Integer = 0
imgFrame1 = capVideo.QueryFrame()
imgFrame2 = capVideo.QueryFrame()
Dim horizontalLinePosition As Integer = CInt(Math.Round(CDbl(imgFrame1.Rows()) * 0.3))
crossingLine(0).X = 0
crossingLine(0).Y = horizontalLinePosition
crossingLine(1).X = imgFrame1.Cols() - 1
crossingLine(1).Y = horizontalLinePosition
Dim blnFirstFrame As Boolean = True
While (blnFormClosing = False)
Dim currentFrameBlobs As New List(Of Blob)
Dim imgFrame1Copy As Mat = imgFrame1.Clone()
Dim imgFrame2Copy As Mat = imgFrame2.Clone()
Dim imgDifference As New Mat(imgFrame1.Size, DepthType.Cv8U, 1)
Dim imgThresh As New Mat(imgFrame1.Size, DepthType.Cv8U, 1)
CvInvoke.CvtColor(imgFrame1Copy, imgFrame1Copy, ColorConversion.Bgr2Gray)
CvInvoke.CvtColor(imgFrame2Copy, imgFrame2Copy, ColorConversion.Bgr2Gray)
CvInvoke.GaussianBlur(imgFrame1Copy, imgFrame1Copy, New Size(5, 5), 0)
CvInvoke.GaussianBlur(imgFrame2Copy, imgFrame2Copy, New Size(5, 5), 0)
CvInvoke.AbsDiff(imgFrame1Copy, imgFrame2Copy, imgDifference)
CvInvoke.Threshold(imgDifference, imgThresh, 30, 255.0, ThresholdType.Binary)
CvInvoke.Imshow("imgThresh", imgThresh)
Dim structuringElement3x3 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(3, 3), New Point(-1, -1))
Dim structuringElement5x5 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(5, 5), New Point(-1, -1))
Dim structuringElement7x7 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(7, 7), New Point(-1, -1))
Dim structuringElement9x9 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(9, 9), New Point(-1, -1))
For i As Integer = 0 To 1
CvInvoke.Dilate(imgThresh, imgThresh, structuringElement5x5, New Point(-1, -1), 1, BorderType.Default, New MCvScalar(0, 0, 0))
CvInvoke.Dilate(imgThresh, imgThresh, structuringElement5x5, New Point(-1, -1), 1, BorderType.Default, New MCvScalar(0, 0, 0))
CvInvoke.Erode(imgThresh, imgThresh, structuringElement5x5, New Point(-1, -1), 1, BorderType.Default, New MCvScalar(0, 0, 0))
Next
Dim imgThreshCopy As Mat = imgThresh.Clone()
Dim contours As New VectorOfVectorOfPoint()
CvInvoke.FindContours(imgThreshCopy, contours, Nothing, RetrType.External, ChainApproxMethod.ChainApproxSimple)
'drawAndShowContours(imgThresh.Size(), contours, "imgContours")
Dim convexHulls As New VectorOfVectorOfPoint(contours.Size())
For i As Integer = 0 To contours.Size() - 1
CvInvoke.ConvexHull(contours(i), convexHulls(i))
Next
'drawAndShowContours(imgThresh.Size(), convexHulls, "imgConvexHulls")
For i As Integer = 0 To contours.Size() - 1
Dim possibleBlob As New Blob(convexHulls(i))
If (possibleBlob.intCurrentRectArea > 400 And
possibleBlob.dblCurrentAspectRatio > 0.2 And
possibleBlob.dblCurrentAspectRatio < 4.0 And
possibleBlob.currentBoundingRect.Width > 30 And
possibleBlob.currentBoundingRect.Height > 30 And
possibleBlob.dblCurrentDiagonalSize > 60.0 And
(CvInvoke.ContourArea(possibleBlob.currentContour) / possibleBlob.intCurrentRectArea) > 0.5) Then
currentFrameBlobs.Add(possibleBlob)
End If
Next
'drawAndShowContours(imgThresh.Size(), currentFrameBlobs, "imgCurrentFrameBlobs")
If (blnFirstFrame = True) Then
For Each currentFrameBlob As Blob In currentFrameBlobs
blobs.Add(currentFrameBlob)
Next
Else
matchCurrentFrameBlobsToExistingBlobs(blobs, currentFrameBlobs)
End If
'drawAndShowContours(imgThresh.Size(), blobs, "imgBlobs")
imgFrame2Copy = imgFrame2.Clone()
drawBlobInfoOnImage(blobs, imgFrame2Copy)
Dim atLeastOneBlobCrossedTheLine = checkIfBlobsCrossedTheLine(blobs, horizontalLinePosition, carCount)
If (atLeastOneBlobCrossedTheLine) Then
CvInvoke.Line(imgFrame2Copy, crossingLine(0), crossingLine(1), SCALAR_GREEN, 2)
Else
CvInvoke.Line(imgFrame2Copy, crossingLine(0), crossingLine(1), SCALAR_RED, 2)
End If
drawCarCountOnImage(carCount, imgFrame2Copy)
imageBox.Image = imgFrame2Copy
'now we prepare for the next iteration
currentFrameBlobs.Clear()
imgFrame1 = imgFrame2.Clone() 'move frame 1 up to where frame 2 is
If (capVideo.GetCaptureProperty(CapProp.PosFrames) + 1 < capVideo.GetCaptureProperty(CapProp.FrameCount)) Then 'if there is at least one more frame
imgFrame2 = capVideo.QueryFrame() 'get the next frame
Else 'else if there is not at least one more frame
txtInfo.AppendText("end of video") 'show end of video message
Exit While 'and jump out of while loop
End If
blnFirstFrame = False
Application.DoEvents()
End While
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub matchCurrentFrameBlobsToExistingBlobs(ByRef existingBlobs As List(Of Blob), ByRef currentFrameBlobs As List(Of Blob))
For Each existingBlob As Blob In existingBlobs
existingBlob.blnCurrentMatchFoundOrNewBlob = False
existingBlob.predictNextPosition()
Next
For Each currentFrameBlob As Blob In currentFrameBlobs
Dim intIndexOfLeastDistance As Integer = 0
Dim dblLeastDistance As Double = 1000000.0
For i As Integer = 0 To existingBlobs.Count() - 1
If (existingBlobs(i).blnStillBeingTracked = True) Then
Dim dblDistance As Double = distanceBetweenPoints(currentFrameBlob.centerPositions.Last(), existingBlobs(i).predictedNextPosition)
If (dblDistance < dblLeastDistance) Then
dblLeastDistance = dblDistance
intIndexOfLeastDistance = i
End If
End If
Next
If (dblLeastDistance < currentFrameBlob.dblCurrentDiagonalSize * 0.5) Then
addBlobToExistingBlobs(currentFrameBlob, existingBlobs, intIndexOfLeastDistance)
Else
addNewBlob(currentFrameBlob, existingBlobs)
End If
Next
For Each existingBlob As Blob In existingBlobs
If (existingBlob.blnCurrentMatchFoundOrNewBlob = False) Then
existingBlob.intNumOfConsecutiveFramesWithoutAMatch = existingBlob.intNumOfConsecutiveFramesWithoutAMatch + 1
End If
If (existingBlob.intNumOfConsecutiveFramesWithoutAMatch >= 5) Then
existingBlob.blnStillBeingTracked = False
End If
Next
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub addBlobToExistingBlobs(ByRef currentFrameBlob As Blob, ByRef existingBlobs As List(Of Blob), ByRef intIndex As Integer)
existingBlobs(intIndex).currentContour = currentFrameBlob.currentContour
existingBlobs(intIndex).currentBoundingRect = currentFrameBlob.currentBoundingRect
existingBlobs(intIndex).centerPositions.Add(currentFrameBlob.centerPositions.Last())
existingBlobs(intIndex).dblCurrentDiagonalSize = currentFrameBlob.dblCurrentDiagonalSize
existingBlobs(intIndex).dblCurrentAspectRatio = currentFrameBlob.dblCurrentAspectRatio
existingBlobs(intIndex).blnStillBeingTracked = True
existingBlobs(intIndex).blnCurrentMatchFoundOrNewBlob = True
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub addNewBlob(ByRef currentFrameBlob As Blob, ByRef existingBlobs As List(Of Blob))
currentFrameBlob.blnCurrentMatchFoundOrNewBlob = True
existingBlobs.Add(currentFrameBlob)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function distanceBetweenPoints(point1 As Point, point2 As Point) As Double
Dim intX As Integer = Math.Abs(point1.X - point2.X)
Dim intY As Integer = Math.Abs(point1.Y - point2.Y)
Return Math.Sqrt((intX ^ 2) + (intY ^ 2))
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawAndShowContours(imageSize As Size, contours As VectorOfVectorOfPoint, strImageName As String)
Dim image As New Mat(imageSize, DepthType.Cv8U, 3)
CvInvoke.DrawContours(image, contours, -1, SCALAR_WHITE, -1)
CvInvoke.Imshow(strImageName, image)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawAndShowContours(imageSize As Size, blobs As List(Of Blob), strImageName As String)
Dim image As New Mat(imageSize, DepthType.Cv8U, 3)
Dim contours As New VectorOfVectorOfPoint()
For Each blob As Blob In blobs
If (blob.blnStillBeingTracked = True) Then
contours.Push(blob.currentContour)
End If
Next
CvInvoke.DrawContours(image, contours, -1, SCALAR_WHITE, -1)
CvInvoke.Imshow(strImageName, image)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function checkIfBlobsCrossedTheLine(ByRef blobs As List(Of Blob), ByRef horizontalLinePosition As Integer, ByRef carCount As Integer) As Boolean
Dim atLeastOneBlobCrossedTheLine As Boolean = False 'this will be the return value
For Each blob As Blob In blobs
If (blob.blnStillBeingTracked = True And blob.centerPositions.Count() >= 2) Then
Dim prevFrameIndex As Integer = blob.centerPositions.Count() - 2
Dim currFrameIndex As Integer = blob.centerPositions.Count() - 1
If (blob.centerPositions(prevFrameIndex).Y > horizontalLinePosition And blob.centerPositions(currFrameIndex).Y <= horizontalLinePosition) Then
carCount = carCount + 1
atLeastOneBlobCrossedTheLine = True
End If
End If
Next
Return (atLeastOneBlobCrossedTheLine)
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawBlobInfoOnImage(ByRef blobs As List(Of Blob), ByRef imgFrame2Copy As Mat)
For i As Integer = 0 To blobs.Count - 1
If (blobs(i).blnStillBeingTracked = True) Then
CvInvoke.Rectangle(imgFrame2Copy, blobs(i).currentBoundingRect, SCALAR_RED, 2)
Dim fontFace As FontFace = FontFace.HersheySimplex
Dim dblFontScale As Double = blobs(i).dblCurrentDiagonalSize / 60.0
Dim intFontThickness As Integer = CInt(Math.Round(dblFontScale * 1.0))
CvInvoke.PutText(imgFrame2Copy, i.ToString(), blobs(i).centerPositions.Last(), fontFace, dblFontScale, SCALAR_GREEN, intFontThickness)
End If
Next
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawCarCountOnImage(ByRef carCount As Integer, ByRef imgFrame2Copy As Mat)
Dim fontFace As FontFace = FontFace.HersheySimplex
Dim dblFontScale As Double = CDbl(imgFrame2Copy.Rows() * imgFrame2Copy.Cols()) / 300000.0
Dim intFontThickness As Integer = CInt(Math.Round(dblFontScale * 1.5))
Dim textSize As Size = getTextSize(carCount.ToString(), fontFace, dblFontScale, intFontThickness)
Dim bottomLeftTextPosition As New Point()
bottomLeftTextPosition.X = imgFrame2Copy.Cols - 1 - CInt(CDbl(textSize.Width) * 1.3)
bottomLeftTextPosition.Y = CInt(CDbl(textSize.Height) * 1.3)
CvInvoke.PutText(imgFrame2Copy, carCount.ToString(), bottomLeftTextPosition, fontFace, dblFontScale, SCALAR_GREEN, intFontThickness)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getTextSize(strText As String, intFontFace As Integer, dblFontScale As Double, intFontThickness As Integer) As Size
Dim textSize As New Size() 'this will be the return value
Dim intNumChars As Integer = strText.Count()
textSize.Width = 55 * intNumChars
textSize.Height = 65
Return (textSize)
End Function
Private Sub imageBox_Click(sender As Object, e As EventArgs) Handles imageBox.Click
End Sub
End Class

Related

Hasmorepages property fails

I have created a routine that is intended to print a variable number of lines and/or pages, based on a queue of line information previously stored. Each page prints fine, but when printing more than one page, two pages overprint. I can't see my logic error, but there must be one. A copy of the offending code is follows. Nextline.newpage is a boolean set to true to force a new page. In my text example there were six "Newpage" and "hasmorepages" was set to true six times, and the routine was exited six times. Still the output was four pages with one printing correctly, and three with two pages printed on one sheet. Any help would be greatly appreciated. By the way, this is my first question, so be kind.
Private Sub PrintLines(Sender As Object, e As PrintPageEventArgs) Handles PrintDoc.PrintPage
Dim White As String = GetARGBString(PrinterDefaultBackcolor)
Do Until Lines.Count = 0
Dim Nextline As Lineformat = Lines.Dequeue
If Nextline.NewPage Then
e.HasMorePages = True
Exit Sub
End If
With Nextline
Dim LineBackColor As String = Nextline.backColor
If LineBackColor <> White Or .Borders = True Then DrawShape(Nextline, e)
If .Text <> "" Then DrawText(Nextline, e)
End With
Loop
End Sub
Private Sub DrawShape(Line As Lineformat, E As PrintPageEventArgs)
With Line
Dim Top As Integer = .Top * 100
Dim Left As Integer = .Left * 100
Dim Width As Integer = .BackGroundWidth * 100
Dim Height As Integer = .BackGroundHeight * 100
Dim Point As New Point(Left, Top)
Dim Size As New Size(Width, Height)
Dim Rect As New Rectangle(Point, Size)
Dim TransparentFillColor As String = "00" & Strings.Right(.backColor, 6)
Dim FillColor As FullColor = GetColorFromString(.backColor)
Dim BorderPen As New Pen(Color.Black)
Dim FillBrush As New SolidBrush(FillColor.Color)
E.Graphics.FillRectangle(FillBrush, Rect)
If Line.Borders = True Then
E.Graphics.DrawRectangle(BorderPen, Rect)
End If
End With
End Sub
Private Sub DrawText(Line As Lineformat, E As PrintPageEventArgs)
With Line
Dim MyFont = SetFontStyle(.FontFamily, .FontPoints, .FontBold, .FontItalic, .FontUnderline)
Dim TextColor As FullColor = GetColorFromString(.ForeColor)
Dim MyBrush As New SolidBrush(TextColor.Color)
Dim top As Integer = .Top * 100
Dim Left As Integer = .Left * 100
Dim Width As Integer = .LineWidth * 100
Dim Height As Integer = .LineHeight * 100
Dim point As New Point(Left, top)
Dim Size As New Size(Width, Height)
Dim Rect As New RectangleF(point, Size)
Dim SF As New StringFormat()
SF.FormatFlags = TextFormatFlags.WordEllipsis
E.Graphics.DrawString(.Text, MyFont, MyBrush, Rect, SF)
End With
End Sub
End Class

Load a screenshot into a function as a bitmap without saving it as a file first

Basically my program takes a "sample" image from the user, then takes a screenshot of the entire user's screen, and then if it found that sample on the users screen, it returns the coordinates of it and moves the mouse there.
It works fine if I save the screenshot to a bitmap and compare the sample to a file, but when I try to call the screenshot directly into the function, it fails to find a match.
Any idea why?
First the code for the button click that triggers the comparison:
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim clickhere As Point
Dim bounds As Rectangle
Dim screenshot As System.Drawing.Bitmap
Dim graph As Graphics
bounds = Screen.PrimaryScreen.Bounds
screenshot = New System.Drawing.Bitmap(bounds.Width, bounds.Height, System.Drawing.Imaging.PixelFormat.Format32bppArgb)
graph = Graphics.FromImage(screenshot)
graph.CopyFromScreen(bounds.X, bounds.Y, 0, 0, bounds.Size, CopyPixelOperation.SourceCopy)
Dim src As New Bitmap(srcpath.Text)
Dim g = Graphics.FromImage(screenshot)
g.CopyFromScreen(0, 0, 0, 0, screenshot.Size)
g.Dispose()
clickhere = BitmapExtension.Contains(screenshot, src)
MsgBox(clickhere.ToString)
Cursor.Position = clickhere
End Sub
And here is the function:
Imports System.Drawing
Imports System.Runtime.CompilerServices
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Module BitmapExtension
<Extension()>
Public Function Contains(src As Bitmap, ByRef bmp As Bitmap) As Point
'
'-- Some logic pre-checks
'
If src Is Nothing OrElse bmp Is Nothing Then Return New Point(Integer.MinValue, Integer.MinValue)
If src.Width < bmp.Width OrElse src.Height < bmp.Height Then
Return New Point(Integer.MinValue, Integer.MinValue)
End If
'
'-- Prepare optimizations
'
Dim sr As New Rectangle(0, 0, src.Width, src.Height)
Dim br As New Rectangle(0, 0, bmp.Width, bmp.Height)
Dim srcLock As BitmapData = src.LockBits(sr, Imaging.ImageLockMode.ReadOnly, PixelFormat.Format32bppRgb)
Dim bmpLock As BitmapData = bmp.LockBits(br, Imaging.ImageLockMode.ReadOnly, PixelFormat.Format32bppRgb)
Dim sStride As Integer = srcLock.Stride
Dim bStride As Integer = bmpLock.Stride
Dim srcSize As Integer = sStride * src.Height
Dim bmpSize As Integer = bStride * bmp.Height
Dim srcBuff(srcSize) As Byte
Dim bmpBuff(bmpSize) As Byte
Marshal.Copy(srcLock.Scan0, srcBuff, 0, srcSize)
Marshal.Copy(bmpLock.Scan0, bmpBuff, 0, bmpSize)
' we don't need to lock the image anymore as we have a local copy
bmp.UnlockBits(bmpLock)
src.UnlockBits(srcLock)
Return FindMatch(srcBuff, src.Width, src.Height, sStride, bmpBuff, bmp.Width, bmp.Height, bStride)
End Function
Private Function FindMatch(srcBuff() As Byte, srcWidth As Integer, srcHeight As Integer, srcStride As Integer,
bmpBuff() As Byte, bmpWidth As Integer, bmpHeight As Integer, bmpStride As Integer) As Point
For Y As Integer = 0 To srcHeight - bmpHeight - 1
For x As Integer = 0 To srcWidth - bmpWidth - 1
If AllPixelsMatch(x, Y, srcBuff, srcStride, bmpBuff, bmpWidth, bmpHeight, bmpStride) Then
Return New Point(x, Y)
End If
Next
Next
Return New Point(Integer.MinValue, Integer.MinValue)
End Function
Private Function AllPixelsMatch(X As Integer, Y As Integer, srcBuff() As Byte, srcStride As Integer,
bmpBuff() As Byte, bmpWidth As Integer, bmpHeight As Integer, bmpStride As Integer) As Boolean
For by As Integer = 0 To bmpHeight - 1
For bx As Integer = 0 To bmpWidth - 1
Dim bmpIndex As Integer = by * bmpStride + bx * 4
Dim a As Byte = bmpBuff(bmpIndex + 3)
'If bmp pixel is not transparent, check if the colours are identical
If a > 0 T
hen
Dim srcX = X + bx
Dim srcY = Y + by
Dim srcIndex = srcY * srcStride + srcX * 4
For i As Integer = 0 To 2
'check if the r, g and b bytes match
If srcBuff(srcIndex + i) <> bmpBuff(bmpIndex + i) Then Return False
Next
Else
'if bmp pixel is transparent, continue seeking.
Continue For
End If
Next
Next
Return True
End Function
End Module

Convert 1DPointArray into 2DPointArray

I started a new project which loads and saves tilesets in style of ini-datas.
The problem is now, that it loads the tiles into a 1d- list, which got copied sorted into a 1d-array.
Now I am trying to convert this sorted 1d-array into a 2d-array.
My try:
LoadedTiles.Sort(Function(p1, p2) (p1.Position.X.CompareTo(p2.Position.X)))
LoadedTiles.Sort(Function(p1, p2) (p1.Position.Y.CompareTo(p2.Position.Y)))
Dim currentArray(AmountTiles) As Tile
currentArray = LoadedTiles.ToArray
Dim lengthX, lengthY As Integer
Dim yAxis As Integer = currentArray(0).Position.Y
For Each p In currentArray
If Not p.Position.Y = yAxis Then
lengthX = (p.Position.X / p.Size.Width)
lengthY = (currentArray(currentArray.Length - 1).Position.Y / p.Size.Width)
Else
lengthX = (currentArray(currentArray.Length - 1).Position.X / p.Size.Width)
lengthY = 0
End If
Next
MapTiles = New Tile(lengthX, lengthY) {}
Dim ii As Integer
For x = 0 To lengthX
For y = 0 To lengthY
MapTiles(x, y) = currentArray(ii)
If Not ii >= currentArray.Length - 1 Then
ii += 1
End If
Next
Next
This gives a wrong output.
See picture below:
http://www.directupload.net/file/d/3690/pz8x98jr_png.htm
Is it possible to do it right?
Thanks alot!

The k-th element in a 1D array can correspond to row i=k/N and column j=k%N where N is the number of columns. The reverse is k=i*N+j

Ok guys, I got it ( =
Public Class Form1
Dim List As New List(Of Point)
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
List.Add(New Point(180, 360))
List.Add(New Point(180, 180))
List.Add(New Point(180, 540))
'Convert 1d to 2d
Dim count As Point = countXYAxis(List, 180)
MsgBox(count.ToString)
Dim p(count.X - 1, List.Count - 1) As Point
MsgBox(p.Length)
Dim rofl As Integer
For i = 0 To p.GetUpperBound(0)
For j = 0 To p.GetUpperBound(1)
p(i, j) = List(rofl)
If Not rofl >= List.Count - 1 Then
rofl += 1
End If
Next
Next
For Each t In p
MsgBox(t.ToString)
Next
End Sub
Private Function countXYAxis(ByVal pt As List(Of Point), ByVal size As Integer) As Point
Dim bufferY As New List(Of Integer)
Dim cP As New Point
For Each pts In pt
If Not bufferY.Contains(pts.Y) Then
bufferY.Add(pts.Y)
End If
Next
For i = 0 To pt.Count - 1
If pt(i).Y = bufferY(0) Then
Else
cP = New Point(pt(i).X / size, bufferY.Count)
End If
Next
Return cP
End Function
End Class

Runtime error message Index was outside the bounds of the array. for Visual Basic 2010

I am computing the ROI with a moving rectangle and extracting the ROI to compute the standard deviation, mean, area and Pixel value coordinates X and Y in a seperate form2 by clicking the mouse. At this juncture I am trying to pass a function from the main Form that loads the Image and displays the rectangle to another Form that has the displayed properties of the mean and standard deviation etc. However, I'm receiving errors in runtime in the function that contains the standard deviation. The error displayed is
Index was outside the bounds of the array.
It is displayed at the end of this portion of the code in the function StD, i.e at the end of the mean part'
SD(count) = Double.Parse(pixelcolor.R) + Double.Parse(pixelcolor.G) + Double.Parse(pixelcolor.B) - mean
what is this actually saying and how can I fix this situation. Any tips and ideas, thanks.
My code is at the bottom
enterPublic Function StD(ByVal image As Bitmap, ByVal mean As Double, ByVal meancount As Integer) As Double
Dim SD(SquareHeight * SquareWidth) As Double
Dim count As Integer = 0
For i = 0 To SquareWidth
For j = 0 To SquareHeight
Dim pixelcolor As Color = image.GetPixel(i, j)
SD(count) = Double.Parse(pixelcolor.R) + Double.Parse(pixelcolor.G) + Double.Parse(pixelcolor.B) - mean
count += 1
Next
Next
Dim SDsum As Double = 0
For i = 0 To count
SDsum = SDsum + SD(i)
Next
SDsum = SDsum / (SquareHeight * SquareWidth)
SDsum = ((SDsum) ^ (1 / 2))
Return SDsum
End Function code here
I would like to pass this using the code below
enterPrivate Sub PictureBox1_MouseDown(ByVal sender As System.Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseDown
Dim mean As Double = 0
Dim meancount As Integer = 0
Dim bmap As New Bitmap(400, 400)
bmap = PictureBox1.Image
Dim colorpixel As Color = bmap.GetPixel(e.X, e.Y)
' Dim pixels As Double = colorpixel.R + colorpixel.G + colorpixel.B
If e.Button = Windows.Forms.MouseButtons.Left AndAlso Rect.Contains(e.Location) Then
If (PictureBox1.Image Is Nothing) Or (PictureBox1.Height - (e.Y + SquareHeight) < 0) Or (PictureBox1.Width - (e.X + SquareWidth) < 0) Then
Else
Dim ROI As New Bitmap(400, 400)
Dim x As Integer = 0
Dim countx As Integer = 0
Dim county As Integer = 0
For i = e.X To (e.X + SquareWidth)
For j = (e.Y + x) To (e.Y + SquareHeight)
Dim pixelcolor As Color = bmap.GetPixel(i, j)
ROI.SetPixel(countx, county, pixelcolor)
mean = mean + pixelcolor.R + pixelcolor.G + pixelcolor.B
county += 1
meancount += 1
Next
county = 0
countx += 1
x = x + 1
Next
mean = mean / (meancount * 3)
Dim SD = mean - 75
Dim area As Integer = (SquareHeight * SquareWidth)
Dim anotherForm As Form2
anotherForm = New Form2(mean, StD(bmap, mean, meancount), area, 34)
anotherForm.Show()
End If
End If
' Catch ex As Exception
' MessageBox.Show(ex.Message())
' End Try
End Sub code here
To be displayed with this code
enter Public Sub New(ByVal mean As Double, ByVal StD As Double, ByVal Area As Integer, ByVal pixel As Double)
MyBase.New()
InitializeComponent()
TextBox1.Text = mean.ToString()
TextBox2.Text = StD.ToString()
TextBox3.Text = Area.ToString()
TextBox4.Text = pixel.ToString()
End Sub code here

The problem probably is because of these lines:
For i = 0 To SquareWidth
For j = 0 To SquareHeight
Try using this instead:
For i = 0 To SquareWidth - 1
For j = 0 To SquareHeight - 1

How can I go about adding a ProgressBar to this code which calculates CRC32 checksum in VB.NET?

Thanks for reading - I am using the class below to calculate the CRC32 checksum of a specified file.
My question is how would I go about reporting the progress of file completion (in %) to a progressbar on a different form. I have tried (i / count) * 100 under the New() sub but I am not having any luck, or setting the progress bar with it for that matter. Can anyone help?
Thanks in advance
Steve
Public Class CRC32
Private crc32Table() As Integer
Private Const BUFFER_SIZE As Integer = 1024
Public Function GetCrc32(ByRef stream As System.IO.Stream) As Integer
Dim crc32Result As Integer
crc32Result = &HFFFFFFFF
Dim buffer(BUFFER_SIZE) As Byte
Dim readSize As Integer = BUFFER_SIZE
Dim count As Integer = stream.Read(buffer, 0, readSize)
Dim i As Integer
Dim iLookup As Integer
Do While (count > 0)
For i = 0 To count - 1
iLookup = (crc32Result And &HFF) Xor buffer(i)
crc32Result = ((crc32Result And &HFFFFFF00) \ &H100) And &HFFFFFF
crc32Result = crc32Result Xor crc32Table(iLookup)
Next i
count = stream.Read(buffer, 0, readSize)
Loop
GetCrc32 = Not (crc32Result)
End Function
Public Sub New()
Dim dwPolynomial As Integer = &HEDB88320
Dim i As Integer, j As Integer
ReDim crc32Table(256)
Dim dwCrc As Integer
For i = 0 To 255
Form1.CRCWorker.ReportProgress((i / 255) * 100) 'Report Progress
dwCrc = i
For j = 8 To 1 Step -1
If (dwCrc And 1) Then
dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
dwCrc = dwCrc Xor dwPolynomial
Else
dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
End If
Next j
crc32Table(i) = dwCrc
Next i
'file complete
End Sub
End Class
'------------- END CRC32 CLASS--------------
'-------------- START FORM1 --------------------------
Private Sub CRCWorker_DoWork(ByVal sender As System.Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles CRCWorker.DoWork
For i = CurrentInt To dgv.Rows.Count - 1
CRCWorker.ReportProgress(0, i & "/" & Total_Files)
Current_File_Num = (i + 1)
SetControlText(lblCurrentFile, Str(Current_File_Num) & "/" & Total_Files)
result = CheckFile(SFV_Parent_Directory & "\" & dgv.Rows(i).Cells(0).Value, dgv.Rows(i).Cells(1).Value)
Select Case result
Case 0 ' missing file
UpdateRow(i, 2, "MISSING")
'dgv.Rows(i).Cells(2).Value = "MISSING"
Missing_Files = Missing_Files + 1
SetControlText(lblMissingFiles, Str(Missing_Files))
Case 1 ' crc match
UpdateRow(i, 2, "OK")
' dgv.Rows(i).Cells(2).Value = "OK"
Good_Files = Good_Files + 1
SetControlText(lblGoodFiles, Str(Good_Files))
Case 2 'crc bad
UpdateRow(i, 2, "BAD")
' dgv.Rows(i).Cells(2).Value = "BAD"
Bad_Files = Bad_Files + 1
SetControlText(lblBadFiles, Str(Bad_Files))
End Select
If CRCWorker.CancellationPending = True Then
e.Cancel = True
Exit Sub
End If
Next
End Sub
Private Sub CRCWorker_ProgressChanged(ByVal sender As Object, ByVal e As System.ComponentModel.ProgressChangedEventArgs) Handles CRCWorker.ProgressChanged
Dim val As Integer = e.ProgressPercentage
ProgressBar2.Maximum = 100
ProgressBar2.Value = e.ProgressPercentage
Debug.Print(val)
End Sub
Function CheckFile(ByVal tocheck_filepath As String, ByVal expected_crc As String) As Integer 'returns result of a file check 0 = missing 1 = good 2 = bad
If File.Exists(tocheck_filepath) = False Then
Return 0 'return file missing
End If
Dim f As FileStream = New FileStream(tocheck_filepath, FileMode.Open, FileAccess.Read, FileShare.Read, 8192)
Dim c As New CRC32()
crc = c.GetCrc32(f)
Dim crcResult As String = "00000000"
crcResult = String.Format("{0:X8}", crc)
f.Close()
End Function

It appears your .ReportProgress() call is in the New() subroutine, which is the part that makes the lookup table for the CRC calculation. The New() subroutine is called once, before the main CRC routine. The main CRC routine is the one that takes up all the time and needs the progress bar.
Shouldn't the progress bar updating be in the GetCrc32() function? Something like this:
Public Function GetCrc32(ByRef stream As System.IO.Stream, _
Optional prbr As ProgressBar = Nothing) As UInteger
Dim crc As UInteger = Not CUInt(0)
Dim buffer(BUFFER_SIZE) As Byte
Dim readSize As Integer = BUFFER_SIZE
Dim left As Long = stream.Length
If Not (prbr Is Nothing) Then ' ProgressBar setup for counting down amount left.
prbr.Maximum = 100
prbr.Minimum = 0
prbr.Value = 100
End If
Dim count As Integer : Do
count = stream.Read(buffer, 0, readSize)
For i As Integer = 0 To count - 1
crc = (crc >> 8) Xor tbl((crc And 255) Xor buffer(i))
Next
If Not (prbr Is Nothing) Then ' ProgressBar updated here
left -= count
prbr.Value = CInt(left * 100 \ stream.Length)
prbr.Refresh()
End If
Loop While count > 0
Return Not crc
End Function

In Windows Forms BackgroundWorker Class is often used to run intensive tasks in another thread and update progress bar without blocking the interface.
Example of using BackgroundWorker in VB.Net
The problem is when you use use the form in your code without instantiating it Form1.CRCWorker.ReportProgress((i / 255) * 100) there is a kind of hidden "auto-instantiation" happening and new instance of Form1 is created each time.