📄 frmlander.frm
字号:
VERSION 5.00
Begin VB.Form frmlander
BorderStyle = 1 'Fixed Single
Caption = "Lander!"
ClientHeight = 8745
ClientLeft = 45
ClientTop = 360
ClientWidth = 7125
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 583
ScaleMode = 3 'Pixel
ScaleWidth = 475
StartUpPosition = 1 'CenterOwner
Begin VB.TextBox txtheight
Height = 375
Left = 5280
Locked = -1 'True
TabIndex = 8
Text = "500.0"
Top = 3000
Width = 1695
End
Begin VB.TextBox txtvspeed
Height = 375
Left = 5280
Locked = -1 'True
TabIndex = 7
Text = "0.0"
Top = 2040
Width = 1695
End
Begin VB.TextBox txtfuel
Height = 375
Left = 5280
Locked = -1 'True
TabIndex = 4
Text = "1000.0"
Top = 1080
Width = 1695
End
Begin VB.CommandButton cmdgo
Caption = "Start"
Default = -1 'True
Height = 495
Left = 5280
TabIndex = 3
Top = 120
Width = 1695
End
Begin VB.PictureBox picsmash
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 480
Left = 5400
Picture = "frmlander.frx":0000
ScaleHeight = 32
ScaleMode = 3 'Pixel
ScaleWidth = 32
TabIndex = 2
Top = 6960
Visible = 0 'False
Width = 480
End
Begin VB.PictureBox picEarth
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 8520
Left = 120
ScaleHeight = 568
ScaleMode = 3 'Pixel
ScaleWidth = 336
TabIndex = 1
Top = 120
Width = 5040
End
Begin VB.Timer tmrgravity
Enabled = 0 'False
Interval = 1
Left = 5400
Top = 5760
End
Begin VB.PictureBox piclander
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 480
Left = 5400
Picture = "frmlander.frx":0842
ScaleHeight = 32
ScaleMode = 3 'Pixel
ScaleWidth = 32
TabIndex = 0
Top = 6360
Visible = 0 'False
Width = 480
End
Begin VB.Label lblkeys
Caption = "Use down arrow for thrusters!"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 5280
TabIndex = 14
Top = 8040
Width = 1815
WordWrap = -1 'True
End
Begin VB.Label lblinfo1
AutoSize = -1 'True
Caption = "For more demonstration Visual Basic Projects, please visit:"
Height = 615
Left = 5280
TabIndex = 13
Top = 3480
Width = 1800
WordWrap = -1 'True
End
Begin VB.Label lblurl
AutoSize = -1 'True
Caption = "http://www.vb-world.net"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 5280
TabIndex = 12
Top = 4080
Width = 1740
End
Begin VB.Label lblemail
AutoSize = -1 'True
Caption = "john@vb-world.net"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 5280
TabIndex = 11
Top = 4680
Width = 1335
End
Begin VB.Label lblinfo2
AutoSize = -1 'True
Caption = "To contact us, please send email to:"
Height = 390
Left = 5280
TabIndex = 10
Top = 4320
Width = 1725
WordWrap = -1 'True
End
Begin VB.Label lblheight
AutoSize = -1 'True
Caption = "Height:"
Height = 195
Left = 5280
TabIndex = 9
Top = 2640
Width = 510
End
Begin VB.Label lblvspeed
AutoSize = -1 'True
Caption = "Vertical Speed:"
Height = 195
Left = 5280
TabIndex = 6
Top = 1680
Width = 1080
End
Begin VB.Label lblfuel
AutoSize = -1 'True
Caption = "Fuel:"
Height = 195
Left = 5280
TabIndex = 5
Top = 720
Width = 345
End
End
Attribute VB_Name = "frmlander"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'API Declares
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private 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
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const VK_DOWN = &H28
' Vertical speed of the craft
Private vSpeed As Double
' The y coordinate of the craft
Private LandY As Double
' The amount of fuel left
Private Fuel As Double
Private Sub cmdgo_Click()
tmrgravity.Enabled = True
cmdgo.Enabled = False
End Sub
Private Sub Form_Load()
' Set initial values for fuel and vertical speed
Fuel = 700
vSpeed = 0
LandY = 0
txtvspeed.Text = Format(vSpeed, "0.0")
txtfuel.Text = Format(Fuel, "0.0")
txtheight.Text = Format(picEarth.ScaleHeight - piclander.ScaleHeight - 30 - LandY, "0.0")
lblemail = email
lblurl = URL
Dim instructions As String
instructions = "Welcome to Lander!" & vbNewLine
instructions = instructions & "When you start, space will be drawn, and you will start to fall."
instructions = instructions & "Press the down arrow to apply thrusters!" & vbNewLine
instructions = instructions & "You must land at less than 2 to prevent crashing!" & vbNewLine
instructions = instructions & "Press the Start button to start!"
MsgBox instructions
End Sub
Private Sub lblemail_Click()
sendemail
End Sub
Private Sub lblurl_Click()
gotoweb
End Sub
Private Sub tmrgravity_Timer()
Static curtime As Long
Dim timenow As Long
Dim timediff As Long
' curtime=0 if this is the first time that the event has been raised
If curtime = 0 Then
' Draw the earth
picEarth.Line (0, picEarth.ScaleHeight - 30)-(picEarth.ScaleWidth, picEarth.ScaleHeight), vbWhite, BF
Randomize Timer
Dim starx As Long, stary As Long
For starx = 0 To picEarth.ScaleWidth
For stary = 0 To picEarth.ScaleHeight - 30
If Rnd * 1000 < 5 Then
SetPixelV picEarth.hdc, starx, stary, vbYellow
End If
Next
Next
timenow = GetTickCount
curtime = timenow
Else
' GetTickCount returns number of milliseconds since windows was started
' This allows us to guage the length of time since this event was last raised,
' allowing us to calculate accelerations
timenow = GetTickCount
' If it isn't the first time, put back the previous background
BitBlt picEarth.hdc, 150, LandY, piclander.ScaleWidth, piclander.ScaleHeight, piclander.hdc, 0, 0, vbSrcInvert
End If
' Get the number of milliseconds since the event was last called
timediff = timenow - curtime
' Calculate new vertical speed based on g ( currently using the value for Earth )
' On Earth, g=10
' On Moon, g=1.7
vSpeed = vSpeed - ((timediff / 1000) * 10)
' Find out if the down key is pressed, so if thrust should be applied
' Also check that there is fuel remaining
If GetAsyncKeyState(VK_DOWN) <> 0 Then
If Fuel > 0 Then
' Apply thrust: 15 is the acceleration produced
vSpeed = vSpeed + ((timediff / 1000) * 15)
Fuel = Fuel - ((timediff / 1000) * 150)
' Check that fuel does not go below 0
If Fuel < 0 Then Fuel = 0
Else
Beep
End If
End If
LandY = LandY - vSpeed
' Update text boxes
txtvspeed.Text = Format(vSpeed, "0.0")
txtfuel.Text = Format(Fuel, "0.0")
txtheight.Text = Format(picEarth.ScaleHeight - piclander.ScaleHeight - 30 - LandY, "0.0")
' Update the 'last called time'
curtime = timenow
' If it has touched down...
If LandY >= picEarth.ScaleHeight - 30 - piclander.ScaleHeight Then
' Make sure that it is on the surface
LandY = picEarth.ScaleHeight - 30 - piclander.ScaleHeight
txtheight.Text = Format(picEarth.ScaleHeight - piclander.ScaleHeight - 30 - LandY, "0.0")
' Stop the timer and disable the pause button...the game is over!
tmrgravity.Enabled = False
' Figure out if it was a safe landing or not, and paint the appropriate craft
If vSpeed > -2 Then
' If it was safe, then the craft remains intact
BitBlt picEarth.hdc, 150, LandY, piclander.ScaleWidth, piclander.ScaleHeight, piclander.hdc, 0, 0, vbSrcInvert
MsgBox "Congratulations! You have landed successfully!"
Else
' If it was moving too fast, it blows up!
BitBlt picEarth.hdc, 150, LandY, piclander.ScaleWidth, piclander.ScaleHeight, picsmash.hdc, 0, 0, vbSrcInvert
MsgBox "Smash! Oooops!"
End If
Else
' paint the craft into its new position.
BitBlt picEarth.hdc, 150, LandY, piclander.ScaleWidth, piclander.ScaleHeight, piclander.hdc, 0, 0, vbSrcInvert
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -