2D движок на VB 6.0 30.05.2025

Germany.ru → Группы → Дневник тяжелобольного инвалида

118

uscheswoi_82 патриот30.05.25 23:32

NEW 30.05.25 23:32

Последний раз изменено 30.05.25 23:36 (uscheswoi_82)

Всем привет!

Решил создать 2D движок на VB 6.0, чтобы создавать 2D игры.

Файл ctlSprite.ctl:

VERSION 5.00
Begin VB.UserControl Sprite 
   AutoRedraw      =   -1  'True
   ClientHeight    =   510
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   495
   ScaleHeight     =   34
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   33
   Begin VB.PictureBox picBackground 
      AutoRedraw      =   -1  'True
      BackColor       =   &H0000FFFF&
      BorderStyle     =   0  'None
      Height          =   495
      Left            =   3720
      ScaleHeight     =   33
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   41
      TabIndex        =   2
      Top             =   2040
      Visible         =   0   'False
      Width           =   615
   End
   Begin VB.Timer tmCollisionDetect 
      Left            =   960
      Top             =   1320
   End
   Begin VB.PictureBox picSpriteMask 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      Height          =   495
      Left            =   2880
      ScaleHeight     =   33
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   33
      TabIndex        =   1
      Top             =   2040
      Visible         =   0   'False
      Width           =   495
   End
   Begin VB.PictureBox picSprite 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      Height          =   495
      Left            =   1800
      ScaleHeight     =   33
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   41
      TabIndex        =   0
      Top             =   2040
      Visible         =   0   'False
      Width           =   615
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   0
      Picture         =   "ctlSprite.ctx":0000
      Top             =   0
      Width           =   480
   End
End
Attribute VB_Name = "Sprite"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private bInitSprite As Boolean 'Инициализация спрайта?
Private bInitBackground As Boolean 'Инициализация фона?
Private strSpriteFilename As String 'Имя файла спрайта
Private strMaskSpriteFilename As String 'Имя файла маски спрайта
Private strBackgroundFilename As String 'Имя файла фона
Private strSoundFileName As String 'Имя файла для проигрывания аудиофайла
Private strBackgroundMusic As String 'Фоновая музыка
Private intSpriteX As Integer 'Горизонтальная позиция спрайта
Private intSpriteY As Integer 'Вертикаальная позиция спрайта
Private intSpriteWidth As Integer 'Ширина спрайта
Private intSpriteHeight As Integer 'Высота спрайта
Private spr As Sprite 'Спрайт для определения колизии
Public Event Collision() 'Событие срабатывает когда произйдёт столкновение спрайтов
'Спрайт
Public Property Get SpriteFileName() As Variant
Attribute SpriteFileName.VB_Description = "Имя файла спрайта."
    SpritFileName = strSpriteFilename
End Property
Public Property Let SpriteFileName(ByVal vNewValue As Variant)
    strSpriteFilename = vNewValue
End Property
'Маска спрайта
Public Property Get MaskSpriteFileName() As Variant
Attribute MaskSpriteFileName.VB_Description = "Имя файла для маски. Фон маски должен быть чёрным, а то что отображается должно быть белым."
    MaskSpritFileName = strMaskSpriteFilename
End Property
Public Property Let MaskSpriteFileName(ByVal vNewValue As Variant)
    strMaskSpriteFilename = vNewValue
End Property
'Инициализация
Public Sub Init()
  bInitSprite = True
  bInitBackground = True
  If strSpriteFilename <> "" Then picSprite.Picture = LoadPicture(strSpriteFilename)
  If strMaskSpriteFilename <> "" Then picSpriteMask.Picture = LoadPicture(strMaskSpriteFilename)
  If strBackgroundFilename <> "" Then picBackground.Picture = LoadPicture(strBackgroundFilename)
  Image1.Visible = False
