Adding images of different sizes into a listview - vb.net

I have a listview to which i add images of different sizes, eg. 123x23, 23,43, and so on..
How do i go on about this problem. I know listview has a tilesize property but that sets the general size of all the tiles
Tried with an imagelist, changing the imagelist imagesize doesnt help either... Heres the code i use to add the images to the listbox
The imglist in the code is an imagelist to which all the required images are loaded.
Private Sub frm_load_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Form1.ListViewEx1.LargeImageList = imglist
For i = 0 To imglist.Images.Count - 1
Dim x = Form1.ListViewEx1.Items.Add(New ListViewItem("", i))
x.Tag = imglist.Images.Keys(i).ToString
Next
Form1.lbl_status1.Text = "Image Count: " & Form1.ListViewEx1.Items.Count
End sub

I had the same problem.
I found this and that works for me: Click here
Public Sub LoadImageList(ByVal ImagePath As String, ByVal Key As String)
Dim picImage As Image = Nothing
Dim final_Bitmap As Bitmap = Nothing
Dim org_Image As Bitmap = Nothing
If File.Exists(ImagePath) Then
picImage = Image.FromFile(ImagePath)
'********************* Drawing the Image in proportion to the imagelist Size Here ****************
Dim proportion As Integer = 0
Dim startx As Decimal = 0
Dim startY As Decimal = 0
Dim drawwidth As Decimal = 0
Dim drawheight As Decimal = 0
org_Image = New Bitmap(picImage)
final_Bitmap = New Bitmap(ImageList1.ImageSize.Width, ImageList1.ImageSize.Height)
Dim gr As Graphics = Graphics.FromImage(final_Bitmap)
Dim factorscale As Decimal
factorscale = org_Image.Height / org_Image.Width
drawwidth = final_Bitmap.Width
drawheight = final_Bitmap.Width * factorscale
If drawheight > final_Bitmap.Height Then
proportion = 1
factorscale = org_Image.Width / org_Image.Height
drawheight = final_Bitmap.Height
drawwidth = final_Bitmap.Height * factorscale
End If
startx = 0
startY = final_Bitmap.Height - drawheight
gr.DrawImage(org_Image, startx, startY, drawwidth, drawheight)
ImageList1.Images.Add(Key, final_Bitmap)
org_Image.Dispose()
final_Bitmap.Dispose()
'************************** End Loading the Image****************
End If
End Sub

Related

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

Is there a way to convert Pixel coordinates to Cartesian Coordinates in VB.net

