Login
Аркада Win16 27.02.2025
844
NEW 27.02.25 12:33
Всем привет! Попытаюсь сделать стрелялку на Visual Basic 4.0 под архитектуру Win16 для Windows 3.1. Но ничего не обещаю.
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
27.02.25 12:43
in Antwort uscheswoi_82 27.02.25 12:33
В г. Алматы я сидел всё время дома, и занимался дизайном игры. Вот это я рисовал перед отъездом в Германию. Рисовал это всё я в обычном Paint Brush-е ну или в Microsoft Paint:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 12:49
in Antwort uscheswoi_82 27.02.25 12:43
Сегодня я где-то 2 часа потратил чтобы сделать это всё сделать в программе Blender 2.79. Это то, что у меня получилось:
Это оригинальный скрин:
Покуда в графической оболочки Windows 3.1 чаще всего максимум 16 цветов, поэтому было уменьшено до 16 цветов:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 13:06
in Antwort uscheswoi_82 27.02.25 12:49
Короче из окон должен появлятся слкчайно чувaчёк или одновременно несколько чувачкoв, , по которым нужно было cтрeлять. Когда попадаешь, получаешь oчки. Я рисовал чyвочка с ceбя, мoя мaть в Гepмaнии купила видеокамеру Panasonic и фотоаппарат Canon, я фотол сeбя спомощью видеокамеры Panasonic, дело в том, что камера подключалась через COM-порт, и сохраняла фотографии в формате JPEG на SD-карту:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 13:15
in Antwort uscheswoi_82 27.02.25 13:06
Потом я уменьшил чувочка:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 13:18
in Antwort uscheswoi_82 27.02.25 13:15
Вот код на Visual Basic 6.0, да я использовал DirectX 7, см (27.11.2003 17:35):
Option Explicit
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Const SND_ASYNC = &H1 ' play asynchronously
Const SND_SYNC = &H0 ' play synchronously (default)
Dim i As Long, n As Long, res As Long
Dim what_cols(10) As Boolean
Dim col As Long, curr As Long
Dim scores As Long, Lives As Long
Dim ObjDx As DirectX7
Dim ObjDraw As DirectDraw7
Private Sub Form_Load()
Dim j As Long
Set ObjDx = New DirectX7
Set ObjDraw = ObjDx.DirectDrawCreate("")
ObjDraw.SetCooperativeLevel frmLevel0.hWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE
ObjDraw.SetDisplayMode 640, 480, 16, 0, DDSDM_DEFAULT
Lives = 5
Me.Picture = LoadPicture(App.Path & "\bgpic.img")
Me.MouseIcon = Me.picCursor.Picture
For j = 0 To Me.PictWindows.Count - 1
Me.PictWindows(j).Visible = True
Me.PictWindows(j).Picture = Me.picWindow
Me.PictWindows(j).MouseIcon = Me.picCursor.Picture
what_cols(j) = False
Next j
col = 1
Timer1.Interval = 1000
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
sndPlaySound App.Path & "\gunshot.wav", SND_ASYNC
Me.PSet (X, Y), vbBlack
Me.PSet (X + 1, Y), vbBlack
Me.PSet (X, Y + 1), vbBlack
Me.PSet (X + 1, Y + 1), vbBlack
scores = scores - 10
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer2.Enabled = False
End Sub
Private Sub lbClose_Click()
Unload Me
End Sub
Private Sub PictWindows_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim j As Long
sndPlaySound App.Path & "\gunshot.wav", SND_ASYNC
If what_cols(Index) = True Then
scores = scores + 10
Timer2.Enabled = False
Else
scores = scores - 10
End If
For j = 0 To Me.PictWindows.Count - 1
Me.PictWindows(j).Visible = True
Me.PictWindows(j).Picture = Me.picWindow
Me.PictWindows(j).MouseIcon = Me.picCursor.Picture
Next j
End Sub
Private Sub PictWindows_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer2.Enabled = True
Timer2.Interval = Timer1.Interval + 100
curr = Index
End Sub
Private Sub PictWindows_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim j As Long
For j = 0 To Me.PictWindows.Count - 1
what_cols(j) = False
Next j
End Sub
Private Sub Timer1_Timer()
Dim j As Long
For j = 0 To Me.PictWindows.Count - 1
Me.PictWindows(j).Visible = True
Me.PictWindows(j).Picture = Me.picWindow
Me.PictWindows(j).MouseIcon = Me.picCursor.Picture
Next j
For i = 1 To col
res = Int(Rnd * 9)
Me.PictWindows(res) = Me.picSoldat.Picture
what_cols(res) = True
Next i
For j = 0 To 5000
Sin 0.5
Timer1.Enabled = False
Next j
Timer1.Enabled = True
Me.Label1.Caption = "Очки:" & scores & " Жизней:" & Lives
End Sub
Private Sub Timer2_Timer()
Dim j As Long
Me.PictWindows(res).Picture = Me.picSoldat.Picture
Timer2.Enabled = False
sndPlaySound App.Path & "\explode.wav", SND_ASYNC
Me.PictWindows(res) = Me.picSoldatFire.Picture
Lives = Lives - 1
End SubЕсли я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 13:25
in Antwort uscheswoi_82 27.02.25 13:18
Игру я назвал стрелок. Вот такое скронмное меню должно было быть:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 13:39
in Antwort uscheswoi_82 27.02.25 13:25
Это полигинальная сетка, я 2 часа потратил на эту 3D модель чтобы нарисовать в Blender-е 2.79 (дом, луну, автомобиль, и 2 фонаря):
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 16:29
in Antwort uscheswoi_82 27.02.25 13:39
Я переделал игру тараканьи бега см. Тараканьи бега 09.05.2024 под Win16 / Windows 3.11. Писал на Visual Basic 4.0 :
Вот так выглядет проект:
Вот так выглядет диалоговое окно игры:
Алгоритм frmGame.frm:
Attribute VB_Name = "frmGame"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim stavka_tarakan As Integer
Const cnt_tarakany As Integer = 5
Private Sub cmdStart_Click()
On Error Resume Next
Do While Not (stavka_tarakan >= 1 And stavka_tarakan <= 6)
stavka_tarakan = CInt(InputBox("Which tarakan (1-6)?"))
Loop
lbTarakan(stavka_tarakan).ForeColor = vbRed
cmdStart.Enabled = False
cmdStop.Enabled = True
tmTimer.Enabled = True
tmTimer.Interval = 100
End Sub
Private Sub cmdStop_Click()
Dim i As Integer
tmTimer.Enabled = False
tmTimer.Interval = 0
For i = 0 To cnt_tarakany
lbTarakan(i).Left = 8
lbTarakan(i).ForeColor = vbBlack
Next i
stavka_tarakan = 0
End Sub
Private Sub Form_Load()
Randomize Timer
cmdStart.Enabled = False
cmdStop.Enabled = False
End Sub
Private Sub popupAbout_Click()
MsgBox "Author uscheswoi_82", vbOKOnly + vbInformation
End Sub
Private Sub popupNewGame_Click()
tmTimer.Enabled = False
cmdStart.Enabled = True
cmdStop.Enabled = True
tarakan_stavka = 0
End Sub
Private Sub popupQuit_Click()
Unload Me
End Sub
Private Sub tmTimer_Timer()
Dim i As Integer
For i = 0 To cnt_tarakany
Move_Tarakan lbTarakan(i), Int((10 * Rnd()) + 1)
If get_position_tarakan(lbTarakan(i)) >= lbFinish.Left Then
If stavka_tarakan = i Then
tmTimer.Interval = 0
tmTimer.Enabled = False
MsgBox "You Won!"
Exit Sub
Else
tmTimer.Interval = 0
tmTimer.Enabled = False
MsgBox "You Lose!"
Exit Sub
End If
End If
Next i
End Sub
Алгоритм modMain.bas:
Attribute VB_Name = "modMain"
Public Function get_position_tarakan(tarakan_id As Label)
get_position_tarakan = tarakan_id.Left
End Function
Public Sub Move_Tarakan(id As Label, step As Integer)
id.Left = id.Left + step
End Sub
Вуаля! А вот так игра работает:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 27.02.25 17:40
in Antwort uscheswoi_82 27.02.25 16:29
Я улучшил картинку для игры "Cтpeлок". Внизу теперь отражается свет.
Это картинка примерно 2003 г. Делал в обычном Paint Brush-е, ну или Paint-е:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 28.02.25 19:17
in Antwort uscheswoi_82 27.02.25 17:40
Короче сделал я стрелялку простую.
Вот код frmmain.frm:
VERSION 4.00
Begin VB.Form frmKiller
BackColor = &H00000000&
Caption = "Killer"
ClientHeight = 7200
ClientLeft = 1005
ClientTop = 1815
ClientWidth = 9600
Height = 7935
Left = 945
LinkTopic = "Form1"
MouseIcon = "FRMKILLE.frx":0000
MousePointer = 99 'Custom
Picture = "FRMKILLE.frx":0152
ScaleHeight = 480
ScaleMode = 3 'Pixel
ScaleWidth = 640
Top = 1140
Width = 9720
Begin VB.PictureBox picNN
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 495
Left = 3240
Picture = "FRMKILLE.frx":1C3D4
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 21
Top = 5640
Visible = 0 'False
Width = 285
End
Begin VB.PictureBox picK1
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 495
Left = 3840
Picture = "FRMKILLE.frx":1C5E2
ScaleHeight = 495
ScaleWidth = 285
TabIndex = 20
Top = 5640
Visible = 0 'False
Width = 285
End
Begin VB.PictureBox picK0
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 495
Left = 4320
Picture = "FRMKILLE.frx":1CDE0
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 19
Top = 5640
Visible = 0 'False
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 17
Left = 6750
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 18
Top = 3120
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 16
Left = 5790
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 17
Top = 3120
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 15
Left = 4815
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 16
Top = 3120
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 14
Left = 3840
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 15
Top = 3120
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 13
Left = 2880
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 14
Top = 3120
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 12
Left = 1920
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 13
Top = 3120
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 11
Left = 6750
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 12
Top = 2160
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 10
Left = 5790
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 11
Top = 2160
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 9
Left = 4815
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 10
Top = 2160
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 8
Left = 3840
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 9
Top = 2160
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 7
Left = 2880
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 8
Top = 2160
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 6
Left = 1920
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 7
Top = 2160
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 5
Left = 6750
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 6
Top = 1200
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 4
Left = 5790
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 5
Top = 1200
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 3
Left = 4815
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 4
Top = 1200
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 2
Left = 3840
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 3
Top = 1200
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 1
Left = 2880
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 2
Top = 1200
Width = 285
End
Begin VB.PictureBox picKiller
AutoRedraw = -1 'True
BackColor = &H0000FFFF&
BorderStyle = 0 'None
Height = 495
Index = 0
Left = 1920
ScaleHeight = 33
ScaleMode = 3 'Pixel
ScaleWidth = 19
TabIndex = 1
Top = 1200
Width = 285
End
Begin VB.Timer tmTimerScore
Left = 5160
Top = 5640
End
Begin VB.Timer tmTimer
Left = 5640
Top = 5640
End
Begin VB.Label lbScore
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Scores:0 Lives:5"
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 13.5
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 360
Left = 120
TabIndex = 0
Top = 5640
Width = 2310
End
Begin VB.Menu mnuGame
Caption = "&Game"
Begin VB.Menu popupNewGame
Caption = "&New game"
Shortcut = ^N
End
Begin VB.Menu popupQuit
Caption = "&Quit"
Shortcut = ^Q
End
End
Begin VB.Menu mnuHelp
Caption = "&Help"
Begin VB.Menu popupAbout
Caption = "&About..."
End
End
End
Attribute VB_Name = "frmKiller"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim intScores As Integer
Dim intLives As Integer
Dim intKillerWindows As Integer
Const cintWindows As Integer = 17
'Показывает киллера
Private Sub show_killer()
Dim i As Integer
'Прячим все окошки
For i = 0 To cintWindows
picKiller(i).Picture = picNN.Picture
Next i
intKillerWindows = Int((cintWindows * Rnd()) + 1) 'Ищет случайное окошко в здание от 17 до 1
picKiller(intKillerWindows).Picture = picK0 'Отображает спрайт киллера в окошке в здание
tmTimer.Enabled = True 'Таймет запускаем чтобы киллер застрелил
tmTimer.Interval = 2000
End Sub
'Показывает стреляющего киллера, если пользователь промазал
Private Sub show_killed()
picKiller(intKillerWindows).Picture = picK1.Picture 'В окошко в здание добавляем спрайт киллера который стрелят
sndPlaySound App.Path & "\explode.wav", SND_ASYNC 'Проигрывает звук взрыва
'Если жизней ещё больше 0, то вычитаем жизнь
If intLives > 0 Then
intLives = intLives - 1
End If
tmTimer.Enabled = False
End Sub
Private Sub Form_Load()
Randomize Timer
Dim i As Integer
tmTimer.Enabled = False
tmTimer.Interval = 0
tmTimerScore.Enabled = True
tmTimerScore.Interval = 100
'Окошки в здание чёрного цвета
For i = 0 To cintWindows
picKiller(i).BackColor = vbBlack
Next i
End Sub
'Если пользователь нажал на окошки
Private Sub picKiller_Click(Index As Integer)
tmTimer.Enabled = False 'Останавливаем таймер
'Если пользователь попад в окошко где находится киллер
If intKillerWindows = Index Then
intScores = intScores + 10
picKiller(Index).Picture = picNN.Picture
Else
If intLives > 0 Then
intLives = intLives - 1
End If
End If
sndPlaySound App.Path & "\gunshot.wav", SND_ASYNC 'Проигрывает звук выстрела из пистолета
show_killer 'Показывает спрайт киллера
End Sub
Private Sub popupAbout_Click()
MsgBox "Author uscheswoi_82", vbOKOnly + vbInformation
End Sub
Private Sub popupNewGame_Click()
intScores = 0
intLives = 5
intKillerWindows = -1
'Показывает киллера в случайном окошке в здание
show_killer
End Sub
Private Sub popupQuit_Click()
Unload Me
End Sub
'Таймер для отображение киллера
Private Sub tmTimer_Timer()
show_killed 'Показываем киллера
int_lives = int_lives - 1 'Вычитаем жизнь
End Sub
'Таймер для отображение очков и жизний
Private Sub tmTimerScore_Timer()
Me.lbScore.Caption = "Score:" & intScores & " Lives:" & intLives
End Sub
Вот код modmain.bas:
Attribute VB_Name = "modMain" Public Const SND_ASYNC = &H1 ' Asynchrones Abspielen Public Declare Function sndPlaySound Lib "MMSYSTEM" (ByVal lpszSoundName As String, ByVal uFlags As Integer) As Integer
Вот так выглядет проект:
Вуаля! А вот и результат...
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 01.03.25 07:51
in Antwort uscheswoi_82 28.02.25 19:17
Вот так игра работает со звуком https://my.mail.ru/mail/semyon_kulikov/video/_myvideo/72.h..., а это игра тараканы https://my.mail.ru/mail/semyon_kulikov/video/_myvideo/73.h....
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 01.03.25 08:07
in Antwort uscheswoi_82 01.03.25 07:51
Полный код frmgame.frm:
VERSION 4.00
Begin VB.Form frmGame
BorderStyle = 1 'Fixed Single
Caption = "Tarakany 1.0"
ClientHeight = 3600
ClientLeft = 1590
ClientTop = 2955
ClientWidth = 4800
Height = 4335
Icon = "FRMGAME.frx":0000
Left = 1530
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 240
ScaleMode = 3 'Pixel
ScaleWidth = 320
Top = 2280
Width = 4920
Begin VB.Timer tmTimer
Enabled = 0 'False
Left = 3720
Top = 2640
End
Begin VB.Label lbFinish
BackStyle = 0 'Transparent
Height = 1935
Left = 4320
TabIndex = 8
Top = 120
Width = 135
End
Begin Threed.SSCommand cmdStop
Height = 495
Left = 1680
TabIndex = 7
Top = 2280
Width = 1455
_version = 65536
_extentx = 2566
_extenty = 873
_stockprops = 78
caption = "S&top"
End
Begin Threed.SSCommand cmdStart
Height = 495
Left = 120
TabIndex = 6
Top = 2280
Width = 1455
_version = 65536
_extentx = 2566
_extenty = 873
_stockprops = 78
caption = "&Start"
End
Begin VB.Label lbTarakan
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "x"
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 12
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 300
Index = 5
Left = 120
TabIndex = 5
Top = 1800
Width = 135
End
Begin VB.Label lbTarakan
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "x"
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 12
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 300
Index = 4
Left = 120
TabIndex = 4
Top = 1380
Width = 135
End
Begin VB.Label lbTarakan
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "x"
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 12
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 300
Index = 3
Left = 120
TabIndex = 3
Top = 1020
Width = 135
End
Begin VB.Label lbTarakan
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "x"
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 12
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 300
Index = 2
Left = 120
TabIndex = 2
Top = 690
Width = 135
End
Begin VB.Label lbTarakan
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "x"
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 12
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 300
Index = 1
Left = 120
TabIndex = 1
Top = 390
Width = 135
End
Begin VB.Label lbTarakan
Appearance = 0 'Flat
AutoSize = -1 'True
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "x"
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 12
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 300
Index = 0
Left = 120
TabIndex = 0
Top = 105
Width = 135
End
Begin VB.Shape Shape1
BackColor = &H00004080&
BackStyle = 1 'Opaque
BorderStyle = 0 'Transparent
Height = 1935
Left = 120
Top = 120
Width = 4455
End
Begin VB.Menu mnuGame
Caption = "&Game"
Begin VB.Menu popupNewGame
Caption = "&New game"
End
Begin VB.Menu n1
Caption = "-"
End
Begin VB.Menu popupQuit
Caption = "&Quit"
End
End
Begin VB.Menu mnuHelp
Caption = "&Help"
Begin VB.Menu popupRules
Caption = "&Rules"
Shortcut = {F1}
End
Begin VB.Menu N2
Caption = "-"
End
Begin VB.Menu popupAbout
Caption = "&About..."
End
End
End
Attribute VB_Name = "frmGame"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim stavka_tarakan As Integer
Const cnt_tarakany As Integer = 5
Private Sub cmdStart_Click()
On Error Resume Next
Do While Not (stavka_tarakan >= 1 And stavka_tarakan <= 6)
stavka_tarakan = CInt(InputBox("Which tarakan (1-6)?"))
Loop
lbTarakan(stavka_tarakan).ForeColor = vbRed
cmdStart.Enabled = False
cmdStop.Enabled = True
tmTimer.Enabled = True
tmTimer.Interval = 100
End Sub
Private Sub cmdStop_Click()
Dim i As Integer
tmTimer.Enabled = False
tmTimer.Interval = 0
For i = 0 To cnt_tarakany
lbTarakan(i).Left = 8
lbTarakan(i).ForeColor = vbBlack
Next i
stavka_tarakan = 0
End Sub
Private Sub Form_Load()
Randomize Timer
cmdStart.Enabled = False
cmdStop.Enabled = False
End Sub
Private Sub popupAbout_Click()
MsgBox "Author uscheswoi_82", vbOKOnly + vbInformation
End Sub
Private Sub popupNewGame_Click()
tmTimer.Enabled = False
cmdStart.Enabled = True
cmdStop.Enabled = True
tarakan_stavka = 0
End Sub
Private Sub popupQuit_Click()
Unload Me
End Sub
Private Sub tmTimer_Timer()
Dim i As Integer
For i = 0 To cnt_tarakany
Move_Tarakan lbTarakan(i), Int((10 * Rnd()) + 1)
If get_position_tarakan(lbTarakan(i)) >= lbFinish.Left Then
If stavka_tarakan = i Then
tmTimer.Interval = 0
tmTimer.Enabled = False
MsgBox "You Won!"
Exit Sub
Else
tmTimer.Interval = 0
tmTimer.Enabled = False
MsgBox "You Lose!"
Exit Sub
End If
End If
Next i
End Sub
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 21.03.25 02:01
in Antwort uscheswoi_82 01.03.25 08:07
Я курсор прицел улучшил.
Кстати я скоро займусь новым уровнем, в игре про террористов было два уровня, второй был таким, это я рисовал 27.11.2003 г.:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 21.03.25 23:55
in Antwort uscheswoi_82 21.03.25 02:01
Короче идеи не было посоветовался с дpyзьями и poдителями, они сказали чтобы я нарисовал, кактус, многоэтажный дом, одноэтажный домик, трактор, дорогу, солнце, тучки, это типа действие в Аризоне в США где живут ковбои:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 21.03.25 23:56
in Antwort uscheswoi_82 21.03.25 23:55
Вот этот уровень с 2003 года я не буду делать:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 26.03.25 02:02
in Antwort uscheswoi_82 21.03.25 23:56
Почти сделал игру в воздушные шарики, вот так выглядет:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 26.03.25 02:06
in Antwort 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
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 26.03.25 02:09
in Antwort uscheswoi_82 26.03.25 02:06
Вуаля! А вот результат:
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
NEW 26.03.25 04:54
in Antwort uscheswoi_82 26.03.25 02:09
Нарисовал иконку для моей игры 16x16:
Вуаля!
Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение
Zurück
Liste