Related
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
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
I use VB.net 2008 to make a memory scanner and hacking program. I try some of their answers but still the memory scanner is slow. Maybe I have an improvement because before I scan a simple minesweeper and it takes 10 to 20 minutes. But now I can scan it for 2 to 10 seconds.
But I'm still not satisfied because when I try it in other games it takes 5 to 10 minutes or sometimes freeze due of too much long and too much usage of CPU.
Here is my code
Assume I declare all the API and some arguments for making a first scan
this code is a sample of scanning a 4 bytes address:
'' Command Button Event
btn_firstScan(....) Handle....
'' The Code
Me.Enabled = False
FirstScanThread = New Thread(AddressOf scanF)
FirstScanThread.IsBackground = True
FirstScanThread.Priority = ThreadPriority.Highest
FirstScanThread.Start() '' Thread Started for the First Scan.
End sub
Private Sub scanF() '' This is the Function is being Executed by the FirstScanThread at the btn_firstScan.
FirstScan(Of Int32)(pHandle, &H400000, &H7FFF0000, CType(txt_value.Text, Int32))
End Sub
The Sub FirstScan Executed by Sub scanF() that is being Executed by FirstScanThread in Command button btn_firstScan sub
Friend Sub FirstScan(Of T)(ByVal pHandle As IntPtr, ByVal minAddress As Int64, ByVal maxAddress As Int64, _
ByVal VALUE As T, Optional ByVal tempFileName As String = "temp.txt")
Dim thr As New Thread(AddressOf getProcessMemoryInfo) '' Get the Process Memory Info First
Dim memRange As New scanRange
memRange.minimum_address = minAddress
memRange.maximum_address = maxAddress
thr.IsBackground = True
thr.Priority = ThreadPriority.Highest
thr.Start(memRange)
thr.Join()
thr = New Thread(AddressOf dumpReadProcessMemory) '' Read All Bytes and Dump to the Temporary File
thr.IsBackground = True
thr.Priority = ThreadPriority.Highest
thr.Start()
thr.Join()
thr = New Thread(AddressOf readTempFile) '' Scan the Dump File in a Specific Set of Bytes [4 Bytes Aligned]
thr.IsBackground = True
thr.Priority = ThreadPriority.Highest
thr.Start(VALUE)
thr.Join()
setControlState(Me, True) '' If the Scan is Complete , The form is Ready Again to Receive Input
End Sub
Friend Sub dumpReadProcessMemory() '' This Sub is Use to Dump the All Bytes Read by ReadProcessMemory
Dim INFO As FileStream = New FileStream("FIRST.INFO.txt", FileMode.Open, FileAccess.Read, FileShare.Read)
Dim SR As StreamReader = New StreamReader(INFO) '' This is use to Obtain the Info that is needed to switch Page by Page Faster , No need to obtain in VirtualQueryEx
Dim BFILE As FileStream = New FileStream("FIRST.SCAN.txt", FileMode.Create, FileAccess.Write, FileShare.Write)
Dim BW As BinaryWriter = New BinaryWriter(BFILE) '' This is the Binary Writer for writing the READ Bytes
Dim BUFFER(0 To (1048576 * 128)) As Byte
Dim mem As New memoryInfo
While Not SR.EndOfStream '' While there is Page Found
mem.regionBaseAddress = CLng(SR.ReadLine.ToString)
mem.regionSize = CLng(SR.ReadLine.ToString)
ReadProcessMemory(pHandle, mem.regionBaseAddress, BUFFER, mem.regionSize, 0)
BW.Write(BUFFER, 0, mem.regionSize)
Thread.Sleep(1)
End While
SR.Close()
SR.Dispose()
INFO.Close()
INFO.Dispose()
BW.Close()
BFILE.Close()
BFILE.Dispose()
GC.Collect() '' Collect Garbage of BUFFER prevent CPU Stressing and RAM Leak, and i think i helps :P
End Sub
Friend Sub getProcessMemoryInfo(ByVal Obj As Object) '' Use to Get What PAGE is Readable/Writable and its Size
Dim FILE As System.IO.FileStream = New System.IO.FileStream("FIRST.INFO.txt", IO.FileMode.Create, FileAccess.Write, IO.FileShare.Write)
Dim SW As System.IO.StreamWriter = New System.IO.StreamWriter(FILE)
Dim BASE_ADDRESS As Int64 = CLng(Obj.minimum_address.ToString)
Dim MAX As Int64 = CLng(Obj.maximum_address.ToString)
Dim PAGE_COUNT As Integer = 0
While VirtualQueryEx(pHandle, BASE_ADDRESS, MBI, MBIsize)
If MBI.State = MemoryAllocationState.Commit Then
If MBI.zType = MemoryAllocationType.MEM_PRIVATE Or MBI.zType = MemoryAllocationType.MEM_IMAGE Then
Select Case MBI.AllocationProtect
'' Check if The Region is Readable/Writable and Executable
Case MemoryAllocationProtectionType.PAGE_CANWRITE
GoTo WRITE_INFO
Case MemoryAllocationProtectionType.PAGE_EXECUTE_READWRITE
GoTo WRITE_INFO
Case MemoryAllocationProtectionType.PAGE_WRITECOMBINE
GoTo WRITE_INFO
Case MemoryAllocationProtectionType.PAGE_EXECUTE_WRITECOPY
GoTo WRITE_INFO
Case MemoryAllocationProtectionType.PAGE_READWRITE
GoTo WRITE_INFO
Case Else
GoTo BYPASS_WRITE
End Select
WRITE_INFO:
SW.WriteLine(BASE_ADDRESS)
SW.WriteLine(MBI.RegionSize.ToInt32)
Thread.Sleep(1)
'PAGE_COUNT += 1
End If
End If
BYPASS_WRITE:
BASE_ADDRESS = BASE_ADDRESS + MBI.RegionSize.ToInt32
updateProgressTo(Me.pb_scanProgress, CInt(BASE_ADDRESS / MAX * 100))
End While
SW.Close()
SW.Dispose()
FILE.Close()
FILE.Close()
'Console.WriteLine(PAGE_COUNT)
End Sub
Public Sub readTempFile(ByVal Value As Object)
Dim TEMP As System.IO.FileStream = New System.IO.FileStream("TEMP.txt", IO.FileMode.Create, IO.FileAccess.Write, IO.FileShare.Write)
Dim TFILE As System.IO.FileStream = New System.IO.FileStream("FIRST.INFO.txt", IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.Read)
Dim BFILE As System.IO.FileStream = New System.IO.FileStream("FIRST.SCAN.txt", IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.Read)
Dim SW As System.IO.StreamWriter = New System.IO.StreamWriter(TEMP) '' Will Contain a list of Addressed found with the Value input.
Dim SR As System.IO.StreamReader = New System.IO.StreamReader(TFILE) '' Contains the Region baseAddesses and Size
Dim BR As System.IO.BinaryReader = New System.IO.BinaryReader(BFILE) '' Contains the Bytes being Dump Before and will now Read for Scanning.
Dim ADDRESS_POINTER As Int64 = 0
Dim mem As New memoryInfo
Dim TEMP_BYTE(0 To 4 - 1) As Byte
Dim BUFFER(0 To (1024 * 1024)) As Byte = 1024KB
Dim BUFFER_INDEX = 0
mem.regionBaseAddress = CLng(SR.ReadLine.ToString) ''Obtain the Staring Base Address
mem.regionSize = CLng(SR.ReadLine.ToString) '' Obtain the Region Size
ADDRESS_POINTER = mem.regionBaseAddress
While BR.Read(BUFFER, 0, BUFFER.Length) '' Fill the BUFFER with Data
BUFFER_INDEX = 0
While BUFFER_INDEX < BUFFER.Length - (4 - 1)
For a As Integer = 0 To (4 - 1) '' Compile the Read Bytes
TEMP_BYTE(a) = BUFFER(BUFFER_INDEX + a)
Next
If BitConverter.ToInt32(TEMP_BYTE, 0) = Value Then '' If the Compiled 4 Bytes = Value then
SW.WriteLine(formatHex(Hex(ADDRESS_POINTER).ToString))
'addItemTo(Me.lb_addressList, formatHex(Hex(ADDRESS_POINTER).ToString))
End If
ADDRESS_POINTER += 4
BUFFER_INDEX += 1
mem.regionSize -= 4
If mem.regionSize <= 0 Then
If SR.EndOfStream Then
Exit While
Else
''Switch to the Next Region
mem.regionBaseAddress = CLng(SR.ReadLine.ToString) ''Obtain the Staring Base Address
mem.regionSize = CLng(SR.ReadLine.ToString) '' Obtain the Region Size
ADDRESS_POINTER = mem.regionBaseAddress
End If
End If
End While
Thread.Sleep(1) '' Prevent 100% CPU Usage therefore the Form and other App avoid Crashing and Not Responding,
End While
BR.Close()
BFILE.Close()
SW.Close()
TEMP.Close()
SW.Dispose()
TEMP.Dispose()
SR.Close()
SR.Dispose()
TFILE.Dispose()
GC.Collect()
setControlState(Me, True) '' Make the Form Enabled
End Sub
NOTE: formatHex is only a Function that will put trailing Zeros in the front of Hex String if the Hex is not have Length of 8.
This code works in minesweeper in Windows XP 32 Bit and works fast in MINESWEEPER ONLY. I tried it in Grand Chase and Farm Frenzy; the scan won't ends because its still slow and even the scan is done, there is no address being found (maybe because in just tested it for 4 bytes).
I like to use VirtualProtectEx and VirtualAllocEx to enable to scan those PAGE_GUARD and write on it. Therefore I am able to obtain the specific address that I want but I can't do it because it is still slow. I make the PAGE_GUARD'ed PAGE into EXECUTE_READWRITE it will make more bytes to scan. It will make the App slower.
Edit: I found another example that creates the encoder params like this and I get the exact same error as befoer: "A generic error occurred in GDI+"
Dim info As ImageCodecInfo = Nothing
Dim ice As ImageCodecInfo
For Each ice In ImageCodecInfo.GetImageEncoders()
If ice.MimeType = "image/tiff" Then
info = ice
End If
Next ice 'use the save encoder
Dim enc As Encoder = Encoder.SaveFlag
Dim ep As New EncoderParameters(1)
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.MultiFrame))
ORIGINAL POST
VB.Net, Visual Studio 2012, .Net 4.5
I have been trying to write, borrow, or steal code that will merge multiple TIFF files in to a single tiff file. Every example, whether I write or get it from someplace fails on the same line with the exception, "A generic error occurred in GDI+". The line that causes the problem is DestinationImage.SaveAdd(img, imagePararms). There is just not enough to go on with that generic error message about a generic error. Has anyone experienced this?
Greg
Public Sub mergeTiffPages(str_DestinationPath As String, sourceFiles As String())
Dim codec As System.Drawing.Imaging.ImageCodecInfo = Nothing
For Each cCodec As System.Drawing.Imaging.ImageCodecInfo In System.Drawing.Imaging.ImageCodecInfo.GetImageEncoders()
If cCodec.CodecName = "Built-in TIFF Codec" Then
codec = cCodec
End If
Next
Try
Dim imagePararms As New System.Drawing.Imaging.EncoderParameters(1)
imagePararms.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(System.Drawing.Imaging.EncoderValue.MultiFrame))
If sourceFiles.Length = 1 Then
System.IO.File.Copy(DirectCast(sourceFiles(0), String), str_DestinationPath, True)
ElseIf sourceFiles.Length >= 1 Then
Dim DestinationImage As System.Drawing.Image = DirectCast(New System.Drawing.Bitmap(DirectCast(sourceFiles(0), String)), System.Drawing.Image)
DestinationImage.Save(str_DestinationPath, codec, imagePararms)
imagePararms.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(System.Drawing.Imaging.EncoderValue.FrameDimensionPage))
For i As Integer = 0 To sourceFiles.Length - 2
Dim img As System.Drawing.Image = DirectCast(New System.Drawing.Bitmap(DirectCast(sourceFiles(i), String)), System.Drawing.Image)
DestinationImage.SaveAdd(img, imagePararms)
img.Dispose()
Next
imagePararms.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(System.Drawing.Imaging.EncoderValue.Flush))
DestinationImage.SaveAdd(imagePararms)
imagePararms.Dispose()
DestinationImage.Dispose()
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Although I did not find a solution for this code I did find code that works. JohnH a moderator at http://www.vbdotnetforums.com/ posted the code below in this thread http://www.vbdotnetforums.com/graphics-gdi/22113-create-multipage-tiff-loop.html
It works for me. I added a few lines at the top to show how I called it.
Greg
'Example: Combine 4 tiff images in a new file called FinishedTiff.tiff
'Dim oNewImage As Image
'oNewImage = Image.FromFile("C:\IRISScan\Week of Jan 6 no SSN_Page_1.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
'oNewImage = Image.FromFile("C:\IRISScan\Week of Jan 6 no SSN_Page_2.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
'oNewImage = Image.FromFile("C:\IRISScan\Document3_Page_1.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
'oNewImage = Image.FromFile("C:\IRISScan\Document3_Page_2.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
Imports System.Drawing.Imaging
Module modTiff
'
Sub SaveAddTiff(ByVal img As Image, ByVal filename As String)
If Not IO.File.Exists(filename) Then
img.Save(filename, Imaging.ImageFormat.Tiff)
Else
Dim frames As List(Of Image) = getFrames(filename)
frames.Add(img)
SaveMultiTiff(frames.ToArray, filename)
End If
img.Dispose()
End Sub
Sub SaveMultiTiff(ByVal frames() As Image, ByVal filename As String)
Dim codec As ImageCodecInfo = getTiffCodec()
Dim enc As Encoder = Encoder.SaveFlag
Dim ep As New EncoderParameters(2)
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.MultiFrame))
ep.Param(1) = New EncoderParameter(Encoder.Compression, CLng(EncoderValue.CompressionNone))
Dim tiff As Image = frames(0)
tiff.Save(filename, codec, ep)
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.FrameDimensionPage))
For i As Integer = 1 To frames.Length - 1
tiff.SaveAdd(frames(i), ep)
frames(i).Dispose()
Next
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.Flush))
tiff.SaveAdd(ep)
tiff.Dispose()
End Sub
Function getTiffCodec() As ImageCodecInfo
For Each ice As ImageCodecInfo In ImageCodecInfo.GetImageEncoders()
If ice.MimeType = "image/tiff" Then
Return ice
End If
Next
Return Nothing
End Function
Function getFrames(ByVal filename) As List(Of Image)
Dim frames As New List(Of Image)
Dim img As Image = Image.FromFile(filename)
For i As Integer = 0 To img.GetFrameCount(Imaging.FrameDimension.Page) - 1
img.SelectActiveFrame(Imaging.FrameDimension.Page, i)
Dim tmp As New Bitmap(img.Width, img.Height)
Dim g As Graphics = Graphics.FromImage(tmp)
g.CompositingQuality = Drawing2D.CompositingQuality.HighQuality
g.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
g.PixelOffsetMode = Drawing2D.PixelOffsetMode.HighQuality
g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality
g.TextRenderingHint = Drawing.Text.TextRenderingHint.AntiAliasGridFit
g.DrawImageUnscaled(img, 0, 0)
frames.Add(tmp)
g.Dispose()
Next
img.Dispose()
Return frames
End Function
End Module
I replaced
g.DrawImageUnscaled(img, 0, 0)
with
g.DrawImageUnscaledAndClipped(img, New Rectangle(0, 0, img.Width, img.Height))
and it fixed the scaling issue where it would shrink the image to a quarter of its original size
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.