Related
I have a query in the SqlServer database, the result of that query is played inside a Datagridview, the result can contain from 0 to 100 data or even more if you doubt it.
I'm trying to print the "Identification" column of Datagridview horizontally, but without success. I have researched in several places and nothing too.
screenshot of form with DataGridView
Follow the form code:
Imports System.ComponentModel
Imports System.Data.SqlClient
Imports System.Drawing.Printing
Public Class frm_relatorio_entregas
' Variables used in the module
Dim RelatorioTitulo As String ' Report title
Dim paginaatual As Integer ' Page number being printed
Dim LinhaAtual As Integer ' Current line number being printed
Dim LinhasporPagina As Integer ' Number of lines per page
Dim PosicaoDaLinha As Single ' Position of the line being printed
Dim registro As Integer ' Record being printed
Private Sub Imprimir()
RelatorioTitulo = "Delivery Report"
Dim doc As PrintDocument = New PrintDocument
AddHandler doc.PrintPage, New Printing.PrintPageEventHandler(AddressOf Me.pdRelatorios_Printpage)
AddHandler doc.BeginPrint, New Printing.PrintEventHandler(AddressOf Me.Begin_Print)
Dim dialogo As PrintDialog = New PrintDialog
'dialogo.Document = doc
' If (dialogo.ShowDialog = DialogResult.OK) Then
Dim preview As PrintPreviewDialog = New PrintPreviewDialog()
preview.Document = doc
preview.WindowState = FormWindowState.Maximized
preview.PrintPreviewControl.Zoom = 1.0
preview.ShowDialog()
'End If
End Sub
Private Sub Begin_Print(ByVal sender As Object, ByVal e As Printing.PrintEventArgs)
' Assigning values to variables at the start of printing
LinhaAtual = 0
paginaatual = 1
PosicaoDaLinha = 0
registro = 0
End Sub
Private Sub pdRelatorios_Printpage(ByVal sender As System.Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs)
' Margin variables (e.MarginBounds obtain the rectangular area that represents the part of the page within the margins.)
Dim MargemEsquerda As Single = e.MarginBounds.Left
Dim MargemDireita As Single = e.MarginBounds.Right
Dim MargemSuperior As Single = e.MarginBounds.Top
Dim MargemInferios As Single = e.MarginBounds.Bottom
'Pen class defines an object used to define lines and curves
Dim CanetaDaImpressora As Pen = New Pen(Color.Black, 1)
'Variables of the fonts used (the font class defines a specific format for text, including font face, size and style attributes.
Dim FonteNegrito As Font
Dim FonteTitulo As Font
Dim FonteSubTitulo As Font
Dim FonteRodape As Font
Dim FonteNormal As Font
Dim font1 As Font
'Define effects on fonts used
FonteNegrito = New Font("Arial", 9, FontStyle.Bold)
FonteTitulo = New Font("Arial", 13, FontStyle.Bold)
FonteSubTitulo = New Font("Arial", 9, FontStyle.Bold)
FonteRodape = New Font("Arial", 8)
FonteNormal = New Font("Calibri", 9)
font1 = New Font("Segoe UI", 8, FontStyle.Bold)
'Print the title of the report
e.Graphics.DrawString(RelatorioTitulo, FonteTitulo, Brushes.Black, MargemEsquerda + 200, 30, New StringFormat)
If DateTimePicker1.Value = DateTimePicker1.Value Then
e.Graphics.DrawString(DateTimePicker1.Value, FonteSubTitulo, Brushes.Black, MargemEsquerda + 900, 30, New StringFormat)
Else
e.Graphics.DrawString(DateTimePicker1.Value & " - " & DateTimePicker1.Value, FonteSubTitulo, Brushes.Black, MargemEsquerda + 900, 30, New StringFormat)
End If
'Define the number of lines per page
LinhasporPagina = CInt(e.MarginBounds.Height / New Font("Calibri", 18).GetHeight(e.Graphics) - 2)
While (LinhaAtual <= LinhasporPagina AndAlso registro <= DataGridView1.Rows.Count - 1)
PosicaoDaLinha = MargemSuperior + (LinhaAtual * New Font("Calibri", 18).GetHeight(e.Graphics) + 30)
e.Graphics.DrawString(DataGridView1.Rows(registro).Cells(0).Value.ToString, New Font("Calibri", 8, FontStyle.Bold), Brushes.Black, 30, PosicaoDaLinha, New StringFormat())
'Increment record
registro += 1
'increment line
LinhaAtual += 1
End While
'baseboard
e.Graphics.DrawLine(CanetaDaImpressora, 20, MargemInferios + 15, 1150, MargemInferios + 15)
e.Graphics.DrawString(System.DateTime.Now.ToString(), FonteRodape, Brushes.Black, 30, MargemInferios + 15, New StringFormat())
e.Graphics.DrawString("Página : " & paginaatual, FonteRodape, Brushes.Black, 1070, MargemInferios + 15, New StringFormat)
'Increase the page number
paginaatual += 1
'Here check if you are going to open a new page
If (LinhaAtual > LinhasporPagina) Then
' When you open a new page, you have to reset LlinhaAtual
e.HasMorePages = True
LinhaAtual = 0
Else
e.HasMorePages = False
End If
End Sub
Private Sub frm_relatorio_entregas_Load(sender As Object, e As EventArgs) Handles MyBase.Load
txtcod.Clear()
txtrazao.Clear()
TextBox1.Clear()
TextBox2.Clear()
TextBox3.Clear()
DateTimePicker1.ResetText()
DateTimePicker2.ResetText()
ComboBox1.SelectedIndex = 0
txtcod.Select()
End Sub
Private Sub txtcod_KeyUp(sender As Object, e As KeyEventArgs) Handles txtcod.KeyUp
If e.KeyCode = Keys.F2 Then
frm_consulta_cliente_cadastro.ShowDialog()
End If
End Sub
Private Sub consulta()
DataGridView1.Rows.Clear()
Cursor.Current = Cursors.WaitCursor
Dim consultando As New frm_aguarde_consultando
consultando.Show()
' Set cursor as hourglass
Application.DoEvents()
Dim ano, mes, dia As Integer
Dim var1data, var2data As Date
Dim dinicio, dfim As String
var1data = DateTimePicker1.Value '.ToString.Substring(0, 10)
dia = var1data.Day
mes = var1data.Month
ano = var1data.Year
dinicio = ano & "-" & mes & "-" & dia
var2data = DateTimePicker2.Value
dia = var2data.Day
mes = var2data.Month
ano = var2data.Year
dfim = ano & "-" & mes & "-" & dia
Using sqlcoon As SqlConnection = GetConnectionsql()
Dim READER As SqlDataReader
Try
sqlcoon.Open()
Dim Query As String
Query = "select MOV_IDENTIFICACAO,MOV_PROTOCOLO,MOV_DATADOC,MOV_SITUACAO,MOV_DATAENTREGA,MOV_HORAENTREGA,MOV_SITEND_CODIGO
from movimento where MOV_DATADOC = '" & dinicio & "'
AND MOV_CLI_CODIGO = '" & txtcod.Text & "' AND MOV_SITUACAO = '" & "E" & "'
AND CAST(MOV_DATAENTREGA AS DATE) = '" & dfim & "' "
Dim COMMAND As SqlCommand = New SqlCommand(Query, sqlcoon)
READER = COMMAND.ExecuteReader
While READER.Read
Dim MOV_IDENTIFICACAO = READER("MOV_IDENTIFICACAO")
Dim MOV_DATADOC = READER("MOV_DATADOC")
Dim MOV_DATAENTREGA = READER("MOV_DATAENTREGA")
Dim MOV_PROTOCOLO = READER("MOV_PROTOCOLO")
Dim MOV_SITUACAO = READER("MOV_SITUACAO")
Dim MOV_SITEND_CODIGO = READER("MOV_SITEND_CODIGO")
DataGridView1.Rows.Add(MOV_IDENTIFICACAO, MOV_PROTOCOLO, MOV_DATADOC, MOV_SITUACAO, MOV_DATAENTREGA, MOV_SITEND_CODIGO)
End While
READER.Close()
sqlcoon.Close()
''--------------'''''''''
Label9.Text = DataGridView1.Rows.Count
For Each linha In DataGridView1.Rows
Dim altura As Integer = 17
linha.height = altura
Next
If DataGridView1.Rows.Count >= 0 Then
' Set cursor as default arrow
Cursor.Current = Cursors.Default
' Hide the please wait form
consultando.Hide()
End If
Catch ex As SqlException
MessageBox.Show(ex.Message)
Finally
' sqlcoon.Dispose()
End Try
sqlcoon.Open()
Try
For r As Integer = 0 To DataGridView1.Rows.Count - 1
Dim COMMAND3 As SqlCommand
Dim READER3 As SqlDataReader
Dim Query_3 As String
Query_3 = "select IMOV_CODIGORECBTO from imovimento where IMOV_MOV_IDENTIFICACAO ='" & DataGridView1.Rows(r).Cells(0).Value.ToString & "'"
COMMAND3 = New SqlCommand(Query_3, sqlcoon)
READER3 = COMMAND3.ExecuteReader
While READER3.Read
Dim IMOV_CODIGORECBTO = READER3("IMOV_CODIGORECBTO")
'DataGridView1.Columns(6).HeaderCell.Value = "ID"
DataGridView1.Rows(r).Cells(6).Value = IMOV_CODIGORECBTO
End While
READER3.Close()
Next
DataGridView1.Sort(DataGridView1.Columns(6), ListSortDirection.Ascending)
sqlcoon.Close()
Catch ex As SqlException
MsgBox(ex.Message)
End Try
End Using
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
consulta()
End Sub
Private Sub Button4_Click(sender As Object, e As EventArgs) Handles Button4.Click
Imprimir()
End Sub
End Class
screenshot of what is currently being printed
screenshot of I would like the result to be:
Would anyone have any ideas, tools or means to help me? I thank.
An alternative would be to:
Get just the column values that you want.
Join the values from #1 using a delimiter, such as a tab.
Use the Graphics.DrawString method (documentation) for the value from #2.
There will need to be some considerations:
You will need to measure the string from #3 to see if it exceeds the bounds of your print document
If so, then you will need to print multiple pages, picking up where you left off.
Update
Per the OP's request, here is an example. Keep in mind that it doesn't account for the considerations listed above. That will take a bit of effort in debugging to account for those points:
Private Sub pdRelatorios_PrintPage(sender As Object, e As PrintPageEventArgs) Handles pdRelatorios.PrintPage
Dim title = "Relatorio de Entregas"
Dim titleFont = New Font(Font.FontFamily, Convert.ToSingle(Font.Size * 1.5), FontStyle.Bold)
Dim titlePosition = New PointF(Convert.ToSingle(e.MarginBounds.X * 2 - e.PageBounds.Width / 2), e.MarginBounds.Y)
Dim titleSize = e.Graphics.MeasureString(title, titleFont)
e.Graphics.DrawString(title, titleFont, SystemBrushes.ControlText, titlePosition)
Dim cellValues = DataGridView1.Rows.Cast(Of DataGridViewRow).Select(Function(row) row.Cells(0)?.Value?.ToString())
Dim joinedCellValues = String.Join(Constants.vbTab, cellValues)
Dim bodyBounds = New RectangleF(e.MarginBounds.X, Convert.ToSingle(titleSize.Height + e.MarginBounds.Y), e.PageBounds.Width - e.MarginBounds.X * 2, e.PageBounds.Height - e.MarginBounds.Y * 2)
e.Graphics.DrawString(joinedCellValues, Font, SystemBrushes.ControlText, bodyBounds)
End Sub
I have this code to align the form's title but I can not totally align with it, when I put a space for it to go totally left it works but it adds 3 points at the end, does anyone have any idea with fixing this?
Form FIXED SINGLE STYLE
Thank you all for the time
Private Sub ALINHAMENTO()
Dim g As Graphics = Me.CreateGraphics()
Dim startingPoint As Double = (Me.Width / 2) - (g.MeasureString(Me.Text.Trim, Me.Font).Width / 2)
Dim widthOfASpace As Double = g.MeasureString(" ", Me.Font).Width
Dim tmp As String = " "
Dim tmpWidth As Double = 0
Do
tmp += " "
tmpWidth += widthOfASpace
Loop While (tmpWidth + widthOfASpace) < startingPoint
Me.Text = Me.Text.Trim & tmp
End Sub
RUNNING
Solution based in idea of : Olivier Jacot-Descombes
Private Sub ALINHAMENTO()
Dim g As Graphics = Me.CreateGraphics()
Dim startingPoint As Double = (Me.Width / 1.3) - (g.MeasureString(Me.Text.Trim, Me.Font).Width / 1)
Dim widthOfASpace As Double = g.MeasureString(" ", Me.Font).Width
Dim tmp As String = " "
Dim tmpWidth As Double = 0
Do
tmp += " "
tmpWidth += widthOfASpace
Loop While (tmpWidth + widthOfASpace) < startingPoint
Me.Text = Me.Text.Trim & tmp
End Sub
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 am printing records from an ODBC connection but I am not able to print more than the first page. The code I have below generates multiple copies of the same first page. How can I iterate through my records and still create page breaks when necessary?
Private Sub btnPrint_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnPrint.Click
'MsgBox("Printing functionality is still under construction.", MsgBoxStyle.Information)
Dim RecordDoc As Drawing.Printing.PrintDocument
RecordDoc = New Drawing.Printing.PrintDocument
With RecordDoc.DefaultPageSettings
.Landscape = False
.Margins.Left = 50
.Margins.Right = 50
.Margins.Top = 50
.Margins.Bottom = 50
End With
RecordDoc.DocumentName = "Print Records"
AddHandler RecordDoc.PrintPage, AddressOf Me.printrecords
dlgPreview.Document = RecordDoc
dlgPreview.ShowDialog()
RecordDoc.Dispose()
End Sub
Private Sub PrintRecords(ByVal sender As Object, ByVal e As Drawing.Printing.PrintPageEventArgs)
Dim lvi As ListViewItem
Dim Conn As OdbcConnection
Dim Reader As OdbcDataReader
Dim strFname As String = ""
Dim strLname As String = ""
Dim strReportHdr As String = ""
Dim strMainCategory As String = ""
Dim strColumnHeader As String = ""
Dim intLinesPerPage As Integer = 0
Dim x, y As Single
Dim myfont As Font = New Font("Arial", 12, FontStyle.Regular)
Dim myPen As New Pen(Color.Black, 3)
'DEFINE THE REPORT HEADER BASED ON LISTVIEW SELECTIONS
'FIRST, GET THE COLUMN NUMBER SELECTED. YOU'LL USE THIS FOR THE REPORT HEADER AS WELL AS WHEN PRINTING DATA
Dim PrintColHeader As ColumnHeader = ListView1.Columns(intLViewColSort)
'REMOVE THE < OR > AS NECESSARY, IF PRESENT
If PrintColHeader.Text.StartsWith("> ") Then
strColumnHeader = Mid(PrintColHeader.Text, 3) & ", in descending order"
ElseIf PrintColHeader.Text.StartsWith("< ") Then
strColumnHeader = Mid(PrintColHeader.Text, 3) & ", in ascending order"
End If
If rdoCustInfo.Checked = True Then
strMainCategory = "Customer Information"
ElseIf rdoCustVendPrefs.Checked = True Then
strMainCategory = "Customer Vendor Preferences"
ElseIf rdoPricePts.Checked = True Then
strMainCategory = "Customer Price Points"
ElseIf rdoSalesHist.Checked = True Then
strMainCategory = "Customer Sales History"
ElseIf rdoSpecific.Checked = True Then
strMainCategory = "Other"
Else
MsgBox("System error with print function. Have a glass of wine.", MsgBoxStyle.Critical)
Exit Sub
End If
y = e.MarginBounds.Y
x = e.MarginBounds.X
e.Graphics.DrawRectangle(myPen, e.MarginBounds.X, e.MarginBounds.Y + 20, 500, 1)
e.Graphics.DrawString(strMainCategory & " - " & strColumnHeader, myfont, Brushes.Black, x, y)
y += CInt(2 * myfont.GetHeight(e.Graphics))
myfont = New Font("Arial", 10, FontStyle.Regular)
intLinesPerPage = e.MarginBounds.Height / myfont.GetHeight(e.Graphics)
'Open Connection TO ASC
Conn = New OdbcConnection(ConnString)
Conn.Open()
For Each lvi In ListView1.Items
'Execute Query
cmdString = "select lastname,firstname,street1,street2,city,state,zipcode,phonenum,emailaddress from customer where customernum=" & lvi.Text
Dim Cmd As New OdbcCommand(cmdString, Conn)
Reader = Cmd.ExecuteReader()
'Process The Result Set
While (Reader.Read())
Dim tempy As Integer
tempy = y
Dim CustName As String = Trim(Reader("firstname")) & " " & Trim(Reader("lastname"))
CustName = StrConv(CustName, VbStrConv.ProperCase)
e.Graphics.DrawString(CustName, myfont, Brushes.Black, e.MarginBounds.X, y)
y += CInt(myfont.GetHeight(e.Graphics))
Dim street As String = ""
If Trim(Reader("street2").ToString) <> "" And Not (IsDBNull(Reader("street2"))) Then
street += Trim(Reader("street1").ToString) & vbCrLf & Trim(Reader("street2"))
Else
street += Trim(Reader("street1").ToString)
End If
street = StrConv(street, VbStrConv.ProperCase)
e.Graphics.DrawString(street, myfont, Brushes.Black, e.MarginBounds.X, y)
y += CInt(myfont.GetHeight(e.Graphics))
Dim CityStateZip As String = ""
CityStateZip = StrConv(Trim(Reader("city")), VbStrConv.ProperCase) & ", " & Trim(Reader("state")) & ", " & Reader("zipcode")
e.Graphics.DrawString(CityStateZip, myfont, Brushes.Black, e.MarginBounds.X, y)
x += 200
e.Graphics.DrawString(Trim(Reader("phonenum")), myfont, Brushes.Black, x, tempy)
tempy += CInt(myfont.GetHeight(e.Graphics))
y += CInt(2 * myfont.GetHeight(e.Graphics))
e.Graphics.DrawString(Trim(Reader("emailaddress")), myfont, Brushes.Black, x, tempy)
x = e.MarginBounds.X
'If intPrintLineCount1 > intLinesPerPage Then
' e.HasMorePages = True
' intPrintLineCount1 = 0
'Else
' e.HasMorePages = False
'End If
If y + myfont.Height > e.MarginBounds.Bottom Then
e.HasMorePages = True
End If
'intPrintLineCount1 += 10
End While
Cmd.Dispose()
Next
Reader.Close()
Conn.Close()
Conn.Dispose()
End Sub
How to make when i type in a RichTextBox a certain word it gets highlited?
how do i find words in the text to use SelectionColor or SelectionFont
For example: i want that all times that the word "hello" appear in the RichTextBox it turn to bold or turn into a color...
Then if i open my program and type "hello, how are you?" the word hello turns into bold... any idea? (my idea is to make a text editor with syntax highlight that ill specify the words)
(sorry if there is another question like that, i tried to search but i didn't find a answer that helped me)
its windows forms, visual basic
This code should do the work:
Dim searchstring As String = "hello"
' The word you're looking for
Dim count As New List(Of Integer)()
For i As Integer = 0 To richTextBox1.Text.Length - 1
If richTextBox1.Text.IndexOf(searchstring, i) <> -1 Then
'If the word is found
'Add the index to the list
count.Add(richTextBox1.Text.IndexOf(searchstring, i))
End If
Next
Try
For i As Integer = 0 To count.Count - 1
richTextBox1.[Select](count(i), searchstring.Length)
richTextBox1.SelectionFont = New Font(richTextBox1.Font, FontStyle.Bold)
count.RemoveAt(i)
Next
Catch
End Try
richTextBox1.[Select](richTextBox1.Text.Length, 0)
richTextBox1.SelectionFont = New Font(richTextBox1.Font, FontStyle.Regula
For each index select the text and make it bold.
Now add this code to the TextChanged-Event to check any time the text changed for your word.
I got it in a different way:
While Not RichTextBox1.Text.IndexOf("hello", startIndex) = -1
selectedIndex= RichTextBox1.SelectionStart
Try
RichTextBox1.Select(RichTextBox1.Text.IndexOf("test", startIndex) - 1, 1)
Catch
End Try
If RichTextBox1.SelectedText = " " Or RichTextBox1.SelectedText = Nothing Then
RichTextBox1.Select(RichTextBox1.Text.IndexOf("hello", startIndex) + "test".Length, 1)
If RichTextBox1.SelectedText = " " Or RichTextBox1.SelectedText = Nothing Then
RichTextBox1.Select(RichTextBox1.Text.IndexOf("hello", startIndex), "test".Length)
RichTextBox1.SelectionColor = Color.Blue
End If
End If
startIndex = RichTextBox1.Text.IndexOf("hello", startIndex) + "hello".Length
RichTextBox1.SelectionStart = selectedIndex
RichTextBox1.SelectionLength = 0
RichTextBox1.SelectionColor = Color.Black
End While
I don't know if it is the best way, but works.
That is a code for highlighting selected text at yellow (can be replaced by any other color), after finding it:
'find the text that need to be highlighted.
foundIndex = RichTextBox1.Find("hello", foundIndex + 1, -1, selectedFinds)
RichTextBox1.Focus()
If foundIndex = -1 Then
MessageBox.Show("This document don't contains the text you typed, or any of the text you typed as a whole word or mach case.", "Find Text Error", MessageBoxButtons.OK, MessageBoxIcon.Asterisk)
else
'now the text will be highlighted.
RichTextBox1.SelectionBackColor = Color.Yellow
Richtextbox1.focus
End If
I hope that code will help.
Private Sub RichTextBox1_DragOver(sender As Object, e As DragEventArgs) Handles RichTextBox1.DragOver
Dim p As Point
p.X = e.X
p.Y = e.Y
Dim num As Integer
Dim rightTXT As String
Dim leftTXT As String
Dim textpart As String
Dim TSelect As Boolean
Dim curpos As Integer = RichTextBox1.GetCharIndexFromPosition(RichTextBox1.PointToClient(p))
Dim PosStart As Integer
TSelect = False
If e.Data.GetDataPresent(DataFormats.StringFormat) Then
e.Effect = DragDropEffects.All
Try
leftTXT = Microsoft.VisualBasic.Left(RichTextBox1.Text, curpos)
If InStr(leftTXT, "%", CompareMethod.Text) Then
rightTXT = Microsoft.VisualBasic.Right(RichTextBox1.Text, Len(RichTextBox1.Text) - curpos)
If InStr(rightTXT, "%", CompareMethod.Text) Then
PosStart = curpos - InStr(StrReverse(leftTXT), "%") + 1
num = curpos + InStr(rightTXT, "%") - PosStart - 1
textpart = (RichTextBox1.Text.Substring(PosStart, num).TrimEnd)
Label3.Text = "mouse drag over:" + textpart
Label5.Text = num.ToString()
If ListBox1.Items.Contains(textpart) Then
TSelect = True
End If
End If
End If
Catch ex As Exception
Label4.Text = ex.ToString()
End Try
End If
If TSelect Then
Me.RichTextBox1.Select(PosStart - 1, num + 2)
wordSearch = RichTextBox1.SelectedText
Label4.Text = "word drag state: true"
match = True
Else
Label3.Text = "mouse drag over:"
Label4.Text = "word drag state: false"
Me.RichTextBox1.Select(0, 0)
End If
End Sub
I find the above codes to be too lengthy/complicated for a simple task...
Dim c As Integer = 0
Dim o As Integer = 0
Dim s As Integer = 0
Dim txt As String = RTB.Text
RTB.BackColor = Color.Black
Dim starts As Integer = 0
Do While txt.Contains(key) ' this avoids unnecessary loops
s = txt.IndexOf(key)
starts = s + o
RTB.Select(starts, key.Length)
RTB.SelectionBackColor = Color.Yellow
RTB.SelectionColor = Color.Blue
txt = txt.Substring(s + key.Length)
o += (s + key.Length)
c += 1
Loop
Me.Status.Text = c.ToString() & " found" ' and the number found