Deutsch

Аркада Win16 27.02.2025

26.03.25 02:06
Re: Аркада Win16 27.02.2025
 
uscheswoi_82 патриот

Вот код frmmain.frm:

VERSION 4.00
Begin VB.Form frmGame 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Balloons v1.0 Score:0"
   ClientHeight    =   3600
   ClientLeft      =   1020
   ClientTop       =   1830
   ClientWidth     =   4800
   Height          =   4335
   Left            =   960
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MouseIcon       =   "FRMGAME.frx":0000
   Picture         =   "FRMGAME.frx":0152
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   Top             =   1155
   Width           =   4920
   Begin VB.Timer tmTimer 
      Left            =   1680
      Top             =   2760
   End
   Begin VB.PictureBox picBalloonsSprite 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   1095
      Index           =   1
      Left            =   2640
      Picture         =   "FRMGAME.frx":97D4
      ScaleHeight     =   73
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   159
      TabIndex        =   1
      Top             =   1080
      Visible         =   0   'False
      Width           =   2385
   End
   Begin VB.PictureBox picBalloonsSprite 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   1095
      Index           =   0
      Left            =   2280
      Picture         =   "FRMGAME.frx":AF26
      ScaleHeight     =   73
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   159
      TabIndex        =   0
      Top             =   2040
      Visible         =   0   'False
      Width           =   2385
   End
   Begin VB.Label lbBad 
      Appearance      =   0  'Flat
      BackColor       =   &H00FFFF00&
      ForeColor       =   &H80000008&
      Height          =   135
      Left            =   0
      TabIndex        =   8
      Top             =   0
      Width           =   4815
   End
   Begin VB.Label lbBalloon 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   5
      Left            =   3480
      TabIndex        =   7
      Top             =   360
      Width           =   255
   End
   Begin VB.Label lbBalloon 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   4
      Left            =   3240
      TabIndex        =   6
      Top             =   360
      Width           =   255
   End
   Begin VB.Label lbBalloon 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   3
      Left            =   3000
      TabIndex        =   5
      Top             =   360
      Width           =   255
   End
   Begin VB.Label lbBalloon 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   2
      Left            =   2760
      TabIndex        =   4
      Top             =   360
      Width           =   255
   End
   Begin VB.Label lbBalloon 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   1
      Left            =   2520
      TabIndex        =   3
      Top             =   360
      Width           =   255
   End
   Begin VB.Label lbBalloon 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   0
      Left            =   2280
      TabIndex        =   2
      Top             =   360
      Width           =   255
   End
   Begin VB.Menu mnuGame 
      Caption         =   "&Game"
      Begin VB.Menu popupNewGame 
         Caption         =   "&New Game"
      End
      Begin VB.Menu popupNone 
         Caption         =   "-"
      End
      Begin VB.Menu popupQuit 
         Caption         =   "&Quit"
      End
   End
End
Attribute VB_Name = "frmGame"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Const BALLOONS_CNT As Integer = 5
Const BALLOON_WIDTH As Integer = 25
Const BALLOON_HEIGHT As Integer = 73
Dim Scores As Integer

'Инициализация игры
'Уставливает ширину и
'высоту воздушных шариков,
'а так-же прячет рамк
Private Sub init()
    For i = 0 To BALLOONS_CNT
        lbballoon(i).Width = BALLOON_WIDTH
        lbballoon(i).Height = BALLOON_HEIGHT
        lbballoon(i).BorderStyle = 0
    Next i
End Sub

'https://foren.germany.ru/showmessage.pl?Number=41256230&
'Board=12994140000001&Cat=&page=&view=&sb=#Post41256230
'Рисование воздушных шариков
Private Sub Load_Ballon(ByVal Index As Integer, ByVal shiftx As Integer)
  Dim idx As Integer
  Dim i As Integer
  For i = 0 To Index
    idx = idx + shiftx
  Next i
  Me.Cls
  BitBlt Me.hDC, idx, 0, 25, 79, picBalloonsSprite(1).hDC, _
  lbballoon(Index).Left, lbballoon(Index).Top, SRCPAINT
  BitBlt Me.hDC, idx, 0, 25, 79, picBalloonsSprite(0).hDC, _
  lbballoon(Index).Left, lbballoon(Index).Top, SRCAND
  Me.Refresh
End Sub

'При загрузки формы
Private Sub Form_Load()
  Dim i As Integer
  Dim res As Integer
  
  tmTimer.Enabled = False 'Отключает таймер
  tmTimer.Interval = 0 'Устанавливает таймеру интервал 0
  'Прячет воздушные шарики
  For i = 0 To BALLOONS_CNT
    lbballoon(i).Visible = False
  Next i
End Sub

'Если нажали на шарик мышкой
Private Sub lbballoon_Click(Index As Integer)
    'https://groups.germany.ru/12994140000001/f
    '/41567213.html?Cat=&page=0&view=collapsed&sb=5
    'Проигрывает звук лопующего воздушного шарика
    sndPlaySound App.Path & "\pop.wav", SND_ASYNC
    'Увеличиваем очки на 1
    Scores = Scores + 1
    'Перемещаем воздушный шарик
    lbballoon(Index).Left = Int((BALLOON_WIDTH + 20) + Rnd * Me.ScaleWidth)
    lbballoon(Index).Top = Int(Me.ScaleHeight + BALLOON_HEIGHT + Rnd * _
    (Me.ScaleHeight + BALLOON_HEIGHT + 100))
'    Load_Ballon Index, Index
End Sub

'Новая игра
Private Sub popupNewGame_Click()
    Dim i As Integer
    Randomize Timer
    Dim idx As Integer
    'Показывает воздушные шарики, 
    'устанвливает позицию всех 
    'воздушных шариков
    For i = 0 To BALLOONS_CNT
      lbballoon(i).Visible = True
      lbballoon(i).Top = -80
      idx = Int(Rnd * BALLOONS_CNT)
      'Load_Ballon idx, idx
      lbballoon(i).Left = Int(10 + Rnd * Me.ScaleWidth - 40)
      lbballoon(i).Top = Int(210 + Rnd * 400)
    Next i

  tmTimer.Enabled = True 'Активирует таймер
  tmTimer.Interval = 100 'Устанавливает интервал таймера
End Sub


'Закрывает приложение
Private Sub popupQuit_Click()
  Unload Me
End Sub


'Таймер запускается во время игры
Private Sub tmTimer_Timer()
    Dim i As Integer
    For i = 0 To BALLOONS_CNT
        'Если воздушный шарик находится
        'возле лейбла lbBad.Top, то заканчивается
        'игра, короче игрок проиграл
        If lbballoon(i).Top <= lbBad.Top Then
            Me.Caption = "Balloons v1.0 Score " _ &
            Scores & " Game Over"
            tmTimer.Enabled = False
            Exit Sub
        End If

        'Поднимает шарики вверх  
        lbballoon(i).Top = lbballoon(i).Top - 5
        Load_Ballon i, 0
    Next i
    'Отображает сколько очков
    Me.Caption = "Balloons v1.0 Score:" & _
    Scores
End Sub



Вот код modMain.bas:

Attribute VB_Name = "modMainAPI"
'Модуль нужен для отображение воздушных шариков 
'а так-же для проигрывания аудио файла лопоющегося
'воздушного шарика
Public Declare Function BitBlt Lib "GDI" (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 Long) As Integer
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 sndPlaySound Lib "MMSYSTEM" (ByVal lpszSoundName As String, _
ByVal uFlags As Integer) As Integer
Public Const SND_ASYNC = &H1                '  Asynchrones Abspielen
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
 

Перейти на