End Sub
'Простая отрисовка спрайта
Public Sub DrawSpriteAt(ByVal hdc As Long, ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, ByVal height As Integer)
  If bInitSprite = True Then
    picSprite.width = width
    picSprite.height = height
    picSpriteMask.width = width
    picSpriteMask.height = height
    bInitSprite = False
  End If
  BitBlt hdc, x, y, width, height, picSpriteMask.hdc, 0, 0, SRCPAINT
  BitBlt hdc, x, y, width, height, picSprite.hdc, 0, 0, SRCAND
  intX = x
  intY = y
End Sub
'Анимированная отрисовка спрайта
Public Sub DrawAnimatedSpriteAt(ByVal hdc As Long, ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, _
           ByVal height As Integer, ByVal sx As Integer, ByVal sy As Integer)
  If bInitSprite = True Then
    picSprite.width = width
    picSprite.height = height
    picSpriteMask.width = width
    picSpriteMask.height = height
    bInitSprite = False
  End If
  BitBlt hdc, x, y, width, height, picSpriteMask.hdc, sx, sy, SRCPAINT
  BitBlt hdc, x, y, width, height, picSprite.hdc, sx, sy, SRCAND
  intX = x
  intY = y
End Sub
'Фон
Public Sub DrawBackground(ByVal hdc As Long, ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, _
       ByVal height As Integer)
  If bInitBackground = True Then
    picBackground.width = width
    picBackground.height = height
    picBackground.width = width
    picBackground.height = height
    bInitBackground = False
  End If
  BitBlt hdc, x, y, width, height, picBackground.hdc, 0, 0, SRCCOPY
End Sub
Public Sub DrawBackgroundTiled(ByVal hdc As Long, ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, _
       ByVal height As Integer, ByVal sx As Integer, ByVal sy As Integer)
  If bInitBackground = True Then
    picBackground.width = width
    picBackground.height = height
    picBackground.width = width
    picBackground.height = height
    bInitBackground = False
  End If
  BitBlt hdc, x, y, width, height, picBackground.hdc, sx, sy, SRCCOPY
End Sub
'Звук
Public Property Get SoundFileName() As Variant
Attribute SoundFileName.VB_Description = "Имя файла для звука."
    SoundFileName = strSoundFileName
End Property
Public Property Let SoundFileName(ByVal vNewValue As Variant)
    strSoundFileName = vNewValue
End Property
'Проиграть звук
Public Sub PlaySound()
    sndPlaySound strSoundFileName, SND_FILENAME Or SND_ASYNC
End Sub
'Столкновение
Public Sub StartCollisionDetection(sp As Sprite)
    spr = sp
    tmCollisionDetect.Enabled = True
    tmCollisionDetect.Interval = 100
End Sub
Public Sub StopCollisionDetection()
    tmCollisionDetect.Enabled = False
End Sub
Private Sub tmCollisionDetect_Timer()
    MsgBox spr.SpriteX & " " & spr.SpriteY & " " & spr.SpriteWidth & " " & spr.SpriteHeight
    RaiseEvent Collision
    'Exit Sub
    If intSpriteX + intSpriteWidth > spr.SpriteX And _
       intSpriteX < spr.SpriteX + spr.SpriteWidth And _
       intSpriteX + intSpriteHeight > spr.SpriteY And _
       intSpriteY < spr.SpriteY + spr.SpriteHeight Then
            RaiseEvent Collision
    End If
End Sub
'Инициализация
Private Sub UserControl_Initialize()
    tmCollisionDetect.Interval = 0
    tmCollisionDetect.Enabled = False
End Sub
'Позиция спрайта
Public Property Get SpriteX() As Variant
Attribute SpriteX.VB_Description = "Горизонтальная позиция спрайта."
    SpriteX = intSpriteX
End Property
Public Property Get SpriteY() As Variant
Attribute SpriteY.VB_Description = "Вертикальная позиция спрайта."
    SpriteY = intSpriteY
End Property
'Размеры спрайта
Public Property Get SpriteWidth() As Variant
Attribute SpriteWidth.VB_Description = "Ширина спрайта."
    SpriteWidth = intSpriteWidth
End Property
Public Property Get SpriteHeight() As Variant
Attribute SpriteHeight.VB_Description = "Высота спрайта."
    SpriteHeight = intSpriteHeight
End Property
'Фон
Public Property Get BackgroundFileName() As Variant
    BackgroundFileName = strBackgroundFilename
End Property
Public Property Let BackgroundFileName(ByVal vNewValue As Variant)
    strBackgroundFilename = vNewValue
End Property

Файл modMain.bas:

Attribute VB_Name = "modMain"
Public Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Public Const SRCERASE = &H440328        ' (DWORD) dest = source AND (NOT dest )
Public Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR dest
Public Const SRCPAINT = &HEE0086        ' (DWORD) dest = source OR dest
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
                                            ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Const SND_ASYNC = &H1         '  play asynchronously
Public Const SND_FILENAME = &H20000     '  name is a file name
Public Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound
Public Const SND_MEMORY = &H4         '  lpszSoundName points to a memory file
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

файл frmIcon.frm:

VERSION 5.00
Begin VB.Form frmIcon 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   Icon            =   "frmIcon.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Visible         =   0   'False
End
Attribute VB_Name = "frmIcon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Файл readme.txt:

Для спрайта
Sprite1.SpriteFileName = "sprite.bmp"
Sprite1.MaskSpriteFileName = "sprite_mask.bmp"
Sprite1.Init


Для рисования спрайта
Sprite1.DrawSpriteAt Me.hDC, 1, 1, 40, 40


Для рисования анимированного спрайта
sprite1.DrawAnimatedSpriteAt 


Для фона 
SpriteBackground.Visible = False
SpriteBackground.BackgroundFileName = "bg.bmp"
SpriteBackground.Init


Для отображение фона
SpriteBackground.DrawBackground hDC, 0, 0, 640, 480


Для фона tiled
SpriteBackground.DrawBackgroundTiled 


Для проигрывания звука
Sprite1.SoundFileName = "gun_shot.wav"
Sprite1.Init
Sprite1.PlaySound


Для очистки экрана нужно использовать 
Me.Cls

Обработка клавиш нужно делать так:

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyLeft:
        Debug.Print "Нажали клавишу влево"
    Case vbKeyRight:
        Debug.Print "Нажали клавишу вправо"
    Case vbKeyDown:
        Debug.Print "Нажали клавишу вниз"
    Case vbKeyUp:
        Debug.Print "Нажали клавишу вверх"
    Case vbKeyReturn:
        Debug.Print "Нажали клавишу Enter"
    Case vbKeySpace:
        Debug.Print "Нажали клавишу пробел"
    End Select
End Sub

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

uscheswoi_82 патриот30.05.25 23:39

30.05.25 23:39

в ответ uscheswoi_82 30.05.25 23:32

Файл GameEngine.vbp:

Type=Control
UserControl=ctlSprite.ctl
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\WINNT\System32\stdole2.tlb#OLE Automation
Form=frmIcon.frm
Module=modMain; modMain.bas
IconForm="frmIcon"
Startup="(None)"
HelpFile=""
Title="GameEngine"
ExeName32="GameEngine.ocx"
Command32=""
Name="GameEngine"
HelpContextID="0"
CompatibleMode="1"
CompatibleEXE32="GameEngine.ocx"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=1
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
ThreadingModel=1
DebugStartupOption=1
DebugStartupComponent=Sprite


[MS Transaction Server]
AutoRefresh=1

Файл GameEngine.vbw:

Sprite = 154, 154, 1378, 644, Z, 32, 22, 1246, 512, C
frmIcon = 0, 0, 0, 0, C, 66, 66, 1290, 556, C
modMain = 176, 176, 1400, 666,

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

uscheswoi_82 патриот30.05.25 23:51

NEW 30.05.25 23:51

в ответ uscheswoi_82 30.05.25 23:39

Пример

Файл frmMain.frm:

VERSION 5.00
Object = "{117023D9-0FFE-49F3-8203-5B62AA0043FF}#34.0#0"; "GameEngine.ocx"
Begin VB.Form frmMain 
   Caption         =   "Form1"
   ClientHeight    =   3840
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5205
   LinkTopic       =   "Form1"
   ScaleHeight     =   256
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   347
   StartUpPosition =   3  'Windows Default
   Begin VB.Timer tmTimer2 
      Left            =   960
      Top             =   1800
   End
   Begin VB.CommandButton cmdGo 
      Caption         =   "&Go"
      Height          =   495
      Left            =   3960
      TabIndex        =   1
      Top             =   3240
      Width           =   1095
   End
   Begin VB.Timer tmTimer 
      Left            =   2280
      Top             =   600
   End
   Begin GameEngine.Sprite Sprite1 
      Height          =   495
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   495
      _ExtentX        =   873
      _ExtentY        =   873
   End
   Begin GameEngine.Sprite Sprite2 
      Height          =   495
      Left            =   720
      TabIndex        =   2
      Top             =   0
      Width           =   495
      _ExtentX        =   873
      _ExtentY        =   873
   End
   Begin GameEngine.Sprite SpriteBackground 
      Height          =   495
      Left            =   1320
      TabIndex        =   3
      Top             =   0
      Width           =   495
      _ExtentX        =   873
      _ExtentY        =   873
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim x1 As Integer


Private Sub cmdGo_Click()
    Me.tmTimer.Enabled = True
    Me.tmTimer.Interval = 100
    Me.tmTimer2.Enabled = True
    Me.tmTimer2.Interval = 1000
    x1 = 10
End Sub

Private Sub Form_Load()
    Sprite1.Visible = False
    Sprite1.SpriteFileName = "C:\GAMEENGINE\TEST\audio.bmp"
    Sprite1.MaskSpriteFileName = "C:\GAMEENGINE\TEST\audio_mask2.bmp"
    Sprite1.SoundFileName = "C:\GAMEENGINE\TEST\ding.wav"
    Sprite1.Init
    
    Sprite2.Visible = False
    Sprite2.SpriteFileName = "C:\GAMEENGINE\TEST\audio.bmp"
    Sprite2.MaskSpriteFileName = "C:\GAMEENGINE\TEST\audio_mask2.bmp"
    Sprite2.SoundFileName = "C:\GAMEENGINE\TEST\ding.wav"
    Sprite2.Init
    
    SpriteBackground.Visible = False
    SpriteBackground.BackgroundFileName = "C:\GAMEENGINE\TEST\bg.bmp"
    SpriteBackground.Init
    'Sprite1.StartCollisionDetection Sprite2
End Sub

Private Sub Sprite1_Collision()
    Sprite1.StopCollisionDetection
    Me.tmTimer.Enabled = False
    Me.tmTimer2.Enabled = False
    MsgBox "YES!"
End Sub

Private Sub tmTimer_Timer()
    x1 = x1 + 1
    Me.Cls
    SpriteBackground.DrawBackground hDC, 0, 0, 283, 212
    Sprite2.DrawSpriteAt Me.hDC, 50, 10, 40, 40
    Sprite1.DrawSpriteAt Me.hDC, x1, 10, 40, 40
End Sub

Private Sub tmTimer2_Timer()
    Sprite1.PlaySound
End Sub

Файл Test.vbp:

Type=Exe
Form=frmMain.frm
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\WINNT\System32\stdole2.tlb#OLE Automation
Object={117023D9-0FFE-49F3-8203-5B62AA0043FF}#34.0#0; GameEngine.ocx
IconForm="frmMain"
Startup="frmMain"
Command32=""
Name="Test"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1


[MS Transaction Server]
AutoRefresh=1

Файл Test.vbw:

frmMain = 44, 44, 1268, 534, , 154, 154, 1378, 644, C

Результат работы:

Ссылка на видео со звуком как работает 2D движок см. https://my.mail.ru/mail/semyon_kulikov/video/_myvideo/118....

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

список вперед