Вход на сайт
Аркада Win16 27.02.2025
863 просмотров
Перейти к просмотру всей ветки
в ответ uscheswoi_82 26.03.25 02:02
Вот код 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
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение