' VB.NET Games Source Code
Option Explicit On
Option Strict On
Public Class Form1
' Declare KPKEngines Class
Dim mKPKEngines As KPKEngines
' Declare KPKMaps Class
Dim mKPKMaps As KPKMaps
Dim hMapsTiles As Integer
Dim mMapsX As Integer
Dim mMapsY As Integer
' Declare KPKCharacters Class
Dim mKPKChar As KPKCharacters
Dim mCharX As Integer
Dim mCharY As Integer
Dim mCharCols As Integer
Dim mCharRows As Integer
Const mCharWidth As Integer = 39
Const mCharHeight As Integer = 47
' Declare KPKCharacters Class
Dim mKPKTreasure As KPKCharacters
Dim mTreasureX As Integer
Dim mTreasureY As Integer
Dim mTreasureCols As Integer
Dim mTreasureRows As Integer
Dim bRndTreasurePos As Boolean
Dim bShowTreasure As Boolean
Const mTreasureWidth As Integer = 31
Const mTreasureHeight As Integer = 32
Dim Rows As Integer
Dim Cols As Integer
Dim CColumns() As Integer
Dim CRows() As Integer
Private Sub InitClass()
mKPKEngines = New KPKEngines
mKPKMaps = New KPKMaps
mKPKChar = New KPKCharacters
mKPKTreasure = New KPKCharacters
End Sub
Private Sub InitMaps()
hMapsTiles = mKPKEngines.LoadBitmaps("D:\MapsTiles_002.Bmp")
mKPKMaps.LoadMaps("D:\Maps\Treasure_Game_01.MAPS")
End Sub
Private Sub ReleaseGames()
DeleteDC(hMapsTiles)
mKPKChar.ReleaseChar()
mKPKTreasure.ReleaseChar()
mKPKEngines.ReleaseEngines()
End Sub
Private Sub InitEngines()
mKPKEngines.InitEngines(Me.Handle.ToInt32, 1280, 1024)
End Sub
Private Sub InitGames()
mCharCols = 2
mCharRows = 2
bRndTreasurePos = True
bShowTreasure = False
End Sub
Private Sub InitChar()
mKPKChar.SetFileNameNormal("D:\Image Games\Treasure_Char_Normal_01.Bmp")
mKPKChar.SetFileNameMask("D:\Image Games\Treasure_Char_Mask_01.Bmp")
mKPKChar.SetCharWidth(mCharWidth)
mKPKChar.SetCharHeight(mCharHeight)
mKPKChar.InitCharNormal(mKPKEngines.GethDCBuffer)
mKPKChar.InitCharMask(mKPKEngines.GethDCBuffer)
End Sub
Private Sub InitTreasure()
mKPKTreasure.SetFileNameNormal("D:\Image Games\Treasure_01.Bmp")
mKPKTreasure.SetCharWidth(mTreasureWidth)
mKPKTreasure.SetCharHeight(mTreasureHeight)
mKPKTreasure.InitCharNormal(mKPKEngines.GethDCBuffer)
End Sub
Private Sub MainLoop()
mKPKEngines.BeginEngines()
Call DrawMaps()
' Calculation Columns And Rows
For Rows = 1 To mKPKMaps.GetMapsHeight
For Cols = 1 To mKPKMaps.GetMapsWidth
CColumns(Cols) = mMapsX + (Cols - 1) * 32
CRows(Rows) = mMapsY + (Rows - 1) * 32
Next Cols
Next Rows
mTreasureX = CColumns(mTreasureCols)
mTreasureY = CRows(mTreasureRows)
If bRndTreasurePos = True Then
mTreasureCols = CInt(Rnd() * mKPKMaps.GetMapsWidth)
mTreasureRows = CInt(Rnd() * mKPKMaps.GetMapsHeight)
If mTreasureCols <= 0 Then
mTreasureCols = 1
End If
If mTreasureRows <= 0 Then
mTreasureRows = 1
End If
If mKPKMaps.GetTileMoveState(mTreasureCols, mTreasureRows) = 1 Then
bRndTreasurePos = False
End If
End If
Me.Text = " Treasure Cols = " & mTreasureCols & " Treasure Rows = " & mTreasureRows
' Draw Treasure
If bShowTreasure = True Then
mKPKTreasure.SetCharX(mTreasureX)
mKPKTreasure.SetCharY(mTreasureY)
mKPKTreasure.DrawCharacters()
End If
mCharX = CColumns(mCharCols) - 2
mCharY = CRows(mCharRows) - 10
' Draw Char
mKPKChar.SetCharX(mCharX)
mKPKChar.SetCharY(mCharY)
mKPKChar.DrawCharactersTransparency()
mKPKEngines.EndEngines()
End Sub
Private Sub DrawMaps()
mKPKMaps.DrawMaps(mKPKEngines.GethDCBuffer, hMapsTiles)
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.Right
If mKPKMaps.GetTileMoveState(mCharCols + 1, mCharRows) = 1 Then
mCharCols = mCharCols + 1
End If
Case Keys.Left
If mKPKMaps.GetTileMoveState(mCharCols - 1, mCharRows) = 1 Then
mCharCols = mCharCols - 1
End If
Case Keys.Up
If mKPKMaps.GetTileMoveState(mCharCols, mCharRows - 1) = 1 Then
mCharRows = mCharRows - 1
End If
Case Keys.Down
If mKPKMaps.GetTileMoveState(mCharCols, mCharRows + 1) = 1 Then
mCharRows = mCharRows + 1
End If
Case Keys.Enter
If mCharCols <> mTreasureCols Or mCharRows <> mTreasureRows Then
bShowTreasure = False
MsgBox(" Can't Find Treasure ", MsgBoxStyle.Critical Or MsgBoxStyle.OkOnly, " VB.NET Treasure Games ")
End If
If mCharCols = mTreasureCols And mCharRows = mTreasureRows Then
bShowTreasure = True
MsgBox(" You Find Treasure ", MsgBoxStyle.Information Or MsgBoxStyle.OkOnly, " VB.NET Treasure Games ")
End If
End Select
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Randomize()
Call InitClass()
Call InitEngines()
Call InitMaps()
ReDim CColumns(mKPKMaps.GetMapsWidth)
ReDim CRows(mKPKMaps.GetMapsHeight)
Call InitGames()
Call InitChar()
Call InitTreasure()
Timer1.Interval = 1
Timer1.Enabled = True
End Sub
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
Call MainLoop()
End Sub
Private Sub Form1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Me.MouseDown
Select Case e.Button
Case Windows.Forms.MouseButtons.Right
If MsgBox(" Do you want to New Treasure Games? ", MsgBoxStyle.Question Or MsgBoxStyle.YesNo, " VB.NET Treasure Games ") = MsgBoxResult.Yes Then
Call InitGames()
End If
End Select
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
' 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 Overloads 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
Public Overloads Function LoadBitmaps(ByVal sFilename As String) As Integer
Dim tmphDC As Integer
Dim tmphBitmaps As Integer
tmphDC = CreateCompatibleDC(TmphBuffer)
tmphBitmaps = LoadImage(0, sFilename, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
SelectObject(tmphDC, tmphBitmaps)
DeleteObject(tmphBitmaps)
LoadBitmaps = tmphDC
End Function
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
' 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
' 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 Sub DrawMaps(ByVal hDest As Integer, ByVal hSrc As Integer)
For TmpRows = 1 To MapsHeight
For TmpCols = 1 To MapsWidth
BitBlt(hDest, strMaps(TmpCols, TmpRows).TilePosX, strMaps(TmpCols, TmpRows).TilePosY, _
strMaps(TmpCols, TmpRows).TileWidth, strMaps(TmpCols, TmpRows).TileHeight, _
hSrc, strMaps(TmpCols, TmpRows).TileX, strMaps(TmpCols, TmpRows).TileY, SRCCOPY)
Next TmpCols
Next TmpRows
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
ไม่มีความคิดเห็น:
แสดงความคิดเห็น