kurosen codding


Posts : 291 Join date : 2012-04-17
 | Subject: vb.net game map + char on it Sun Jun 05, 2016 10:18 pm | |
| the code will be used for stuff far beyong the code may be updated sometime add picbox with map elements for map tiles (invisible) add picbox with char (up down left right facing) invisible - Code:
-
Imports System.Drawing Imports System.Math Public Class Form1 ' view scale Dim resWidth As Integer = 750 Dim resHeight As Integer = 550 Dim tileSize As Integer = 32 Dim g As Graphics Dim bbg As Graphics Dim bb As Bitmap 'mutationed Dim r As Rectangle to Dim bmpTile As Bitmap ' image of tile Dim sRect As Rectangle ' source image tile Dim dRect As Rectangle ' destination image tile ' Dim tSec As Integer = TimeOfDay.Second Dim tTicks As Integer = 0 Dim maxTicks As Integer = 0 ' map vars Dim map(100, 100, 10) As Integer ' map vars for saving Dim mapx As Integer = 20 Dim mapy As Integer = 20 ' game running ? Dim isRunning As Boolean = True 'mouce locations Dim mouseX As Integer Dim mouseY As Integer Dim mMapX As Integer Dim mMapY As Integer 'toon variables Dim bmpToon As Bitmap Dim xPos As Integer Dim yPos As Integer Dim moveSpeed As Integer = 8 Dim moveDir As Short = 0 Dim lastDir As Short = 2 ' paint brush Dim paintbrush As Integer = 0
Private Sub Form1_KeyPress(sender As Object, e As KeyPressEventArgs) Handles Me.KeyPress Select Case e.KeyChar Case "w" moveDir = 1 Case "a" moveDir = 2 Case "s" moveDir = 3 Case "d" moveDir = 4 End Select lastDir = moveDir
End Sub
Private Sub Form1_KeyUp(sender As Object, e As KeyEventArgs) Handles Me.KeyUp moveDir = 0 End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load Me.Show() Me.Focus() ' initialize graphics object g = Me.CreateGraphics bb = New Bitmap(resWidth, resHeight) bmpTile = New Bitmap(PictureBox1.Image) bmpToon = New Bitmap(pbToon.Image)
map(21, 21, 0) = 1 'example populate a tile on D map
startGameLoop() End Sub Private Sub startGameLoop() Do While isRunning ' keep app responsive Application.DoEvents() ' get user input moveToon(moveDir) ' run a.i ' update object data ' chk triggers & conditions ' draw graphics drawGraphics() ' update tick counter tickCounter() Loop End Sub Private Sub moveToon(ByVal dir) 'duplicate #, var mutation for loop nested with conjurati formula Select Case dir Case 1 mapy -= 1 Case 2 mapy += 1 Case 3 mapx -= 1 Case 4 mapx += 1 End Select End Sub Private Sub drawGraphics() ' fill D backbuffer ' draw tiles For x = 0 To 19 For y = 0 To 14 'mutation r deleted getSourceRect(mapx + x, mapy + y, tileSize, tileSize) dRect = New Rectangle(x * tileSize, y * tileSize, tileSize, tileSize) g.DrawImage(bmpTile, dRect, sRect, GraphicsUnit.Pixel) Next Next g.FillRectangle(Brushes.Red, 21 * tileSize, 4 * tileSize, tileSize, tileSize) g.FillRectangle(Brushes.Blue, 21 * tileSize, 6 * tileSize, tileSize, tileSize) 'draw toon getToom(lastDir) bmpToon.MakeTransparent(Color.Fuchsia) g.DrawImage(bmpToon, 9 * tileSize, 6 * tileSize, sRect, GraphicsUnit.Pixel)
' mark mouse g.DrawRectangle(Pens.Red, mouseX * tileSize, mouseY * tileSize, tileSize, tileSize) ' draw final layers g.DrawString("Ticks:" & tTicks & vbCrLf & "TPS: " & maxTicks & vbCrLf & "mouseXPos: " & mouseX & vbCrLf & "mouseYPos: " & mouseY & vbCrLf & "mMapY" & mMapY & vbCrLf & "mMapx :" & mMapX & vbCrLf, Me.Font, Brushes.Black, 650, 0) 'copy back buffer to graphics object g = Graphics.FromImage(bb) 'draw backbuffer to screen bbg = Me.CreateGraphics bbg.DrawImage(bb, 0, 0, resWidth, resHeight) 'clear overdraw g.Clear(Color.Wheat)
End Sub Private Sub getToom(ByVal dir As Short) Select Case dir Case 1 sRect = New Rectangle(32, 0, tileSize, tileSize) Case 2 sRect = New Rectangle(0, 0, tileSize, tileSize) Case 3 sRect = New Rectangle(0, 32, tileSize, tileSize) Case 4 sRect = New Rectangle(32, 32, tileSize, tileSize)
End Select End Sub Private Sub tickCounter() If tSec = TimeOfDay.Second And isRunning Then tTicks += 1 Else maxTicks = tTicks tTicks = 0 tSec = TimeOfDay.Second
End If End Sub
Private Sub Form1_MouseClick(sender As Object, e As MouseEventArgs) Handles Me.MouseClick If mouseX = 21 Then If mouseY = 4 Then paintbrush = 1 ElseIf mouseY = 6 Then paintbrush = 2 End If End If Select Case paintbrush Case 0 Case 1 ' red map(mMapX, mMapY, 0) = 1 Case 2 'blue map(mMapX, mMapY, 0) = 2
End Select End Sub
Private Sub Form1_MouseMove(sender As Object, e As MouseEventArgs) Handles Me.MouseMove mouseX = Math.Floor(e.X / tileSize) mouseY = Math.Floor(e.Y / tileSize) mMapX = mapx + mouseX mMapY = mapy + mouseY End Sub Private Sub getSourceRect(ByVal x As Integer, y As Integer, w As Integer, h As Integer) Select Case map(x, y, 0) Case 0 'grass sRect = New Rectangle(32, 0, tileSize, tileSize) Case 1 'tree or whatevet tjis is the tile image type m'kay sRect = New Rectangle(128, 128, tileSize, tileSize) End Select End Sub End Class
| |
|