DirectCast not working - vb.net

'ofd is open file dialog
Dim img As Bitmap
Dim iscmyk As Boolean
Dim i As String
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
ofd.Filter = "Jpg Image(*.jpg)|*.jpg"
If ofd.ShowDialog = Windows.Forms.DialogResult.OK Then
img = Bitmap.FromFile(ofd.FileName)
iscmyk = ((DirectCast(img.Flags, Imaging.ImageFlags) And Imaging.ImageFlags.ColorSpaceCmyk) = Imaging.ImageFlags.ColorSpaceCmyk)
End If
img = New Bitmap(img, New Size(120, 190))
MsgBox("cmyk = " & iscmyk)
PictureBox1.Image = img
End Sub
i need to check if the image is cmyk or rgb
if its cmyk then iscmyk returns true
if its not cmyk then iscmyk returns false
in my windows 7 pc its returns false for each & every image
but in XP it returns perfect answer
why its not working in my other win7 pcs???

First, sorry for responding so late...
Second, actually I don't know
why you get different results on different OS versions.
Anyway, here is a low-level (and ugly) workaround. It's designed for JPEG images:
Public Shared Function GetJpegBpp(FileName As String) As Integer
Dim len As Integer
Dim fp As FileStream = Nothing
Dim marker(1) As Byte
Dim data(15) As Byte
Dim components As Byte = 0
GetJpegBpp = -2
Try
fp = New FileStream(FileName, FileMode.Open, FileAccess.Read)
GetJpegBpp = -1
If fp.Read(marker, 0, 2) < 2 OrElse marker(0) <> &HFF OrElse marker(1) <> &HD8 Then Exit Function
Do
If fp.Read(marker, 0, 2) < 2 OrElse marker(0) <> &HFF OrElse (marker(1) > 1 And marker(1) < &HC0) Then Exit Function
If (marker(1) < &HD0 Or marker(1) > &HD9) AndAlso marker(1) > 1 Then
If fp.Read(data, 0, 2) < 2 Then Exit Function
len = (CInt(data(0)) << 8) Or data(1)
len -= 2
If len < 0 Then Exit Function
If (marker(1) >= &HC0) And (marker(1) <= &HC3) Then
If len < 9 OrElse fp.Read(data, 0, 6) < 6 Then Exit Function
components = data(5)
If components = 0 OrElse components = 2 OrElse components > 4 OrElse (components * 3 + 6) <> len Then Exit Function
len -= 6
ElseIf marker(1) = &HDA Then
If len < (4 + 2 * components) Or (fp.ReadByte() <> components) Then Exit Function
len -= 1
End If
fp.Position += len
End If
Loop Until marker(1) = &HDA Or marker(1) = &HD9
If components = 0 OrElse marker(1) = &HD9 OrElse (fp.Length - fp.Position) < 3 Then Exit Function
Catch
Exit Function
Finally
If Not fp Is Nothing Then fp.Close()
End Try
GetJpegBpp = components * 8
End Function
You need to replace this line
iscmyk = ((DirectCast(img.Flags, Imaging.ImageFlags) And Imaging.ImageFlags.ColorSpaceCmyk) = Imaging.ImageFlags.ColorSpaceCmyk)
with this:
iscmyk = (GetJpegBpp(ofd.FileName) = 32)
Finally, I haven't tested this code with CMYK JPEG images, but I guess it should work...

Related

Finding Sequence of numbers in Text file

