' VB.NET Ball Block Game Source Code
Option Explicit On
Option Strict On
Public Class Form1
Dim Rows As Integer
Dim Cols As Integer
' Engines Class
Dim g_Engines As New KPKEngines
' Maps
Dim hImages As Integer
Dim Mps As New KPKMaps
Dim hMaps As Integer
Dim MapsX As Integer
Dim MapsY As Integer
' Character Ball Green
Dim Ball_Green As New KPKCharacters
Dim Ball_Green_Cols As Integer
Dim Ball_Green_Rows As Integer
Dim Ball_Green_X As Integer
Dim Ball_Green_Y As Integer
Const Ball_Green_Width As Integer = 32
Const Ball_Green_Height As Integer = 32
' Character Ball Green
Const MAXBALLPINK As Integer = 2
Dim Ball_Pink(MAXBALLPINK) As KPKCharacters
Dim Ball_Pink_Cols(MAXBALLPINK) As Integer
Dim Ball_Pink_Rows(MAXBALLPINK) As Integer
Dim Ball_Pink_X(MAXBALLPINK) As Integer
Dim Ball_Pink_Y(MAXBALLPINK) As Integer
Dim Ball_Pink_Show(MAXBALLPINK) As Boolean
Const Ball_Pink_Width As Integer = 32
Const Ball_Pink_Height As Integer = 32
Dim CColumns() As Integer
Dim CRows() As Integer
Dim bBallBlock1 As Boolean
Dim bBallBlock2 As Boolean
Dim bBallBlock3 As Boolean
Dim i As Integer
Dim NumBall As Integer
Private Function LoadBitmaps(ByVal hDCDest As Integer, ByVal sFilename As String) As Integer
Dim tmphDC As Integer
Dim tmphBitmaps As Integer
tmphDC = CreateCompatibleDC(hDCDest)
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()
Ball_Green.ReleaseChar()
For i = 0 To MAXBALLPINK
Ball_Pink(i).ReleaseChar()
Next i
DeleteDC(hMaps)
DeleteDC(hImages)
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 InitGames()
NumBall = 0
Ball_Green_Cols = 2
Ball_Green_Rows = 2
For i = 0 To MAXBALLPINK
Ball_Pink_Show(i) = True
Next i
Ball_Pink_Cols(0) = 3
Ball_Pink_Rows(0) = 3
Ball_Pink_Cols(1) = 4
Ball_Pink_Rows(1) = 7
Ball_Pink_Cols(2) = 8
Ball_Pink_Rows(2) = 7
End Sub
Private Sub Form1_DoubleClick(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.DoubleClick
If MsgBox(" Do you want to New Game? ", MsgBoxStyle.Question Or MsgBoxStyle.YesNo, " VB.NET Ball Block Game ") = MsgBoxResult.Yes Then
Call InitGames()
End If
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
If MsgBox(" Do you want to Close Ball Block Game? ", MsgBoxStyle.Question Or MsgBoxStyle.YesNo, " VB.NET Ball Block Game ") = MsgBoxResult.Yes Then
Call ReleaseGames()
End
End If
Case Keys.Right
If Mps.GetTileMoveState(Ball_Green_Cols + 1, Ball_Green_Rows) = 1 Then
For i = 0 To MAXBALLPINK
If Ball_Green_Cols = Ball_Pink_Cols(i) - 1 And Ball_Green_Rows = Ball_Pink_Rows(i) Then
If Mps.GetTileMoveState(Ball_Pink_Cols(i) + 1, Ball_Pink_Rows(i)) = 1 Then
Ball_Pink_Cols(i) = Ball_Pink_Cols(i) + 1
End If
End If
Next i
Ball_Green_Cols = Ball_Green_Cols + 1
End If
Case Keys.Left
If Mps.GetTileMoveState(Ball_Green_Cols - 1, Ball_Green_Rows) = 1 Then
For i = 0 To MAXBALLPINK
If Ball_Green_Cols = Ball_Pink_Cols(i) + 1 And Ball_Green_Rows = Ball_Pink_Rows(i) Then
If Mps.GetTileMoveState(Ball_Pink_Cols(i) - 1, Ball_Pink_Rows(i)) = 1 Then
Ball_Pink_Cols(i) = Ball_Pink_Cols(i) - 1
End If
End If
Next i
Ball_Green_Cols = Ball_Green_Cols - 1
End If
Case Keys.Up
If Mps.GetTileMoveState(Ball_Green_Cols, Ball_Green_Rows - 1) = 1 Then
For i = 0 To MAXBALLPINK
If Ball_Green_Cols = Ball_Pink_Cols(i) And Ball_Green_Rows = Ball_Pink_Rows(i) + 1 Then
If Mps.GetTileMoveState(Ball_Pink_Cols(i), Ball_Pink_Rows(i) - 1) = 1 Then
Ball_Pink_Rows(i) = Ball_Pink_Rows(i) - 1
End If
End If
Next i
Ball_Green_Rows = Ball_Green_Rows - 1
End If
Case Keys.Down
If Mps.GetTileMoveState(Ball_Green_Cols, Ball_Green_Rows + 1) = 1 Then
For i = 0 To MAXBALLPINK
If Ball_Green_Cols = Ball_Pink_Cols(i) And Ball_Green_Rows = Ball_Pink_Rows(i) - 1 Then
If Mps.GetTileMoveState(Ball_Pink_Cols(i), Ball_Pink_Rows(i) + 1) = 1 Then
Ball_Pink_Rows(i) = Ball_Pink_Rows(i) + 1
End If
End If
Next i
Ball_Green_Rows = Ball_Green_Rows + 1
End If
End Select
End Sub
Private Sub Form1_Load(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles MyBase.Load
Me.FormBorderStyle = Windows.Forms.FormBorderStyle.FixedToolWindow
Me.Text = " The Gun Balls Games In VB.NET "
Me.Width = 400
Me.Height = 400
g_Engines.InitEngines(Me.Handle.ToInt32, 800, 600)
Timer1.Interval = 1
Timer1.Enabled = True
hImages = LoadBitmaps(g_Engines.GethDCBuffer, "D:\Image Games\Ball_Block_Maps_02.bmp")
Mps.LoadMaps("D:\Maps\VB.NET_Ball_Block_01.MAPS")
ReDim CColumns(Mps.GetMapsWidth)
ReDim CRows(Mps.GetMapsHeight)
Call InitGames()
' Ball Green
Ball_Green.SetFileNameNormal("D:\Image Games\Ball_Block_Green_Normal_01.Bmp")
Ball_Green.SetFileNameMask("D:\Image Games\Ball_Block_Green_Mask_01.Bmp")
Ball_Green.SetCharWidth(Ball_Green_Width)
Ball_Green.SetCharHeight(Ball_Green_Height)
Ball_Green.InitCharNormal(g_Engines.GethDCBuffer)
Ball_Green.InitCharMask(g_Engines.GethDCBuffer)
' Ball Pink
For i = 0 To MAXBALLPINK
Ball_Pink(i) = New KPKCharacters
Ball_Pink(i).SetFileNameNormal("D:\Image Games\Ball_Block_Pink_Normal_01.Bmp")
Ball_Pink(i).SetFileNameMask("D:\Image Games\Ball_Block_Pink_Mask_01.Bmp")
Ball_Pink(i).SetCharWidth(Ball_Pink_Width)
Ball_Pink(i).SetCharHeight(Ball_Pink_Height)
Ball_Pink(i).InitCharNormal(g_Engines.GethDCBuffer)
Ball_Pink(i).InitCharMask(g_Engines.GethDCBuffer)
Next i
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), hImages, Mps.GetTileX(Cols, Rows), _
Mps.GetTileY(Cols, Rows), SRCCOPY)
Next
Next
End Sub
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
g_Engines.BeginEngines()
'Draw Maps In Games
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
' Check Games Loop
For i = 0 To MAXBALLPINK
If Ball_Pink_Cols(i) = 3 And Ball_Pink_Rows(i) = 2 Then
bBallBlock1 = True
Ball_Pink_Cols(i) = 3
Ball_Pink_Rows(i) = 2
End If
If Ball_Pink_Cols(i) = 4 And Ball_Pink_Rows(i) = 6 Then
bBallBlock2 = True
Ball_Pink_Cols(i) = 4
Ball_Pink_Rows(i) = 6
End If
If Ball_Pink_Cols(i) = 7 And Ball_Pink_Rows(i) = 8 Then
bBallBlock3 = True
Ball_Pink_Cols(i) = 7
Ball_Pink_Rows(i) = 8
End If
If Bballblock1 = True And bballblock2 = True And bballblock3 = True Then
Me.Text = " You Win : The Gun Balls Games In VB.NET "
Call InitGames()
End If
Next i
For i = 0 To MAXBALLPINK
If Ball_Pink_Show(i) = True Then
' Set Position Ball Pink
Ball_Pink_X(i) = CColumns(Ball_Pink_Cols(i))
Ball_Pink_Y(i) = CRows(Ball_Pink_Rows(i))
' Draw Character Ball Pink
Ball_Pink(i).SetCharX(Ball_Pink_X(i))
Ball_Pink(i).SetCharY(Ball_Pink_Y(i))
Ball_Pink(i).DrawCharactersTransparency()
End If
Next i
' Set Position Ball Green
Ball_Green_X = CColumns(Ball_Green_Cols)
Ball_Green_Y = CRows(Ball_Green_Rows)
' Draw Character
Ball_Green.SetCharX(Ball_Green_X)
Ball_Green.SetCharY(Ball_Green_Y)
Ball_Green.DrawCharactersTransparency()
g_Engines.EndEngines()
End Sub
End Class
' basMain.vb ( Module )
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
ไม่มีความคิดเห็น:
แสดงความคิดเห็น