' VB.NET Car Games Source Code
Option Explicit On
Option Strict On
Public Class Form1
' Declare KPKEngines Class
Dim g_Engines As New KPKEngines
' KPKMaps Class
Dim Mps As New KPKMaps
Dim hMaps As Integer
Dim MapsX As Integer
Dim MapsY As Integer
Const AreaWidth As Integer = 1280
Const AreaHeight As Integer = 1024
Dim Rows As Integer
Dim Cols As Integer
' Car KPKCharacters Class
Dim Car As New KPKCharacters
Dim CarX As Integer
Dim CarY As Integer
Dim CarCols As Integer
Dim CarRows As Integer
Dim CarMoveEnd As Boolean
' Enemy Car
Dim eCar As New KPKCharacters
Dim eCarX As Integer
Dim eCarY As Integer
Dim eCarCols As Integer
Dim eCarRows As Integer
Dim eCarStart As Boolean
Dim eCarMoveLeft As Boolean
Dim eCarMoveDown As Boolean
Dim eCarMoveRight As Boolean
Dim eCarMoveEnd As Boolean
Const CarWidth As Integer = 32
Const CarHeight As Integer = 18
Dim CColumns() As Integer
Dim CRows() As Integer
Private Function LoadBitmaps(ByVal sFilename As String) As Integer
Dim tmphDC As Integer
Dim tmphBitmaps As Integer
tmphDC = CreateCompatibleDC(g_Engines.GethDCBuffer)
tmphBitmaps = LoadImage(0, sFilename, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
SelectObject(tmphDC, tmphBitmaps)
DeleteObject(tmphBitmaps)
LoadBitmaps = tmphDC
End Function
Private Sub ReleaseGames()
DeleteDC(hMaps)
Car.ReleaseChar()
eCar.ReleaseChar()
g_Engines.ReleaseEngines()
End Sub
Private Sub Form1_Disposed(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Disposed
Call ReleaseGames()
End Sub
Private Sub Form1_KeyDown(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles Me.KeyDown
Select Case e.KeyCode
Case Keys.Escape
Call ReleaseGames()
End
Case Keys.Left
eCarStart = True
If Mps.GetTileMoveState(CarCols - 1, CarRows) = 1 Then
CarCols = CarCols - 1
If CarCols = 2 And CarRows = 9 Then
CarMoveEnd = True
End If
End If
End Select
End Sub
Private Sub InitGames()
CarCols = 26
CarRows = 9
CarMoveEnd = False
eCarCols = 26
eCarRows = 5
eCarMoveEnd = False
eCarStart = False
eCarMoveLeft = True
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Randomize()
Me.FormBorderStyle = Windows.Forms.FormBorderStyle.Sizable
Me.MaximizeBox = False
Me.Text = " VB.NET Cars Games "
Me.KeyPreview = True
g_Engines.InitEngines(Me.Handle.ToInt32, AreaWidth, AreaHeight)
hMaps = LoadBitmaps("D:\MapsTiles01.Bmp")
Mps.LoadMaps("D:\Maps\VB.NET_Cars_Game_01.MAPS")
ReDim CColumns(Mps.GetMapsWidth)
ReDim CRows(Mps.GetMapsHeight)
' Init Games
Call InitGames()
' Init Car
Car.SetFileNameNormal("D:\Image Games\Red_Car_Normal_01.Bmp")
Car.SetFileNameMask("D:\Image Games\Red_Car_Mask_01.Bmp")
Car.InitCharNormal(g_Engines.GethDCBuffer)
Car.InitCharMask(g_Engines.GethDCBuffer)
Car.SetCharWidth(CarWidth)
Car.SetCharHeight(CarHeight)
' Init Enemy Car
eCar.SetFileNameNormal("D:\Image Games\Blue_Car_Normal_01.Bmp")
eCar.SetFileNameMask("D:\Image Games\Blue_Car_Mask_01.Bmp")
eCar.InitCharNormal(g_Engines.GethDCBuffer)
eCar.InitCharMask(g_Engines.GethDCBuffer)
eCar.SetCharWidth(CarWidth)
eCar.SetCharHeight(CarHeight)
Timer1.Interval = 1
Timer1.Enabled = True
End Sub
Private Sub DrawMaps()
For Rows = 1 To Mps.GetMapsHeight
For Cols = 1 To Mps.GetMapsWidth
BitBlt(g_Engines.GethDCBuffer, Mps.GetTilePosX(Cols, Rows), _
Mps.GetTilePosY(Cols, Rows), Mps.GetTileWidth(Cols, Rows), _
Mps.GetTileHeight(Cols, Rows), hMaps, Mps.GetTileX(Cols, Rows), _
Mps.GetTileY(Cols, Rows), SRCCOPY)
Next Cols
Next Rows
End Sub
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
g_Engines.BeginEngines()
' Draw Maps
Call DrawMaps()
' Calculation Columns And Rows
For Rows = 1 To Mps.GetMapsHeight
For Cols = 1 To Mps.GetMapsWidth
CColumns(Cols) = MapsX + (Cols - 1) * 32
CRows(Rows) = MapsY + (Rows - 1) * 32
Next Cols
Next Rows
' Set Position Car
CarX = CColumns(CarCols)
CarY = CRows(CarRows) + 5
Car.SetCharX(CarX)
Car.SetCharY(CarY)
Car.DrawCharactersTransparency()
If eCarStart = True Then
If eCarMoveLeft = True Then
eCarCols = eCarCols - 1
eCarRows = 5
If eCarCols <= 2 Then
eCarMoveLeft = False
eCarMoveDown = True
End If
End If
If eCarMoveDown = True Then
eCarCols = 2
eCarRows = eCarRows + 1
If eCarRows >= 7 Then
eCarMoveDown = False
eCarMoveRight = True
End If
End If
If eCarMoveRight = True Then
eCarCols = eCarCols + 1
eCarRows = 7
If eCarCols >= 26 Then
eCarCols = 26
eCarRows = 7
eCarMoveRight = False
eCarMoveEnd = True
End If
End If
End If
' Check You Or Enemy Win
If CarMoveEnd = True And eCarMoveEnd = False Then
Me.Text = " You Win "
ElseIf eCarMoveEnd = True And CarMoveEnd = False Then
Me.Text = " Enemy Win "
End If
' Set Position Enemy Car
eCarX = CColumns(eCarCols)
eCarY = CRows(eCarRows) + 5
eCar.SetCharX(eCarX)
eCar.SetCharY(eCarY)
eCar.DrawCharactersTransparency()
g_Engines.EndEngines()
End Sub
End Class
' basMain.vb ( Class )
Module basMain
Public Declare Function CreateCompatibleDC Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hdc As Integer) As Integer
Public Declare Function CreateCompatibleBitmap Lib "gdi32" Alias "CreateCompatibleBitmap" (ByVal hdc As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Public Declare Function SelectObject Lib "gdi32" Alias "SelectObject" (ByVal hdc As Integer, ByVal hObject As Integer) As Integer
Public Declare Function DeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Integer) As Integer
Public Declare Function DeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Integer) As Integer
Public Declare Function GetDC Lib "user32" Alias "GetDC" (ByVal hwnd As Integer) As Integer
Public Declare Function BitBlt Lib "gdi32" Alias "BitBlt" (ByVal hDestDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal xSrc As Integer, ByVal ySrc As Integer, ByVal dwRop As Integer) As Integer
Public Const SRCCOPY As Integer = &HCC0020 ' (DWORD) dest = source
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Integer, ByVal lpsz As String, ByVal un1 As Integer, ByVal n1 As Integer, ByVal n2 As Integer, ByVal un2 As Integer) As Integer
Public Const IMAGE_BITMAP As Integer = 0
Public Const LR_LOADFROMFILE As Integer = &H10
Public Const LR_CREATEDIBSECTION As Integer = &H2000
Public Const SRCAND As Integer = &H8800C6 ' (DWORD) dest = source AND dest
Public Const SRCPAINT As Integer = &HEE0086 ' (DWORD) dest = source OR dest
Public Const MERGEPAINT As Integer = &HBB0226 ' (DWORD) dest = (NOT source) OR dest
Public Const AreaWidth As Integer = 1280
Public Const AreaHeight As Integer = 1024
End Module
' KPKCharacters.vb ( Class )
Public Class KPKCharacters
Private Structure TCHARS
Dim vStrFileNameNormal As String
Dim vStrFileNameMask As String
Dim vCharX As Integer
Dim vCharY As Integer
Dim vCharWidth As Integer
Dim vCharHeight As Integer
Dim vhDCNormal As Integer
Dim vhBitmapsNormal As Integer
Dim vhDCMask As Integer
Dim vhBitmapsMask As Integer
End Structure
Dim tmphDCDest As Integer
Dim g_Chars As TCHARS
Public Sub SetFileNameNormal(ByVal sFileName As String)
g_Chars.vStrFileNameNormal = sFileName
End Sub
Public Sub SetFileNameMask(ByVal sFileName As String)
g_Chars.vStrFileNameMask = sFileName
End Sub
Public Sub InitCharNormal(ByVal hDest As Integer)
g_Chars.vhDCNormal = CreateCompatibleDC(hDest)
g_Chars.vhBitmapsNormal = LoadImage(0, g_Chars.vStrFileNameNormal, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
SelectObject(g_Chars.vhDCNormal, g_Chars.vhBitmapsNormal)
tmphDCDest = hDest
End Sub
Public Sub InitCharMask(ByVal hDest As Integer)
g_Chars.vhDCMask = CreateCompatibleDC(hDest)
g_Chars.vhBitmapsMask = LoadImage(0, g_Chars.vStrFileNameMask, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
SelectObject(g_Chars.vhDCMask, g_Chars.vhBitmapsMask)
tmphDCDest = hDest
End Sub
Public Sub SetCharX(ByVal CharX As Integer)
g_Chars.vCharX = CharX
End Sub
Public Sub SetCharY(ByVal CharY As Integer)
g_Chars.vCharY = CharY
End Sub
Public Sub SetCharWidth(ByVal CharWidth As Integer)
g_Chars.vCharWidth = CharWidth
End Sub
Public Sub SetCharHeight(ByVal CharHeight As Integer)
g_Chars.vCharHeight = CharHeight
End Sub
Public Sub DrawCharacters()
BitBlt(tmphDCDest, g_Chars.vCharX, g_Chars.vCharY, g_Chars.vCharWidth, g_Chars.vCharHeight, g_Chars.vhDCNormal, 0, 0, SRCCOPY)
End Sub
Public Sub DrawCharNormal(ByVal SrcX As Integer, ByVal SrcY As Integer, ByVal vDwRop As Integer)
BitBlt(tmphDCDest, g_Chars.vCharX, g_Chars.vCharY, g_Chars.vCharWidth, g_Chars.vCharHeight, g_Chars.vhDCNormal, SrcX, SrcY, vDwRop)
End Sub
Public Sub DrawCharMask(ByVal SrcX As Integer, ByVal SrcY As Integer, ByVal vDwRop As Integer)
BitBlt(tmphDCDest, g_Chars.vCharX, g_Chars.vCharY, g_Chars.vCharWidth, g_Chars.vCharHeight, g_Chars.vhDCMask, SrcX, SrcY, vDwRop)
End Sub
Public Sub DrawCharactersTransparency()
BitBlt(tmphDCDest, g_Chars.vCharX, g_Chars.vCharY, g_Chars.vCharWidth, g_Chars.vCharHeight, g_Chars.vhDCMask, 0, 0, SRCAND)
BitBlt(tmphDCDest, g_Chars.vCharX, g_Chars.vCharY, g_Chars.vCharWidth, g_Chars.vCharHeight, g_Chars.vhDCNormal, 0, 0, SRCPAINT)
End Sub
Public Sub ReleaseChar()
DeleteObject(g_Chars.vhBitmapsMask)
DeleteObject(g_Chars.vhBitmapsNormal)
DeleteObject(g_Chars.vhDCMask)
DeleteObject(g_Chars.vhDCNormal)
DeleteObject(tmphDCDest)
End Sub
End Class
' KPKEngines.vb ( Class )
Public Class KPKEngines
Private Structure STR_ENGINES
Dim g_hDC As Integer
Dim g_hDCBuffer As Integer
Dim g_hBitmapsBuffer As Integer
Dim g_hDCBack As Integer
Dim g_hBitmapsBack As Integer
Dim g_AreaWidth As Integer
Dim g_AreaHeight As Integer
End Structure
Dim StrEngines As STR_ENGINES
Dim TmphBuffer As Integer
Public Function GethDCBuffer() As Integer
GethDCBuffer = TmphBuffer
End Function
Public Function InitEngines(ByVal hWnd As Integer, ByVal AreaWidth As Integer, ByVal AreaHeight As Integer) As Integer
StrEngines.g_hDC = GetDC(hWnd)
StrEngines.g_hDCBuffer = CreateCompatibleDC(StrEngines.g_hDC)
StrEngines.g_hBitmapsBuffer = CreateCompatibleBitmap(StrEngines.g_hDC, AreaWidth, AreaHeight)
StrEngines.g_hDCBack = CreateCompatibleDC(StrEngines.g_hDC)
StrEngines.g_hBitmapsBack = CreateCompatibleBitmap(StrEngines.g_hDC, AreaWidth, AreaHeight)
SelectObject(StrEngines.g_hDCBuffer, StrEngines.g_hBitmapsBuffer)
SelectObject(StrEngines.g_hDCBack, StrEngines.g_hBitmapsBack)
StrEngines.g_AreaWidth = AreaWidth
StrEngines.g_AreaHeight = AreaHeight
TmphBuffer = StrEngines.g_hDCBuffer
End Function
Public Sub BeginEngines()
BitBlt(StrEngines.g_hDCBuffer, 0, 0, StrEngines.g_AreaWidth, StrEngines.g_AreaHeight, StrEngines.g_hDCBack, 0, 0, SRCCOPY)
End Sub
Public Sub EndEngines()
BitBlt(StrEngines.g_hDC, 0, 0, StrEngines.g_AreaWidth, StrEngines.g_AreaHeight, StrEngines.g_hDCBuffer, 0, 0, SRCCOPY)
End Sub
Public Sub ReleaseEngines()
DeleteObject(StrEngines.g_hBitmapsBack)
DeleteObject(StrEngines.g_hBitmapsBuffer)
DeleteDC(StrEngines.g_hDCBack)
DeleteDC(StrEngines.g_hDCBuffer)
DeleteDC(StrEngines.g_hDC)
End Sub
End Class
' KPKMaps.vb ( Class )
Public Class KPKMaps
Private Structure STR_MAPS
Dim TileX As Integer
Dim TileY As Integer
Dim TileWidth As Integer
Dim TileHeight As Integer
Dim TilePosX As Integer
Dim TilePosY As Integer
Dim TileMoveState As Byte
End Structure
Dim strMaps(,) As STR_MAPS
Dim MapsWidth As Integer
Dim MapsHeight As Integer
Dim TmpRows As Integer
Dim TmpCols As Integer
Public Sub LoadMaps(ByVal sFilename As String)
Dim nFileNum As Integer
nFileNum = FreeFile()
FileOpen(nFileNum, sFilename, OpenMode.Binary, OpenAccess.Read)
FileGet(nFileNum, MapsWidth)
FileGet(nFileNum, MapsHeight)
ReDim strMaps(MapsWidth + 1, MapsHeight + 1)
For TmpRows = 1 To MapsHeight
For TmpCols = 1 To MapsWidth
FileGet(nFileNum, strMaps(TmpCols, TmpRows).TileX)
FileGet(nFileNum, strMaps(TmpCols, TmpRows).TileY)
FileGet(nFileNum, strMaps(TmpCols, TmpRows).TileWidth)
FileGet(nFileNum, strMaps(TmpCols, TmpRows).TileHeight)
FileGet(nFileNum, strMaps(TmpCols, TmpRows).TilePosX)
FileGet(nFileNum, strMaps(TmpCols, TmpRows).TilePosY)
FileGet(nFileNum, strMaps(TmpCols, TmpRows).TileMoveState)
Next TmpCols
Next TmpRows
FileClose(nFileNum)
End Sub
Public Function GetMapsWidth() As Integer
GetMapsWidth = MapsWidth
End Function
Public Function GetMapsHeight() As Integer
GetMapsHeight = MapsHeight
End Function
Public Function GetTileX(Optional ByVal nCols As Integer = 1, Optional ByVal nRows As Integer = 1) As Integer
GetTileX = strMaps(nCols, nRows).TileX
End Function
Public Function GetTileY(ByVal nCols As Integer, ByVal nRows As Integer) As Integer
GetTileY = strMaps(nCols, nRows).TileY
End Function
Public Function GetTileWidth(ByVal nCols As Integer, ByVal nRows As Integer) As Integer
GetTileWidth = strMaps(nCols, nRows).TileWidth
End Function
Public Function GetTileHeight(ByVal nCols As Integer, ByVal nRows As Integer) As Integer
GetTileHeight = strMaps(nCols, nRows).TileHeight
End Function
Public Function GetTilePosX(ByVal nCols As Integer, ByVal nRows As Integer) As Integer
GetTilePosX = strMaps(nCols, nRows).TilePosX
End Function
Public Function GetTilePosY(ByVal nCols As Integer, ByVal nRows As Integer) As Integer
GetTilePosY = strMaps(nCols, nRows).TilePosY
End Function
Public Function GetTileMoveState(ByVal nCols As Integer, ByVal nRows As Integer) As Integer
GetTileMoveState = strMaps(nCols, nRows).TileMoveState
End Function
End Class
' Design VB.NET Source Code Games By Fernando Firaht
ไม่มีความคิดเห็น:
แสดงความคิดเห็น