I have a PictureBox that is sized 1096 x 1004 with the SizeMode set to StretchImage. I am able to get the coordinates of each pixel correctly(see code below) by factoring in the StrechImage effect on the pixel coordinates.
Now what I am trying to accomplish is converting those pixel coordinates to a Cartesian Coordinate to be able to graph. In the long run, I am going to take the Cartesian Coordinates and convert them to Polar Coordinates.
I have tried to convert the pixel coordinates to cartesian by using this method.
cartesianx = scalefactor*screenx - screenwidth / 2;
cartesiany = -scalefactor*screeny + screenheight / 2;
This method is not putting the origin at (0,0) in the center of the PictureBox. It seems to be setting the origin closer to the Upper Left of the PictureBox. Is there any idea as to what I am missing?
Below is my code to convert the image to BitMap and get those coordinates and scale them correctly.
Imports System.IO
Public Class HomePanel
Dim realX As Int32
Dim realY As Int32
Private Sub HomePanel_Load(sender As Object, e As EventArgs) Handles MyBase.Load
chartImageDisplay_box.Image = Image.FromFile("C:\Users\UserB\Desktop\test.jpg")
End Sub
Private Sub chartImageDisplay_box_MouseMove(sender As Object, e As MouseEventArgs) Handles chartImageDisplay_box.MouseMove
If (e.Button = MouseButtons.Left) Then
ShowCoords(e.X, e.Y)
End If
End Sub
Private Sub chartImageDisplay_box_MouseDown(sender As Object, e As MouseEventArgs) Handles chartImageDisplay_box.MouseDown
If (e.Button = MouseButtons.Left) Then
ShowCoords(e.X, e.Y)
Dim MyBitmap As Bitmap
MyBitmap = CType(chartImageDisplay_box.Image, Bitmap)
'Me.BackColor = MyBitmap.GetPixel(realX, realY)
rgbValue.Text = "RGB Value: " & MyBitmap.GetPixel(realX, realY).ToString()
End If
'printAllPixels()
End Sub
Private Sub ShowCoords(ByVal mouseX As Int32, ByVal mouseY As Int32)
Dim realW As Int32 = chartImageDisplay_box.Image.Width
Dim realH As Int32 = chartImageDisplay_box.Image.Height
Dim currentW As Int32 = chartImageDisplay_box.ClientRectangle.Width
Dim currentH As Int32 = chartImageDisplay_box.ClientRectangle.Height
Dim zoomW As Double = (currentW / CType(realW, Double))
Dim zoomH As Double = (currentH / CType(realH, Double))
Dim zoomActual As Double = Math.Min(zoomW, zoomH)
Dim padX As Double = If(zoomActual = zoomW, 0, (currentW - (zoomActual * realW)) / 2)
Dim padY As Double = If(zoomActual = zoomH, 0, (currentH - (zoomActual * realH)) / 2)
realX = CType(((mouseX - padX) / zoomActual), Int32)
realY = CType(((mouseY - padY) / zoomActual), Int32)
lblPosXval.Text = "X: " & If(realX < 0 OrElse realX > realW, "-", realX.ToString())
lblPosYVal.Text = "Y: " & If(realY < 0 OrElse realY > realH, "-", realY.ToString())
cartX.Text = "X: " 'Where to add the cart conversion for X
cartY.Text = "Y: " 'Where to add the cart conversion for Y
End Sub
'Writes all the pixels to a text file along with RGB values for each pixel
Public Sub printAllPixels()
Using writer As StreamWriter =
New StreamWriter("C:\Users\UserB\Desktop\Pixels.txt")
Dim MyBitmap As Bitmap
MyBitmap = CType(chartImageDisplay_box.Image, Bitmap)
For y = 0 To MyBitmap.Height - 1
For x = 0 To MyBitmap.Width - 1
writer.WriteLine("XY Coord: " & x & ", " & y & "; " & MyBitmap.GetPixel(x, y).ToString)
Next
Next
End Using
End Sub
End Class
I don't know if the content of the variable contains the right value but the formula should look more like this:
cartesianx = scalefactor * (screenx - (screenwidth / 2))
cartesiany = -scalefactor* (screeny - (screenheight / 2))
Translate to 0,0 add the scale factor then flip the y.
I believe I figured my question out. I was using the wrong value for my screenx and screeny. I was using the calculated scale value but I needed to just use the mouse event X and Y values.

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

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

Changing the area of a pixel search

I have been working on an app to search for 3 pixels in a certain area then play a sound. It currently works however I wish to reduce the zone of which it searches from the whole screen to a rectangular area on my screen, this is to save memory usage of the app, here's the code that works
Private Sub dcdTimer_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles dcdTimer.Tick
Dim screensize As Size = New Size(My.Computer.Screen.Bounds.Width, My.Computer.Screen.Bounds.Height)
Dim screenshot As New Bitmap(My.Computer.Screen.Bounds.Width, My.Computer.Screen.Bounds.Height)
Dim ge As System.Drawing.Graphics = System.Drawing.Graphics.FromImage(screenshot)
Dim pointx As Integer = 1
Dim pointy As Integer = 1
ge.CopyFromScreen(New Point(0, 0), New Point(0, 0), screensize)
looking = True
Try
While looking = True
Dim atpoint As Color = screenshot.GetPixel(pointx, pointy)
Dim reckcol1 As Color = Color.FromArgb(a, r, g, b) 'first pixel colour
Dim reckcol2 As Color = Color.FromArgb(a1, r1, g1, b1) 'second pixel colour
Dim reckcol3 As Color = Color.FromArgb(a2, r2, g2, b2) 'third pixel colour
If atpoint = reckcol1 Then 'Matches 3 pixels
Dim testPoint As Color = screenshot.GetPixel(pointx, pointy + 10)
If testPoint = reckcol2 Then
Dim testPoint2 As Color = screenshot.GetPixel(pointx + 10, pointy + 10)
If testPoint2 = reckcol3 Then
My.Computer.Audio.Play(sounddir + "Found.wav")
looking = False
Sleep(15000)
pointx = 0
pointy = 0
End If
End If
End If
pointy = pointy + 1
If pointy = My.Computer.Screen.Bounds.Height Then
pointy = 0
pointx = pointx + 1
End If
End While
Catch ex As Exception
End Try
End Sub
I tried to use this code as suggested:
Dim pointofY As New Point(500, 400)
Dim screensize As New Size(400, 200)
Dim screenshot As New Rectangle(pointofY, screensize)
Dim ge As System.Drawing.Graphics = System.Drawing.Graphics.FromImage(screenshot)
However, using a rectangle does not allow me to use getpixel or use ge.copyfromscreen