Hello I'm having quite some trouble with this task that was given to me.
I need to find a Sequence of 8 consecutive numbers in a Text file and Put that Line into a MsgBox.
So far I've only found
For Each i As Char In fileLocation
If IsNumeric(i) Then
result += i
End If
Next`
MsgBox(result)
But that won't help me I guess
Edit:
an example Line woudl look like this:
! MK 90 GRAD ALU L 10793013 144 63.00 90 1 3745 !
In this case I would need the 10793013 as an output
Edit 2:
this is the code I currently managed to create
Dim objReader As New System.IO.StreamReader(fileLocation)
Do While objReader.Peek() <> -1
concounter = 0
zeileInhalt = objReader.ReadLine()
ListBox1.Items.Add(zeileInhalt)
For Each zeichen As Char In zeileInhalt
If IsNumeric(zeichen) Then
concounter += 1
vorhanden = True
If vorhanden = False Then
ListBox1.Items.Add(zeileInhalt)
End If
ElseIf IsNumeric(zeichen) = False And concounter = 8 Then
concounter = 0
ElseIf IsNumeric(zeichen) = False And concounter < 8 Then
concounter = 0
ListBox1.Items.Remove(zeileInhalt)
ElseIf concounter > 8 Then
concounter = 0
ListBox1.Items.Remove(zeileInhalt)
vorhanden = False
End If
Next
Loop
'For i As Integer = 0 To fileLocation.Length <> -1
objReader.Close()
The counter itself appears to work however for some reason no entries end up in my listbox.
am I missing a case where the entries are getting removed?
PS: I hope you don't mind the german variable names. If you do
zeileInhalt = content of the row
zeichen = character
vorhanden = existing
Here's another approach to try out:
Dim values() As String
Using objReader As New System.IO.StreamReader(fileLocation)
Do While Not objReader.EndOfStream
values = objReader.ReadLine().Split(" ".ToCharArray(), StringSplitOptions.RemoveEmptyEntries)
For Each value As String In values
value = value.Trim()
If value.Length = 8 AndAlso value.All(Function(c) Char.IsDigit(c)) Then
ListBox1.Items.Add(value)
Exit For
End If
Next
Loop
End Using
try to introduce a counter to check the consecutivity in your if clause and reset it and result string to zero once it's not numeric!
Dim result As String = ""
Dim conCounter As Integer = 0
For Each i As Char In fileLocation
If Char.IsDigit(i) Then
conCounter = (conCounter + 1)
result = (result + i)
Else
conCounter = 0
If (result.Length < 8) Then
result = ""
End If
End If
Next
MsgBox(result)
for each word in fileLocation
Dim noExp As New Regex("([0-9]{8,11})")
Dim m As Match = noExp.Match(word)
If Not m.Success Then Throw New Exception("No sequence number found")
Dim c = m.Groups(1).Captures(0)
Msgbox(c.value)
next
how about this ?

Does Visual Basic process nested loops like this very slowly, or is there some other issue with my code?

Basically, I'm trying to loop through every pixel of a picture and check it against every pixel of another image. The problem is that it seems to just do this very slowly (I can no longer interact with the opened window, and Debug.WriteLine works). I want to be sure this is the problem rather than there just being something wrong with my code.
monPic and crop are dimmed as bitmaps at the top of my code.
Private Sub BtnCheck_Click(sender As Object, e As EventArgs) Handles btnCheck.Click
monPic = New Bitmap("../../../../" & picNum & ".png")
crop = New Bitmap("../../../../mm.png")
For x As Integer = 0 To monPic.Width - 1
Debug.WriteLine("level 1")
For y As Integer = 0 To monPic.Height - 1
Debug.WriteLine("level 2")
If CInt(monPic.GetPixel(x, y).A) <> 0 Then
For x2 As Integer = 0 To crop.Width - 1
Debug.WriteLine("level 3")
For y2 As Integer = 0 To crop.Height - 1
Debug.WriteLine("level 4")
If monPic.GetPixel(x, y).R = crop.GetPixel(x2, y2).R And monPic.GetPixel(x, y).G = crop.GetPixel(x2, y2).G And monPic.GetPixel(x, y).B = crop.GetPixel(x2, y2).B Then matches += 1
Next y2
Next x2
End If
Next y
Next x
lblMatches.Text = CStr(matches)
End Sub
This works quickly. It requires
Imports System.Security.Cryptography
Convert the 2 bitmaps to Byte arrays then hash with Sha256. Compare the hash.
Adapted from https://www.codeproject.com/Articles/9299/Comparing-Images-using-GDI
Private Function Compare(bmp1 As Bitmap, bmp2 As Bitmap) As String
Dim result = "It's a match!"
If Not (bmp1.Size = bmp2.Size) Then
result = "It's not even the same size"
Else
Dim ic As New ImageConverter
Dim btImage1(0) As Byte
btImage1 = CType(ic.ConvertTo(bmp1, btImage1.GetType), Byte())
Dim btImage2(0) As Byte
btImage2 = CType(ic.ConvertTo(bmp2, btImage2.GetType), Byte())
Dim shaM As New SHA256Managed
Dim hash1 = shaM.ComputeHash(btImage1)
Dim hash2 = shaM.ComputeHash(btImage2)
Dim i As Integer = 0
Do While i < hash1.Length AndAlso i < hash2.Length AndAlso result = "It's a match!"
If hash1(i) <> hash2(i) Then
result = "The pixels don't match"
End If
i = (i + 1)
Loop
End If
Return result
End Function
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim png1 As New Bitmap(path1)
Dim png2 As New Bitmap(path2)
Dim message = Compare(png1, png2)
MessageBox.Show(message)
End Sub

Timer1 freezes the UI thread

My programm gets a high-speed data from serialport, and timer reads it , after timer gets value , timer is disabled and code does sting operations where add value which accepted earlier from com to listview. THe problem is that UI thread is not completely freezing but it seems laggy when i drag the form also, That code which add +1 every time on the subitem.text - is not smooth.
founditem.SubItems(4).Text = founditem.SubItems(4).Text + 1
Why is that as knows timer creats its own thread, and it shouldnot freeze an UI( i cant get rid of timer, becsouse its neccesary to accept correct data from serial)
Any tips? i tried invoke,begininvoke and background_worker, maybe not correctly.
Also can i call background worker from timer event? I'm not good at asyc tasks. My code is:
Private Sub spOpen()
Try
spClose()
spObj.PortName = "COM4"
spObj.BaudRate = 230400
spObj.Parity = IO.Ports.Parity.None
spObj.DataBits = 8
spObj.StopBits = IO.Ports.StopBits.One
spObj.Handshake = IO.Ports.Handshake.None
spObj.DtrEnable = False 'imp
spObj.RtsEnable = False 'imp
spObj.NewLine = vbCr
spObj.ReadTimeout = 0
spObj.WriteTimeout = 250
spObj.ReceivedBytesThreshold = 1
spObj.Open()
Catch ex As Exception
'catch
End Try
End Sub
Private Sub spClose()
Try
If spObj.IsOpen Then
spObj.Close()
spObj.Dispose()
End If
Catch ex As Exception
'handle the way you want
End Try
End Sub
Function ReverseString(ByVal sText As String) As String
Dim lenText As Long, lPos As Long
If Len(sText) = 0 Then Exit Function
lenText = Len(sText)
ReverseString = Space(lenText)
For lPos = lenText To 1 Step -2
If lPos > 0 Then Mid(ReverseString, lenText - lPos + 1, 2) = Mid(sText, lPos - 1, 2)
If lPos = 0 Then Mid(ReverseString, lenText - lPos + 1, 2) = Mid(sText, lPos, 2)
Next lPos
'Return
End Function
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
'stop the timer (stops this function being called while it is still working
Timer1.Enabled = False
' get any new data and add the the global variable receivedData
receivedData = ReceiveSerialData()
'If receivedData contains a "<" and a ">" then we have data
If ((receivedData.Contains("<") And receivedData.Contains(">"))) Then
'parseData()
first_msg = 1
parseData()
End If
' restart the timer
Timer1.Enabled = True
End Sub
Function ReceiveSerialData() As String
Dim Incoming As String
Try
Incoming = spObj.ReadExisting()
If Incoming Is Nothing Then
Return "nothing" & vbCrLf
Else
Return Incoming
End If
Catch ex As TimeoutException
Return "Error: Serial Port read timed out."
End Try
End Function
Function parseData()
' uses the global variable receivedData
Dim pos1 As Integer
Dim pos2 As Integer
Dim length As Integer
Dim newCommand As String
Dim done As Boolean = False
Dim count As Integer = 0
While (Not done)
pos1 = receivedData.IndexOf("<") + 1
pos2 = receivedData.IndexOf(">") + 1
'occasionally we may not get complete data and the end marker will be in front of the start marker
' for exampe "55><T0056><"
' if pos2 < pos1 then remove the first part of the string from receivedData
If (pos2 < pos1) Then
receivedData = Microsoft.VisualBasic.Mid(receivedData, pos2 + 1)
pos1 = receivedData.IndexOf("<") + 1
pos2 = receivedData.IndexOf(">") + 1
End If
If (pos1 = 0 Or pos2 = 0) Then
' we do not have both start and end markers and we are done
done = True
Else
' we have both start and end markers
length = pos2 - pos1 + 1
If (length > 0) Then
'remove the start and end markers from the command
newCommand = Mid(receivedData, pos1 + 1, length - 2)
' show the command in the text box
RichTextBox1.Text = ""
RichTextBox1.AppendText(newCommand & vbCrLf)
'remove the command from receivedData
receivedData = Mid(receivedData, pos2 + 1)
'RichTextBox1.Text &= receivedData
uart_in = RichTextBox1.Text
data = ""
'RichTextBox2.Text = Mid(RichTextBox1.Text, 6, 3)
'If RichTextBox1.TextLength = 26 Then
can_id = Mid(uart_in, 6, 3) 'extracting and id
dlc = Mid(uart_in, 10, 1)
data = uart_in.Substring(26 - (dlc * 2))
hex2ascii(data)
data = data.InsertEveryNthChar(" ", 2)
' data = ReverseString(data)
Dim articlecheck As String = can_id
Dim founditem As ListViewItem = ListView1.FindItemWithText(articlecheck)
If Not (founditem Is Nothing) Then
founditem.SubItems(0).Text = can_id
founditem.SubItems(1).Text = dlc
' If founditem.SubItems(2).Text <> data Then
' founditem.SubItems(2).ForeColor = Color.LightYellow
founditem.SubItems(2).Text = data
' End If
founditem.SubItems(3).Text = timer_count - founditem.SubItems(3).Text
founditem.SubItems(4).Text = founditem.SubItems(4).Text + 1
founditem.SubItems(5).Text = asciival
' timer_count = 1
first_msg = 0
Else
Dim lvi As New ListViewItem(can_id)
lvi.SubItems.Add(dlc)
lvi.SubItems.Add(data)
lvi.SubItems.Add(timer_count)
lvi.SubItems.Add(count)
lvi.SubItems.Add(asciival)
ListView1.Items.Add(lvi)
End If
End If ' (length > 0)
End If '(pos1 = 0 Or pos2 = 0)
End While
End Function
Function hex2ascii(ByVal hextext As String) As String
Dim a As Integer
Dim y As Integer
Dim value As String
Dim num As String
For y = 1 To Len(hextext) Step 2
num = Mid(hextext, y, 2)
a = Val("&h" & num)
If a = 160 Or a = 0 Or a = 9 Or a = 32 Or a = 11 Then a = 46
value = value & Chr(a)
Next
asciival = value
End Function
Dim System.Threading.Thread yourthread As New System.Threading.Thread(AddressOf yourfunction())
yourthread.Priority = System.Threading.Priority.Highest
yourthread.Start();
you can create a loop in your function and add System.Threading.Thread.Sleep(1000) in the end of the loop to make it work like a timer. You can call all your existing functions through this thread, even the timer.
Be careful while accessing your controls through the thread.
Invoke(Sub() yourcontrol.property = someproperty)

How to compare between two images using VB.net?

I have a small bitmap image and I will do a screenshot. I need to find whether the small image is the screenshot. How I can compare two bitmap images? and then return the coordinates.
If it is MATLAB, (NOTE: I need VB.net)
What my plan is this
screenshot
for x_screen = 1: screen_width_x
for y_screen = 1: screen_col_y
for x_pic = = 1: pic_width_x
for y_pic = = 1: pic_col_y
if screenshot(x_screen, y_screen) != pic(x_pic , y_pic)
break
end
end
xx = (x_screen)
yy = (y_screen)
end
end
See Image comparison if you want something advanced Also you can look for machine learning techniques for such tasks.
Here is naive solution and not optimized one (plus it is better to do such tasks in native code):
Plus Note that it is better to check this with bmp files. otherwise it will not handle problem
Private Function FindSubImg2(img As Bitmap, subimg As Bitmap) As Point
If (img.Width - subimg.Width < 0) Or (img.Height - subimg.Height < 0) Then Return Nothing
Dim stepxLen As Integer = img.Width - subimg.Width
Dim stepyLen As Integer = img.Height - subimg.Height
Dim coor As Point
Dim match As Boolean = False
For oy As Integer = 0 To stepyLen
For ox As Integer = 0 To stepxLen
match = True
For x As Integer = 0 To subimg.Width - 1
For y As Integer = 0 To subimg.Height - 1
'actually here we do not need ToArgb method. But it will skip unneeded Color comparisions
If img.GetPixel(x + ox, y + oy).ToArgb <> subimg.GetPixel(x, y).ToArgb Then
match = False
Exit For 'we can use goto operator instead of double exit for
End If
Next
If match = False Then Exit For
Next
If match = True Then
coor.X = ox
coor.Y = oy
Return coor
End If
Next
Next
Return New Point(-1, -1)
End Function
Private Function FindSubImg(a As Bitmap, b As Bitmap) As Point
Dim subimg As Bitmap
Dim img As Bitmap
If (a.Height <= b.Height AndAlso a.Width <= b.Width) Then
subimg = a : img = b
Return FindSubImg2(img, subimg)
ElseIf (a.Height > b.Height AndAlso a.Width > b.Width) Then
subimg = b : img = a
Return FindSubImg2(img, subimg)
Else
Return New Point(-1, -1)
End If
End Function
Usage:
Dim p As Point = FindSubImg(New Bitmap("A.bmp"), New Bitmap("B.bmp"))
Try something like this:
Public Function CompareImages(ByVal img1 As Bitmap, ByVal img2 As Bitmap) As Boolean
Dim i As Integer
Dim j As Integer
For i = 0 To img1.Width - 1
For j = 0 To img2.Height - 1
If img1.GetPixel(i, j) <> img2.GetPixel(i, j) Then
Return False
End If
Next
Next
Return True
End Function
sample call:
CompareImages(New Bitmap("f:\img1.bmp"), New Bitmap("f:\img2.bmp"))

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.