I'm scanning some text in the screen using Windows.Media.Ocr under a timer control, firing the tick event every 200 ms.
I'm then displaying the output in a richtextbox that is unfortunately flickering..
I made a gif to show the issue ( the ocr is on purpose scanning just the values with M)
is there any way to stop this behavior? Thanks
The code I'm using inside of the timer is:
Dim softwareBmp As Windows.Graphics.Imaging.SoftwareBitmap
Using bmp As Bitmap = New Bitmap(PictureBox1.Width, PictureBox1.Height)
Using g As Graphics = Graphics.FromImage(bmp)
Dim pt As Point = Me.PointToScreen(New Point(PictureBox1.Left, PictureBox1.Top))
g.CopyFromScreen(pt.X, pt.Y, 0, 0, bmp.Size, CopyPixelOperation.SourceCopy)
Using memStream = New Windows.Storage.Streams.InMemoryRandomAccessStream()
bmp.Save(memStream.AsStream(), System.Drawing.Imaging.ImageFormat.Bmp)
Dim decoder As Windows.Graphics.Imaging.BitmapDecoder = Await Windows.Graphics.Imaging.BitmapDecoder.CreateAsync(memStream)
softwareBmp = Await decoder.GetSoftwareBitmapAsync(decoder.BitmapPixelFormat, BitmapAlphaMode.Ignore)
End Using
End Using
End Using
Dim ocrEng = OcrEngine.TryCreateFromLanguage(New Windows.Globalization.Language("en-US"))
Dim languages As IReadOnlyList(Of Windows.Globalization.Language) = ocrEng.AvailableRecognizerLanguages
For Each language In languages
Console.WriteLine(language.LanguageTag)
Next
Dim r = ocrEng.RecognizerLanguage
Dim n = ocrEng.MaxImageDimension
Dim ocrResult = Await ocrEng.RecognizeAsync(softwareBmp)
RichTextBox1.Clear()
Dim wordList As List(Of cText) = New List(Of cText)()
Dim lines As IReadOnlyList(Of OcrLine) = ocrResult.Lines
For Each line In lines
For Each word In line.Words
Dim nY As Double = CLng(word.BoundingRect.Bottom / 10) * 10
wordList.Add(New cText() With {.Text = word.Text, .LocY = nY, .LocX = word.BoundingRect.Left})
Next
Next
wordList.Sort(New WordComparer())
Dim oldLocY As Double = 0
For Each item As cText In wordList
If (item.LocY > oldLocY And oldLocY <> 0) Then
RichTextBox1.Text += Environment.NewLine
End If
RichTextBox1.Text += (item.Text + " ")
oldLocY = item.LocY
Next
I solved using WM_SETREDRAW
<DllImport("User32.dll", SetLastError:=True, CharSet:=CharSet.Unicode)>
Public Shared Function SendMessage(ByVal hWnd As IntPtr, ByVal Msg As Integer, ByVal wParam As Integer, ByVal lParam As IntPtr) As Integer
End Function
Public Const WM_SETREDRAW As Integer = &HB
Before adding lines (before RichTextBox1.Clear())
If (RichTextBox1.IsHandleCreated) Then
SendMessage(RichTextBox1.Handle, WM_SETREDRAW, 0, IntPtr.Zero)
End If
After lines have been added :
If (RichTextBox1.IsHandleCreated) Then
SendMessage(RichTextBox1.Handle, WM_SETREDRAW, 1, IntPtr.Zero)
RichTextBox1.Invalidate()
End If
guys
I'm having difficulty with the Dropbox API in uploading.
I have a list of files, and in each pass of the for I call the function that uploads:
Public Function Upload(ByVal ArquivoOrigem As String, ByVal ArquivoDestino As String)
Try
Dim fileStream As FileStream = New FileStream(ArquivoOrigem, FileMode.Open)
Me.CtrlTask = Task.Run(Function() Upload_Executar(fileStream, ArquivoDestino))
Me.CtrlTask.Wait()
Catch ex As Exception
End Try
End Function
Private Async Function Upload_Executar(ByVal fileStream As FileStream, ByVal ArquivoDestino As String) As Task
Me.ArquivoUploadIs = False
Try
Dim numChunks As Integer = CInt(Math.Ceiling(CDbl(fileStream.Length) / Me.chunkSize))
Dim buffer As Byte() = New Byte(Me.chunkSize - 1) {}
Dim sessionId As String = Nothing
Console.WriteLine("Chunk upload file...")
Console.WriteLine("fileStream.Length: " + fileStream.Length.ToString())
Console.WriteLine("chunkSize: " + Me.chunkSize.ToString())
Console.WriteLine("numChunks: " + numChunks.ToString())
For idx = 0 To numChunks - 1
Dim Porc1 As Integer = 0
Dim Porc2 As Integer = 0
Porc1 = CInt((idx / numChunks) * 100)
Porc2 = idx * Me.chunkSize
Console.WriteLine("Posicao: " + idx.ToString() + " / Total: " + numChunks.ToString() + " / Porc1: " + Porc1.ToString() + " / Total Transferido: " + FormatBytes(Porc2) + " / Tamanho Total: " + FormatBytes(fileStream.Length))
Dim byteRead = fileStream.Read(buffer, 0, Me.chunkSize)
Using memStream As MemoryStream = New MemoryStream(buffer, 0, byteRead)
If idx = 0 Then
Console.WriteLine("memStream.Length: " + memStream.Length.ToString())
Console.WriteLine("UploadSessionStartAsync")
Dim result = Await Dbx.Files.UploadSessionStartAsync(False, memStream)
Console.WriteLine(result)
sessionId = result.SessionId
Console.WriteLine("sessionId: " + sessionId)
Else
Dim cursor As UploadSessionCursor = New UploadSessionCursor(sessionId, CULng((Me.chunkSize * idx)))
If idx = numChunks - 1 Then
Console.WriteLine("UploadSessionFinishAsync")
Dim CtrlUp = Await Dbx.Files.UploadSessionFinishAsync(cursor, New CommitInfo(ArquivoDestino), memStream)
If CtrlUp.Id <> "" Then
Me.ArquivoUploadIs = True
End If
Else
Console.WriteLine("UploadSessionAppendV2Async")
Await Dbx.Files.UploadSessionAppendV2Async(cursor, body:=memStream)
End If
End If
End Using
Next
Catch ex As Exception
ShowMsgError(ex)
End Try
End Function
And I call her through the task, using "wait" to wait for the submission to finish before going to the next file:
Upload("C:\Arq1.pdf", "/Arq1.pdf");
Upload("C:\Arq2.pdf", "/Arq2.pdf");
Upload("C:\Arq3.pdf", "/Arq3.pdf");
Upload("C:\Arq4.pdf", "/Arq4.pdf");
However, while the upload is done the application is stuck.
To test put a thread, however, this causes all files in my list to be sent at the same time and I want to send one, wait for it to finish and then send the next one.
Does anyone have any suggestions?
You should avoid using .Wait as it can cause deadlocks.
Public Async Function Upload(ByVal ArquivoOrigem As String, ByVal ArquivoDestino As String) As Task
Try
Dim fileStream As FileStream = New FileStream(ArquivoOrigem, FileMode.Open)
Await Upload_Executar(fileStream, ArquivoDestino))
Catch ex As Exception
End Try
End Function
Await Upload("C:\Arq1.pdf", "/Arq1.pdf");
Await Upload("C:\Arq2.pdf", "/Arq2.pdf");
Await Upload("C:\Arq3.pdf", "/Arq3.pdf");
Await Upload("C:\Arq4.pdf", "/Arq4.pdf");
i can not update a ProgressBar value,i tried also
Convert.ToInt32(Bytes as long).But,it does not worked.
i'm using Progress (of integer).
'Button OnClick
Public Shared s3client As AmazonS3Client
Public Shared myProgress As Progress(Of Integer)
Public Shared Bytes As Double
Public Shared myProgress As Progress(Of Integer)
Public Shared bucketName As String = "S3BucketName"
Private Async Sub Button1_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim AllowedFiles As List(Of String) = New List(Of String)
Try
Dim TheSize As Long
Dim TotalSize As Long
For Each file In AllowedFiles
TheSize = Long.Parse((My.Computer.FileSystem.GetFileInfo(file).Length))
TotalSize += TheSize
Next
Select Case TotalSize
Case Is >= 1099511627776
Bytes = CDbl(TotalSize / 1099511627776) 'TB
Case 1073741824 To 1099511627775
Bytes = CDbl(TotalSize / 1073741824) 'GB
Case 1048576 To 1073741823
Bytes = CDbl(TotalSize / 1048576) 'MB
Case 1024 To 1048575
Bytes = CDbl(TotalSize / 1024) 'KB
Case 0 To 1023
Bytes = TotalSize ' bytes
Case Else
Bytes = 0
'Return ""
End Select
ProgForm2.CPBar1.Value = 0
ProgForm2.CPBar1.Minimum = 0
ProgForm2.CPBar1.Maximum = Convert.ToInt32(Bytes)
Dim result As DialogResult = MessageBox.Show("Selected " & TotalFiles & " files have " & CalculateSize.ToString & "" & SizeType, "in total Size", MessageBoxButtons.OKCancel, MessageBoxIcon.Information)
If result = DialogResult.OK And TextBox1.Text IsNot "" = True Then
myProgress = New Progress(Of Integer)(AddressOf ReportProgress)
Foldername=Textbox1.Text
For Each file In AllowedFiles
Try
ProgForm2.Show()
Await AddFileToRootFolderAsync(file, bucketName, Foldername, myProgress)
TheSize = Long.Parse(My.Computer.FileSystem.GetFileInfo(file).Length)
Catch ex As Exception
MessageBox.Show(ex.Message)
End Try
ProgForm2.CPBar1.Text = ProgForm2.CPBar1.Value.ToString + "/" + Form2.CPBar1.Maximum.ToString
Next
ProgForm2.CPBar1.Value = ProgForm2.CPBar1.Maximum
If ProgForm2.CPBar1.Value = ProgForm2.CPBar1.Maximum Then
ProgForm2.CPBar1.Text = "Task Completed"
ProgForm2.Button1.Show()
End If
Else
Exit Sub
End if
End Sub
'file uploading function
Public Async Function AddFileToFolderAsync(FileName As String, bucketName As String, folderName As String, ByVal myProgress As IProgress(Of Integer)) As Task
Try
If AmazonS3Util.DoesS3BucketExistV2(s3client, bucketName) Then
Dim Checkresult = FolderCheck(bucketName, folderName) /'Folder Exist or Not
If Checkresult = True Then
Dim keyname As String = "" 'destination path(s3 bucket folder)
Dim filepath As String = FileName 'current file's local fullpath
Dim fname As String = Path.GetFileName(FileName) 'filename
If Not folderName.EndsWith("/") Then
keyname += folderName & "/"
keyname += fname 'bucket's target folder /fname (eg:folder/subfolder/file.mp4)
Else
keyname += fname 'bucket's target folder /fname (eg:folder/subfolder/file.mp4)
End If
Dim fileTransferUtility = New TransferUtility(s3client)
Dim fileTransferUtilityRequest = New TransferUtilityUploadRequest With {
.BucketName = bucketName,
.FilePath = filepath,
.StorageClass = S3StorageClass.Standard,
.ServerSideEncryptionMethod = ServerSideEncryptionMethod.None,
.PartSize = 6291456,
.Key = keyname,
.ContentType = "*.*"}
AddHandler fileTransferUtilityRequest.UploadProgressEvent,
Sub(sender As Object, e As UploadProgressArgs)
Dim percent As Integer = Convert.ToInt32(e.TransferredBytes) //e.TransferredBytes as long
myProgress.Report(percent)
End Sub
Await fileTransferUtility.UploadAsync(fileTransferUtilityRequest)
Else
MessageBox.Show(folderName + " folder does not exist")
End If
Else
MessageBox.Show(bucketName + " Bucket does not exist")
End If
Catch ex As AmazonS3Exception
MessageBox.Show(ex.Message + " Upload task canceled.")
Catch ex As Exception
MessageBox.Show(ex.Message + " Upload task canceled.")
End Try
End Function
Public Sub ReportProgress(ByVal myInt As Integer)
Form2.CPBar1.Value += myInt
Form2.CPBar1.Text = Form2.CPBar1.Value.ToString + "/" + Form2.CPBar1.Maximum.ToString
End Sub
i am stucked into this,can't know what i missed.I want to progress Bytes which is transferred to target folder in my progressbar.for example, the file size is 1gb(1073741824 bytes) then how can i set Progressbar maximum value=1073741824 and progressbar value + =transferredbytes.
It seems that when you want to calculate the Maximum value, you've token into account the value of the TotalSize through the Select-Case mechanism and hence, scaled it based on its range. But in the ReportProgress, the myInt input integer is directly added to the progressbar value. I think your Select-Case should be implemented in the ReportProgress as well.
Edit 1:
Let's assume that TotalSize = 109951162777. Right? Hence, Byte = 1 and the progressbar's maximum value is equal to 1 (i.e., 1 TB). Then, in the ReportProgress function you must first divide myInt (which is in bytes) by 109951162777 to make it a TB value (e.g., 0.5 TB) and then update the progressbar's value. If you do not do so, myInt will exceed the int32 limit and errors occur. Am I right?
Therefore, you have to know that which case is selected in the Select-Case statement and the TotalSize is divided by which number? I recommend to modify the Button1_Click function as:
Dim divider as long
Private Async Sub Button1_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim AllowedFiles As List(Of String) = New List(Of String)
Try
Dim TheSize As Long
Dim TotalSize As Long
For Each file In AllowedFiles
TheSize = Long.Parse((My.Computer.FileSystem.GetFileInfo(file).Length))
TotalSize += TheSize
Next
Select Case TotalSize
Case Is >= 1099511627776
divider = 1099511627776 'TB
Case 1073741824 To 1099511627775
divider = 1073741824 'GB
Case 1048576 To 1073741823
divider = 1048576 'MB
Case 1024 To 1048575
divider = 1024 'KB
Case 0 To 1023
divider = 1 ' bytes
Case Else
Bytes = 0
divider = 1
'Return ""
End Select
Bytes = CDbl(TotalSize / divider) 'always between 0 and 1
ProgForm2.CPBar1.Value = 0
ProgForm2.CPBar1.Minimum = 0
ProgForm2.CPBar1.Maximum = Convert.ToInt32(Bytes)
Dim result As DialogResult = MessageBox.Show("Selected " & TotalFiles & " files have " & CalculateSize.ToString & "" & SizeType, "in total Size", MessageBoxButtons.OKCancel, MessageBoxIcon.Information)
If result = DialogResult.OK And TextBox1.Text IsNot "" = True Then
myProgress = New Progress(Of Integer)(AddressOf ReportProgress)
Foldername=Textbox1.Text
For Each file In AllowedFiles
Try
ProgForm2.Show()
Await AddFileToRootFolderAsync(file, bucketName, Foldername, myProgress)
TheSize = Long.Parse(My.Computer.FileSystem.GetFileInfo(file).Length)
Catch ex As Exception
MessageBox.Show(ex.Message)
End Try
ProgForm2.CPBar1.Text = ProgForm2.CPBar1.Value.ToString + "/" + Form2.CPBar1.Maximum.ToString
Next
ProgForm2.CPBar1.Value = ProgForm2.CPBar1.Maximum
If ProgForm2.CPBar1.Value = ProgForm2.CPBar1.Maximum Then
ProgForm2.CPBar1.Text = "Task Completed"
ProgForm2.Button1.Show()
End If
Else
Exit Sub
End if
End Sub
and the ReportProgress as follows:
Form2.CPBar1.Value += myInt / divider ‘to normalize myInt to [0,1]
Form2.CPBar1.Text = Form2.CPBar1.Value.ToString + "/" + Form2.CPBar1.Maximum.ToString
Hope this solves the problem.
I have been making a game for my games development class but due to the limitations in college we have to create a game using Visual Basic and no plugins, so I only have GDI+ to work with.
I have run into an error where it will run out of memory and the game stops running, the error is at line 312 - "_backBufferGr.DrawImage(_backbuffer, 0, 0, _resWidth, _resHeight)"
I think it may be due to the images that are being spawned aren't being cleared but I'm not sure as I have only been coding for about 3 months. If anyone can help that would be very appreciated. I have attached the code below - the classes are in separate files in my project.
Here is an image of my error:
https://imgur.com/WEAwSb4
and as text:
System.OutOfMemory: Out of memory.
at System.Drawing.Graphics.CheckErrorStatus(Int32 Status)
at System.Drawing.Graphics.DrawImage(Image image, Int32 x, Int32 y, Int32 Width, Int32 height)
at SpaceInvaders.Spaceinvaders.DrawGraphics()
Imports System.Drawing.Imaging
Imports System.IO
Public Class Spaceinvaders
'Star Generation Variables
ReadOnly _random As New Random
Private ReadOnly _r As New Random
Private ReadOnly _stars As New List(Of Point)
'Sound Variabless
Public Shared Intsound As Integer = 0
Public Shared Snd As New Sounds
'Graphics varibles
Dim _backbuffer As Bitmap
Dim _backBufferGr As Graphics
Public Shared Gr As Graphics
Shared _sourceRec As Rectangle
'View Port Variables
Dim _resWidth As Int16 = 700
Dim _resHeight As Int16 = 650
Dim _paused As Boolean = False
Dim _pauseNum As Int16 = 0
Dim _pausedText As Int16 = 40
Dim _mouseX, _mouseY As Int16
'Key Detection
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Int16) As Int16
Public Function GetKeyState(ByVal key1 As Int16) As Boolean
Dim s As Int16
s = GetAsyncKeyState(key1)
If s = 0 Then Return False
Return True
End Function
'Character Variables
Dim _bmpPlayer As Bitmap
Public Shared PlayerW, PlayerH As Int16
Public Shared XPos As Int16 = 0
Public Shared YPos As Int16 = 0
Dim _movementSpeed As Int16 = 8
Dim _moveDir As Int16 = 0
Dim _lastDir As Int16 = 0
'Fire Variables
Dim _fire As Boolean
Dim _bulletArray(100000) As Bullet
Dim _bulletNum As Int16 = 0
Dim _cooldown As Int16
Public Shared Points As Int32 = 0
Public Shared EnemiesKilled As Int16 = 0
Public Shared ExploArray(100000) As Explo
Public Shared ExploNum As Int16 = 0
'Enemy Variables
Dim _spawnNum As Int16
Public Shared EnemyArray(100000) As Enemies
Public Shared EnemyNum As Int16 = 0
Public Shared Lives As Int16 = 3
Dim SpawnSpd As Int16 = 30
'Other Variables
Dim _isRunning As Boolean = True
Public Shared CollitionDetc As New StreamWriter(Application.StartupPath() & "\" & "Detection" & ".Log")
Public Function FadeInImage(ByVal bmp As Bitmap, ByVal opacity As Single) As Bitmap
Dim bmp2 As New Bitmap(bmp.Width, bmp.Height, PixelFormat.Format32bppArgb)
opacity = Math.Max(0, Math.Min(opacity, 1.0F))
Using ia As New ImageAttributes
Dim cm As New ColorMatrix
cm.Matrix33 = opacity
ia.SetColorMatrix(cm)
Dim destpoints() As PointF = {New Point(0, 0), New Point(bmp.Width, 0), New Point(0, bmp.Height)}
Using g As Graphics = Graphics.FromImage(bmp2)
g.DrawImage(bmp, destpoints, New RectangleF(Point.Empty, bmp.Size), GraphicsUnit.Pixel, ia)
End Using
End Using
Return bmp2
End Function
'Form Events
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Show()
Focus()
'Create Stars - 300 is the Number of Stars
CreateStarField(300)
'Start Music
Intsound += 1
With Snd
.Name = "Sound" & Intsound
.PlaySound(1, True)
End With
'This creates the graphics and the backbuffer, along with drawing the player to the screen
Gr = CreateGraphics()
_backbuffer = New Bitmap(_resWidth, _resHeight)
_bmpPlayer = New Bitmap(My.Resources.Ship)
XPos = (Width / 2)
YPos = 500
Gr.DrawImage(_bmpPlayer, XPos, YPos, _sourceRec, GraphicsUnit.Pixel)
StartGameLoop()
End Sub
Private Sub Spaceinvaders_FormClosing(sender As Object, e As FormClosingEventArgs) Handles MyBase.FormClosing
Do Until Intsound = 0
Snd.Kill("Sound" & Intsound)
Intsound -= 1
Loop
Dispose()
End
End Sub
Private Sub Spaceinvaders_MouseMove(sender As Object, e As MouseEventArgs) Handles MyBase.MouseMove
_mouseX = e.X
_mouseY = e.Y
End Sub
Private Sub Spaceinvaders_MouseDown(sender As Object, e As MouseEventArgs) Handles MyBase.MouseDown
If (290 + 110 < _mouseX Or _mouseX < 290 Or 336 + 63 < _mouseY Or _mouseY < 336) Then
Else
_paused = False
End If
End Sub
'Starfield Background Generation
Private Sub CreateStarField(numStars As Integer)
_stars.Clear()
For i = 1 To numStars
_stars.Add(New Point(_r.Next(0, Width), _r.Next(0, Height)))
Next
End Sub
'Runs the actual game over and over again until it is stopped
Sub StartGameLoop()
Do While _isRunning = True
Application.DoEvents()
LivesCheck()
SetMoveDir()
MovePlayer(_moveDir)
'Start the drawing events & FPS Counter
DrawGraphics()
Loop
Do While _isRunning = False
Application.DoEvents()
Loop
End Sub
'Subs to do with player creation and movement
Private Sub GetPlayer(ByVal dir As Int16)
Select Case dir
Case 1 'Upfacing Direction
_bmpPlayer = New Bitmap(My.Resources.Ship)
_sourceRec = New Rectangle(0, 0, 85, 50)
PlayerH = 50
PlayerW = 85
Case 2 'Downfacing Direction
_bmpPlayer = New Bitmap(My.Resources.Ship)
_sourceRec = New Rectangle(0, 0, 85, 50)
PlayerH = 50
PlayerW = 85
Case 3 'Left Facing Direction
_bmpPlayer = New Bitmap(My.Resources.ShipLeft)
_sourceRec = New Rectangle(0, 0, 96, 76)
PlayerH = 76
PlayerW = 96
Case 4 'Right Facing Direction
_bmpPlayer = New Bitmap(My.Resources.ShipRight)
_sourceRec = New Rectangle(0, 0, 96, 76)
PlayerH = 76
PlayerW = 96
End Select
End Sub
Sub SetMoveDir()
If GetKeyState(Keys.W) = True Then _moveDir = 1
If GetKeyState(Keys.A) = True Then _moveDir = 3
If GetKeyState(Keys.S) = True Then _moveDir = 2
If GetKeyState(Keys.D) = True Then _moveDir = 4
If GetKeyState(Keys.Space) = True Then _fire = True
If GetKeyState(Keys.P) = True Then
If _pauseNum = 0 Then
_paused = True
_pauseNum = 1
ElseIf _pauseNum = 1 Then
_paused = False
_pauseNum = 0
End If
End If
If GetKeyState(Keys.W) = False And
GetKeyState(Keys.A) = False And
GetKeyState(Keys.S) = False And
GetKeyState(Keys.D) = False Then
_moveDir = 0
End If
If _moveDir <> 0 Then _lastDir = _moveDir
End Sub
Private Sub MovePlayer(ByVal dir As Int16)
Select Case dir
Case 1
If YPos <= 0 Then
Else
YPos -= _movementSpeed
End If
Case 2
If YPos >= 544 Then
Else
YPos += _movementSpeed
End If
Case 3
If XPos <= -2 Then
Else
XPos -= _movementSpeed
End If
Case 4
If XPos >= 606 Then
Else
XPos += _movementSpeed
End If
End Select
End Sub
'Draw the stuff to the screen
Sub DrawGraphics()
If _paused = True Then
Gr.DrawString("Paused", New Font("Verdana", _pausedText), New SolidBrush(Color.White), New Point(235, 256))
If (290 + 110 < _mouseX Or _mouseX < 290 Or 336 + 63 < _mouseY Or _mouseY < 336) Then
Gr.DrawString("Play", New Font("Verdana", 25), New SolidBrush(Color.White), New Point(290, 336))
Else
Gr.DrawString("Play", New Font("Verdana", 25), New SolidBrush(Color.Red), New Point(290, 336))
End If
'Copy BackBuffer To Graphics Object
Gr = Graphics.FromImage(_backbuffer)
'Draw BackBuffer to the screen
Try
_backBufferGr = CreateGraphics()
_backBufferGr.DrawImage(_backbuffer, 0, 0, _resWidth, _resHeight)
Catch ex As Exception
MsgBox(ex)
_isRunning = False
Exit Sub
End Try
Gr.Clear(Color.Black)
'Runs when the game is unpaused
ElseIf _paused = False Then
Gr.Clear(Color.Black)
'Draws Stars to the screen
DrawStars()
'Draws Enemies to the screen
EnemyDraw()
'Draws bullets to the screen
BulletDraw()
'Draws Explosions
Expslostion()
'Draw the player
DrawPlayer()
'Draws lives to the screen
DrawHUD()
'Copy BackBuffer To Graphics Object
Gr = Graphics.FromImage(_backbuffer)
'Draw BackBuffer to the screen
Try
_backBufferGr = CreateGraphics()
_backBufferGr.DrawImage(_backbuffer, 0, 0, _resWidth, _resHeight)
Catch ex As Exception
MsgBox("ERROR: " & vbCrLf & ex.ToString)
_isRunning = False
Exit Sub
End Try
Gr.Clear(Color.Black)
GC.Collect()
_fire = False
WriteLog()
End If
End Sub
Sub BulletDraw()
If _bulletNum = 0 Then
_bulletNum = 0
Else
For i = 1 To _bulletNum
_bulletArray(i).Move(i)
Next
End If
If _cooldown < 2 Then
_cooldown += 1
Else : If _fire = True Then
_bulletNum += 1
_bulletArray(_bulletNum) = New Bullet
_bulletArray(_bulletNum).Spawn(_bulletNum, 4)
_cooldown = 0
End If : End If
End Sub
Sub EnemyDraw()
If EnemyNum = 0 Then
EnemyNum = 0
Else
For i = 1 To EnemyNum
EnemyArray(i).Move()
Next
End If
If _spawnNum < SpawnSpd Then
_spawnNum += 1
Else
Points += 5
EnemyNum += 1
EnemyArray(EnemyNum) = New Enemies
EnemyArray(EnemyNum).Spawn()
_spawnNum = 0
End If
End Sub
Sub Expslostion()
If ExploNum = 0 Then
ExploNum = 0
Else
For i = 1 To ExploNum
ExploArray(i).Animation()
Next
End If
End Sub
Sub DrawStars()
For Each pt As Point In _stars 'Loops until all the stars are added to the form background
Dim num = _random.Next(1, 6) 'Randomly Picks a number
Dim numSize = _random.Next(1, 3)
If num = 1 Then 'Picks a colour based on the number picked
Gr.FillEllipse(Brushes.White, New Rectangle(pt, New Size(numSize, numSize)))
ElseIf num = 2 Then
Gr.FillEllipse(Brushes.Blue, New Rectangle(pt, New Size(numSize, numSize)))
ElseIf num = 3 Then
Gr.FillEllipse(Brushes.DimGray, New Rectangle(pt, New Size(numSize, numSize)))
ElseIf num = 4 Then
Gr.FillEllipse(Brushes.DarkOrange, New Rectangle(pt, New Size(numSize, numSize)))
ElseIf num = 5 Then
Gr.FillEllipse(Brushes.Red, New Rectangle(pt, New Size(numSize, numSize)))
End If
Next
End Sub
Sub DrawPlayer()
If _moveDir = 0 Then
_bmpPlayer = New Bitmap(My.Resources.Ship)
Else
GetPlayer(_lastDir)
End If
_bmpPlayer.MakeTransparent(Color.Fuchsia)
Gr.DrawImage(_bmpPlayer, XPos, YPos, _sourceRec, GraphicsUnit.Pixel)
End Sub
Sub DrawHUD()
Select Case Lives
Case 3
Gr.FillRectangle(Brushes.Red, 510, 5, 150, 10)
Case 2
Gr.FillRectangle(Brushes.Red, 510, 5, 100, 10)
Case 1
Gr.FillRectangle(Brushes.Red, 510, 5, 50, 10)
End Select
Gr.DrawString("Ships Destroyed: " & EnemiesKilled, New Font("Verdana", 10), New SolidBrush(Color.White), New Point(5, 5))
Gr.DrawString("Score: " & Points, New Font("Verdana", 10), New SolidBrush(Color.White), New Point(5, 20))
End Sub
Sub WriteLog()
Dim sw As New StreamWriter(Application.StartupPath() & "\" & "Variables" & ".Log")
sw.WriteLine("--------Variables Log--------")
sw.WriteLine("")
sw.WriteLine("Sounds Playing: " & Intsound)
sw.WriteLine("")
sw.WriteLine("Window Resolution: " & _resWidth & " " & _resHeight)
sw.WriteLine("Game Running: " & _isRunning)
sw.WriteLine("")
sw.WriteLine("Player Postion: " & XPos & " " & YPos)
sw.WriteLine("Player Size: " & PlayerW & " " & PlayerH)
sw.WriteLine("Player Movement Speed: " & _movementSpeed)
sw.WriteLine("PLayer Last Direction: " & _lastDir)
sw.WriteLine("")
sw.WriteLine("Bullets Being Fired?: " & _fire)
sw.WriteLine("Number Of bullets spawned: " & _bulletNum)
sw.WriteLine("")
sw.WriteLine("Number of enemies spawned: " & EnemyNum)
sw.WriteLine()
sw.WriteLine("--------Bullet Variables--------")
sw.WriteLine("Bullet Number X Y")
For i = 1 To _bulletNum
sw.WriteLine(i & " " & _bulletArray(i).X & " " & _bulletArray(i).Y)
Next
sw.WriteLine("--------Enemy Variables--------")
sw.WriteLine("Enemy Number X Y")
For i = 1 To EnemyNum
sw.WriteLine(i & " " & EnemyArray(i).X & " " & EnemyArray(i).Y)
Next
sw.Close()
sw.Dispose()
End Sub
Sub LivesCheck()
If Lives = 0 Then
_isRunning = False
Gameover.Show()
End If
End Sub
End Class
Public Class Bullet
Dim _bulletX, _bulletY As Int16
Dim _bmpBullet As Bitmap = My.Resources.bullet1
Dim _bulletRec As New Rectangle
Dim _bulletSpd As Int16 = 4
Dim _enemyNum As Int16
Dim _active As Boolean = True
Function X()
Return _bulletX
End Function
Function Y()
Return _bulletY
End Function
Sub Spawn(ByVal i As Int16, ByVal s As Int16)
Spaceinvaders.Intsound += 1
With Spaceinvaders.Snd
.Name = "Sound" & Spaceinvaders.Intsound
.PlaySound(2, False)
End With
_bulletSpd = s
_bulletX = Spaceinvaders.XPos + (Spaceinvaders.PlayerW / 2)
_bulletY = Spaceinvaders.YPos + (Spaceinvaders.PlayerH / 2)
_bmpBullet = My.Resources.bullet1
_bmpBullet.MakeTransparent(Color.Fuchsia)
Spaceinvaders.Gr.DrawImage(_bmpBullet, _bulletX, _bulletY, _bulletRec, GraphicsUnit.Pixel)
End Sub
Sub Move(ByVal bulletNum As Int16)
If _active = False Then
Me.Finalize()
Else
_enemyNum = Spaceinvaders.EnemyNum
For i = 1 To _enemyNum
Dim EnemyRect As Rectangle
EnemyRect = Spaceinvaders.EnemyArray(i).Rectangle
If (_bulletRec.IntersectsWith(EnemyRect)) Then
If Spaceinvaders.EnemyArray(i).Invc >= 40 Then
Spaceinvaders.EnemyArray(i).Kill(-10, -10)
_active = False
Spaceinvaders.Points += 500
Spaceinvaders.CollitionDetc.WriteLine("Enemy Num: " & i & " & " & "Bullet Num: " & bulletNum & " - HIT")
_bulletX = -100
_bulletY = -100
_bulletRec = New Rectangle(-100, 100, 1, 1)
Spaceinvaders.Intsound += 1
With Spaceinvaders.Snd
.Name = "Sound" & Spaceinvaders.Intsound
.PlaySound(3, False)
End With
Dim enemyX, enemyY As Int16
enemyX = Spaceinvaders.EnemyArray(i).X
enemyY = Spaceinvaders.EnemyArray(i).Y
Spaceinvaders.ExploNum += 1
Spaceinvaders.ExploArray(Spaceinvaders.ExploNum) = New Explo()
Spaceinvaders.ExploArray(Spaceinvaders.ExploNum).Spawn(enemyX, enemyY)
Me.Finalize()
End If
End If
Next
If _bulletY <= 0 Then
_bulletX = -100
_bulletY = -100
Else
_bulletY -= _bulletSpd
_bmpBullet.MakeTransparent(Color.Fuchsia)
Spaceinvaders.Gr.DrawImage(_bmpBullet, _bulletX, _bulletY)
_bulletRec = New Rectangle(_bulletX, _bulletY, 16, 16)
End If
End If
End Sub
End Class
Public Class Enemies
Dim _enemyX, _enemyY As Int16
Dim _bmpEnemy As Bitmap = My.Resources.InvaderSkullWhite
Dim _moveNum As Int16 = 0
Dim _active As Boolean = True
Dim _tempInvc As Int16 = 0
Dim EnemyRect As Rectangle
Function X()
Return _enemyX
End Function
Function Y()
Return _enemyY
End Function
Function Kill(ByVal x, ByVal y)
_enemyX = x
_enemyY = y
_active = False
EnemyRect = New Rectangle(x, y, 1, 1)
Me.Finalize()
End Function
Function Invc()
Return _tempInvc
End Function
Function Rectangle()
Return EnemyRect
End Function
Sub Spawn()
Dim rand As New Random
_enemyY = 3
_enemyX = rand.Next(10, 600)
Select Case rand.Next(1, 5)
Case 1
_bmpEnemy = My.Resources.InvaderSkullWhite
Case 2
_bmpEnemy = My.Resources.InvaderSkullRed
Case 3
_bmpEnemy = My.Resources.InvaderSkullGreen
Case 4
_bmpEnemy = My.Resources.InvaderSkullYellow
End Select
_bmpEnemy.MakeTransparent(Color.Fuchsia)
Spaceinvaders.Gr.DrawImage(_bmpEnemy, _enemyX, _enemyY)
Move()
End Sub
Sub Move()
If _active = False Then
Me.Finalize()
Else
If _tempInvc < 40 Then
_tempInvc += 1
End If
If _moveNum < 10 Then
_moveNum += 1
_bmpEnemy.MakeTransparent(Color.Fuchsia)
Spaceinvaders.Gr.DrawImage(_bmpEnemy, _enemyX, _enemyY)
Else
If _enemyY >= 700 Then
Spaceinvaders.Lives -= 1
_enemyX = -5
_enemyY = -5
Else
Dim randX As New Random
_enemyY += 5
Select Case _enemyX
Case _enemyX <= 5
_enemyX = _enemyX + randX.Next(1, 4)
Case _enemyX >= 600
_enemyX = _enemyX + randX.Next(-4, -1)
Case Else
_enemyX = _enemyX + randX.Next(-4, 4)
End Select
_bmpEnemy.MakeTransparent(Color.Fuchsia)
Spaceinvaders.Gr.DrawImage(_bmpEnemy, _enemyX, _enemyY)
EnemyRect = New Rectangle(_enemyX, _enemyY, 64, 64)
End If
_moveNum = 0
End If
End If
End Sub
End Class
Public Class Sounds
Public Declare Function MciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
Dim _appPath As String = Application.StartupPath()
Private _oName As String = Nothing
Public Property Name As String
Set(value As String)
_oName = value
End Set
Get
Return _oName
End Get
End Property
Public Sub PlaySound(ByVal id As Integer, ByVal repeat As Boolean, Optional vol As Integer = 35)
If repeat = True Then
MciSendString("Open " & GetFile(id) & " alias " & _oName, 0, 0, 0)
MciSendString("Play " & _oName & " repeat", CStr(0), 0, 0)
Else
MciSendString("Open " & GetFile(id) & " alias " & _oName, CStr(0), 0, 0)
MciSendString("Play " & _oName, CStr(0), 0, 0)
End If
'Set Vol
MciSendString("Open " & GetFile(id) & " alias " & _oName, CStr(0), 0, 0)
MciSendString("setaudio " & _oName & " volume to " & vol, CStr(0), 0, 0)
End Sub
Private Function GetFile(ByVal id As Integer) As String
Dim path As String = ""
'Here is where you put the sound paths so that your game can play sounds
Select Case id
Case 0 'Menu Background Music
path = _appPath & "\Audio\Menu.mp3"
Case 1 'Ingame Background Music
path = _appPath & "\Audio\InGame.mp3"
Case 2 'Fire Spund
path = _appPath & "\Audio\Lazer.mp3"
Case 3 'Expolsion sound
path = _appPath & "\Audio\Expolsion.mp3"
End Select
path = Chr(34) & path & Chr(34)
Return path
End Function
Public Sub Kill(ByVal song As String)
MciSendString("close " & song, CStr(0), 0, 0)
_oName = Nothing
End Sub
End Class
Whenever you're done with an object that implements IDisposable in almost all cases you should probably call it (there are exceptions outside the scope of this answer). For note, A "using" statement always calls Dispose when it's done (so you're Graphics calls that are using a using are good on that front).
Where I see potential problems are the places you're using a class wide variable and resetting new Bitmap's onto it (I don't think the old one's get disposed and as a result I think they're hanging out there and slowly eating up your memory).
_bmpPlayer = New Bitmap(My.Resources.Ship)
See if something like this helps:
If _bmpPlayer IsNot Nothing Then
_bmpPlayer.Dispose()
End If
_bmpPlayer = new Bitmap(My.Resources.Ship)
That said, if you're using these same images over and over I would probably store them and re-use them as opposed to re-writing a new Bitmap from the resource every time.
Thanks to everyone trying to help me fix the problem. I fixed the out of memory error by changing this bit of code:
If _bulletNum = 0 Then
_bulletNum = 0
Else
For i = 1 To _bulletNum
_bulletArray(i).Move(i)
Next
End If
To this:
If _bulletNum = 0 Then
_bulletNum = 0
Else
Dim skipbullet As Int16
skipbullet = _bulletNum - 50
If skipbullet >= 1 Then
For i = skipbullet To _bulletNum
_bulletArray(i).Move(i)
Next
For i = 1 To skipbullet
_bulletArray(i).Kill()
Next
Else
For i = 1 To _bulletNum
_bulletArray(i).Move(i)
Next
End If
End If
I have a problem when I connect to the server from the client, it connects without any issues, but when I close the client window, the server shows the following error message:
The length can not be less than zero. Parameter name: length
And then when I try to reconnect the client it crashes too
This is the server source code:
serverSocket.Start()
AddInfo("Server Started", ConsoleColor.Cyan)
AddInfo("---------------- ACCOUNTS ----------------", ConsoleColor.Blue)
Dim AN As Integer = 0
For Each f In Directory.GetFiles("saved\accounts\")
Dim acc As String = Path.GetFileNameWithoutExtension(f).Split(CChar("%"))(0)
Dim pass As String = Path.GetFileNameWithoutExtension(f).Split(CChar("%"))(1)
AddInfo(acc & " - " & pass, ConsoleColor.Magenta)
AN += 1
Next
AddInfo(AN & " Accounts exists .", ConsoleColor.DarkCyan)
AddInfo("-----------------------------------------------", ConsoleColor.Blue)
clientSocket = serverSocket.AcceptTcpClient()
AddInfo("New Client Connected", ConsoleColor.Yellow)
clients_number += 1
AddInfo("Clients Num : " & clients_number, ConsoleColor.DarkYellow)
requestCount = 0
While (True)
'RECEIVING
requestCount = requestCount + 1
serverStream = clientSocket.GetStream()
Dim bytesFrom(10024) As Byte
serverStream.Read(bytesFrom, 0, CInt(clientSocket.ReceiveBufferSize))
Dim dataFromClient As String = System.Text.Encoding.ASCII.GetString(bytesFrom)
dataFromClient = dataFromClient.Substring(0, dataFromClient.IndexOf("$"))
AddInfo("Data from client - " + dataFromClient, ConsoleColor.DarkYellow)
'### CHEKING ACCOUNT ###
For Each f In Directory.GetFiles("saved\accounts\")
If dataFromClient = Path.GetFileNameWithoutExtension(f) Then
account_avaible = True
End If
Next
If account_avaible = True Then
Dim serverResponse As String = ""
Dim l As New List(Of String)
l.AddRange(File.ReadAllLines("saved\accounts\" & dataFromClient & ".inf"))
For i = 0 To l.Count - 1
serverResponse += l.Item(i).ToString.Split(CChar("="))(1) & "|"
Next
Dim sendBytes As [Byte]() = Encoding.ASCII.GetBytes(serverResponse)
serverStream.Write(sendBytes, 0, sendBytes.Length)
serverStream.Flush()
AddInfo(serverResponse, ConsoleColor.Green)
Else
Dim serverResponse As String = "connection_false"
Dim sendBytes As [Byte]() = Encoding.ASCII.GetBytes(serverResponse)
serverStream.Write(sendBytes, 0, sendBytes.Length)
serverStream.Flush()
AddInfo(serverResponse, ConsoleColor.Green)
account_avaible = False
End If
End While
I've fixed this problem . thanks #WDS .
i deleted the loop and i made a return to the clientSocket = serverSocket.AcceptTcpClient()
this is the source :
`serverSocket.Start() : AddInfo("Server Started", ConsoleColor.Cyan)
AddInfo("---------------- ACCOUNTS ----------------", ConsoleColor.Blue)
Dim AN As Integer = 0
For Each f In Directory.GetFiles("saved\accounts\")
Dim acc As String = Path.GetFileNameWithoutExtension(f).Split(CChar("%"))(0)
Dim pass As String = Path.GetFileNameWithoutExtension(f).Split(CChar("%"))(1)
AddInfo(acc & " - " & pass, ConsoleColor.Magenta)
AN += 1
Next
AddInfo(AN & " Accounts exists .", ConsoleColor.DarkCyan)
AddInfo("-----------------------------------------------", ConsoleColor.Blue)
Dodo:
account_avaible = False
clientSocket = serverSocket.AcceptTcpClient()
AddInfo("New Client Connected", ConsoleColor.Yellow)
clients_number += 1
AddInfo("Clients Num : " & clients_number, ConsoleColor.DarkYellow)
requestCount = 0
'RECEIVING
requestCount = requestCount + 1
serverStream = clientSocket.GetStream()
Dim bytesFrom(10024) As Byte
serverStream.Read(bytesFrom, 0, clientSocket.ReceiveBufferSize)
Dim dataFromClient As String = System.Text.Encoding.ASCII.GetString(bytesFrom)
dataFromClient = dataFromClient.Substring(0, dataFromClient.IndexOf("$"))
AddInfo("Data from client - " + dataFromClient, ConsoleColor.DarkYellow)
'### CHEKING ACCOUNT ###
For Each f In Directory.GetFiles("saved\accounts\")
If dataFromClient = Path.GetFileNameWithoutExtension(f) Then
account_avaible = True
End If
Next
If account_avaible = True Then
Dim serverResponse As String = ""
Dim l As New List(Of String)
l.AddRange(File.ReadAllLines("saved\accounts\" & dataFromClient & ".inf"))
For i = 0 To l.Count - 1
serverResponse += l.Item(i).ToString.Split(CChar("="))(1) & "|"
Next
Dim sendBytes As [Byte]() = Encoding.ASCII.GetBytes(serverResponse)
serverStream.Write(sendBytes, 0, sendBytes.Length)
serverStream.Flush()
AddInfo(serverResponse, ConsoleColor.Green)
Else
Dim serverResponse As String = "connection_false"
Dim sendBytes As [Byte]() = Encoding.ASCII.GetBytes(serverResponse)
serverStream.Write(sendBytes, 0, sendBytes.Length)
serverStream.Flush()
AddInfo(serverResponse, ConsoleColor.Green)
account_avaible = False
End If
GoTo Dodo
'clientSocket.Close()
'serverSocket.Stop()`
But now i have new problem =/ when i enter an incorrect account msg show ("Incorrect account") and then when i try to enter an other account the client bugg (freeze)